adding support for runtime definition of new types

TODO

@@ -26,7 +26,7 @@
 **- only/except/rename modifiers
 **- scheme-complete.el support
 *= ffi
-**- libdl interface
+**+ libdl interface
 **- opcode generation interface
 **- stub generator
 *= cleanup

config.scm

@@ -131,6 +131,8 @@
          open-input-string open-output-string get-output-string
          sc-macro-transformer rsc-macro-transformer er-macro-transformer
          identifier? identifier=? identifier->symbol make-syntactic-closure
+         register-simple-type make-constructor make-type-predicate
+         make-getter make-setter
          )))
   (set! *modules*
         (list (cons '(scheme) (make-module exports

debug.c

@@ -11,7 +11,8 @@ static const char* reverse_opcode_names[] =
    "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
    "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND",
    "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
-   "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
+   "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR",
+   "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
    "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE",
    "LT", "LE", "EQN", "EQ",
    "EXACT->INEXACT", "INEXACT->EXACT",
@@ -47,6 +48,11 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
     sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
     ip += sizeof(sexp);
     break;
+  case OP_SLOT_REF:
+  case OP_SLOT_SET:
+  case OP_MAKE:
+    ip += sizeof(sexp)*2;
+    break;
   case OP_GLOBAL_REF:
   case OP_GLOBAL_KNOWN_REF:
   case OP_TAIL_CALL:

eval.c

@@ -286,6 +286,14 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
   sexp_gc_var1(res);
   if (ctx) sexp_gc_preserve1(ctx, res);
   res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
+  sexp_context_parent(res) = ctx;
+  sexp_context_lambda(res) = SEXP_FALSE;
+  sexp_context_fv(res) = SEXP_NULL;
+  sexp_context_saves(res) = 0;
+  sexp_context_depth(res) = 0;
+  sexp_context_pos(res) = 0;
+  sexp_context_tailp(res) = 1;
+  sexp_context_tracep(res) = 0;
   if ((! stack) || (stack == SEXP_FALSE)) {
     stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK);
     sexp_stack_length(stack) = INIT_STACK_SIZE;
@@ -300,15 +308,6 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
   sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
   sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
   sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
-  sexp_context_parent(res) = ctx;
-  sexp_context_lambda(res) = SEXP_FALSE;
-  sexp_context_fv(res) = SEXP_NULL;
-  sexp_context_saves(res) = 0;
-  sexp_context_depth(res) = 0;
-  sexp_context_pos(res) = 0;
-  sexp_context_top(res) = 0;
-  sexp_context_tailp(res) = 1;
-  sexp_context_tracep(res) = 0;
   if (ctx) sexp_gc_release1(ctx);
   return res;
 }
@@ -913,9 +912,16 @@ static void generate_opcode_app (sexp ctx, sexp app) {
     emit_word(ctx, (sexp_uint_t)op);
     break;
   case OPC_TYPE_PREDICATE:
+  case OPC_ACCESSOR:
+  case OPC_CONSTRUCTOR:
     emit(ctx, sexp_opcode_code(op));
-    if (sexp_opcode_data(op))
+    if ((sexp_opcode_class(op) != OPC_CONSTRUCTOR)
-      emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
+        || sexp_opcode_code(op) == OP_MAKE) {
+      if (sexp_opcode_data(op))
+        emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
+      if (sexp_opcode_data2(op))
+        emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
+    }
     break;
   case OPC_PARAMETER:
     emit_push(ctx, sexp_opcode_data(op));
@@ -1181,6 +1187,9 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
 #define _WORD0 ((sexp*)ip)[0]
 #define _UWORD0 ((sexp_uint_t*)ip)[0]
 #define _SWORD0 ((sexp_sint_t*)ip)[0]
+#define _WORD1 ((sexp*)ip)[1]
+#define _UWORD1 ((sexp_uint_t*)ip)[1]
+#define _SWORD1 ((sexp_sint_t*)ip)[1]
 
 #define sexp_raise(msg, args)                                       \
   do {sexp_context_top(ctx) = top+1;                                \
@@ -1537,11 +1546,29 @@ sexp sexp_vm (sexp ctx, sexp proc) {
   case OP_CHARP:
     _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
   case OP_TYPEP:
-    _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1)
+    _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0));
-                              && (sexp_make_fixnum(sexp_pointer_tag(_ARG1))
-                                  == _WORD0));
     ip += sizeof(sexp);
     break;
+  case OP_MAKE:
+    _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0));
+    ip += sizeof(sexp)*2;
+    break;
+  case OP_SLOT_REF:
+    if (! sexp_check_tag(_ARG1, _UWORD0))
+      sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1));
+    _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
+    ip += sizeof(sexp)*2;
+    break;
+  case OP_SLOT_SET:
+    if (! sexp_check_tag(_ARG1, _UWORD0))
+      sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1));
+    else if (sexp_immutablep(_ARG1))
+      sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
+    sexp_slot_set(_ARG1, _UWORD1, _ARG2);
+    _ARG2 = SEXP_VOID;
+    ip += sizeof(sexp)*2;
+    top--;
+    break;
   case OP_CAR:
     if (! sexp_pairp(_ARG1))
       sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));
