369.8

svn: r5594

collects/mzlib/foreign.ss

@@ -58,12 +58,13 @@
 
 (provide* ctype-sizeof ctype-alignof compiler-sizeof
           malloc free end-stubborn-change
-          cpointer? ptr-equal? (unsafe ptr-ref) (unsafe ptr-set!)
+          cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
           ctype? make-ctype make-cstruct-type make-sized-byte-string
           _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
           _fixint _ufixint _fixnum _ufixnum
           _float _double _double*
-          _bool _pointer _scheme _fpointer)
+          _bool _pointer _scheme _fpointer
+          (unsafe memcpy) (unsafe memmove) (unsafe memset))
 
 (define-syntax define*
   (syntax-rules ()

collects/mzlib/md5.ss

@@ -134,7 +134,7 @@
                      #xFFF #x1FFF #x3FFF #x7FFF #xFFFF)])
       (lambda (a s)
         (let-values ([(hi lo s)
-                      (cond [(< 0 s 16) (values (car a) (cdr a) s)]
+                      (cond [(< s 16) (values (car a) (cdr a) s)]
                             [(< s 32) (values (cdr a) (car a) (- s 16))]
                             [else (error 'word<<< "shift out of range: ~e"
                                          s)])])
@@ -161,12 +161,12 @@
     ;;   (error 'bytes->word-vector! "something bad happened"))
     (let loop ([n 15])
       (when (<= 0 n)
-        (let ([m (* 4 n)])
+        (let ([m (arithmetic-shift n 2)])
           (cons! (vector-ref result n)
                  (+ (bytes-ref l-raw (+ 2 m))
-                    (* 256 (bytes-ref l-raw (+ 3 m))))
+                    (arithmetic-shift (bytes-ref l-raw (+ 3 m)) 8))
                  (+ (bytes-ref l-raw m)
-                    (* 256 (bytes-ref l-raw (+ 1 m))))))
+                    (arithmetic-shift (bytes-ref l-raw (+ 1 m)) 8))))
         (loop (sub1 n)))))
 
   (define empty-port (open-input-bytes #""))

collects/tests/mzscheme/foreign-test.c

@@ -55,3 +55,5 @@ X int use_g3(int x) { return ((int(*)(int))g3)(x); }
 /* typedef int2int(*int_to_int2int)(int); */
 /* int hoho(int x, int_to_int2int f) { */
 X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); }
+
+X int grab7th(void *p) { return ((char *)p)[7]; }

collects/tests/mzscheme/foreign-test.ss

@@ -120,10 +120,56 @@
          (lambda (x y)
            (let ([x (ptr-ref x _int)] [y (ptr-ref y _int)])
              (cond [(< x y) -1] [(> x y) +1] [else 0])))))
