adding parent links to cpointers to prevent freeing shared structures

Makefile

@@ -52,8 +52,10 @@ endif
 
 all: chibi-scheme$(EXE) libs
 
-libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
+COMPILED_LIBS := lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
-	lib/chibi/net$(SO) lib/chibi/posix$(SO)
+	lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO)
+
+libs: $(COMPILED_LIBS)
 
 ifeq ($(USE_BOEHM),1)
 GCLDFLAGS := -lgc
@@ -106,7 +108,7 @@ clean:
 	find lib -name \*.$(SO) -exec rm -f '{}' \;
 
 cleaner: clean
-	rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a
+	rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a
 	rm -rf *.dSYM
 
 test-basic: chibi-scheme$(EXE)

eval.c

@@ -16,7 +16,6 @@ static int scheme_initialized_p = 0;
 #define sexp_disasm(...)
 #endif
 
-static sexp analyze (sexp ctx, sexp x);
 static void generate (sexp ctx, sexp x);
 static sexp sexp_make_null_env (sexp ctx, sexp version);
 static sexp sexp_make_standard_env (sexp ctx, sexp version);
@@ -354,7 +353,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
     kar = sexp_strip_synclos(ctx, sexp_car(x));
     kdr = sexp_strip_synclos(ctx, sexp_cdr(x));
     res = sexp_cons(ctx, kar, kdr);
-    sexp_immutablep(res) = sexp_immutablep(x);
+    sexp_immutablep(res) = 1;
   } else {
     res = x;
   }
@@ -388,7 +387,7 @@ static sexp analyze_app (sexp ctx, sexp x) {
   sexp_gc_preserve2(ctx, res, tmp);
   for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
     sexp_push(ctx, res, SEXP_FALSE);
-    tmp = analyze(ctx, sexp_car(x));
+    tmp = sexp_analyze(ctx, sexp_car(x));
     if (sexp_exceptionp(tmp)) {
       res = tmp;
       break;
@@ -406,7 +405,7 @@ static sexp analyze_seq (sexp ctx, sexp ls) {
   if (sexp_nullp(ls))
     res = SEXP_VOID;
   else if (sexp_nullp(sexp_cdr(ls)))
-    res = analyze(ctx, sexp_car(ls));
+    res = sexp_analyze(ctx, sexp_car(ls));
   else {
     res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
     tmp = analyze_app(ctx, ls);
@@ -451,7 +450,7 @@ static sexp analyze_set (sexp ctx, sexp x) {
     ref = analyze_var_ref(ctx, sexp_cadr(x));
     if (sexp_lambdap(sexp_ref_loc(ref)))
       sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
-    value = analyze(ctx, sexp_caddr(x));
+    value = sexp_analyze(ctx, sexp_caddr(x));
     if (sexp_exceptionp(ref))
       res = ref;
     else if (sexp_exceptionp(value))
@@ -495,7 +494,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
       value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp));
     } else {
       name = sexp_cadr(tmp);
-      value = analyze(ctx2, sexp_caddr(tmp));
+      value = sexp_analyze(ctx2, sexp_caddr(tmp));
     }
     if (sexp_exceptionp(value)) sexp_return(res, value);
     sexp_push(ctx2, defs,
@@ -522,10 +521,10 @@ static sexp analyze_if (sexp ctx, sexp x) {
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
     res = sexp_compile_error(ctx, "bad if syntax", x);
   } else {
-    test = analyze(ctx, sexp_cadr(x));
+    test = sexp_analyze(ctx, sexp_cadr(x));
-    pass = analyze(ctx, sexp_caddr(x));
+    pass = sexp_analyze(ctx, sexp_caddr(x));
     fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
-    fail = analyze(ctx, fail_expr);
+    fail = sexp_analyze(ctx, fail_expr);
     res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
            sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
   }
@@ -559,7 +558,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
         tmp = sexp_cons(ctx, SEXP_VOID, tmp);
         value = analyze_lambda(ctx, tmp);
       } else
-        value = analyze(ctx, sexp_caddr(x));
+        value = sexp_analyze(ctx, sexp_caddr(x));
       ref = analyze_var_ref(ctx, name);
       if (sexp_exceptionp(ref))
         res = ref;
@@ -644,7 +643,7 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) {
   return res;
 }
 
-static sexp analyze (sexp ctx, sexp object) {
+sexp sexp_analyze (sexp ctx, sexp object) {
   sexp op;
   sexp_gc_var4(res, tmp, x, cell);
   sexp_gc_preserve4(ctx, res, tmp, x, cell);
@@ -731,7 +730,7 @@ static sexp analyze (sexp ctx, sexp object) {
                                         sexp_synclo_free_vars(x),
                                         sexp_context_fv(tmp));
     x = sexp_synclo_expr(x);
-    res = analyze(tmp, x);
+    res = sexp_analyze(tmp, x);
   } else {
     res = x;
   }
@@ -2274,7 +2273,7 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args,
 #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))
+  if (! sexp_fixnump(type))
     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),
@@ -2285,7 +2284,7 @@ sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) {
 
 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))