@@ -2196,6 +2223,86 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) {
   return res;
 }
 
+
+sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code,
+                       sexp num_args, sexp flags, sexp arg1t, sexp arg2t,
+                       sexp invp, sexp data, sexp data2, sexp_proc0 func) {
+  sexp res;
+  if (! sexp_stringp(name))
+    res = sexp_type_exception(ctx, "make-opcode: not a string", name);
+  else if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
+      || (sexp_unbox_fixnum(op_class) >= OPC_NUM_OP_CLASSES))
+    res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class);
+  else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0)
+      || (sexp_unbox_fixnum(code) >= OP_NUM_OPCODES))
+    res = sexp_type_exception(ctx, "make-opcode: bad opcode", code);
+  else if (! sexp_fixnump(num_args))
+    res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args);
+  else if (! sexp_fixnump(flags))
+    res = sexp_type_exception(ctx, "make-opcode: bad flags", flags);
+  else {
+    res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+    sexp_opcode_class(res) = sexp_unbox_fixnum(op_class);
+    sexp_opcode_code(res) = sexp_unbox_fixnum(code);
+    sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args);
+    sexp_opcode_flags(res) = sexp_unbox_fixnum(flags);
+    sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t);
+    sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t);
+    sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp);
+    sexp_opcode_data(res) = data;
+    sexp_opcode_data2(res) = data2;
+    sexp_opcode_func(res) = func;
+    sexp_opcode_name(res)
+      = strndup(sexp_string_data(name), sexp_string_length(name)+1);
+  }
+  return res;
+}
+
+#if USE_TYPE_DEFS
+
+sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) {
+  if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES))
+    return sexp_type_exception(ctx, "make-type-predicate: bad type", type);
+  return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE),
+                          sexp_make_fixnum(OP_TYPEP), sexp_make_fixnum(1),
+                          sexp_make_fixnum(0), sexp_make_fixnum(0),
+                          sexp_make_fixnum(0), sexp_make_fixnum(0), type,
+                          NULL, NULL);
+}
+
+sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) {
+  sexp_uint_t type_size;
+  if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES))
+    return sexp_type_exception(ctx, "make-constructor: bad type", type);
+  type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)]));
+  return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR),
+                          sexp_make_fixnum(OP_MAKE), sexp_make_fixnum(0),
+                          sexp_make_fixnum(0), sexp_make_fixnum(0),
+                          sexp_make_fixnum(0), sexp_make_fixnum(0), type,
+                          sexp_make_fixnum(type_size), NULL);
+}
+
+sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) {
+  if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES))
+    return sexp_type_exception(ctx, "make-accessor: bad type", type);
+  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
+    return sexp_type_exception(ctx, "make-accessor: bad index", index);
+  return
+    sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_ACCESSOR), code,
+                     sexp_make_fixnum(sexp_unbox_fixnum(code)==OP_SLOT_REF?1:2),
+                     sexp_make_fixnum(0), type, sexp_make_fixnum(0),
+                     sexp_make_fixnum(0), type, index, NULL);
+}
+
+sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) {
+  return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_REF));
+}
+sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) {
+  return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_SET));
+}
+
+#endif
+
 sexp sexp_make_env (sexp ctx) {
   sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
   sexp_env_lambda(e) = NULL;
@@ -2326,7 +2433,7 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
   sexp_gc_var1(thunk);
   sexp_gc_preserve1(ctx, thunk);
   ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
-  sexp_context_parent(ctx2) = ctx;
+  /* sexp_context_parent(ctx2) = ctx; */
   thunk = sexp_compile(ctx2, obj);
   if (sexp_exceptionp(thunk)) {
     sexp_print_exception(ctx2, thunk,

gc.c

@@ -45,7 +45,7 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
 sexp_uint_t sexp_allocated_bytes (sexp x) {
   sexp_uint_t res, *len_ptr;
   sexp t;
-  if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT))
+  if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types))
     return sexp_heap_align(1);
   t = &(sexp_type_specs[sexp_pointer_tag(x)]);
   len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t));