+
+  ;; ---
+  (t  55 'grab7th   (_fun _pointer -> _int ) #"012345678")
+  (t  56 'grab7th   (_fun _pointer -> _int ) (ptr-add #"012345678" 1))
+  (t  52 'grab7th   (_fun _pointer -> _int ) (ptr-add #"012345678" -3))
   )
 
-(report-errs)
+;; Test pointer arithmetic and memmove-like operations
+(let ([p (malloc 10 _int)])
+  (memset p 0 10 _int)
+  (test 0 ptr-ref p _int)
+  (test 0 ptr-ref (ptr-add p 3 _int) _int)
+  (ptr-set! p _int 5)
+  (test 5 ptr-ref p _int)
+  (test 0 ptr-ref (ptr-add p 3 _int) _int)
+  (memcpy p 3 _int p 0 1 _int)
+  (test 5 ptr-ref (ptr-add p 3 _int) _int)
 
+  ;; A MzScheme `int' is always 4 bytes.
+  (memset p 1 _int 17 9 _int)
+  (test 5 ptr-ref p _int)
+  (test #x11111111 ptr-ref (ptr-add p 4) _int)
+  (memset p 2 18 9 _int)
+  (test #x12121212 ptr-ref (ptr-add p 4) _int)
+  (if (system-big-endian?)
+      (test #x00001212 ptr-ref p _int)
+      (test #x12120005 ptr-ref p _int))
+
+  (ptr-set! (ptr-add p 4 _int) _int 10)
+  (ptr-set! (ptr-add p 5 _int) _int 11)
+  (ptr-set! (ptr-add p 6 _int) _int 12)
+  (memmove p 2 _int p 4 _int 3 _int)
+  (test 10 ptr-ref (ptr-add p 2 _int) _int)
+  (test 11 ptr-ref (ptr-add p 3 _int) _int)
+  (test 12 ptr-ref (ptr-add p 4 _int) _int)
+  (memmove p 6 _short p 8 _byte 12)
+  (test 10 ptr-ref (ptr-add p 2 _int) _int)
+  (test 10 ptr-ref (ptr-add p 3 _int) _int)
+  (test 11 ptr-ref (ptr-add p 4 _int) _int)
+  (test 12 ptr-ref (ptr-add p 5 _int) _int)
+  (test 12 ptr-ref (ptr-add p 6 _int) _int)
+  (memmove p p 8 4)
+  (test 10 ptr-ref p _int)
+
+  (test #f ptr-equal? p (ptr-add p 3))
+  (test #t ptr-equal? p (ptr-add (ptr-add p 3) -3))
+  (test #f ptr-equal? #f (ptr-add #f 8))
+  (test #t ptr-equal? #f (ptr-add (ptr-add #f 8) -8)))
+
+(report-errs)
 
 #| --- ignore everything below ---
 

collects/tests/mzscheme/rx.ss

@@ -1662,6 +1662,21 @@
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;; Check that [\s] doesn't match \s, etc.
+(let ([test-both
+       (lambda (r bstr arg)
+         (test (and r (list r))regexp-match (byte-pregexp bstr) arg)
+         (test (and r (list (bytes->string/latin-1 r)) )
+               regexp-match 
+               (pregexp (bytes->string/latin-1 bstr))
+               (bytes->string/latin-1 arg)))])
+  (test-both #f #"[\\s]" #"a")
+  (test-both #f #"[\\s]" #"s")
+  (test-both #" " #"[\\s]" #" ")
+  (test-both #"a" #"[^\\s]" #"a")
+  (test-both #"s" #"[^\\s]" #"s")
+  (test-both #f #"[^\\s]" #" "))
+
 ;; Check that rx doesn't parse as px:
 (test '(#"aa" #"a") regexp-match #px#"(a)\\1" #"aa")
 (test '(#"a1" #"a") regexp-match #rx#"(a)\\1" #"a1")

collects/wxme/doc.txt

@@ -73,12 +73,19 @@ Like `read', but for a stream that starts with WXME-format data. If
 multiple S-expressions are in the WXME data, they are all read and
 combined with `begin'.
 
+If MrEd is available (as determined by checking for `#%mred-kernel'),
+then MrEd is used via `open-input-text-editor'. Otherwise,
+`wxme-port->port' is used.
+
 > (wxme-read-syntax source-v port)
 
 Like `read-syntax', but for a WXME format input stream.  If multiple
 S-expressions are in the WXME data, they are all read and combined
 with `begin'.
 
+If MrEd is available (as determined by checking for `#%mred-kernel'),
+then MrEd is used via `open-input-text-editor'. Otherwise,
+`wxme-port->port' is used.
 
 > snip-reader<%>
 

collects/wxme/wxme.ss

@@ -616,7 +616,17 @@
     (wxme-convert-port port close? #f))
 
   (define (do-read port who read)
-    (let ([port (decode who port (lambda (x) x) #f)])
+    (let ([port (if (with-handlers ([exn:fail? (lambda (x) #f)])
+                      (dynamic-require '#%mred-kernel #f)
+                      #t)
+                    ;; GUI mode, since MrEd is available:
+                    (let ([text% (dynamic-require '(lib "mred.ss" "mred") 'text%)]
+                          [open-input-text-editor (dynamic-require '(lib "mred.ss" "mred") 'open-input-text-editor)])
+                      (let ([t (new text%)])
+                        (send t insert-port port 'standard)
+                        (open-input-text-editor t 0 'end values (object-name port) #t)))
+                    ;; Non-GUI mode:
+                    (decode who port (lambda (x) x) #f))])
       (let ([v (read port)])
         (let ([v2 (let loop ()
                     (let ([v2 (read port)])

doc/release-notes/mzscheme/HISTORY

@@ -1,5 +1,10 @@
 Version 369.8
 Added -p, -P, and -Q command-line options
+Changed H-expression parsing to represent angle brackets specially
+Added syntax-local-expand-expression
+MzLib: foreign.ss: Added ptr-add, memmove, memcpy, and memset
+Inside MzScheme: added scheme_set_type_equality(), based on a patch
+ from Dimitris Vyzovitis
 
 Version 369.7
 Added string->path-element and path-element->string

src/foreign/foreign.c

@@ -74,6 +74,8 @@
 # define GC_CAN_IGNORE /* empty */
 #endif
 
+#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
+
 /* same as the macro in file.c */
 #define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
 
@@ -487,6 +489,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      -none-
  * Predicate:   -none-
  * Scheme->C:   -none-
+ * S->C offset: 0
  * C->Scheme:   scheme_void
  */
 
@@ -496,6 +499,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tsint8
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer(<C>)
  */
 
@@ -505,6 +509,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tuint8
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
  */
 
@@ -514,6 +519,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tsint16
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer(<C>)
  */
 
@@ -523,6 +529,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tuint16
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
  */
 
@@ -533,6 +540,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tsint32
  * Predicate:   scheme_get_realint_val(<Scheme>,&aux)
  * Scheme->C:   -none- (set by the predicate)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_realinteger_value(<C>)
  */
 
@@ -543,6 +551,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tuint32
  * Predicate:   scheme_get_unsigned_realint_val(<Scheme>,&aux)
  * Scheme->C:   -none- (set by the predicate)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_realinteger_value_from_unsigned(<C>)
  */
 
@@ -552,6 +561,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tsint64
  * Predicate:   scheme_get_long_long_val(<Scheme>,&aux)
  * Scheme->C:   -none- (set by the predicate)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer_value_from_long_long(<C>)
  */
 
@@ -561,6 +571,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tuint64
  * Predicate:   scheme_get_unsigned_long_long_val(<Scheme>,&aux)
  * Scheme->C:   -none- (set by the predicate)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer_value_from_unsigned_long_long(<C>)
  */
 
@@ -571,6 +582,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tsint32
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer(<C>)
  */
 
@@ -581,6 +593,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Tuint32
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
  */
 
@@ -600,6 +613,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      long
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer(<C>)
  */
 
@@ -610,6 +624,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      unsigned long
  * Predicate:   SCHEME_INTP(<Scheme>)
  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
  */
 
@@ -619,6 +634,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      float
  * Predicate:   SCHEME_FLTP(<Scheme>)
  * Scheme->C:   SCHEME_FLT_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_float(<C>)
  */
 
@@ -628,6 +644,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      double
  * Predicate:   SCHEME_DBLP(<Scheme>)
  * Scheme->C:   SCHEME_DBL_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_double(<C>)
  */
 
@@ -638,6 +655,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      double
  * Predicate:   SCHEME_REALP(<Scheme>)
  * Scheme->C:   scheme_real_to_double(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_double(<C>)
  */
 
@@ -648,6 +666,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      int
  * Predicate:   1
  * Scheme->C:   SCHEME_TRUEP(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   (<C>?scheme_true:scheme_false)
  */
 
@@ -661,6 +680,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      mzchar*
  * Predicate:   SCHEME_CHAR_STRINGP(<Scheme>)
  * Scheme->C:   SCHEME_CHAR_STR_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_make_char_string_without_copying(<C>)
  */
 
@@ -670,6 +690,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      unsigned short*
  * Predicate:   SCHEME_CHAR_STRINGP(<Scheme>)
  * Scheme->C:   ucs4_string_to_utf16_pointer(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   utf16_pointer_to_ucs4_string(<C>)
  */
 
@@ -682,6 +703,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      char*
  * Predicate:   SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>)
  * Scheme->C:   SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
  */
 
@@ -691,6 +713,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      char*
  * Predicate:   SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>)
  * Scheme->C:   SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>))
+ * S->C offset: 0
  * C->Scheme:   (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
  */
 
@@ -700,6 +723,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      char*
  * Predicate:   SCHEME_SYMBOLP(<Scheme>)
  * Scheme->C:   SCHEME_SYM_VAL(<Scheme>)
+ * S->C offset: 0
  * C->Scheme:   scheme_intern_symbol(<C>)
  */
 
@@ -712,6 +736,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      void*
  * Predicate:   SCHEME_FFIANYPTRP(<Scheme>)
  * Scheme->C:   SCHEME_FFIANYPTR_VAL(<Scheme>)
+ * S->C offset: FFIANYPTR
  * C->Scheme:   scheme_make_foreign_cpointer(<C>)
  */
 
@@ -723,6 +748,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      Scheme_Object*
  * Predicate:   1
  * Scheme->C:   <Scheme>
+ * S->C offset: 0
  * C->Scheme:   <C>
  */
 
@@ -735,6 +761,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * C type:      -none-
  * Predicate:   -none-
  * Scheme->C:   -none-
+ * S->C offset: 0
  * C->Scheme:   -none-
  */
 
@@ -990,6 +1017,10 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
       (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
        SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
          NULL)))
+#define SCHEME_FFIANYPTR_OFFSET(x) \
+  (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
+#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
+  W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
 
 #define scheme_make_foreign_cpointer(x) \
   ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
@@ -1078,7 +1109,6 @@ END_XFORM_SKIP;
 #define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
 #define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
 #endif
-#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
 
 static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
 {
@@ -1135,9 +1165,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
 #ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
+#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
 #else
-#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
+#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,_offset,basep)
 #endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
@@ -1145,7 +1175,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
  * basetype_p is set to the corrsponding number tag.  If basetype_p is NULL,
  * then a struct value will be *copied* into dst. */
 static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
-                      Scheme_Object *val, long *basetype_p,
+                      Scheme_Object *val, long *basetype_p, long *_offset,
                       int ret_loc)
 {
   if (!SCHEME_CTYPEP(type))
@@ -1178,7 +1208,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         Tsint8 tmp;
         tmp = (Tsint8)(SCHEME_INT_VAL(val));
-        (((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","int8",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1193,7 +1222,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         Tuint8 tmp;
         tmp = (Tuint8)(SCHEME_UINT_VAL(val));
-        (((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","uint8",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1208,7 +1236,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         Tsint16 tmp;
         tmp = (Tsint16)(SCHEME_INT_VAL(val));
-        (((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","int16",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1223,7 +1250,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         Tuint16 tmp;
         tmp = (Tuint16)(SCHEME_UINT_VAL(val));
-        (((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","uint16",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1250,7 +1276,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         Tsint32 tmp;
         tmp = (Tsint32)(SCHEME_INT_VAL(val));
-        (((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","fixint",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1265,7 +1290,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         Tuint32 tmp;
         tmp = (Tuint32)(SCHEME_UINT_VAL(val));
-        (((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","ufixint",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1280,7 +1304,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         long tmp;
         tmp = (long)(SCHEME_INT_VAL(val));
-        (((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","fixnum",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1295,7 +1318,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_INTP(val)) {
         unsigned long tmp;
         tmp = (unsigned long)(SCHEME_UINT_VAL(val));
-        (((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1310,7 +1332,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_FLTP(val)) {
         float tmp;
         tmp = (float)(SCHEME_FLT_VAL(val));
-        (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","float",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1325,7 +1346,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_DBLP(val)) {
         double tmp;
         tmp = (double)(SCHEME_DBL_VAL(val));
-        (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","double",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1340,7 +1360,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (SCHEME_REALP(val)) {
         double tmp;
         tmp = (double)(scheme_real_to_double(val));
-        (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","double*",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1355,7 +1374,6 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (1) {
         int tmp;
         tmp = (int)(SCHEME_TRUEP(val));
-        (((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","bool",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1371,10 +1389,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         mzchar* tmp;
         tmp = (mzchar*)(SCHEME_CHAR_STR_VAL(val));
         if (basetype_p == NULL ||tmp == NULL) {
-          (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+          (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_string_ucs_4; return tmp;
+          *basetype_p = FOREIGN_string_ucs_4;
+          return tmp;
         }
+        (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1390,10 +1411,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         unsigned short* tmp;
         tmp = (unsigned short*)(ucs4_string_to_utf16_pointer(val));
         if (basetype_p == NULL ||tmp == NULL) {
-          (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+          (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_string_utf_16; return tmp;
+          *basetype_p = FOREIGN_string_utf_16;
+          return tmp;
         }
+        (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1409,10 +1433,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         char* tmp;
         tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
         if (basetype_p == NULL ||tmp == NULL) {
-          (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_bytes; return tmp;
+          *basetype_p = FOREIGN_bytes;
+          return tmp;
         }
+        (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","bytes",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1428,10 +1455,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         char* tmp;
         tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
         if (basetype_p == NULL ||tmp == NULL) {
-          (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_path; return tmp;
+          *basetype_p = FOREIGN_path;
+          return tmp;
         }
+        (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","path",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1447,10 +1477,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         char* tmp;
         tmp = (char*)(SCHEME_SYM_VAL(val));
         if (basetype_p == NULL ||tmp == NULL) {
-          (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_symbol; return tmp;
+          *basetype_p = FOREIGN_symbol;
+          return tmp;
         }
+        (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","symbol",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1463,13 +1496,18 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       }
 #endif
       if (SCHEME_FFIANYPTRP(val)) {
-        void* tmp;
+        void* tmp; long toff;
         tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
-        if (basetype_p == NULL || tmp == NULL) {
+        toff = SCHEME_FFIANYPTR_OFFSET(val);
-          (((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+        if (_offset) *_offset = toff;
+        if (basetype_p == NULL ||(tmp == NULL && toff == 0)) {
+          (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_pointer; return tmp;
+          *basetype_p = FOREIGN_pointer;
+          return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
         }
+        (((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1485,10 +1523,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         Scheme_Object* tmp;
         tmp = (Scheme_Object*)(val);
         if (basetype_p == NULL ||tmp == NULL) {
-          (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+          (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
         } else {
-          *basetype_p = FOREIGN_scheme; return tmp;
+          *basetype_p = FOREIGN_scheme;
+          return tmp;
         }
+        (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
       } else {
         scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
         return NULL; /* shush the compiler */
@@ -1498,14 +1539,22 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
-      if (basetype_p == NULL) {
+      {
         void* p = SCHEME_FFIANYPTR_VAL(val);
-        if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
+        long poff = SCHEME_FFIANYPTR_OFFSET(val);
-        memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
+        if (basetype_p == NULL) {
+          if (p == NULL && poff == 0) scheme_signal_error("FFI pointer value was NULL.");
+          memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff), CTYPE_PRIMTYPE(type)->size);
           return NULL;
         } else {
           *basetype_p = FOREIGN_struct;
-        return SCHEME_FFIANYPTR_VAL(val);
+          if (_offset) {
+            *_offset = poff;
+            return p;
+          } else {
+            return W_OFFSET(p, poff);
+          }
+        }
       }
     default: scheme_signal_error("corrupt foreign type: %V", type);
   }
@@ -1643,6 +1692,8 @@ static Scheme_Object *atomic_sym;
 static Scheme_Object *stubborn_sym;
 static Scheme_Object *uncollectable_sym;
 static Scheme_Object *eternal_sym;
+static Scheme_Object *interior_sym;
+static Scheme_Object *atomic_interior_sym;
 static Scheme_Object *raw_sym;
 static Scheme_Object *fail_ok_sym;
 
@@ -1666,6 +1717,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
 {
   int i, size=0, num=0, failok=0;
   void *from = NULL, *res = NULL;
+  long foff = 0;
   Scheme_Object *mode = NULL, *a, *base = NULL;
   void *(*mf)(size_t);
   for (i=0; i<argc; i++) {
@@ -1695,6 +1747,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
         scheme_signal_error(MYNAME": specifying a second source pointer: %V",
                             a);
       from = SCHEME_FFIANYPTR_VAL(a);
+      foff = SCHEME_FFIANYPTR_OFFSET(a);
     } else {
       scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
     }
@@ -1709,13 +1762,15 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
   else if (SAME_OBJ(mode, stubborn_sym))      mf = scheme_malloc_stubborn;
   else if (SAME_OBJ(mode, eternal_sym))       mf = scheme_malloc_eternal;
   else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
+  else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_atomic_allow_interior;
+  else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
   else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
   else {
     scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
     return NULL; /* shush the compiler */
   }
   if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
-  if ((from != NULL) && (res != NULL)) memcpy(res, from, size);
+  if (((from != NULL) || (foff != 0)) && (res != NULL)) memcpy(res, W_OFFSET(from, foff), size);
   return scheme_make_foreign_cpointer(res);
 }
 
@@ -1725,12 +1780,14 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
 static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[])
 {
   void *ptr;
+  long poff;
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (poff == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
-  scheme_end_stubborn_change(ptr);
+  scheme_end_stubborn_change(W_OFFSET(ptr, poff));
   return scheme_void;
 }
 
@@ -1742,15 +1799,165 @@ static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[
 static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
 {
   void *ptr;
+  long poff;
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (poff == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
-  free(ptr);
+  free(W_OFFSET(ptr, poff));
   return scheme_void;
 }
 
+#define C_LONG_TYPE_STR "exact integer that fits a C long"
+
+#undef MYNAME
+#define MYNAME "ptr-add"
+static Scheme_Object *foreign_ptr_add(int argc, Scheme_Object *argv[])
+{
+  void *ptr;
+  long poff, noff;
+  if (!SCHEME_FFIANYPTRP(argv[0]))
+    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
+  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
+  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if (!scheme_get_int_val(argv[1], &noff)) {
+    scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
+  }
+  if (argc > 2) {
+    if (SCHEME_CTYPEP(argv[2])) {
+      long size;
+      if (NULL == get_ctype_base(argv[2]))
+        scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
+      size = ctype_sizeof(argv[2]);
+      if (size <= 0)
+        scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
+
+            noff = noff * size;
+    } else
+      scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
+  }
+  return scheme_make_offset_cptr(ptr, poff + noff, NULL);
+}
+
+/* (mem{move,copy} dest-ptr [dest-offset [dest-offset-type]] 
+                   src-ptr [src-offset [src-c-offset-type]] 
+                   cnt [c-type]) */
+/* Copies cnt*sizeof(c-type) bytes from src-ptr + src-offset * sizeof(dest-offset-c-type)
+   to dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
+/* or (memset dest-ptr [dest-offset [dest-offset-type]] byte cnt [c-type]) */
+/* Sets cnt*sizeof(c-type) bytes to byte
+   at dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
+/* The argument handling for the function is very similar, so we just package it all
+   together. */
+static Scheme_Object *do_memop(const char *who, int is_copy, int argc, Scheme_Object **argv)
+{
+  void *src = NULL, *dest = NULL;
+  long soff = 0, doff = 0, cnt = 0;
+  int j, i = argc - 1, ch = 0;
+
+  for (j = 3; j--; ) {
+    if (!is_copy && (j == 1)) {
+      /* Just get byte */
+      if (i < 0)
+        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+                         "%s: missing the fill-byte argument (parsing from right to left)",
+                         who);
+      ch = SCHEME_INTP(argv[i]) ? SCHEME_INT_VAL(argv[i]) : -1;
+      if ((ch < 0) || (ch > 255))
+        scheme_wrong_type(who, "byte", i, argc, argv);
+      i--;
+    } else {
+      long size, v = 0;
+      if (SCHEME_CTYPEP(argv[i])) {
+        if (NULL == get_ctype_base(argv[i]))
+          scheme_wrong_type(who, "C-type", i, argc, argv);
+        size = ctype_sizeof(argv[i]);
+        if (size <= 0)
+          scheme_wrong_type(who, "non-void-C-type", i, argc, argv);
+        --i;
+      } else
+        size = 0;
+      if (SCHEME_EXACT_INTEGERP(argv[i])) {
+        if (!scheme_get_int_val(argv[i], &v)) {
+          scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
+        }
+        --i;
+      } else if (size || (j == 2)) {
+        /* must have final count: */
+        scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, i, argc, argv);
+      }
+
+      if (size)
+        v = v * size;
+
+      switch (j) {
+      case 0:
+        doff = v;
+        break;
+      case 1:
+        soff = v;
+        break;
+      case 2:
+        cnt = v;
+      }
+
+      if (j < 2) {
+        if (i < 0) {
+          scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+                           "%s: missing a pointer argument for %s (parsing from right to left)",
+                           who,
+                           (j == 0 ? "destination" : "source"));
+        }
+
+        if (!SCHEME_FFIANYPTRP(argv[i]))
+          scheme_wrong_type(who, "cpointer", i, argc, argv);
+        if (j == 0) {
+          dest = SCHEME_FFIANYPTR_VAL(argv[i]);
+          doff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
+        } else {
+          src = SCHEME_FFIANYPTR_VAL(argv[i]);
+          soff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
+        }
+        --i;
+      }
+    }
+  }
+
+  if (i >= 0) {
+    scheme_arg_mismatch(who, "unexpected extra argument (parsing from right to left): ", argv[i]);
+  }
+
+  if (is_copy)
+    memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), cnt);
+  else
+    memset(W_OFFSET(dest, doff), ch, cnt);
+
+  return scheme_void;
+}
+
+#undef MYNAME
+#define MYNAME "memmove"
+static Scheme_Object *foreign_memmove(int argc, Scheme_Object *argv[])
+{
+  return do_memop(MYNAME, 1, argc, argv);
+}
+
+#undef MYNAME
+#define MYNAME "memcpy"
+static Scheme_Object *foreign_memcpy(int argc, Scheme_Object *argv[])
+{
+  return do_memop(MYNAME, 1, argc, argv);
+}
+
+#undef MYNAME
+#define MYNAME "memset"
+static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
+{
+  return do_memop(MYNAME, 0, argc, argv);
+}
+
 static Scheme_Object *abs_sym;
 
 /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
@@ -1763,12 +1970,13 @@ static Scheme_Object *abs_sym;
 static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
 {
   int size=0; void *ptr; Scheme_Object *base;
-  long delta = 0;
+  long delta;
 
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (delta == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
@@ -1789,11 +1997,11 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
       scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
     if (!SCHEME_INTP(argv[3]))
       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
-    delta = SCHEME_INT_VAL(argv[3]);
+    delta += SCHEME_INT_VAL(argv[3]);
   } else if (argc > 2) {
     if (!SCHEME_INTP(argv[2]))
       scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
-    delta = (size * SCHEME_INT_VAL(argv[2]));
+    delta += (size * SCHEME_INT_VAL(argv[2]));
   }
   return C2SCHEME(argv[1], ptr, delta, 0);
 }
@@ -1808,12 +2016,13 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
 static Scheme_Object *foreign_ptr_set(int argc, Scheme_Object *argv[])
 {
   int size=0; void *ptr;
-  long delta = 0;
+  long delta;
   Scheme_Object *val = argv[argc-1], *base;
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (delta == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
@@ -1840,13 +2049,13 @@ static Scheme_Object *foreign_ptr_set(int argc, Scheme_Object *argv[])
       scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
     if (!SCHEME_INTP(argv[3]))
       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
-    delta = SCHEME_INT_VAL(argv[3]);
+    delta += SCHEME_INT_VAL(argv[3]);
   } else if (argc > 3) {
     if (!SCHEME_INTP(argv[2]))
       scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
-    delta = (size * SCHEME_INT_VAL(argv[2]));
+    delta += (size * SCHEME_INT_VAL(argv[2]));
   }
-  SCHEME2C(argv[1], ptr, delta, val, NULL, 0);
+  SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
   return scheme_void;
 }
 
@@ -1860,7 +2069,7 @@ static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
   if (!SCHEME_FFIANYPTRP(argv[1]))
     scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
   return (SAME_OBJ(argv[0],argv[1]) ||
-          (SCHEME_FFIANYPTR_VAL(argv[0]) == SCHEME_FFIANYPTR_VAL(argv[1])))
+          ((SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) == SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))))
          ? scheme_true : scheme_false;
 }
 
@@ -1869,6 +2078,7 @@ static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
 #define MYNAME "make-sized-byte-string"
 static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[])
 /* Warning: no copying is done so it is possible to share string contents. */
+/* Warning: if source ptr has a offset, resulting string object uses shifted pointer. */
 /* (Should use real byte-strings with new version.) */
 {
   long len;
@@ -1878,7 +2088,7 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar
     scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
   if (SCHEME_FALSEP(argv[0])) return scheme_false;
   else return
-         scheme_make_sized_byte_string(SCHEME_FFIANYPTR_VAL(argv[0]), len, 0);
+         scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), len, 0);
 }
 
 /* internal: apply Scheme finalizer */
@@ -1950,6 +2160,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
   Scheme_Object *otype  = SCHEME_VEC_ELS(data)[3];
   Scheme_Object *base;
   ffi_cif       *cif    = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
+  long          cfoff   = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
   int           nargs   = cif->nargs;
   /* When the foreign function is called, we need an array (ivals) of nargs
    * ForeignAny objects to store the actual C values that are created, and we
@@ -1970,25 +2181,30 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
   void **avalues, *p, *newp, *tmp;
   GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
   void *stack_avalues[MAX_QUICK_ARGS];
+  long stack_offsets[MAX_QUICK_ARGS];
   int i;
-  long basetype;
+  long basetype, offset, *offsets;
   if (nargs <= MAX_QUICK_ARGS) {
     ivals   = stack_ivals;
     avalues = stack_avalues;
+    offsets = stack_offsets;
   } else {
     ivals   = malloc(nargs * sizeof(ForeignAny));
     avalues = scheme_malloc(nargs * sizeof(void*));
+    offsets = scheme_malloc(nargs * sizeof(long));
   }
   /* iterate on input values and types */
   for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
     /* convert argv[i] according to current itype */
-    p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
+    offset = 0;
+    p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, &offset, 0);
     if (p != NULL) {
       avalues[i] = p;
       ivals[i].x_fixnum = basetype; /* remember the base type */
     } else {
       avalues[i] = NULL;
     }
+    offsets[i] = offset;
   }
   base = get_ctype_base(otype); /* verified below, so cannot be NULL */
   /* If this is a struct return value, then need to malloc in any case, even if
@@ -2002,7 +2218,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
     p = &oval;
     newp = NULL;
   }
-  /* We finished with all possible mallocs, clear up the avalues mess */
+  /* We finished with all possible mallocs, clear up the avalues an offsets mess */
   for (i=0; i<nargs; i++) {
     if (avalues[i] == NULL)     /* if this was a non-pointer... */
       avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
@@ -2011,10 +2227,14 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
       ivals[i].x_pointer = avalues[i];
       avalues[i] = &(ivals[i]);
     }
-    /* Otherwise it was a struct pointer, and avalues[i] is already fine */
+    /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
+    /* Add offset, if any: */
+    if (offsets[i] != 0) {
+      ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; 
+    }
   }
   /* Finally, call the function */
-  ffi_call(cif, c_func, p, avalues);
+  ffi_call(cif, (void *)W_OFFSET(c_func, cfoff), p, avalues);
   if (ivals != stack_ivals) free(ivals);
   ivals = NULL; /* no need now to hold on to this */
   for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
@@ -2056,6 +2276,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
   Scheme_Object *itypes = argv[1];
   Scheme_Object *otype  = argv[2];
   Scheme_Object *obj, *data, *p, *base;
+  long ooff;
   GC_CAN_IGNORE ffi_type *rtype, **atypes;
   GC_CAN_IGNORE ffi_cif *cif;
   int i, nargs;
@@ -2065,7 +2286,8 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
   obj = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (obj == NULL)
+  ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((obj == NULL) && (ooff == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   nargs = scheme_proper_list_length(itypes);
   if (nargs < 0)
@@ -2084,7 +2306,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
   cif = malloc(sizeof(ffi_cif));
   if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
-  data = scheme_make_vector(5, NULL);
+  data = scheme_make_vector(6, NULL);
   p = scheme_append_byte_string
         (ffi_name_prefix,
          scheme_make_byte_string_without_copying
@@ -2095,6 +2317,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
   SCHEME_VEC_ELS(data)[2] = itypes;
   SCHEME_VEC_ELS(data)[3] = otype;
   SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
+  SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
   scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
   return scheme_make_closed_prim_w_arity
            (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
@@ -2129,7 +2352,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
     argv[i] = v;
   }
   p = _scheme_apply(data->proc, argc, argv);
-  SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
+  SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
 }
 
 /* see ffi-callback below */
@@ -2278,6 +2501,10 @@ void scheme_init_foreign(Scheme_Env *env)
   uncollectable_sym = scheme_intern_symbol("uncollectable");
   MZ_REGISTER_STATIC(eternal_sym);
   eternal_sym = scheme_intern_symbol("eternal");
+  MZ_REGISTER_STATIC(interior_sym);
+  interior_sym = scheme_intern_symbol("interior");
+  MZ_REGISTER_STATIC(atomic_interior_sym);
+  atomic_interior_sym = scheme_intern_symbol("atomic-interior");
   MZ_REGISTER_STATIC(raw_sym);
   raw_sym = scheme_intern_symbol("raw");
   MZ_REGISTER_STATIC(fail_ok_sym);
@@ -2330,6 +2557,14 @@ void scheme_init_foreign(Scheme_Env *env)
     scheme_make_prim_w_arity(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
   scheme_add_global("free",
     scheme_make_prim_w_arity(foreign_free, "free", 1, 1), menv);
+  scheme_add_global("ptr-add",
+    scheme_make_prim_w_arity(foreign_ptr_add, "ptr-add", 2, 3), menv);
+  scheme_add_global("memmove",
+    scheme_make_prim_w_arity(foreign_memmove, "memmove", 3, 8), menv);
+  scheme_add_global("memcpy",
+    scheme_make_prim_w_arity(foreign_memcpy, "memcpy", 3, 8), menv);
+  scheme_add_global("memset",
+    scheme_make_prim_w_arity(foreign_memset, "memset", 3, 6), menv);
   scheme_add_global("ptr-ref",
     scheme_make_prim_w_arity(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
   scheme_add_global("ptr-set!",

src/foreign/foreign.ssc

@@ -81,6 +81,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
 # define GC_CAN_IGNORE /* empty */
 #endif
 
+#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
+
 /* same as the macro in file.c */
 #define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
 
@@ -423,6 +425,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
 ;;     function with the same arguments as above)
 ;;   c->s:  name of value construction macro/function
 ;;    (or a function of the value that generates the expression)
+;;   offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset
+;;    value for s->c, otherwise leave 0 as the offset
 
 (define types '())
 
@@ -431,7 +435,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
 
 (define *type-counter* 0)
 
-(define (describe-type stype cname ftype ctype pred s->c c->s)
+(define (describe-type stype cname ftype ctype pred s->c c->s offset)
   (set! *type-counter* (add1 *type-counter*))
   (~ "#define FOREIGN_"cname" ("*type-counter*")" \\
      "/* Type Name:   "stype (and (not (equal? cname stype))
@@ -446,6 +450,9 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
                          (if pred "-none- (set by the predicate)" "-none-")]
                         [(procedure? s->c) (s->c "<Scheme>" "aux")]
                         [else (list s->c"(<Scheme>)")]) \\
+     " * S->C offset: "(cond 
+                        [(not offset) "0"]
+                        [else offset]) \\
      " * C->Scheme:   "(cond [(not c->s) "-none-"]
                              [(procedure? c->s) (c->s "<C>")]
                              [else (list c->s"(<C>)")]) \\
@@ -472,10 +479,11 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
          [macro (prop 'macro)]
          [pred  (prop 'pred (and macro (list "SCHEME_"macro"P")))]
          [s->c  (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))]
-         [c->s  (prop 'c->s)])
+         [c->s  (prop 'c->s)]
-    (describe-type stype cname ftype ctype pred s->c c->s)
+         [offset (prop 'offset #f)])
+    (describe-type stype cname ftype ctype pred s->c c->s offset)
     `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
-      (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s))))
+      (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
 
 (define (defctype name . args)
   (set! types (append! types (list (make-ctype name args)))))
@@ -492,6 +500,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
                      [pred  (id 'pred)]
                      [s->c  (id 's->c)]
                      [c->s  (id 'c->s)]
+                     [offset (id 'offset)]
                      [ptr?  (id 'ptr?)])
          #'(for-each
             (lambda (t)
@@ -505,6 +514,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
                      [pred  (get 'pred)]
                      [s->c  (get 's->c)]
                      [c->s  (get 'c->s)]
+                     [offset (get 'offset)]
                      [ptr?  (equal? "pointer" ftype)])
                 body ...))
             types)))]))
@@ -665,6 +675,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
 (defctype 'pointer
   'ctype "void*"
   'macro "FFIANYPTR"
+  'offset "FFIANYPTR"
   'c->s  "scheme_make_foreign_cpointer")
 
 ;; This is probably not needed
@@ -856,6 +867,10 @@ void free_libffi_type(void *ignored, void *p)
       (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
        SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
          NULL)))
+#define SCHEME_FFIANYPTR_OFFSET(x) \
+  (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
+#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
+  W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
 
 #define scheme_make_foreign_cpointer(x) \
   ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
@@ -906,7 +921,6 @@ void free_libffi_type(void *ignored, void *p)
 #define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
 #define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
 #endif
-#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
 
 static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
 {
@@ -944,9 +958,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
 #ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
+#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
 #else
-#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
+#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) scheme_to_c(typ,dst,delta,val,_offset,basep)
 #endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
@@ -954,7 +968,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
  * basetype_p is set to the corrsponding number tag.  If basetype_p is NULL,
  * then a struct value will be *copied* into dst. */
 static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
-                      Scheme_Object *val, long *basetype_p,
+                      Scheme_Object *val, long *basetype_p, long *_offset,
                       int ret_loc)
 {
   if (!SCHEME_CTYPEP(type))
@@ -993,14 +1007,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
                    "  }")
                 (display "#endif\n")
                 (~ "  if ("(f pred)") {" \\
-                   "    "ctype" tmp;" \\
+                   "    "ctype" tmp;" (if offset " long toff;" "") \\
                    "    tmp = ("ctype")("(f s->c)");")
-                (if ptr?
+                (when offset
-                  (~ "    if (basetype_p == NULL || tmp == NULL) {" \\
+                  (~ "    toff = SCHEME_"offset"_OFFSET(val);")
-                     "      "x" = tmp; return NULL;" \\
+                  (~ "    if (_offset) *_offset = toff;"))
+                (when ptr?
+                  (~ "    if (basetype_p == NULL ||"
+                     (if offset
+                         "(tmp == NULL && toff == 0)"
+                         "tmp == NULL")
+                     ") {")
+                  (if offset
+                      (~ "      "x" = (_offset ? tmp : ("ctype")W_OFFSET(tmp, toff));")
+                      (~ "      "x" = tmp;"))
+                  (~ "      return NULL;" \\
                      "    } else {" \\
-                     "      *basetype_p = FOREIGN_"cname"; return tmp;" \\
+                     "      *basetype_p = FOREIGN_"cname";")
-                     "    }")
+                  (if offset
+                      (~ "      return _offset ? tmp : ("ctype")W_OFFSET(tmp, toff);")
+                      (~ "      return tmp;"))
+                  (~ "    }")
                   (~ "    "x" = tmp; return NULL;"))
                 (~ "  } else {" \\
                    "    "(wrong-type "val" stype) \\
@@ -1014,14 +1041,22 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
-      if (basetype_p == NULL) {
+      {
         void* p = SCHEME_FFIANYPTR_VAL(val);
-        if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
+        long poff = SCHEME_FFIANYPTR_OFFSET(val);
-        memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
+        if (basetype_p == NULL) {
+          if (p == NULL && poff == 0) scheme_signal_error("FFI pointer value was NULL.");
+          memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff), CTYPE_PRIMTYPE(type)->size);
           return NULL;
         } else {
           *basetype_p = FOREIGN_struct;
-        return SCHEME_FFIANYPTR_VAL(val);
+          if (_offset) {
+            *_offset = poff;
+            return p;
+          } else {
+            return W_OFFSET(p, poff);
+          }
+        }
       }
     default: scheme_signal_error("corrupt foreign type: %V", type);
   }
@@ -1148,7 +1183,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 /*****************************************************************************/
 /* Pointer type user functions */
 
-{:(defsymbols nonatomic atomic stubborn uncollectable eternal raw fail-ok):}
+{:(defsymbols nonatomic atomic stubborn uncollectable eternal interior atomic-interior raw fail-ok):}
 
 /* (malloc num type cpointer mode) -> pointer */
 /* The arguments for this function are:
@@ -1168,6 +1203,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 {
   int i, size=0, num=0, failok=0;
   void *from = NULL, *res = NULL;
+  long foff = 0;
   Scheme_Object *mode = NULL, *a, *base = NULL;
   void *(*mf)(size_t);
   for (i=0; i<argc; i++) {
@@ -1197,6 +1233,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         scheme_signal_error(MYNAME": specifying a second source pointer: %V",
                             a);
       from = SCHEME_FFIANYPTR_VAL(a);
+      foff = SCHEME_FFIANYPTR_OFFSET(a);
     } else {
       scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
     }
@@ -1211,13 +1248,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
   else if (SAME_OBJ(mode, stubborn_sym))      mf = scheme_malloc_stubborn;
   else if (SAME_OBJ(mode, eternal_sym))       mf = scheme_malloc_eternal;
   else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
+  else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_atomic_allow_interior;
+  else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
   else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
   else {
     scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
     return NULL; /* shush the compiler */
   }
   if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
-  if ((from != NULL) && (res != NULL)) memcpy(res, from, size);
+  if (((from != NULL) || (foff != 0)) && (res != NULL)) memcpy(res, W_OFFSET(from, foff), size);
   return scheme_make_foreign_cpointer(res);
 }
 
@@ -1225,12 +1264,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 {:(cdefine end-stubborn-change 1):}
 {
   void *ptr;
+  long poff;
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (poff == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
-  scheme_end_stubborn_change(ptr);
+  scheme_end_stubborn_change(W_OFFSET(ptr, poff));
   return scheme_void;
 }
 
@@ -1240,15 +1281,157 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 {:(cdefine free 1):}
 {
   void *ptr;
+  long poff;
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (poff == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
-  free(ptr);
+  free(W_OFFSET(ptr, poff));
   return scheme_void;
 }
 
+#define C_LONG_TYPE_STR "exact integer that fits a C long"
+
+{:(cdefine ptr-add 2 3):}
+{
+  void *ptr;
+  long poff, noff;
+  if (!SCHEME_FFIANYPTRP(argv[0]))
+    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
+  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
+  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if (!scheme_get_int_val(argv[1], &noff)) {
+    scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
+  }
+  if (argc > 2) {
+    if (SCHEME_CTYPEP(argv[2])) {
+      long size;
+      if (NULL == get_ctype_base(argv[2]))
+        scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
+      size = ctype_sizeof(argv[2]);
+      if (size <= 0)
+        scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
+      
+      noff = noff * size;
+    } else
+      scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
+  }
+  return scheme_make_offset_cptr(ptr, poff + noff, NULL);
+}
+
+/* (mem{move,copy} dest-ptr [dest-offset [dest-offset-type]] 
+                   src-ptr [src-offset [src-c-offset-type]] 
+                   cnt [c-type]) */
+/* Copies cnt*sizeof(c-type) bytes from src-ptr + src-offset * sizeof(dest-offset-c-type)
+   to dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
+/* or (memset dest-ptr [dest-offset [dest-offset-type]] byte cnt [c-type]) */
+/* Sets cnt*sizeof(c-type) bytes to byte
+   at dest-ptr + dest-offset * sizeof(dest-offset-c-type). */
+/* The argument handling for the function is very similar, so we just package it all
+   together. */
+static Scheme_Object *do_memop(const char *who, int is_copy, int argc, Scheme_Object **argv)
+{
+  void *src = NULL, *dest = NULL;
+  long soff = 0, doff = 0, cnt = 0;
+  int j, i = argc - 1, ch = 0;
+
+  for (j = 3; j--; ) {
+    if (!is_copy && (j == 1)) {
+      /* Just get byte */
+      if (i < 0)
+        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+                         "%s: missing the fill-byte argument (parsing from right to left)",
+                         who);
+      ch = SCHEME_INTP(argv[i]) ? SCHEME_INT_VAL(argv[i]) : -1;
+      if ((ch < 0) || (ch > 255))
+        scheme_wrong_type(who, "byte", i, argc, argv);
+      i--;
+    } else {
+      long size, v = 0;
+      if (SCHEME_CTYPEP(argv[i])) {
+        if (NULL == get_ctype_base(argv[i]))
+          scheme_wrong_type(who, "C-type", i, argc, argv);
+        size = ctype_sizeof(argv[i]);
+        if (size <= 0)
+          scheme_wrong_type(who, "non-void-C-type", i, argc, argv);
+        --i;
+      } else
+        size = 0;
+      if (SCHEME_EXACT_INTEGERP(argv[i])) {
+        if (!scheme_get_int_val(argv[i], &v)) {
+          scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
+        }
+        --i;
+      } else if (size || (j == 2)) {
+        /* must have final count: */
+        scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, i, argc, argv);
+      }
+
+      if (size)
+        v = v * size;
+
+      switch (j) {
+      case 0:
+        doff = v;
+        break;
+      case 1:
+        soff = v;
+        break;
+      case 2:
+        cnt = v;
+      }
+
+      if (j < 2) {
+        if (i < 0) {
+          scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+                           "%s: missing a pointer argument for %s (parsing from right to left)",
+                           who,
+                           (j == 0 ? "destination" : "source"));
+        }
+
+        if (!SCHEME_FFIANYPTRP(argv[i]))
+          scheme_wrong_type(who, "cpointer", i, argc, argv);
+        if (j == 0) {
+          dest = SCHEME_FFIANYPTR_VAL(argv[i]);
+          doff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
+        } else {
+          src = SCHEME_FFIANYPTR_VAL(argv[i]);
+          soff += SCHEME_FFIANYPTR_OFFSET(argv[i]);
+        }
+        --i;
+      }
+    }
+  }
+
+  if (i >= 0) {
+    scheme_arg_mismatch(who, "unexpected extra argument (parsing from right to left): ", argv[i]);
+  }
+
+  if (is_copy)
+    memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), cnt);
+  else
+    memset(W_OFFSET(dest, doff), ch, cnt);
+
+  return scheme_void;
+}
+
+{:(cdefine memmove 3 8):}
+{
+  return do_memop(MYNAME, 1, argc, argv);
+}
+
+{:(cdefine memcpy 3 8):}
+{
+  return do_memop(MYNAME, 1, argc, argv);
+}
+
+{:(cdefine memset 3 6):}
+{
+  return do_memop(MYNAME, 0, argc, argv);
+}
+
 {:(defsymbols abs):}
 
 /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
@@ -1259,12 +1442,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 {:(cdefine ptr-ref 2 4):}
 {
   int size=0; void *ptr; Scheme_Object *base;
-  long delta = 0;
+  long delta;
 
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (delta == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
@@ -1285,11 +1469,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
     if (!SCHEME_INTP(argv[3]))
       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
-    delta = SCHEME_INT_VAL(argv[3]);
+    delta += SCHEME_INT_VAL(argv[3]);
   } else if (argc > 2) {
     if (!SCHEME_INTP(argv[2]))
       scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
-    delta = (size * SCHEME_INT_VAL(argv[2]));
+    delta += (size * SCHEME_INT_VAL(argv[2]));
   }
   return C2SCHEME(argv[1], ptr, delta, 0);
 }
@@ -1302,12 +1486,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 {:(cdefine ptr-set! 3 5):}
 {
   int size=0; void *ptr;
-  long delta = 0;
+  long delta;
   Scheme_Object *val = argv[argc-1], *base;
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (ptr == NULL)
+  delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((ptr == NULL) && (delta == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
@@ -1334,13 +1519,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
     if (!SCHEME_INTP(argv[3]))
       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
-    delta = SCHEME_INT_VAL(argv[3]);
+    delta += SCHEME_INT_VAL(argv[3]);
   } else if (argc > 3) {
     if (!SCHEME_INTP(argv[2]))
       scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
-    delta = (size * SCHEME_INT_VAL(argv[2]));
+    delta += (size * SCHEME_INT_VAL(argv[2]));
   }
-  SCHEME2C(argv[1], ptr, delta, val, NULL, 0);
+  SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
   return scheme_void;
 }
 
@@ -1352,13 +1537,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
   if (!SCHEME_FFIANYPTRP(argv[1]))
     scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
   return (SAME_OBJ(argv[0],argv[1]) ||
-          (SCHEME_FFIANYPTR_VAL(argv[0]) == SCHEME_FFIANYPTR_VAL(argv[1])))
+          ((SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) == SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))))
          ? scheme_true : scheme_false;
 }
 
 /* (make-sized-byte-string cpointer len) */
 {:(cdefine make-sized-byte-string 2 2):}
 /* Warning: no copying is done so it is possible to share string contents. */
+/* Warning: if source ptr has a offset, resulting string object uses shifted pointer. */
 /* (Should use real byte-strings with new version.) */
 {
   long len;
@@ -1368,7 +1554,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
     scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
   if (SCHEME_FALSEP(argv[0])) return scheme_false;
   else return
-         scheme_make_sized_byte_string(SCHEME_FFIANYPTR_VAL(argv[0]), len, 0);
+         scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), len, 0);
 }
 
 /* internal: apply Scheme finalizer */
@@ -1442,6 +1628,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
   Scheme_Object *otype  = SCHEME_VEC_ELS(data)[3];
   Scheme_Object *base;
   ffi_cif       *cif    = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
+  long          cfoff   = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
   int           nargs   = cif->nargs;
   /* When the foreign function is called, we need an array (ivals) of nargs
    * ForeignAny objects to store the actual C values that are created, and we
@@ -1462,25 +1649,30 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
   void **avalues, *p, *newp, *tmp;
   GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
   void *stack_avalues[MAX_QUICK_ARGS];
+  long stack_offsets[MAX_QUICK_ARGS];
   int i;
-  long basetype;
+  long basetype, offset, *offsets;
   if (nargs <= MAX_QUICK_ARGS) {
     ivals   = stack_ivals;
     avalues = stack_avalues;
+    offsets = stack_offsets;
   } else {
     ivals   = malloc(nargs * sizeof(ForeignAny));
     avalues = scheme_malloc(nargs * sizeof(void*));
+    offsets = scheme_malloc(nargs * sizeof(long));
   }
   /* iterate on input values and types */
   for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
     /* convert argv[i] according to current itype */
-    p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
+    offset = 0;
+    p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, &offset, 0);
     if (p != NULL) {
       avalues[i] = p;
       ivals[i].x_fixnum = basetype; /* remember the base type */
     } else {
       avalues[i] = NULL;
     }
+    offsets[i] = offset;
   }
   base = get_ctype_base(otype); /* verified below, so cannot be NULL */
   /* If this is a struct return value, then need to malloc in any case, even if
@@ -1494,7 +1686,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
     p = &oval;
     newp = NULL;
   }
-  /* We finished with all possible mallocs, clear up the avalues mess */
+  /* We finished with all possible mallocs, clear up the avalues an offsets mess */
   for (i=0; i<nargs; i++) {
     if (avalues[i] == NULL)     /* if this was a non-pointer... */
       avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
@@ -1503,10 +1695,14 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
       ivals[i].x_pointer = avalues[i];
       avalues[i] = &(ivals[i]);
     }