+  if (! sexp_fixnump(type))
     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),
@@ -2296,7 +2295,7 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) {
 }
 
 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))
+  if (! sexp_fixnump(type))
     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);
@@ -2435,7 +2434,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
 sexp sexp_compile (sexp ctx, sexp x) {
   sexp_gc_var3(ast, vec, res);
   sexp_gc_preserve3(ctx, ast, vec, res);
-  ast = analyze(ctx, x);
+  ast = sexp_analyze(ctx, x);
   if (sexp_exceptionp(ast)) {
     res = ast;
   } else {

include/chibi/eval.h

@@ -122,6 +122,7 @@ enum sexp_opcode_names {
 SEXP_API void sexp_scheme_init (void);
 SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env);
 SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
+SEXP_API sexp sexp_analyze (sexp context, sexp x);
 SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
 SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
 SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);

include/chibi/sexp.h

@@ -149,8 +149,9 @@ struct sexp_gc_var_t {
 
 struct sexp_struct {
   sexp_tag_t tag;
-  char immutablep;
   char gc_mark;
+  unsigned int immutablep:1;
+  unsigned int freep:1;
   union {
     /* basic types */
     double flonum;
@@ -195,8 +196,9 @@ struct sexp_struct {
       sexp_uint_t data[];
     } bignum;
     struct {
-      sexp_uint_t freep, length;
+      sexp_uint_t length;
       void *value;
+      sexp parent;
       char body[];
     } cpointer;
     /* runtime types */
@@ -370,7 +372,9 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
 
 #define sexp_pointer_tag(x)      ((x)->tag)
 #define sexp_gc_mark(x)          ((x)->gc_mark)
+#define sexp_flags(x)            ((x)->flags)
 #define sexp_immutablep(x)       ((x)->immutablep)
+#define sexp_freep(x)            ((x)->freep)
 
 #define sexp_object_type(x)             (&(sexp_type_specs[(x)->tag]))
 #define sexp_object_type_name(x)        (sexp_type_name(sexp_object_type(x)))
@@ -524,9 +528,10 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
 #define sexp_exception_procedure(p) ((p)->value.exception.procedure)
 #define sexp_exception_source(p)    ((p)->value.exception.source)
 
-#define sexp_cpointer_freep(p)      ((p)->value.cpointer.freep)
+#define sexp_cpointer_freep(p)      (sexp_freep(p))
 #define sexp_cpointer_length(p)     ((p)->value.cpointer.length)
 #define sexp_cpointer_body(p)       ((p)->value.cpointer.body)
+#define sexp_cpointer_parent(p)     ((p)->value.cpointer.parent)
 #define sexp_cpointer_value(p)      ((p)->value.cpointer.value)
 #define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p))
 
@@ -753,7 +758,7 @@ SEXP_API sexp sexp_intern(sexp ctx, char *str);
 SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str);
 SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
 SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls);
-SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, int freep);
+SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep);
 SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out);
 SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out);
 SEXP_API sexp sexp_flush_output(sexp ctx, sexp out);

lib/chibi/net.stub

@@ -12,9 +12,9 @@
   (int              ai_family    address-info-family)
   (int              ai_socktype  address-info-socket-type)
   (int              ai_protocol  address-info-protocol)