include/chibi/config.h

@@ -8,6 +8,9 @@
 /* uncomment this to disable dynamic loading */
 /* #define USE_DL 0 */
 
+/* uncomment this to disable dynamic type definitions */
+/* #define USE_TYPE_DEFS 0 */
+
 /* uncomment this to use the Boehm conservative GC */
 /* #define USE_BOEHM 1 */
 
@@ -70,6 +73,14 @@
 #define USE_MODULES 1
 #endif
 
+#ifndef USE_TYPE_DEFS
+#define USE_TYPE_DEFS 1
+#endif
+
+#ifndef SEXP_MAXIMUM_TYPES
+#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1)
+#endif
+
 #ifndef USE_DL
 #ifdef PLAN9
 #define USE_DL 0

include/chibi/eval.h

@@ -38,7 +38,8 @@ enum opcode_classes {
   OPC_CONSTRUCTOR,
   OPC_ACCESSOR,
   OPC_PARAMETER,
-  OPC_FOREIGN
+  OPC_FOREIGN,
+  OPC_NUM_OP_CLASSES
 };
 
 enum opcode_names {
@@ -82,6 +83,9 @@ enum opcode_names {
   OP_CHARP,
   OP_EOFP,
   OP_TYPEP,
+  OP_MAKE,
+  OP_SLOT_REF,
+  OP_SLOT_SET,
   OP_CAR,
   OP_CDR,
   OP_SET_CAR,
@@ -130,6 +134,14 @@ SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls);
 SEXP_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val);
 SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env);
 SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out);
+SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc0);
+
+#if USE_TYPE_DEFS
+SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type);
+SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type);
+SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index);
+SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index);
+#endif
 
 #endif /* ! SEXP_EVAL_H */
 

include/chibi/sexp.h

@@ -93,11 +93,16 @@ enum sexp_types {
   SEXP_LIT,
   SEXP_STACK,
   SEXP_CONTEXT,
-  SEXP_NUM_TYPES
+  SEXP_NUM_CORE_TYPES
 };
 
 typedef unsigned long sexp_uint_t;
 typedef long sexp_sint_t;
+/* #if SEXP_64_BIT */
+/* typedef unsigned int sexp_tag_t; */
+/* #else */
+/* typedef unsigned short sexp_tag_t; */
+/* #endif */
 typedef unsigned char sexp_tag_t;
 typedef struct sexp_struct *sexp;
 