-    /* Otherwise it was a struct pointer, and avalues[i] is already fine */
+    /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
+    /* Add offset, if any: */
+    if (offsets[i] != 0) {
+      ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; 
+    }
   }
   /* Finally, call the function */
-  ffi_call(cif, c_func, p, avalues);
+  ffi_call(cif, (void *)W_OFFSET(c_func, cfoff), p, avalues);
   if (ivals != stack_ivals) free(ivals);
   ivals = NULL; /* no need now to hold on to this */
   for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
@@ -1546,6 +1742,7 @@ void free_fficall_data(void *ignored, void *p)
   Scheme_Object *itypes = argv[1];
   Scheme_Object *otype  = argv[2];
   Scheme_Object *obj, *data, *p, *base;
+  long ooff;
   GC_CAN_IGNORE ffi_type *rtype, **atypes;
   GC_CAN_IGNORE ffi_cif *cif;
   int i, nargs;
@@ -1555,7 +1752,8 @@ void free_fficall_data(void *ignored, void *p)
   if (!SCHEME_FFIANYPTRP(argv[0]))
     scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
   obj = SCHEME_FFIANYPTR_VAL(argv[0]);
-  if (obj == NULL)
+  ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
+  if ((obj == NULL) && (ooff == 0))
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   nargs = scheme_proper_list_length(itypes);
   if (nargs < 0)
