repairs

original commit: a7c8036d40fc3c92b6b08ba8d1a62f76f2d5fab6

c/externs.h

@@ -94,7 +94,7 @@ extern ptr S_relocation_table PROTO((iptr n));
 /* fasl.c */
 extern void S_fasl_init PROTO((void));
 ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, ptr path));
-ptr S_bv_fasl_read PROTO((ptr bv, ptr path));
+ptr S_bv_fasl_read PROTO((ptr bv, int ty, ptr path));
 /* S_boot_read's f argument is really gzFile, but zlib.h is not included everywhere */
 ptr S_boot_read PROTO((gzFile file, const char *path));
 char *S_format_scheme_version PROTO((uptr n));

c/fasl.c

@@ -211,7 +211,7 @@ static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
 static octet uf_bytein PROTO((unbufFaslFile uf));
 static uptr uf_uptrin PROTO((unbufFaslFile uf));
 static ptr fasl_entry PROTO((ptr tc, unbufFaslFile uf));
-static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, unbufFaslFile uf));
+static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, unbufFaslFile uf));
 static void fillFaslFile PROTO((faslFile f));
 static void bytesin PROTO((octet *s, iptr n, faslFile f));
 static void toolarge PROTO((ptr path));
@@ -304,7 +304,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
   return x;
 }
 
-ptr S_bv_fasl_read(ptr bv, ptr path) {
+ptr S_bv_fasl_read(ptr bv, int ty, ptr path) {
   ptr tc = get_thread_context();
   ptr x; struct unbufFaslFileObj uffo;
 
@@ -312,7 +312,7 @@ ptr S_bv_fasl_read(ptr bv, ptr path) {
   tc_mutex_acquire()
   uffo.path = path;
   uffo.type = UFFO_TYPE_BV;
-  x = bv_fasl_entry(tc, bv, &uffo);
+  x = bv_fasl_entry(tc, bv, ty, &uffo);
   tc_mutex_release()
   return x;
 }
@@ -476,16 +476,21 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
   return x;
 }
 
-static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) {
+static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, unbufFaslFile uf) {
   ptr x; ptr strbuf = S_G.null_string;
   struct faslFileObj ffo;
 
   ffo.size = Sbytevector_length(bv);
-  ffo.next = ffo.buf = &BVIT(bv, 0);
-  ffo.end = &BVIT(bv, ffo.size);
-  ffo.uf = uf;
 
-  faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
+  if (ty == fasl_type_vfasl_size) {
+    x = S_vfasl(bv, (ptr)0, ffo.size);
+  } else {
+    ffo.next = ffo.buf = &BVIT(bv, 0);
+    ffo.end = &BVIT(bv, ffo.size);
+    ffo.uf = uf;
+    
+    faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
+  }
 
   S_flush_instruction_cache(tc);
   return x;

c/vfasl.c

@@ -242,6 +242,18 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
     }
   }
 
+  /* Replace references to singletons like "" and #vu8().
+     This needs to be before interning symbols, in case ""
+     is a symbol name. */
+  {
+    vfoff i;
+    for (i = 0; i < header.singletonref_count; i++) {
+      ptr *ref;
+      ref = ptr_add(data, singletonrefs[i]);
+      *ref = lookup_singleton(UNFIX(*ref));
+    }
+  }
+
   /* Intern symbols */
   {
     ptr sym = TYPE(data, type_symbol);
@@ -338,16 +350,6 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
     }
   }
 
-  /* Replace references to singletons like "" and #vu8() */
-  {
-    vfoff i;
-    for (i = 0; i < header.singletonref_count; i++) {
-      ptr *ref;
-      ref = ptr_add(data, singletonrefs[i]);
-      *ref = lookup_singleton(UNFIX(*ref));
-    }
-  }
-
   /* Fix code pointers on closures */
   {
     ptr cl = TYPE(ptr_add(data, header.closure_offset), type_closure);
@@ -1248,6 +1250,14 @@ static int detect_singleton(ptr p) {
     return 3;
   else if (p == S_G.null_bytevector)
     return 4;
+  else if (p == S_G.eqp)
+    return 5;
+  else if (p == S_G.eqvp)
+    return 6;
+  else if (p == S_G.equalp)
+    return 7;
+  else if (p == S_G.symboleqp)
+    return 8;
   else
     return 0;
 }
@@ -1262,11 +1272,19 @@ static ptr lookup_singleton(int which) {
     return S_G.null_fxvector;
   case 4:
     return S_G.null_bytevector;
+  case 5:
+    return S_G.eqp;
+  case 6:
+    return S_G.eqvp;
+  case 7:
+    return S_G.equalp;
+  case 8:
+    return S_G.symboleqp;
   default:
     S_error("vfasl", "bad singleton index");
     return (ptr)0;
   }
-}
+}  
   
 /*************************************************************/
 

s/7.ss

@@ -121,7 +121,7 @@
 (set! fasl-read
   (let ()
     (define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr))
-    (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr))
+    (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int ptr) ptr))
     (define (get-uptr p)
       (let ([k (get-u8 p)])
         (let f ([k k] [n (fxsrl k 1)])
@@ -168,8 +168,9 @@
                 [(eqv? ty (constant fasl-type-header))
                  (check-header p)
                  (fasl-entry)]
-                [(eqv? ty (constant fasl-type-fasl-size))
-                 ($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))]
+                [(or (eqv? ty (constant fasl-type-fasl-size))
+                     (eqv? ty (constant fasl-type-vfasl-size)))
+                 ($bv-fasl-read (get-bytevector-n p (get-uptr p)) ty (port-name p))]
                 [else (malformed p)])))))))
 
 (define ($compiled-file-header? ip)

s/compile.ss

@@ -455,9 +455,9 @@
       [(group) elt*
        (apply vector (map c-vfaslobj elt*))]
       [(visit-stuff) elt
-       (cons (constant visit-tag) (c-vfaslobj x))]
+       (cons (constant visit-tag) (c-vfaslobj elt))]
       [(revisit-stuff) elt
-       (cons (constant revisit-tag) (c-vfaslobj x))]
+       (cons (constant revisit-tag) (c-vfaslobj elt))]
       [else (c-mkcode x)])))
 
 (define c-print-vfasl

s/patch.ss

@@ -13,6 +13,8 @@
 ;;; See the License for the specific language governing permissions and
 ;;; limitations under the License.
 
+(define (generate-vfasl) #f)
+
 (printf "loading ~s cross compiler~%" (constant machine-type-name))
 
 ; (current-expand (lambda args (apply sc-expand args)))