@@ -200,7 +205,7 @@ struct sexp_struct {
       unsigned char op_class, code, num_args, flags,
         arg1_type, arg2_type, inverse;
       char *name;
-      sexp data, proc;
+      sexp data, data2, proc;
       sexp_proc0 func;
     } opcode;
     struct {
@@ -347,10 +352,14 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
 #define sexp_gc_mark(x)     ((x)->gc_mark)
 #define sexp_immutablep(x)  ((x)->immutablep)
 
-#define sexp_object_type(x)      (&(sexp_type_specs[(x)->tag]))
+#define sexp_object_type(x)        (&(sexp_type_specs[(x)->tag]))
-#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x)))
+#define sexp_object_type_name(x)   (sexp_type_name(sexp_object_type(x)))
+#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)])))
 
-#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
+#define sexp_check_tag(x,t)  (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
+
+#define sexp_slot_ref(x,i)   (((sexp*)&((x)->value))[i])
+#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v))
 
 #if USE_IMMEDIATE_FLONUMS
 union sexp_flonum_conv {
@@ -495,6 +504,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
 #define sexp_opcode_inverse(x)    ((x)->value.opcode.inverse)
 #define sexp_opcode_name(x)       ((x)->value.opcode.name)
 #define sexp_opcode_data(x)       ((x)->value.opcode.data)
+#define sexp_opcode_data2(x)      ((x)->value.opcode.data2)
 #define sexp_opcode_proc(x)       ((x)->value.opcode.proc)
 #define sexp_opcode_func(x)       ((x)->value.opcode.func)
 
@@ -634,6 +644,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p);
 
 #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p))
 
+SEXP_API struct sexp_struct *sexp_type_specs;
 SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
 SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail);
 SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
@@ -674,5 +685,10 @@ SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
 SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
 SEXP_API void sexp_init(void);
 
+#if USE_TYPE_DEFS
+SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
+SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots);
+#endif
+
 #endif /* ! SEXP_H */
 

init.scm

@@ -431,7 +431,10 @@
 
 (define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o)))))
 
-(define (digit-char n) (integer->char (+ n (char->integer #\0))))
+(define (digit-char n)
+  (if (<= n 9)
+      (integer->char (+ n (char->integer #\0)))
+      (integer->char (+ (- n 10) (char->integer #\A)))))
 (define (digit-value ch)
   (if (char-numeric? ch)
       (- (char->integer ch) (char->integer #\0))

main.c

@@ -74,6 +74,7 @@ sexp sexp_init_environments (sexp ctx) {
   sexp_gc_var1(confenv);
   env = sexp_context_env(ctx);
   res = sexp_load_module_file(ctx, sexp_init_file, env);
+#if USE_MODULES
   if (! sexp_exceptionp(res)) {
     res = SEXP_UNDEF;
     sexp_gc_preserve1(ctx, confenv);
@@ -84,13 +85,14 @@ sexp sexp_init_environments (sexp ctx) {
     sexp_env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv);
     sexp_gc_release1(ctx);
   }
+#endif
   return res;
 }
 
 void repl (sexp ctx) {
-  sexp tmp, res, env, in, out, err;
+  sexp in, out, err;
-  sexp_gc_var1(obj);
+  sexp_gc_var4(obj, tmp, res, env);
-  sexp_gc_preserve1(ctx, obj);
+  sexp_gc_preserve4(ctx, obj, tmp, res, env);
   env = sexp_context_env(ctx);
   sexp_context_tracep(ctx) = 1;
   in = sexp_eval_string(ctx, "(current-input-port)", env);
@@ -118,7 +120,7 @@ void repl (sexp ctx) {
       }
     }
   }
-  sexp_gc_release1(ctx);
+  sexp_gc_release4(ctx);
 }
 
 void run_main (int argc, char **argv) {

opcodes.c

@@ -1,7 +1,7 @@
 
 #define _OP(c,o,n,m,t,u,i,s,d,f)                                \
   {.tag=SEXP_OPCODE,                                            \
-      .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, f}}}
+      .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}}
 #define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p)
 #define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d)
 #define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d)
@@ -107,6 +107,9 @@ _PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
 _PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
 _PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE),
 _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
+_FN0("open-output-string", 0, sexp_make_output_string_port),
+_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port),
+_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string),
 #if USE_MATH
 _FN1(0, "exp", 0, sexp_exp),
 _FN1(0, "log", 0, sexp_log),
@@ -123,9 +126,13 @@ _FN1(0, "floor", 0, sexp_floor),
 _FN1(0, "ceiling", 0, sexp_ceiling),
 _FN2(0, 0, "expt", 0, sexp_expt),
 #endif
-_FN0("open-output-string", 0, sexp_make_output_string_port),
+#if USE_TYPE_DEFS
-_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port),
+_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type),
-_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string),
+_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate),
+_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor),
+_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter),
+_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter),
+#endif
 #if USE_DEBUG
 _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm),
 #endif

opt/bignum.c