@@ -1574,7 +1772,7 @@ void free_fficall_data(void *ignored, void *p)
   cif = malloc(sizeof(ffi_cif));
   if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
-  data = scheme_make_vector(5, NULL);
+  data = scheme_make_vector(6, NULL);
   p = scheme_append_byte_string
         (ffi_name_prefix,
          scheme_make_byte_string_without_copying
@@ -1585,6 +1783,7 @@ void free_fficall_data(void *ignored, void *p)
   SCHEME_VEC_ELS(data)[2] = itypes;
   SCHEME_VEC_ELS(data)[3] = otype;
   SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
+  SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
   scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
   return scheme_make_closed_prim_w_arity
            (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
@@ -1619,7 +1818,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
     argv[i] = v;
   }
   p = _scheme_apply(data->proc, argc, argv);
-  SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
+  SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
 }
 
 /* see ffi-callback below */

src/mzscheme/gc2/Makefile.in

@@ -121,7 +121,8 @@ XFORMDEP_NOPRECOMP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss
 XFORMDEP = $(XFORMDEP_NOPRECOMP) $(XSRCDIR)/precomp.h
 
 $(XSRCDIR)/precomp.h : $(XFORMDEP_NOPRECOMP) $(srcdir)/precomp.c $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \
-                       $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schvers.h $(srcdir)/../src/schemef.h
+                       $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schvers.h $(srcdir)/../src/schemef.h \
+                       $(srcdir)/../src/stypes.h 
 	env XFORM_PRECOMP=yes $(XFORM_NOPRECOMP) $(XSRCDIR)/precomp.h $(srcdir)/precomp.c
 
 $(XSRCDIR)/salloc.c: ../src/salloc.@LTO@ $(XFORMDEP)

src/mzscheme/gc2/compact.c

@@ -3884,6 +3884,11 @@ void *GC_malloc_allow_interior(size_t size_in_bytes)
   return malloc_bigblock(size_in_bytes, MTYPE_ARRAY, 1);
 }
 
+void *GC_malloc_atomic_allow_interior(size_t size_in_bytes)
+{
+  return malloc_bigblock(size_in_bytes, MTYPE_ATOMIC, 1);
+}
+
 void *GC_malloc_tagged_allow_interior(size_t size_in_bytes)
 {
   return malloc_bigblock(size_in_bytes, MTYPE_TAGGED, 1);

src/mzscheme/gc2/gc2.h

@@ -180,6 +180,10 @@ GC2_EXTERN void *GC_malloc_allow_interior(size_t size_in_bytes);
    pointers into the middle of the array, or just past the end of the
    array. */
 
+GC2_EXTERN void *GC_malloc_atomic_allow_interior(size_t size_in_bytes);
+/*
+   Like GC_malloc_allow_interior(), but for an atomic object. */
+
 GC2_EXTERN void *GC_malloc_tagged_allow_interior(size_t size_in_bytes);
 /*
    Like GC_malloc_allow_interior(), but for a tagged object. */

src/mzscheme/gc2/newgc.c

@@ -491,6 +491,7 @@ void *GC_malloc_array_tagged(size_t s) { return allocate(s, PAGE_TARRAY); }
 void *GC_malloc_atomic(size_t s) { return allocate(s, PAGE_ATOMIC); }
 void *GC_malloc_atomic_uncollectable(size_t s) { return malloc(s); }
 void *GC_malloc_allow_interior(size_t s) {return allocate_big(s, PAGE_ARRAY);}
+void *GC_malloc_atomic_allow_interior(size_t s) {return allocate_big(s, PAGE_ATOMIC);}
 void *GC_malloc_tagged_allow_interior(size_t s) {return allocate_big(s, PAGE_TAGGED);}
 void GC_free(void *p) {}
 

src/mzscheme/include/mzscheme.exp

@@ -265,6 +265,7 @@ scheme_get_long_long_val
 scheme_get_unsigned_long_long_val
 scheme_real_to_double
 scheme_make_cptr
+scheme_make_offset_cptr
 scheme_get_proc_name
 scheme_utf8_decode
 scheme_utf8_decode_as_prefix
@@ -487,6 +488,7 @@ scheme_eqv
 scheme_equal
 scheme_equal_hash_key
 scheme_equal_hash_key2
+scheme_set_type_equality
 scheme_build_list
 scheme_build_list_offset
 scheme_make_list_immutable

src/mzscheme/include/mzscheme3m.exp

@@ -164,6 +164,9 @@ GC_malloc_one_tagged
 GC_malloc_atomic_uncollectable
 scheme_malloc_uncollectable
 GC_malloc_array_tagged
+GC_malloc_allow_interior
+GC_malloc_atomic_allow_interior
+GC_malloc_tagged_allow_interior
 scheme_malloc_eternal
 scheme_end_stubborn_change
 scheme_calloc
@@ -272,6 +275,7 @@ scheme_get_long_long_val
 scheme_get_unsigned_long_long_val
 scheme_real_to_double
 scheme_make_cptr
+scheme_make_offset_cptr
 scheme_get_proc_name
 scheme_utf8_decode
 scheme_utf8_decode_as_prefix
@@ -495,6 +499,7 @@ scheme_equal
 scheme_hash_key
 scheme_equal_hash_key
 scheme_equal_hash_key2
+scheme_set_type_equality
 scheme_build_list
 scheme_build_list_offset
 scheme_make_list_immutable

src/mzscheme/include/mzwin.def

@@ -253,6 +253,7 @@ EXPORTS
  scheme_get_unsigned_long_long_val
  scheme_real_to_double
  scheme_make_cptr
+ scheme_make_offset_cptr
  scheme_get_proc_name
  scheme_utf8_decode
  scheme_utf8_decode_as_prefix
@@ -475,6 +476,7 @@ EXPORTS
  scheme_equal
  scheme_equal_hash_key
  scheme_equal_hash_key2
+ scheme_set_type_equality
  scheme_build_list
  scheme_build_list_offset
  scheme_make_list_immutable

src/mzscheme/include/mzwin3m.def

@@ -156,6 +156,9 @@ EXPORTS
  GC_malloc_atomic_uncollectable
  scheme_malloc_uncollectable
  GC_malloc_array_tagged
+ GC_malloc_allow_interior
+ GC_malloc_atomic_allow_interior
+ GC_malloc_tagged_allow_interior
  scheme_malloc_eternal
  scheme_end_stubborn_change
  scheme_calloc
@@ -264,6 +267,7 @@ EXPORTS
  scheme_get_unsigned_long_long_val
  scheme_real_to_double
  scheme_make_cptr
+ scheme_make_offset_cptr
  scheme_get_proc_name
  scheme_utf8_decode
  scheme_utf8_decode_as_prefix
@@ -487,6 +491,7 @@ EXPORTS
  scheme_hash_key
  scheme_equal_hash_key
  scheme_equal_hash_key2
+ scheme_set_type_equality
  scheme_build_list
  scheme_build_list_offset
  scheme_make_list_immutable

src/mzscheme/include/scheme.h

@@ -325,6 +325,10 @@ typedef struct Scheme_Vector {
 typedef struct Scheme_Print_Params Scheme_Print_Params;
 typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
 
+typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2);
+typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, long base);
+typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj);
+
 /* This file defines all the built-in types */
 #ifdef INCLUDE_WITHOUT_PATHS
 # include "stypes.h"
@@ -459,7 +463,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type)
 #define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type)
 
-#define SCHEME_CPTRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type)
+#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_offset_cpointer_type))
 
 #define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1))
 #define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)
@@ -549,8 +553,21 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define SCHEME_PINT_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.pint)
 #define SCHEME_PLONG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.pint)
 
-#define SCHEME_CPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.cptr_val.val)
+typedef struct Scheme_Cptr
-#define SCHEME_CPTR_TYPE(obj) (((Scheme_Simple_Object *)(obj))->u.cptr_val.type)
+{
+  Scheme_Object so;
+  void *val;
+  Scheme_Object *type;
+} Scheme_Cptr;
+typedef struct Scheme_Offset_Cptr
+{
+  Scheme_Cptr cptr; 
+  long offset;
+} Scheme_Offset_Cptr;
+
+#define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
+#define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
+#define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
 
 #define SCHEME_SET_IMMUTABLE(obj)  ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
 #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
@@ -1515,6 +1532,7 @@ void *scheme_malloc(size_t size);
 # define scheme_malloc_weak GC_malloc_weak
 # define scheme_malloc_weak_tagged GC_malloc_one_weak_tagged
 # define scheme_malloc_allow_interior GC_malloc_allow_interior
+# define scheme_malloc_atomic_allow_interior GC_malloc_allow_interior
 #else
 # ifdef USE_TAGGED_ALLOCATION
 extern void *scheme_malloc_tagged(size_t);
@@ -1537,6 +1555,7 @@ extern void *scheme_malloc_envunbox(size_t);
 # endif
 # define scheme_malloc_small_dirty_tagged scheme_malloc_small_tagged
 # define scheme_malloc_allow_interior scheme_malloc
+# define scheme_malloc_atomic_allow_interior scheme_malloc_atomic
 # define scheme_malloc_small_atomic_tagged scheme_malloc_atomic_tagged
 #endif
 

src/mzscheme/src/bool.c

@@ -272,9 +272,14 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
     return scheme_bucket_table_equal((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2);
   } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) {
     return vector_equal(obj1, obj2);
-  } else
+  } else {
+    Scheme_Equal_Proc eql = scheme_type_equals[SCHEME_TYPE(obj1)];
+    if (eql)
+      return eql(obj1, obj2);
+    else
       return 0;
   }
+}
 
 static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2)
 {

src/mzscheme/src/env.c

@@ -154,6 +154,20 @@ static void init_compile_data(Scheme_Comp_Env *env);
 /*                             initialization                             */
 /*========================================================================*/
 
+
+#ifdef DONT_USE_FOREIGN
+static void init_dummy_foreign(Scheme *env)
+{
+  /* Works just well enough that the `mzscheme' module can 
+     import it (so that attaching `mzscheme' to a namespace 
+     also attaches `#%foreign'). */
+  Scheme_Env *menv;
+  menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
+  scheme_finish_primitive_module(menv);
+  scheme_protect_primitive_provide(menv, NULL);
+}
+#endif
+
 Scheme_Env *scheme_basic_env()
 {
   Scheme_Env *env;
@@ -350,6 +364,8 @@ Scheme_Env *scheme_basic_env()
 
 #ifndef DONT_USE_FOREIGN
   scheme_init_foreign(env);
+#else
+  init_dummy_foreign(env);
 #endif
 
   scheme_add_embedded_builtins(env);

src/mzscheme/src/eval.c

@@ -172,6 +172,7 @@ static Scheme_Object *compile(int argc, Scheme_Object *argv[]);
 static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *expand(int argc, Scheme_Object **argv);
 static Scheme_Object *local_expand(int argc, Scheme_Object **argv);
+static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv);
 static Scheme_Object *local_expand_catch_lifts(int argc, Scheme_Object **argv);
 static Scheme_Object *local_transformer_expand(int argc, Scheme_Object **argv);
 static Scheme_Object *local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv);
@@ -387,6 +388,11 @@ scheme_init_eval (Scheme_Env *env)
 						      "local-expand",
 						      3, 4), 
 			     env);
+  scheme_add_global_constant("syntax-local-expand-expression", 
+			     scheme_make_prim_w_arity(local_expand_expr, 
+                                                      "syntax-local-expand-expression",
+						      1, 1), 
+			     env);
   scheme_add_global_constant("syntax-local-bind-syntaxes", 
 			     scheme_make_prim_w_arity(local_eval, 
 						      "syntax-local-bind-syntaxes",
@@ -3975,6 +3981,18 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m
   /* caller expects rec[drec] to be used to compile the result... */
 }
 
+static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e)
+{
+  while (1) {
+    if (orig == e)
+      return 1;
+    if (e && e->flags & SCHEME_FOR_STOPS)
+      e = e->next;
+    else
+      return 0;
+  }
+}
+
 static Scheme_Object *compile_expand_expr_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