-  (sockaddr  ai_addr      address-info-address)
+  ((link sockaddr)  ai_addr      address-info-address)
   (size_t           ai_addrlen   address-info-address-length)
-  (addrinfo  ai_next      address-info-next))
+  ((link addrinfo)  ai_next      address-info-next))
 
 (define-c errno (get-address-info getaddrinfo)
   (string string (maybe-null addrinfo) (result free addrinfo)))

sexp.c

@@ -80,7 +80,7 @@ static struct sexp_struct _sexp_type_specs[] = {
   _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL),
   _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL),
   _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL),
-  _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL),
+  _DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL),
   _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT),
   _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT),
   _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL),
@@ -711,12 +711,13 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) {
   return vec;
 }
 
-sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, int freep) {
+sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, int freep) {
   sexp ptr;
   if (! value) return SEXP_FALSE;
   ptr = sexp_alloc_type(ctx, cpointer, typeid);
+  sexp_freep(ptr) = freep;
   sexp_cpointer_value(ptr) = value;
-  sexp_cpointer_freep(ptr) = freep;
+  sexp_cpointer_parent(ptr) = parent;
   sexp_cpointer_length(ptr) = 0;
   return ptr;
 }
@@ -1158,7 +1159,11 @@ sexp sexp_read_string(sexp ctx, sexp in) {
   for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) {
     if (c == '\\') {
       c = sexp_read_char(ctx, in);
-      switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;}
+      switch (c) {
+      case 'n': c = '\n'; break;
+      case 'r': c = '\r'; break; 
+      case 't': c = '\t'; break;
+      }
     }
     if (c == EOF) {
       res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in);

tools/genstubs.scm

@@ -125,34 +125,27 @@
                        funcs))
      #f)))
 