@@ -466,12 +466,11 @@ enum sexp_number_combs {
   SEXP_NUM_BIG_BIG
 };
 
-static int sexp_number_types[SEXP_NUM_TYPES] =
+static int sexp_number_types[] =
-  {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0,
+  {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0};
-   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, };
 
 static int sexp_number_type (sexp a) {
-  return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)]
+  return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&1111]
     : sexp_fixnump(a);
 }
 

sexp.c

@@ -62,7 +62,7 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
 #define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
   {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}}
 
-static struct sexp_struct sexp_type_specs[] = {
+static struct sexp_struct _sexp_type_specs[] = {
   _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"),
   _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
   _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
@@ -84,7 +84,7 @@ static struct sexp_struct sexp_type_specs[] = {
   _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
   _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
   _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
-  _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
+  _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
   _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
   _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"),
   _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
@@ -94,9 +94,67 @@ static struct sexp_struct sexp_type_specs[] = {
   _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"),
   _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
 };
-
 #undef _DEF_TYPE
 
+struct sexp_struct *sexp_type_specs = _sexp_type_specs;
+
+#if USE_TYPE_DEFS
+
+static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES;
+static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES;
+
+sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp fls,
+                         sexp sb, sexp so, sexp sc) {
+  struct sexp_struct *type, *new, *tmp;
+  sexp res;
+  sexp_uint_t i, len;
+  if (sexp_num_types >= SEXP_MAXIMUM_TYPES) {
+    fprintf(stderr, "chibi: exceeded maximum type limit\n");
+    res = SEXP_FALSE;
+  } else if (! sexp_stringp(name)) {
+    res = sexp_type_exception(ctx, "register-type: not a string", name);
+  } else {
+    if (sexp_num_types >= sexp_type_array_size) {
+      len = sexp_type_array_size*2;
+      if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES;
+      new = malloc(len * sizeof(_sexp_type_specs[0]));
+      for (i=0; i<sexp_num_types; i++)
+        memcpy(&(new[i]), &(sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
+      tmp = sexp_type_specs;
+      sexp_type_specs = new;
+      if (sexp_type_array_size > sexp_num_types) free(tmp);
+      sexp_type_array_size = len;
+    }
+    type = &(sexp_type_specs[sexp_num_types]);
+    sexp_pointer_tag(type) = SEXP_TYPE;
+    sexp_type_tag(type) = sexp_num_types++;
+    sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
+    sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb);
+    sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo);
+    sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls);
+    sexp_type_size_base(type) = sexp_unbox_fixnum(sb);
+    sexp_type_size_off(type) = sexp_unbox_fixnum(so);
+    sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
+    sexp_type_name(type) = strndup(sexp_string_data(name), sexp_string_length(name)+1);
+    res = sexp_make_fixnum(sexp_type_tag(type));
+  }
+  return res;
+}
+
+sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) {
+  short type_size
+    = sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots);
+  return sexp_register_type(ctx, name,
+                            sexp_make_fixnum(offsetof(struct sexp_struct, value)),
+                            slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
+                            sexp_make_fixnum(type_size), sexp_make_fixnum(0),
+                            sexp_make_fixnum(0));
+}
+
+#else
+#define sexp_num_types SEXP_NUM_CORE_TYPES
+#endif
+
 #if ! USE_BOEHM
 
 #if ! USE_MALLOC
@@ -877,8 +935,8 @@ void sexp_write (sexp ctx, sexp obj, sexp out) {
       i = sexp_pointer_tag(obj);
       sexp_write_string(ctx, "#<", out);
       sexp_write_string(ctx,
-                        (i < SEXP_NUM_TYPES)
+                        (i < sexp_num_types)
-                        ? sexp_type_name(&(sexp_type_specs[i])) : "invalid",
+                        ? sexp_type_name_by_index(i) : "invalid",
                         out);
       sexp_write_char(ctx, '>', out);
       break;

tests/r5rs-tests.scm

@@ -229,6 +229,8 @@
 
 (test "100" (number->string 256 16))
 
+(test "FF" (number->string 255 16))
+
 (test "177" (number->string 127 8))
 
 (test "101" (number->string 5 2))