@@ -4045,6 +4063,22 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
     SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form);
   }
 
+  if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) {
+    var = SCHEME_STX_VAL(form);
+    if (scheme_stx_has_empty_wraps(form)
+        && same_effective_env(SCHEME_PTR2_VAL(var), env)) {
+      /* FIXME: this needs EXPAND_OBSERVE callbacks. */
+      var = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form);
+      form = scheme_stx_cert(var, scheme_false, NULL, form, NULL, 1);
+      if (!rec[drec].comp) {
+        /* Already fully expanded. */
+        return form;
+      }
+    } else {
+      scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), "expanded syntax not in its original context");
+    }
+  }
+
   looking_for_top = 0;
 
   if (SCHEME_STX_NULLP(form)) {
@@ -7655,15 +7689,16 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
 }
 
 static Scheme_Object *
-do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme_Object **argv)
+do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
 {
-  Scheme_Comp_Env *env;
+  Scheme_Comp_Env *env, *orig_env;
-  Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l;
+  Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
   int cnt, pos, kind;
   int bad_sub_env = 0;
   Scheme_Object *observer;
 
   env = scheme_current_thread->current_local_env;
+  orig_env = env;
 
   if (!env)
     scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: not currently transforming", name);
@@ -7673,7 +7708,9 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
     env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
   }
 
-  if (SAME_OBJ(argv[1], module_symbol))
+  if (for_expr)
+    kind = 0; /* expression */
+  else if (SAME_OBJ(argv[1], module_symbol))
     kind = SCHEME_MODULE_BEGIN_FRAME; /* name is backwards compared to symbol! */
   else if (SAME_OBJ(argv[1], module_begin_symbol))
     kind = SCHEME_MODULE_FRAME; /* name is backwards compared to symbol! */
@@ -7718,7 +7755,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
 
   local_mark = scheme_current_thread->current_local_mark;
   
-  if (SCHEME_TRUEP(argv[2])) {
+  if (for_expr) {
+  } else if (SCHEME_TRUEP(argv[2])) {
     cnt = scheme_stx_proper_list_length(argv[2]);
     if (cnt > 0)
       scheme_add_local_syntax(cnt, env);
@@ -7804,6 +7842,25 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
   if (renaming)
     l = scheme_add_rename(l, renaming);
 
+  if (for_expr) {
+    /* Package up expanded expr with the enviornment. */
+    while (1) {
+      if (orig_env->flags & SCHEME_FOR_STOPS)
+        orig_env = orig_env->next;
+      else if ((orig_env->flags & SCHEME_INTDEF_FRAME)
+               && !orig_env->num_bindings)
+        orig_env = orig_env->next;
+      else
+        break;
+    }
+    exp_expr = scheme_alloc_object();
+    exp_expr->type = scheme_expanded_syntax_type;
+    SCHEME_PTR1_VAL(exp_expr) = l;
+    SCHEME_PTR2_VAL(exp_expr) = orig_env;
+    exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0);
+    exp_expr = scheme_add_remove_mark(exp_expr, local_mark);
+  }
+
   if (local_mark) {
     /* Put the temporary mark back: */
     l = scheme_add_remove_mark(l, local_mark);
@@ -7811,31 +7868,43 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
 
   SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
 
+  if (for_expr) {
+    Scheme_Object *a[2];
+    a[0] = l;
+    a[1] = exp_expr;
+    return scheme_values(2, a);
+  } else
     return l;
 }
 
 static Scheme_Object *
 local_expand(int argc, Scheme_Object **argv)
 {
-  return do_local_expand("local-expand", 0, 0, argc, argv);
+  return do_local_expand("local-expand", 0, 0, 0, argc, argv);
+}
+
+static Scheme_Object *
+local_expand_expr(int argc, Scheme_Object **argv)
+{
+  return do_local_expand("syntax-local-expand-expression", 0, 0, 1, argc, argv);
 }
 
 static Scheme_Object *
 local_transformer_expand(int argc, Scheme_Object **argv)
 {
-  return do_local_expand("local-transformer-expand", 1, 0, argc, argv);
+  return do_local_expand("local-transformer-expand", 1, 0, 0, argc, argv);
 }
 
 static Scheme_Object *
 local_expand_catch_lifts(int argc, Scheme_Object **argv)
 {
-  return do_local_expand("local-expand/capture-lifts", 0, 1, argc, argv);
+  return do_local_expand("local-expand/capture-lifts", 0, 1, 0, argc, argv);
 }
 
 static Scheme_Object *
 local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv)
 {
-  return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, argc, argv);
+  return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, 0, argc, argv);
 }
 
 static Scheme_Object *

src/mzscheme/src/fun.c

@@ -3288,6 +3288,25 @@ static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[])
   return SCHEME_TAIL_CALL_WAITING;
 }
 
+static MZ_INLINE Scheme_Object *values_slow(int argc, Scheme_Object *argv[])
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object **a;
+  int i;
+
+  a = MALLOC_N(Scheme_Object *, argc);
+  p->values_buffer = a;
+  p->values_buffer_size = argc;
+
+  p->ku.multiple.array = a;
+
+  for (i = 0; i < argc; i++) {
+    a[i] = argv[i];
+  }
+
+  return SCHEME_MULTIPLE_VALUES;
+}
+
 Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
 {
   Scheme_Thread *p;
@@ -3299,12 +3318,10 @@ Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
 
   p = scheme_current_thread;
   p->ku.multiple.count = argc;
-  if (p->values_buffer && (p->values_buffer_size >= argc))
+  if (p->values_buffer && (p->values_buffer_size >= argc)) {
     a = p->values_buffer;
-  else {
+  } else {
-    a = MALLOC_N(Scheme_Object *, argc);
+    return values_slow(argc, argv);
-    p->values_buffer = a;
-    p->values_buffer_size = argc;
   }
 
   p->ku.multiple.array = a;

src/mzscheme/src/hash.c

@@ -1080,8 +1080,14 @@ static long equal_hash_key(Scheme_Object *o, long k)
     }
 # endif
   default:    
+    {
+      Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t];
+      if (h1)
+        return h1(o, k);
+      else
         return k + (PTR_TO_LONG(o) >> 4);
     }
+  }
 
   k = (k << 1) + k;
   goto top;
@@ -1274,6 +1280,12 @@ long scheme_equal_hash_key2(Scheme_Object *o)
       return k;
     }
   default:
+    {
+      Scheme_Secondary_Hash_Proc h2 = scheme_type_hash2s[t];
+      if (h2)
+        return h2(o);
+      else
         return t;
     }
   }
+}

src/mzscheme/src/jit.c

@@ -107,6 +107,7 @@ static void *call_original_binary_arith_for_branch_code;
 static void *call_original_binary_rev_arith_for_branch_code;
 static void *bad_car_code, *bad_cdr_code;
 static void *bad_caar_code, *bad_cdar_code, *bad_cadr_code, *bad_cddr_code;
+static void *bad_set_car_code, *bad_set_cdr_code;
 static void *bad_unbox_code;
 static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
 static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
@@ -1897,7 +1898,9 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
     if ((num_rands >= ((Scheme_Primitive_Proc *)rator)->mina)
 	&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)
 	    || (((Scheme_Primitive_Proc *)rator)->mina < 0))
-	&& is_noncm(rator, jitter, 0, 0))
+	&& (is_noncm(rator, jitter, 0, 0)
+            /* It's also ok to directly call `values' if multiple values are ok: */
+            || (multi_ok && SAME_OBJ(rator, scheme_values_func))))
       direct_prim = 1;
   } else {
     Scheme_Type t;
@@ -3260,6 +3263,43 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
       else
 	mz_runstack_unskipped(jitter, 1);
 
+      return 1;
+    } else if (IS_NAMED_PRIM(rator, "set-car!")
+               || IS_NAMED_PRIM(rator, "set-cdr!")) {
+      GC_CAN_IGNORE jit_insn *reffail, *ref;
+      int set_car;
+
+      set_car = IS_NAMED_PRIM(rator, "set-car!");
+
+      LOG_IT(("inlined set-car!\n"));
+
+      generate_two_args(app->rand1, app->rand2, jitter, 1);
+      CHECK_LIMIT();
+
+      __START_SHORT_JUMPS__(1);
+      ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
+      reffail = _jit.x.pc;
+      __END_SHORT_JUMPS__(1);
+      if (set_car)
+        (void)jit_jmpi(bad_set_car_code);
+      else
+        (void)jit_jmpi(bad_set_cdr_code);
+      __START_SHORT_JUMPS__(1);
+      mz_patch_branch(ref);
+      jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
+      (void)jit_bnei_i(reffail, JIT_R2, scheme_pair_type);
+      jit_ldxi_s(JIT_R2, JIT_R0, &(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)0x0)));
+      (void)jit_bmsi_ul(reffail, JIT_R2, 0x1);
+      __END_SHORT_JUMPS__(1);
+      CHECK_LIMIT();
+
+      if (set_car)
+        (void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.car, JIT_R0, JIT_R1);
+      else
+        (void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.cdr, JIT_R0, JIT_R1);
+      
+      (void)jit_movi_p(JIT_R0, scheme_void);
+
       return 1;
     } else if (IS_NAMED_PRIM(rator, "cons")) {
       LOG_IT(("inlined cons\n"));
@@ -4830,6 +4870,37 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
     CHECK_LIMIT();
   }
 
+  /* *** bad_set_{car,cdr}_code *** */
+  /* Bad argument is in R0, other is in R1 */
+  for (i = 0; i < 2; i++) {
+    switch (i) {
+    case 0:
+      bad_set_car_code = jit_get_ip().ptr;
+      break;
+    case 1:
+      bad_set_cdr_code = jit_get_ip().ptr;
+      break;
+    }
+    jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
+    jit_str_p(JIT_RUNSTACK, JIT_R0);
+    jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
+    JIT_UPDATE_THREAD_RSPTR();
+    CHECK_LIMIT();
+    jit_movi_i(JIT_R1, 2);
+    jit_prepare(2);
+    jit_pusharg_p(JIT_RUNSTACK);
+    jit_pusharg_i(JIT_R1);
+    switch (i) {
+    case 0:
+      (void)mz_finish(scheme_checked_set_car);
+      break;
+    case 1:
+      (void)mz_finish(scheme_checked_set_cdr);
+      break;
+    }
+    CHECK_LIMIT();
+  }
+
   /* *** bad_unbox_code *** */
   /* R0 is argument */
   bad_unbox_code = jit_get_ip().ptr;

src/mzscheme/src/list.c

@@ -30,8 +30,6 @@ Scheme_Object scheme_null[1];
 /* locals */
 static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *cons_prim (int argc, Scheme_Object *argv[]);
-static Scheme_Object *set_car_prim (int argc, Scheme_Object *argv[]);
-static Scheme_Object *set_cdr_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *cons_immutable (int argc, Scheme_Object *argv[]);
 static Scheme_Object *null_p_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *list_p_prim (int argc, Scheme_Object *argv[]);