-(define (delq x ls)
-  (cond ((not (pair? ls)) ls)
-        ((eq? x (car ls)) (cdr ls))
-        (else (cons (car ls) (delq x (cdr ls))))))
-
-(define (without-mod x ls)
-  (let ((res (delq x ls)))
-    (if (and (pair? res) (null? (cdr res)))
-        (car res)
-        res)))
-
 (define (with-parsed-type type proc)
-  (let* ((free? (and (pair? type) (memq 'free type)))
+  (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
-         (type (if free? (without-mod 'free type) type))
+           (pointer? #f) (struct? #f) (link? #f) (result? #f))
-         (const? (and (pair? type) (memq 'const type)))
+    (define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
-         (type (if const? (without-mod 'const type) type))
+    (case (and (pair? type) (car type))
-         (null-ptr? (and (pair? type) (memq 'maybe-null type)))
+      ((free) (lp (next) #t const? null-ptr? pointer? struct? link? result?))
-         (type (if null-ptr? (without-mod 'maybe-null type) type))
+      ((const) (lp (next) free? #t null-ptr? pointer? struct? link? result?))
-         (pointer? (and (pair? type) (memq 'pointer type)))
+      ((maybe-null) (lp (next) free? const? #t pointer? struct? link? result?))
-         (type (if pointer? (without-mod 'pointer type) type))
+      ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result?))
-         (result? (and (pair? type) (memq 'result type)))
+      ((struct) (lp (next) free? const? null-ptr? pointer? #t link? result?))
-         (type (if result? (without-mod 'result type) type)))
+      ((link) (lp (next) free? const? null-ptr? pointer? struct? #t result?))
-    (proc type free? const? null-ptr? pointer? result?)))
+      ((result) (lp (next) free? const? null-ptr? pointer? struct? link? #t))
+      (else (proc type free? const? null-ptr? pointer? struct? link? result?)))))
 
-(define (c->scheme-converter type val)
+(define (get-base-type type)
+  (with-parsed-type type (lambda (x . args) x)))
+
+(define (c->scheme-converter type val . o)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? result?)
+   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
      (cond
       ((memq type '(sexp errno))
        (cat val))
@@ -171,14 +164,15 @@
          (cond
           (ctype
            (cat "sexp_make_cpointer(ctx, "  (type-id-name type) ", "
-                val ", " (if free? 1 0) ")"))
+                val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
+                (if free? 1 0) ")"))
           (else
            (error "unknown type" type)))))))))
 
 (define (scheme->c-converter type val)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? result?)
+   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
      (cond
       ((eq? 'sexp type)
        (cat val))
@@ -204,7 +198,7 @@
 (define (type-predicate type)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? result?)
+   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
      (cond
       ((int-type? type) "sexp_exact_integerp")
       ((float-type? type) "sexp_flonump")
@@ -214,7 +208,7 @@
 (define (type-name type)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? result?)
+   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
      (cond
        ((int-type? type) "integer")
        ((float-type? type) "flonum")
@@ -223,7 +217,7 @@
 (define (type-c-name type)
   (with-parsed-type
    type
-   (lambda (base-type free? const? null-ptr? pointer? result?)
+   (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
      (let ((struct? (assq base-type types)))
        (string-append
         (if const? "const " "")
@@ -235,7 +229,7 @@
 (define (check-type arg type)
   (with-parsed-type
    type
-   (lambda (base-type free? const? null-ptr? pointer? result?)
+   (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
      (cond
       ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
        (cat (type-predicate type) "(" arg ")"))
@@ -256,7 +250,7 @@
 (define (validate-type arg type)
   (with-parsed-type
    type
-   (lambda (base-type free? const? null-ptr? pointer? result?)
+   (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
      (cond
       ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
        (cat
@@ -349,7 +343,7 @@
         (type (cdr type)))
     (with-parsed-type
      type
-     (lambda (base-type free? const? null-ptr? pointer? result?)
+     (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
        (cat "  name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
             "  " (type-id-name name)
             " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, "
@@ -368,46 +362,56 @@
 
 (define (type-getter-name type name field)
   (string-append "sexp_" (x->string (type-name name))
-                 "_get_" (x->string (cadr field))))
+                 "_get_" (x->string (get-base-type (cadr field)))))
 
 (define (write-type-getter type name field)
+  (with-parsed-type
+   (car field)
+   (lambda (field-type free? const? null-ptr? pointer? struct? link? result?)
      (cat "static sexp " (type-getter-name type name field)
           " (sexp ctx, sexp x) {\n"
           (lambda () (validate-type "x" name))
           "  return "
-       (lambda () (c->scheme-converter
+          (lambda ()
-               (car field)
+            (c->scheme-converter
+             field-type
              (string-append "((struct " (mangle name) "*)"
-                              "sexp_cpointer_value(x))->"
+                            "sexp_cpointer_value(x))"
-                              (x->string (cadr field)))))
+                            (if struct? "." "->")
+                            (x->string (cadr field)))
+             (and (or struct? link?) "x")))
           ";\n"
-       "}\n\n"))
+          "}\n\n"))))
 
 (define (type-setter-name type name field)
   (string-append "sexp_" (x->string (type-name name))
-                 "_set_" (x->string (car field))))
+                 "_set_" (x->string (get-base-type (car field)))))
 
 (define (write-type-setter type name field)
+  (with-parsed-type
+   (car field)
+   (lambda (field-type free? const? null-ptr? pointer? struct? link? result?)
      (cat "static sexp " (type-setter-name type name field)
          " (sexp ctx, sexp x, sexp v) {\n"
          (lambda () (validate-type "x" name))
          (lambda () (validate-type "v" (car field)))
          "  "
          (lambda () (c->scheme-converter
-               (car field)
+                 field-type
                  (string-append "((struct " (mangle name) "*)"
-                              "sexp_cpointer_value(x))->"
+                                "sexp_cpointer_value(x))"
+                                (if struct? "." "->")
                                 (x->string (cadr field)))))
          " = v;\n"
          "  return SEXP_VOID;"
-       "}\n\n"))
+         "}\n\n"))))
 
 (define (write-type-funcs type)
   (let ((name (car type))
         (type (cdr type)))
     (with-parsed-type
      type
-     (lambda (base-type free? const? null-ptr? pointer? result?)
+     (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
        (cond
         ((memq 'finalizer: base-type)
          => (lambda (x)
@@ -456,8 +460,7 @@
                     (cons (list (type-setter-name type name field)
                                 (car field) (cadddr field)
                                 (list name (car field)))
-                          funcs))
+                          funcs)))))))
-              )))))
         base-type)))))
 
 (define (write-init)