@@ -138,16 +136,14 @@ scheme_init_list (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant ("cdr", p, env);
 
-  scheme_add_global_constant ("set-car!",
+  p = scheme_make_noncm_prim(scheme_checked_set_car, "set-car!", 2, 2);
-			      scheme_make_noncm_prim(set_car_prim,
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
-						     "set-car!",
+  scheme_add_global_constant ("set-car!", p, env);
-						     2, 2),
+
-			      env);
+  p = scheme_make_noncm_prim(scheme_checked_set_cdr, "set-cdr!", 2, 2);
-  scheme_add_global_constant ("set-cdr!",
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
-			      scheme_make_noncm_prim(set_cdr_prim,
+  scheme_add_global_constant ("set-cdr!", p, env);
-						     "set-cdr!",
+
-						     2, 2),
-			      env);
   scheme_add_global_constant ("cons-immutable",
 			      scheme_make_noncm_prim(cons_immutable,
 						     "cons-immutable",
@@ -766,8 +762,8 @@ scheme_checked_cdr (int argc, Scheme_Object *argv[])
   return (SCHEME_CDR (argv[0]));
 }
 
-static Scheme_Object *
+Scheme_Object *
-set_car_prim (int argc, Scheme_Object *argv[])
+scheme_checked_set_car (int argc, Scheme_Object *argv[])
 {
   if (!SCHEME_MUTABLE_PAIRP(argv[0]))
     scheme_wrong_type("set-car!", "mutable-pair", 0, argc, argv);
@@ -776,8 +772,8 @@ set_car_prim (int argc, Scheme_Object *argv[])
   return scheme_void;
 }
 
-static Scheme_Object *
+Scheme_Object *
-set_cdr_prim (int argc, Scheme_Object *argv[])
+scheme_checked_set_cdr (int argc, Scheme_Object *argv[])
 {
   if (!SCHEME_MUTABLE_PAIRP(argv[0]))
     scheme_wrong_type("set-cdr!", "mutable-pair", 0, argc, argv);

src/mzscheme/src/mzmark.c

@@ -152,27 +152,50 @@ static int quotesyntax_obj_FIXUP(void *p) {
 
 static int cpointer_obj_SIZE(void *p) {
   return
-  gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
 }
 
 static int cpointer_obj_MARK(void *p) {
-  gcMARK(SCHEME_CPTR_VAL((Scheme_Object *)p));
+  gcMARK(SCHEME_CPTR_VAL(p));
-  gcMARK(SCHEME_CPTR_TYPE((Scheme_Object *)p));
+  gcMARK(SCHEME_CPTR_TYPE(p));
   return
-  gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
 }
 
 static int cpointer_obj_FIXUP(void *p) {
-  gcFIXUP(SCHEME_CPTR_VAL((Scheme_Object *)p));
+  gcFIXUP(SCHEME_CPTR_VAL(p));
-  gcFIXUP(SCHEME_CPTR_TYPE((Scheme_Object *)p));
+  gcFIXUP(SCHEME_CPTR_TYPE(p));
   return
-  gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
 }
 
 #define cpointer_obj_IS_ATOMIC 0
 #define cpointer_obj_IS_CONST_SIZE 1
 
 
+static int offset_cpointer_obj_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
+}
+
+static int offset_cpointer_obj_MARK(void *p) {
+  gcMARK(SCHEME_CPTR_VAL(p));
+  gcMARK(SCHEME_CPTR_TYPE(p));
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
+}
+
+static int offset_cpointer_obj_FIXUP(void *p) {
+  gcFIXUP(SCHEME_CPTR_VAL(p));
+  gcFIXUP(SCHEME_CPTR_TYPE(p));
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
+}
+
+#define offset_cpointer_obj_IS_ATOMIC 0
+#define offset_cpointer_obj_IS_CONST_SIZE 1
+
+
 static int second_of_cons_SIZE(void *p) {
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));

src/mzscheme/src/mzmarksrc.c

@@ -56,10 +56,18 @@ quotesyntax_obj {
 
 cpointer_obj {
  mark:
-  gcMARK(SCHEME_CPTR_VAL((Scheme_Object *)p));
+  gcMARK(SCHEME_CPTR_VAL(p));
-  gcMARK(SCHEME_CPTR_TYPE((Scheme_Object *)p));
+  gcMARK(SCHEME_CPTR_TYPE(p));
  size:
-  gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
+}
+
+offset_cpointer_obj {
+ mark:
+  gcMARK(SCHEME_CPTR_VAL(p));
+  gcMARK(SCHEME_CPTR_TYPE(p));
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
 }
 
 second_of_cons {

src/mzscheme/src/nummacs.h

@@ -553,6 +553,14 @@ static Scheme_Object *name ## __wrong_type(const Scheme_Object *v) \
   scheme_wrong_type(scheme_name, "exact integer", -1, 0, a); \
   return NULL; \
 } \
+static MZ_INLINE Scheme_Object * name ## __int_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
+  Small_Bignum sb; \
+  return bigop((scheme_make_small_bignum(SCHEME_INT_VAL(n1), &sb)), n2); \
+} \
+static MZ_INLINE Scheme_Object * name ## __big_int(const Scheme_Object *n1, const Scheme_Object *n2) { \
+  Small_Bignum sb; \
+  return bigop(n1, (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \
+} \
 static Scheme_Object * \
 name (const Scheme_Object *n1, const Scheme_Object *n2) \
 { \
@@ -563,13 +571,11 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
       b = SCHEME_INT_VAL(n2); \
       return scheme_make_integer(a op b); \
     } else if (SCHEME_BIGNUMP(n2)) { \
-      Small_Bignum sb; \
+      return name ## __int_big(n1, n2); \
-      return bigop(scheme_make_small_bignum(SCHEME_INT_VAL(n1), &sb), n2); \
     } \
   } else if (SCHEME_BIGNUMP(n1)) { \
     if (SCHEME_INTP(n2)) { \
-      Small_Bignum sb; \
+      return name ## __big_int(n1, n2); \
-      return bigop(n1, scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb)); \
     } \
     if (SCHEME_BIGNUMP(n2)) \
       return bigop(n1, n2); \

src/mzscheme/src/read.c

@@ -89,6 +89,7 @@ static Scheme_Object *print_honu(int, Scheme_Object *[]);
 #define RETURN_FOR_HASH_COMMENT     0x2
 #define RETURN_FOR_DELIM            0x4
 #define RETURN_FOR_COMMENT          0x8
+#define RETURN_HONU_ANGLE           0x10
 
 static MZ_INLINE long SPAN(Scheme_Object *port, long pos) {
   long cpos;
@@ -303,13 +304,16 @@ static Scheme_Object *unsyntax_splicing_symbol;
 static Scheme_Object *quasisyntax_symbol;
 
 static Scheme_Object *honu_comma, *honu_semicolon;
-static Scheme_Object *honu_parens, *honu_braces, *honu_brackets;
+static Scheme_Object *honu_parens, *honu_braces, *honu_brackets, *honu_angles;
 
 static Scheme_Object *paren_shape_symbol;
 
 static Scheme_Object *terminating_macro_symbol, *non_terminating_macro_symbol, *dispatch_macro_symbol;
 static char *builtin_fast;
 
+/* For matching angle brackets in Honu mode: */
+static Scheme_Object *honu_angle_open, *honu_angle_close;
+
 /* For recoginizing unresolved hash tables and commented-out graph introductions: */
 static Scheme_Object *an_uninterned_symbol;
 
@@ -361,12 +365,18 @@ void scheme_init_read(Scheme_Env *env)
   REGISTER_SO(honu_parens);
   REGISTER_SO(honu_braces);
   REGISTER_SO(honu_brackets);
+  REGISTER_SO(honu_angles);
+  REGISTER_SO(honu_angle_open);
+  REGISTER_SO(honu_angle_close);
 
   honu_comma = scheme_intern_symbol(",");
   honu_semicolon = scheme_intern_symbol(";");
   honu_parens = scheme_intern_symbol("#%parens");
   honu_braces = scheme_intern_symbol("#%braces");
   honu_brackets = scheme_intern_symbol("#%brackets");
+  honu_angles = scheme_intern_symbol("#%angles");
+  honu_angle_open = scheme_make_symbol("<"); /* uninterned */
+  honu_angle_close = scheme_make_symbol(">"); /* uninterned */
 
   {
     int i;
@@ -1687,6 +1697,28 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
       }
       special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
       break;
+    case '>':
+    case '<':
+      if ((params->honu_mode) && (comment_mode & RETURN_HONU_ANGLE)) {
+        Scheme_Object *v;
+        v = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
+        special_value = v;
+        if (SCHEME_STXP(v))
+          v = SCHEME_STX_VAL(v);
+        if (SCHEME_SYMBOLP(v) && (SCHEME_SYM_LEN(v) == 1)
+            && ((SCHEME_SYM_VAL(v)[0] == '>') || (SCHEME_SYM_VAL(v)[0] == '<'))) {
+          if (SCHEME_SYM_VAL(v)[0] == '<')
+            v = honu_angle_open;
+          else
+            v = honu_angle_close;
+          if (SCHEME_STXP(special_value))
+            special_value = scheme_datum_to_syntax(v, scheme_false, special_value, 0, 1);
+          else
+            special_value = v;
+        }
+      } else
+        special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
+      break;
     default:
       if (isdigit_ascii(ch))
 	special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
@@ -2220,6 +2252,7 @@ static const char *dot_name(ReadParams *params)
   return mapping_name(params, '.', "`.'", 6);
 }
 
+static Scheme_Object *combine_angle_brackets(Scheme_Object *list);
 static Scheme_Object *honu_add_module_wrapper(Scheme_Object *list,
 					      Scheme_Object *stxsrc,
 					      Scheme_Object *port);
@@ -2322,6 +2355,7 @@ read_list(Scheme_Object *port,
 	}
       }
       pop_indentation(indentation);
+      list = combine_angle_brackets(list);
       list = (stxsrc
 	      ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
 	      : list);
@@ -2344,7 +2378,8 @@ read_list(Scheme_Object *port,
 	   to make sure that it's not a comment. For consistency, always
 	   read ahead. */
 	scheme_ungetc(ch, port);
-	prefetched = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
+	prefetched = read_inner(port, stxsrc, ht, indentation, params, 
+                                RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
 	if (!prefetched)
 	  continue; /* It was a comment; try again. */
 
@@ -2376,7 +2411,8 @@ read_list(Scheme_Object *port,
 	prefetched = NULL;
       } else {
 	scheme_ungetc(ch, port);
-	car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
+	car = read_inner(port, stxsrc, ht, indentation, params, 
+                         RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
 	if (!car) continue; /* special was a comment */
       }
       /* can't be eof, due to check above */
@@ -2428,6 +2464,8 @@ read_list(Scheme_Object *port,
       }
 
       pop_indentation(indentation);
+      if (params->honu_mode)
+        list = combine_angle_brackets(list);
       list = (stxsrc
 	      ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
 	      : list);
@@ -2450,7 +2488,7 @@ read_list(Scheme_Object *port,
 	return NULL;
       }
       /* can't be eof, due to check above: */
-      cdr = read_inner(port, stxsrc, ht, indentation, params, 0);
+      cdr = read_inner(port, stxsrc, ht, indentation, params, RETURN_HONU_ANGLE);
       ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
       effective_ch = readtable_effective_char(params->table, ch);
       if (effective_ch != closer) {
@@ -2503,7 +2541,8 @@ read_list(Scheme_Object *port,
 	/* Assert: infixed is NULL (otherwise we raised an exception above) */
 
 	pop_indentation(indentation);
-
+        if (params->honu_mode)
+          list = combine_angle_brackets(list);
 	list = (stxsrc
 		? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
 		: list);
@@ -2514,7 +2553,8 @@ read_list(Scheme_Object *port,
       if ((ch == SCHEME_SPECIAL) || (params->table && (ch != EOF))) {
 	/* We have to try the read, because it might be a comment. */
 	scheme_ungetc(ch, port);
-	prefetched = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
+	prefetched = read_inner(port, stxsrc, ht, indentation, params, 
+                                RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
 	if (!prefetched)
 	  goto retry_before_dot;
       } else {
@@ -2538,6 +2578,87 @@ read_list(Scheme_Object *port,
   }
 }
 
+static Scheme_Object *combine_angle_brackets(Scheme_Object *list)
+{
+  Scheme_Object *l, *a, *open_stack = NULL, *prev = NULL;
+  int i, ch;
+
+  for (l = list; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
+    a = SCHEME_CAR(l);
+    if (SCHEME_STXP(a))
+      a = SCHEME_STX_VAL(a);
+    if (SAME_OBJ(a, honu_angle_open)) {
+      open_stack = scheme_make_raw_pair(scheme_make_raw_pair(l, prev),
+                                        open_stack);
+      /* Tentatively assume no matching close: */
+      a = scheme_intern_symbol("<");
+      if (SCHEME_STXP(SCHEME_CAR(l)))
+        a = scheme_datum_to_syntax(a, scheme_false, SCHEME_CAR(l), 0, 1);
+      SCHEME_CAR(l) = a;
+    } else if (SAME_OBJ(a, honu_angle_close)) {
+      if (open_stack) {
+        /* A matching close --- combine the angle brackets! */
+        Scheme_Object *open, *open_prev;
+        Scheme_Object *naya, *ang, *seq;
+        open = SCHEME_CAR(open_stack);
+        open_prev = SCHEME_CDR(open);
+        open = SCHEME_CAR(open);
+        open_stack = SCHEME_CDR(open_stack);
+        ang = honu_angles;
+        if (SCHEME_STXP(SCHEME_CAR(l))) {
+          Scheme_Stx *o, *c;
+          int span;
+          o = (Scheme_Stx *)SCHEME_CAR(open);
+          c = (Scheme_Stx *)SCHEME_CAR(l);
+          if ((o->srcloc->pos >= 0) && (c->srcloc->pos >= 0))
+            span = (c->srcloc->pos - o->srcloc->pos) + c->srcloc->span;
+          else
+            span = -1;
+          ang = scheme_make_stx_w_offset(ang, 
+                                         o->srcloc->line,
+                                         o->srcloc->col,
+                                         o->srcloc->pos,
+                                         span,
+                                         o->srcloc->src,
+                                         STX_SRCTAG);
+        }
+        seq = scheme_make_pair(ang, SCHEME_CDR(open));
+        SCHEME_CDR(prev) = scheme_null;
+        if (SCHEME_STXP(ang)) {
+          seq = scheme_datum_to_syntax(seq, scheme_false, ang, 0, 1);
+        }
+        naya = scheme_make_pair(seq, SCHEME_CDR(l));
+        if (open_prev) {
+          SCHEME_CDR(open_prev) = naya;
+        } else {
+          list = naya;
+        }
+        l = naya;
+      } else {
+        /* Not a matching close: */
+        a = scheme_intern_symbol(">");
+        if (SCHEME_STXP(SCHEME_CAR(l)))
+          a = scheme_datum_to_syntax(a, scheme_false, SCHEME_CAR(l), 0, 1);
+        SCHEME_CAR(l) = a;
+      }
+    } else if (open_stack && SCHEME_SYMBOLP(a)) {
+      /* Check for ids containing -, |, or &, which have lower
+         operator precedence than < and >, and which therefore break up 
+         angle brackets. */
+      for (i = SCHEME_SYM_LEN(a); i--; ) {
+        ch = SCHEME_SYM_VAL(a)[i];
+        if ((ch == '=') || (ch == '|') || (ch == '&')) {
+          open_stack = NULL;
+          break;
+        }
+      }
+    }
+    prev = l;
+  }
+
+  return list;
+}
+
 static Scheme_Object *
 honu_add_module_wrapper(Scheme_Object *list, Scheme_Object *stxsrc, Scheme_Object *port)
 {

src/mzscheme/src/salloc.c

@@ -230,10 +230,23 @@ Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag)
 {
   Scheme_Object *o;
 
-  o = scheme_alloc_object();
+  o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Cptr));
   o->type = scheme_cpointer_type;
-  SCHEME_PTR1_VAL(o) = cptr;
+  SCHEME_CPTR_VAL(o) = cptr;
-  SCHEME_PTR2_VAL(o) = (void *)typetag;
+  SCHEME_CPTR_TYPE(o) = (void *)typetag;
+
+  return o;
+}
+
+Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag)
+{
+  Scheme_Object *o;
+
+  o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Offset_Cptr));
+  o->type = scheme_offset_cpointer_type;
+  SCHEME_CPTR_VAL(o) = cptr;
+  SCHEME_CPTR_TYPE(o) = (void *)typetag;
+  ((Scheme_Offset_Cptr *)o)->offset = offset;
 
   return o;
 }

src/mzscheme/src/schemef.h

@@ -335,6 +335,9 @@ MZ_EXTERN void *GC_malloc_one_tagged(size_t size_in_bytes);
 MZ_EXTERN void *GC_malloc_atomic_uncollectable(size_t size_in_bytes);
 MZ_EXTERN void *scheme_malloc_uncollectable(size_t size_in_bytes);
 MZ_EXTERN void *GC_malloc_array_tagged(size_t size_in_bytes);
+MZ_EXTERN void *GC_malloc_allow_interior(size_t size_in_bytes);
+MZ_EXTERN void *GC_malloc_atomic_allow_interior(size_t size_in_bytes);
+MZ_EXTERN void *GC_malloc_tagged_allow_interior(size_t size_in_bytes);
 #  else
 MZ_EXTERN void *GC_malloc_stubborn(size_t size_in_bytes);
 MZ_EXTERN void *GC_malloc_uncollectable(size_t size_in_bytes);
@@ -524,6 +527,7 @@ XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o,
 XFORM_NONGCING MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
 
 MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
+MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag);
 
 MZ_EXTERN const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error);
 
@@ -964,6 +968,11 @@ XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
 MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
 MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);
 
+MZ_EXTERN void scheme_set_type_equality(Scheme_Type type, 
+                                        Scheme_Equal_Proc f,
+                                        Scheme_Primary_Hash_Proc hash1,
+                                        Scheme_Secondary_Hash_Proc hash2);
+
 MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
 MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);
 MZ_EXTERN void scheme_make_list_immutable(Scheme_Object *l);

src/mzscheme/src/schemex.h

@@ -271,6 +271,9 @@ void *(*GC_malloc_one_tagged)(size_t size_in_bytes);
 void *(*GC_malloc_atomic_uncollectable)(size_t size_in_bytes);
 void *(*scheme_malloc_uncollectable)(size_t size_in_bytes);
 void *(*GC_malloc_array_tagged)(size_t size_in_bytes);
+void *(*GC_malloc_allow_interior)(size_t size_in_bytes);
+void *(*GC_malloc_atomic_allow_interior)(size_t size_in_bytes);
+void *(*GC_malloc_tagged_allow_interior)(size_t size_in_bytes);
 #  else
 void *(*GC_malloc_stubborn)(size_t size_in_bytes);
 void *(*GC_malloc_uncollectable)(size_t size_in_bytes);
@@ -431,6 +434,7 @@ int (*scheme_get_long_long_val)(Scheme_Object *o, mzlonglong *v);
 int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
 double (*scheme_real_to_double)(Scheme_Object *r);
 Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
+Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, long offset, Scheme_Object *typetag);
 const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
 /*========================================================================*/
 /*                               strings                                  */
@@ -798,6 +802,10 @@ long (*scheme_hash_key)(Scheme_Object *o);
 #endif
 long (*scheme_equal_hash_key)(Scheme_Object *o);
 long (*scheme_equal_hash_key2)(Scheme_Object *o);
+void (*scheme_set_type_equality)(Scheme_Type type, 
+                                        Scheme_Equal_Proc f,
+                                        Scheme_Primary_Hash_Proc hash1,
+                                        Scheme_Secondary_Hash_Proc hash2);
 Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
 Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
 void (*scheme_make_list_immutable)(Scheme_Object *l);

src/mzscheme/src/schemex.inc

@@ -175,6 +175,9 @@
   scheme_extension_table->GC_malloc_atomic_uncollectable = GC_malloc_atomic_uncollectable;
   scheme_extension_table->scheme_malloc_uncollectable = scheme_malloc_uncollectable;
   scheme_extension_table->GC_malloc_array_tagged = GC_malloc_array_tagged;
+  scheme_extension_table->GC_malloc_allow_interior = GC_malloc_allow_interior;
+  scheme_extension_table->GC_malloc_atomic_allow_interior = GC_malloc_atomic_allow_interior;
+  scheme_extension_table->GC_malloc_tagged_allow_interior = GC_malloc_tagged_allow_interior;
 #  else
   scheme_extension_table->GC_malloc_stubborn = GC_malloc_stubborn;
   scheme_extension_table->GC_malloc_uncollectable = GC_malloc_uncollectable;
@@ -296,6 +299,7 @@
   scheme_extension_table->scheme_get_unsigned_long_long_val = scheme_get_unsigned_long_long_val;
   scheme_extension_table->scheme_real_to_double = scheme_real_to_double;
   scheme_extension_table->scheme_make_cptr = scheme_make_cptr;
+  scheme_extension_table->scheme_make_offset_cptr = scheme_make_offset_cptr;
   scheme_extension_table->scheme_get_proc_name = scheme_get_proc_name;
   scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode;
   scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix;
@@ -539,6 +543,7 @@
 #endif
   scheme_extension_table->scheme_equal_hash_key = scheme_equal_hash_key;
   scheme_extension_table->scheme_equal_hash_key2 = scheme_equal_hash_key2;
+  scheme_extension_table->scheme_set_type_equality = scheme_set_type_equality;
   scheme_extension_table->scheme_build_list = scheme_build_list;
   scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset;
   scheme_extension_table->scheme_make_list_immutable = scheme_make_list_immutable;

src/mzscheme/src/schemexm.h

@@ -175,6 +175,9 @@
 #define GC_malloc_atomic_uncollectable (scheme_extension_table->GC_malloc_atomic_uncollectable)
 #define scheme_malloc_uncollectable (scheme_extension_table->scheme_malloc_uncollectable)
 #define GC_malloc_array_tagged (scheme_extension_table->GC_malloc_array_tagged)
+#define GC_malloc_allow_interior (scheme_extension_table->GC_malloc_allow_interior)
+#define GC_malloc_atomic_allow_interior (scheme_extension_table->GC_malloc_atomic_allow_interior)
+#define GC_malloc_tagged_allow_interior (scheme_extension_table->GC_malloc_tagged_allow_interior)
 #  else
 #define GC_malloc_stubborn (scheme_extension_table->GC_malloc_stubborn)
 #define GC_malloc_uncollectable (scheme_extension_table->GC_malloc_uncollectable)
@@ -296,6 +299,7 @@
 #define scheme_get_unsigned_long_long_val (scheme_extension_table->scheme_get_unsigned_long_long_val)
 #define scheme_real_to_double (scheme_extension_table->scheme_real_to_double)
 #define scheme_make_cptr (scheme_extension_table->scheme_make_cptr)
+#define scheme_make_offset_cptr (scheme_extension_table->scheme_make_offset_cptr)
 #define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name)
 #define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode)
 #define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix)
@@ -539,6 +543,7 @@
 #endif
 #define scheme_equal_hash_key (scheme_extension_table->scheme_equal_hash_key)
 #define scheme_equal_hash_key2 (scheme_extension_table->scheme_equal_hash_key2)
+#define scheme_set_type_equality (scheme_extension_table->scheme_set_type_equality)
 #define scheme_build_list (scheme_extension_table->scheme_build_list)
 #define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset)
 #define scheme_make_list_immutable (scheme_extension_table->scheme_make_list_immutable)

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 890
+#define EXPECTED_PRIM_COUNT 891
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

src/mzscheme/src/schpriv.h

@@ -201,6 +201,10 @@ typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj);
 extern Scheme_Type_Reader *scheme_type_readers;
 extern Scheme_Type_Writer *scheme_type_writers;
 
+extern Scheme_Equal_Proc *scheme_type_equals;
+extern Scheme_Primary_Hash_Proc *scheme_type_hash1s;
+extern Scheme_Secondary_Hash_Proc *scheme_type_hash2s;
+
 void scheme_init_port_config(void);
 void scheme_init_port_fun_config(void);
 Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *c);
@@ -607,6 +611,8 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
 				Scheme_Object *old,
 				Scheme_Object *origin);
 
+int scheme_stx_has_empty_wraps(Scheme_Object *);
+
 Scheme_Object *scheme_new_mark(void);
 Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m);
 
@@ -2708,6 +2714,8 @@ Scheme_Object *scheme_checked_caar(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_cadr(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_cdar(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_cddr(int argc, Scheme_Object **argv);
+Scheme_Object *scheme_checked_set_car (int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_checked_set_cdr (int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_string_ref(int argc, Scheme_Object *argv[]);

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 369
-#define MZSCHEME_VERSION_MINOR 7
+#define MZSCHEME_VERSION_MINOR 8
 
-#define MZSCHEME_VERSION "369.7" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "369.8" _MZ_SPECIAL_TAG

src/mzscheme/src/startup.inc

@@ -3564,6 +3564,7 @@
 "(require #%qqstx)"
 "(require #%define)"
 "(require #%expobs) "
+"(require(only #%foreign)) "
 "(provide(all-from #%more-scheme)"
 "(all-from-except #%misc make-standard-module-name-resolver)"
 "(all-from-except #%stxcase-scheme -define -define-syntax)"

src/mzscheme/src/startup.ss

@@ -4072,6 +4072,7 @@
   (require #%qqstx)
   (require #%define)
   (require #%expobs) ; so it's attached
+  (require (only #%foreign))  ; so it's attached, but doesn't depend on any exports
 
   (provide (all-from #%more-scheme)
 	   (all-from-except #%misc make-standard-module-name-resolver)

src/mzscheme/src/stxobj.c

@@ -2494,6 +2494,11 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
   return lift_inactive_certs(o, 1);
 }
 
+int scheme_stx_has_empty_wraps(Scheme_Object *o)
+{
+  return SCHEME_NULLP(((Scheme_Stx *)o)->wraps);
+}
+
 /*========================================================================*/
 /*                           stx comparison                               */
 /*========================================================================*/
@@ -2682,6 +2687,14 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
 
 #define QUICK_STACK_SIZE 10
 
+#define EXPLAIN_RESOLVE 0
+#if EXPLAIN_RESOLVE
+static int explain_resolves = 0;
+# define EXPLAIN(x) if (explain_resolves) { x; }
+#else
+# define EXPLAIN(x) /* empty */
+#endif
+
 /* Although resolve_env may call itself recursively, the recursion
    depth is bounded (by the fact that modules can't be nested,
    etc.). */
@@ -2710,6 +2723,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
   Scheme_Object *bdg = NULL;
   Scheme_Hash_Table *export_registry = NULL;
 
+  EXPLAIN(printf("Resolving %s:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a))));
+
   if (_wraps) {
     WRAP_POS_COPY(wraps, *_wraps);
     WRAP_POS_INC(wraps);
@@ -2722,27 +2737,37 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
       Scheme_Object *result, *key;
       int did_lexical = 0;
 
+      EXPLAIN(printf("Rename...\n"));
+
       result = scheme_false;
       while (!SCHEME_NULLP(o_rename_stack)) {
 	key = SCHEME_CAAR(o_rename_stack);
 	if (SAME_OBJ(key, result)) {
+          EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0)));
 	  did_lexical = 1;
 	  result = SCHEME_CDR(SCHEME_CAR(o_rename_stack));
-	} else if (SAME_OBJ(key, scheme_true)) {
+	} else {
+          EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0)));
+          if (SAME_OBJ(key, scheme_true)) {
             /* marks a module-level renaming that overrides lexical renaming */
             did_lexical = 0;
           }
+        }
 	o_rename_stack = SCHEME_CDR(o_rename_stack);
       }
       while (stack_pos) {
 	key = rename_stack[stack_pos - 1];
 	if (SAME_OBJ(key, result)) {
+          EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0)));
 	  result = rename_stack[stack_pos - 2];
 	  did_lexical = 1;
-	} else if (SAME_OBJ(key, scheme_true)) {
+	} else {
+          EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0)));
+          if (SAME_OBJ(key, scheme_true)) {
             /* marks a module-level renaming that overrides lexical renaming */
             did_lexical = 0;
           }
+        }
 	stack_pos -= 2;
       }
       if (!did_lexical)
@@ -2750,6 +2775,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
       else if (get_names)
 	get_names[0] = scheme_undefined;
 
+      EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0)));
+
       return result;
     } else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) && w_mod) {
       /* Module rename: */
@@ -2934,6 +2961,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 	      other_env = scheme_false;
 	      envname = SCHEME_VEC_ELS(rename)[2+c+ri];
 	      same = 1;
+              EXPLAIN(printf("Targes %s <- %s\n", 
+                             scheme_write_to_string(envname, 0),
+                             scheme_write_to_string(other_env, 0)));
 	    } else {
 	      envname = SCHEME_VEC_ELS(rename)[0];
 	      other_env = SCHEME_VEC_ELS(rename)[2+c+ri];
@@ -2946,10 +2976,17 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 		SCHEME_USE_FUEL(1);
 	      }
 
+              EXPLAIN(printf("Target %s <- %s (%d)\n", 
+                             scheme_write_to_string(envname, 0),
+                             scheme_write_to_string(other_env, 0),
+                             SCHEME_IMMUTABLEP(rename)));
+
 	      {
 		WRAP_POS w2;
 		WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
 		same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
+                if (!same)
+                  EXPLAIN(printf("Different marks\n"));
 	      }
 	    }
 	    
@@ -2977,14 +3014,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
     } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) {
       /* Lexical-rename rib. Splice in the names. */
       rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
+      EXPLAIN(printf("Rib: %p...\n", rib));
       if (skip_ribs) {
-	if (scheme_bin_gt_eq(rib->timestamp, skip_ribs))
+	if (scheme_bin_gt_eq(rib->timestamp, skip_ribs)) {
+          EXPLAIN(printf("Skip rib\n"));
 	  rib = NULL;
         }
+      }
       if (rib) {
-	if (SAME_OBJ(did_rib, rib))
+	if (SAME_OBJ(did_rib, rib)) {
+          EXPLAIN(printf("Did rib\n"));
 	  rib = NULL;
-	else {
+	} else {
 	  did_rib = rib;
 	  rib = rib->next; /* First rib record has no rename */
 	}
@@ -3271,6 +3312,16 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, long phase)
   return scheme_stx_env_bound_eq(a, b, NULL, phase);
 }
 
+#if EXPLAIN
+Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
+{
+  explain_resolves++;
+  a = resolve_env(NULL, a, 0, 0, NULL, NULL);
+  --explain_resolves;
+  return a;
+}
+#endif
+
 Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
 {
   /* Inspect the wraps to look for a self-modidx shift: */

src/mzscheme/src/stypes.h

@@ -84,150 +84,152 @@ enum {
   scheme_sema_type,                     /* 66 */
   scheme_hash_table_type,               /* 67 */
   scheme_cpointer_type,                 /* 68 */
-  scheme_weak_box_type,                 /* 69 */
+  scheme_offset_cpointer_type,          /* 69 */
-  scheme_ephemeron_type,                /* 70 */
+  scheme_weak_box_type,                 /* 70 */
-  scheme_struct_type_type,              /* 71 */
+  scheme_ephemeron_type,                /* 71 */
-  scheme_module_index_type,             /* 72 */
+  scheme_struct_type_type,              /* 72 */
-  scheme_set_macro_type,                /* 73 */
+  scheme_module_index_type,             /* 73 */
-  scheme_listener_type,                 /* 74 */
+  scheme_set_macro_type,                /* 74 */
-  scheme_namespace_type,                /* 75 */
+  scheme_listener_type,                 /* 75 */
-  scheme_config_type,                   /* 76 */
+  scheme_namespace_type,                /* 76 */
-  scheme_stx_type,                      /* 77 */
+  scheme_config_type,                   /* 77 */
-  scheme_will_executor_type,            /* 78 */
+  scheme_stx_type,                      /* 78 */
-  scheme_custodian_type,                /* 79 */
+  scheme_will_executor_type,            /* 79 */
-  scheme_random_state_type,             /* 80 */
+  scheme_custodian_type,                /* 80 */
-  scheme_regexp_type,                   /* 81 */
+  scheme_random_state_type,             /* 81 */
-  scheme_bucket_type,                   /* 82 */
+  scheme_regexp_type,                   /* 82 */
-  scheme_bucket_table_type,             /* 83 */
+  scheme_bucket_type,                   /* 83 */
-  scheme_subprocess_type,               /* 84 */
+  scheme_bucket_table_type,             /* 84 */
-  scheme_compilation_top_type,          /* 85 */
+  scheme_subprocess_type,               /* 85 */
-  scheme_wrap_chunk_type,               /* 86 */
+  scheme_compilation_top_type,          /* 86 */
-  scheme_eval_waiting_type,             /* 87 */
+  scheme_wrap_chunk_type,               /* 87 */
-  scheme_tail_call_waiting_type,        /* 88 */
+  scheme_eval_waiting_type,             /* 88 */
-  scheme_undefined_type,                /* 89 */
+  scheme_tail_call_waiting_type,        /* 89 */
-  scheme_struct_property_type,          /* 90 */
+  scheme_undefined_type,                /* 90 */
-  scheme_multiple_values_type,          /* 91 */
+  scheme_struct_property_type,          /* 91 */
-  scheme_placeholder_type,              /* 92 */
+  scheme_multiple_values_type,          /* 92 */
-  scheme_case_lambda_sequence_type,     /* 93 */
+  scheme_placeholder_type,              /* 93 */
-  scheme_begin0_sequence_type,          /* 94 */
+  scheme_case_lambda_sequence_type,     /* 94 */
-  scheme_rename_table_type,             /* 95 */
+  scheme_begin0_sequence_type,          /* 95 */
-  scheme_module_type,                   /* 96 */
+  scheme_rename_table_type,             /* 96 */
-  scheme_svector_type,                  /* 97 */
+  scheme_module_type,                   /* 97 */
-  scheme_lazy_macro_type,               /* 98 */
+  scheme_svector_type,                  /* 98 */
-  scheme_resolve_prefix_type,           /* 99 */
+  scheme_lazy_macro_type,               /* 99 */
-  scheme_security_guard_type,           /* 100 */
+  scheme_resolve_prefix_type,           /* 100 */
-  scheme_indent_type,                   /* 101 */
+  scheme_security_guard_type,           /* 101 */
-  scheme_udp_type,                      /* 102 */
+  scheme_indent_type,                   /* 102 */
-  scheme_udp_evt_type,                  /* 103 */
+  scheme_udp_type,                      /* 103 */
-  scheme_tcp_accept_evt_type,           /* 104 */
+  scheme_udp_evt_type,                  /* 104 */
-  scheme_id_macro_type,                 /* 105 */
+  scheme_tcp_accept_evt_type,           /* 105 */
-  scheme_evt_set_type,                  /* 106 */
+  scheme_id_macro_type,                 /* 106 */
-  scheme_wrap_evt_type,                 /* 107 */
+  scheme_evt_set_type,                  /* 107 */
-  scheme_handle_evt_type,               /* 108 */
+  scheme_wrap_evt_type,                 /* 108 */
-  scheme_nack_guard_evt_type,           /* 109 */
+  scheme_handle_evt_type,               /* 109 */
-  scheme_semaphore_repost_type,         /* 110 */
+  scheme_nack_guard_evt_type,           /* 110 */
-  scheme_channel_type,                  /* 111 */
+  scheme_semaphore_repost_type,         /* 111 */
-  scheme_channel_put_type,              /* 112 */
+  scheme_channel_type,                  /* 112 */
-  scheme_thread_resume_type,            /* 113 */
+  scheme_channel_put_type,              /* 113 */
-  scheme_thread_suspend_type,           /* 114 */
+  scheme_thread_resume_type,            /* 114 */
-  scheme_thread_dead_type,              /* 115 */
+  scheme_thread_suspend_type,           /* 115 */
-  scheme_poll_evt_type,                 /* 116 */
+  scheme_thread_dead_type,              /* 116 */
-  scheme_nack_evt_type,                 /* 117 */
+  scheme_poll_evt_type,                 /* 117 */
-  scheme_module_registry_type,          /* 118 */
+  scheme_nack_evt_type,                 /* 118 */
-  scheme_thread_set_type,               /* 119 */
+  scheme_module_registry_type,          /* 119 */
-  scheme_string_converter_type,         /* 120 */
+  scheme_thread_set_type,               /* 120 */
-  scheme_alarm_type,                    /* 121 */
+  scheme_string_converter_type,         /* 121 */
-  scheme_thread_cell_type,              /* 122 */
+  scheme_alarm_type,                    /* 122 */
-  scheme_channel_syncer_type,           /* 123 */
+  scheme_thread_cell_type,              /* 123 */
-  scheme_special_comment_type,          /* 124 */
+  scheme_channel_syncer_type,           /* 124 */
-  scheme_write_evt_type,                /* 125 */
+  scheme_special_comment_type,          /* 125 */
-  scheme_always_evt_type,               /* 126 */
+  scheme_write_evt_type,                /* 126 */
-  scheme_never_evt_type,                /* 127 */
+  scheme_always_evt_type,               /* 127 */
-  scheme_progress_evt_type,             /* 128 */
+  scheme_never_evt_type,                /* 128 */
-  scheme_certifications_type,           /* 129 */
+  scheme_progress_evt_type,             /* 129 */
-  scheme_already_comp_type,             /* 130 */
+  scheme_certifications_type,           /* 130 */
-  scheme_readtable_type,                /* 131 */
+  scheme_already_comp_type,             /* 131 */
-  scheme_intdef_context_type,           /* 132 */
+  scheme_readtable_type,                /* 132 */
-  scheme_lexical_rib_type,              /* 133 */
+  scheme_intdef_context_type,           /* 133 */
-  scheme_thread_cell_values_type,       /* 134 */
+  scheme_lexical_rib_type,              /* 134 */
-  scheme_global_ref_type,               /* 135 */
+  scheme_thread_cell_values_type,       /* 135 */
-  scheme_cont_mark_chain_type,          /* 136 */
+  scheme_global_ref_type,               /* 136 */
-  scheme_raw_pair_type,                 /* 137 */
+  scheme_cont_mark_chain_type,          /* 137 */
-  scheme_prompt_type,                   /* 138 */
+  scheme_raw_pair_type,                 /* 138 */
-  scheme_prompt_tag_type,               /* 139 */
+  scheme_prompt_type,                   /* 139 */
-  scheme_delay_syntax_type,             /* 140 */
+  scheme_prompt_tag_type,               /* 140 */
+  scheme_expanded_syntax_type,          /* 141 */
+  scheme_delay_syntax_type,             /* 142 */
 
 #ifdef MZTAG_REQUIRED
-  _scheme_last_normal_type_,            /* 141 */
+  _scheme_last_normal_type_,            /* 143 */
 
-  scheme_rt_weak_array,                 /* 142 */
+  scheme_rt_weak_array,                 /* 144 */
 
-  scheme_rt_comp_env,                   /* 143 */
+  scheme_rt_comp_env,                   /* 145 */
-  scheme_rt_constant_binding,           /* 144 */
+  scheme_rt_constant_binding,           /* 146 */
-  scheme_rt_resolve_info,               /* 145 */
+  scheme_rt_resolve_info,               /* 147 */
-  scheme_rt_optimize_info,              /* 146 */
+  scheme_rt_optimize_info,              /* 148 */
-  scheme_rt_compile_info,               /* 147 */
+  scheme_rt_compile_info,               /* 149 */
-  scheme_rt_cont_mark,                  /* 148 */
+  scheme_rt_cont_mark,                  /* 150 */
-  scheme_rt_saved_stack,                /* 149 */
+  scheme_rt_saved_stack,                /* 151 */
-  scheme_rt_reply_item,                 /* 150 */
+  scheme_rt_reply_item,                 /* 152 */
-  scheme_rt_closure_info,               /* 151 */
+  scheme_rt_closure_info,               /* 153 */
-  scheme_rt_overflow,                   /* 152 */
+  scheme_rt_overflow,                   /* 154 */
-  scheme_rt_overflow_jmp,               /* 153 */
+  scheme_rt_overflow_jmp,               /* 155 */
-  scheme_rt_meta_cont,                  /* 154 */
+  scheme_rt_meta_cont,                  /* 156 */
-  scheme_rt_dyn_wind_cell,              /* 155 */
+  scheme_rt_dyn_wind_cell,              /* 157 */
-  scheme_rt_dyn_wind_info,              /* 156 */
+  scheme_rt_dyn_wind_info,              /* 158 */
-  scheme_rt_dyn_wind,                   /* 157 */
+  scheme_rt_dyn_wind,                   /* 159 */
-  scheme_rt_dup_check,                  /* 158 */
+  scheme_rt_dup_check,                  /* 160 */
-  scheme_rt_thread_memory,              /* 159 */
+  scheme_rt_thread_memory,              /* 161 */
-  scheme_rt_input_file,                 /* 160 */
+  scheme_rt_input_file,                 /* 162 */
-  scheme_rt_input_fd,                   /* 161 */
+  scheme_rt_input_fd,                   /* 163 */
-  scheme_rt_oskit_console_input,        /* 162 */
+  scheme_rt_oskit_console_input,        /* 164 */
-  scheme_rt_tested_input_file,          /* 163 */
+  scheme_rt_tested_input_file,          /* 165 */
-  scheme_rt_tested_output_file,         /* 164 */
+  scheme_rt_tested_output_file,         /* 166 */
-  scheme_rt_indexed_string,             /* 165 */
+  scheme_rt_indexed_string,             /* 167 */
-  scheme_rt_output_file,                /* 166 */
+  scheme_rt_output_file,                /* 168 */
-  scheme_rt_load_handler_data,          /* 167 */
+  scheme_rt_load_handler_data,          /* 169 */
-  scheme_rt_pipe,                       /* 168 */
+  scheme_rt_pipe,                       /* 170 */
-  scheme_rt_beos_process,               /* 169 */
+  scheme_rt_beos_process,               /* 171 */
-  scheme_rt_system_child,               /* 170 */
+  scheme_rt_system_child,               /* 172 */
-  scheme_rt_tcp,                        /* 171 */
+  scheme_rt_tcp,                        /* 173 */
-  scheme_rt_write_data,                 /* 172 */
+  scheme_rt_write_data,                 /* 174 */
-  scheme_rt_tcp_select_info,            /* 173 */
+  scheme_rt_tcp_select_info,            /* 175 */
-  scheme_rt_namespace_option,           /* 174 */
+  scheme_rt_namespace_option,           /* 176 */
-  scheme_rt_param_data,                 /* 175 */
+  scheme_rt_param_data,                 /* 177 */
-  scheme_rt_will,                       /* 176 */
+  scheme_rt_will,                       /* 178 */
-  scheme_rt_will_registration,          /* 177 */
+  scheme_rt_will_registration,          /* 179 */
-  scheme_rt_struct_proc_info,           /* 178 */
+  scheme_rt_struct_proc_info,           /* 180 */
-  scheme_rt_linker_name,                /* 179 */
+  scheme_rt_linker_name,                /* 181 */
-  scheme_rt_param_map,                  /* 180 */
+  scheme_rt_param_map,                  /* 182 */
-  scheme_rt_finalization,               /* 181 */
+  scheme_rt_finalization,               /* 183 */
-  scheme_rt_finalizations,              /* 182 */
+  scheme_rt_finalizations,              /* 184 */
-  scheme_rt_cpp_object,                 /* 183 */
+  scheme_rt_cpp_object,                 /* 185 */
-  scheme_rt_cpp_array_object,           /* 184 */
+  scheme_rt_cpp_array_object,           /* 186 */
-  scheme_rt_stack_object,               /* 185 */
+  scheme_rt_stack_object,               /* 187 */
-  scheme_rt_preallocated_object,        /* 186 */
+  scheme_rt_preallocated_object,        /* 188 */
-  scheme_thread_hop_type,               /* 187 */
+  scheme_thread_hop_type,               /* 189 */
-  scheme_rt_srcloc,                     /* 188 */
+  scheme_rt_srcloc,                     /* 190 */
-  scheme_rt_evt,                        /* 189 */
+  scheme_rt_evt,                        /* 191 */
-  scheme_rt_syncing,                    /* 190 */
+  scheme_rt_syncing,                    /* 192 */
-  scheme_rt_comp_prefix,                /* 191 */
+  scheme_rt_comp_prefix,                /* 193 */
-  scheme_rt_user_input,                 /* 192 */
+  scheme_rt_user_input,                 /* 194 */
-  scheme_rt_user_output,                /* 193 */
+  scheme_rt_user_output,                /* 195 */
-  scheme_rt_compact_port,               /* 194 */
+  scheme_rt_compact_port,               /* 196 */
-  scheme_rt_read_special_dw,            /* 195 */
+  scheme_rt_read_special_dw,            /* 197 */
-  scheme_rt_regwork,                    /* 196 */
+  scheme_rt_regwork,                    /* 198 */
-  scheme_rt_buf_holder,                 /* 197 */
+  scheme_rt_buf_holder,                 /* 199 */
-  scheme_rt_parameterization,           /* 198 */
+  scheme_rt_parameterization,           /* 200 */
-  scheme_rt_print_params,               /* 199 */
+  scheme_rt_print_params,               /* 201 */
-  scheme_rt_read_params,                /* 200 */
+  scheme_rt_read_params,                /* 202 */
-  scheme_rt_native_code,                /* 201 */
+  scheme_rt_native_code,                /* 203 */
-  scheme_rt_native_code_plus_case,      /* 202 */
+  scheme_rt_native_code_plus_case,      /* 204 */
-  scheme_rt_jitter_data,                /* 203 */
+  scheme_rt_jitter_data,                /* 205 */
-  scheme_rt_module_exports,             /* 204 */
+  scheme_rt_module_exports,             /* 206 */
-  scheme_rt_delay_load_info,            /* 205 */
+  scheme_rt_delay_load_info,            /* 207 */
-  scheme_rt_marshal_info,               /* 206 */
+  scheme_rt_marshal_info,               /* 208 */
-  scheme_rt_unmarshal_info,             /* 207 */
+  scheme_rt_unmarshal_info,             /* 209 */
-  scheme_rt_runstack,                   /* 208 */
+  scheme_rt_runstack,                   /* 210 */
 #endif
 
   _scheme_last_type_

src/mzscheme/src/syntax.c

@@ -4396,6 +4396,7 @@ static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_onl
 static Scheme_Object *
 single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only)
 {
+  scheme_rec_add_certs(rec, drec, form);
   return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec);
 }
 
@@ -4405,15 +4406,20 @@ single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
 {
   Scheme_Object *expr, *form_name;
 
+  scheme_rec_add_certs(erec, drec, form);
+
   expr = check_single(form, top_only ? env : NULL);
   expr = scheme_expand_expr(expr, env, erec, drec);
 
+  form_name = SCHEME_STX_CAR(form);
+
   if (simplify && (erec[drec].depth == -1)) {
+    /* FIXME: this needs EXPAND_OBSERVE callbacks. */
+    expr = scheme_stx_track(expr, form, form_name);
+    expr = scheme_stx_cert(expr, scheme_false, NULL, form, NULL, 1);
     return expr;
   }
 
-  form_name = SCHEME_STX_CAR(form);
-
   return scheme_datum_to_syntax(icons(form_name, icons(expr, scheme_null)), 
 				form, form,
 				0, 2);

src/mzscheme/src/thread.c

@@ -6755,8 +6755,13 @@ static void prepare_thread_for_GC(Scheme_Object *t)
     }
   }
 
-  if (p->values_buffer)
+  if (p->values_buffer) {
+    if (p->values_buffer_size > 128)
+      p->values_buffer = NULL;
+    else {
       memset(p->values_buffer, 0, sizeof(Scheme_Object*) * p->values_buffer_size);
+    }
+  }
 
   p->spare_runstack = NULL;
 

src/mzscheme/src/type.c

@@ -27,6 +27,9 @@
 
 Scheme_Type_Reader *scheme_type_readers;
 Scheme_Type_Writer *scheme_type_writers;
+Scheme_Equal_Proc *scheme_type_equals;
+Scheme_Primary_Hash_Proc *scheme_type_hash1s;
+Scheme_Secondary_Hash_Proc *scheme_type_hash2s;
 
 static char **type_names;
 static Scheme_Type maxtype, allocmax;
@@ -42,6 +45,9 @@ static void init_type_arrays()
   REGISTER_SO(type_names);
   REGISTER_SO(scheme_type_readers);
   REGISTER_SO(scheme_type_writers);
+  REGISTER_SO(scheme_type_equals);
+  REGISTER_SO(scheme_type_hash1s);
+  REGISTER_SO(scheme_type_hash2s);
   
   maxtype = _scheme_last_type_;
   allocmax = maxtype + 10;
@@ -63,6 +69,18 @@ static void init_type_arrays()
 #ifdef MEMORY_COUNTING_ON
   scheme_type_table_count += n;
 #endif  
+
+  scheme_type_equals = MALLOC_N_ATOMIC(Scheme_Equal_Proc, allocmax);
+  n = allocmax * sizeof(Scheme_Equal_Proc);
+  memset((char *)scheme_type_equals, 0, n);
+
+  scheme_type_hash1s = MALLOC_N_ATOMIC(Scheme_Primary_Hash_Proc, allocmax);
+  n = allocmax * sizeof(Scheme_Primary_Hash_Proc);
+  memset((char *)scheme_type_hash1s, 0, n);
+
+  scheme_type_hash2s = MALLOC_N_ATOMIC(Scheme_Secondary_Hash_Proc, allocmax);
+  n = allocmax * sizeof(Scheme_Secondary_Hash_Proc);
+  memset((char *)scheme_type_hash2s, 0, n);
 }
 
 void
@@ -183,6 +201,7 @@ scheme_init_type (Scheme_Env *env)
   
   set_name(scheme_stx_type, "<syntax>");
   set_name(scheme_stx_offset_type, "<internal-syntax-offset>");
+  set_name(scheme_expanded_syntax_type, "<expanded-syntax>");
   set_name(scheme_set_macro_type, "<set!-transformer>");
   set_name(scheme_id_macro_type, "<rename-transformer>");
 
@@ -192,6 +211,7 @@ scheme_init_type (Scheme_Env *env)
   set_name(scheme_subprocess_type, "<subprocess>");
 
   set_name(scheme_cpointer_type, "<cpointer>");
+  set_name(scheme_offset_cpointer_type, "<cpointer>");
 
   set_name(scheme_wrap_chunk_type, "<wrap-chunk>");
 
@@ -270,6 +290,21 @@ Scheme_Type scheme_make_type(const char *name)
     memcpy(naya, scheme_type_writers, maxtype * sizeof(Scheme_Type_Writer));
     scheme_type_writers = (Scheme_Type_Writer *)naya;
 
+    naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Equal_Proc));
+    memset((char *)naya, 0, n);
+    memcpy(naya, scheme_type_equals, maxtype * sizeof(Scheme_Equal_Proc));
+    scheme_type_equals = (Scheme_Equal_Proc *)naya;
+
+    naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Primary_Hash_Proc));
+    memset((char *)naya, 0, n);
+    memcpy(naya, scheme_type_hash1s, maxtype * sizeof(Scheme_Primary_Hash_Proc));
+    scheme_type_hash1s = (Scheme_Primary_Hash_Proc *)naya;
+
+    naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Secondary_Hash_Proc));
+    memset((char *)naya, 0, n);
+    memcpy(naya, scheme_type_hash2s, maxtype * sizeof(Scheme_Secondary_Hash_Proc));
+    scheme_type_hash2s = (Scheme_Secondary_Hash_Proc *)naya;
+
 #ifdef MEMORY_COUNTING_ON
     scheme_type_table_count += 20 * (sizeof(Scheme_Type_Reader)
                                      + sizeof(Scheme_Type_Writer));
@@ -309,6 +344,20 @@ void scheme_install_type_writer(Scheme_Type t, Scheme_Type_Writer f)
   scheme_type_writers[t] = f;
 }
 
+
+void scheme_set_type_equality(Scheme_Type t, 
+                              Scheme_Equal_Proc f,
+                              Scheme_Primary_Hash_Proc hash1,
+                              Scheme_Secondary_Hash_Proc hash2)
+{
+  if (t < 0 || t >= maxtype)
+    return;
+
+  scheme_type_equals[t] = f;
+  scheme_type_hash1s[t] = hash1;
+  scheme_type_hash2s[t] = hash2;
+}
+
 int scheme_num_types(void)
 {
   return maxtype;
@@ -464,6 +513,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
   GC_REG_TRAV(scheme_vector_type, vector_obj);
   GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);
+  GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj);
 
   GC_REG_TRAV(scheme_bucket_type, bucket_obj);
 
@@ -512,6 +562,7 @@ void scheme_register_traversers(void)
 
   GC_REG_TRAV(scheme_stx_type, stx_val);
   GC_REG_TRAV(scheme_stx_offset_type, stx_off_val);
+  GC_REG_TRAV(scheme_expanded_syntax_type, twoptr_obj);
   GC_REG_TRAV(scheme_module_type, module_val);
   GC_REG_TRAV(scheme_rt_module_exports, module_exports_val);
   GC_REG_TRAV(scheme_module_index_type, modidx_val);

src/wxcommon/PSDC.cxx

@@ -1659,6 +1659,7 @@ void wxPostScriptDC::StartPage (void)
   pstream->Out("%%EndPageSetup\n");
 
   resetFont = RESET_FONT | RESET_COLOR;
+  current_font_name = NULL;
 
   if (clipping)
     SetClippingRegion(clipping);