Sync with latest Chez Scheme and Racket-on-Chez PRs

Adds the continuation-attachments PR.

Three other PRs have been merged to Chez Scheme since
the previous sync.

original commit: c2ade1be5da80378529c20ab830d863032961e2b

BUILDING

@@ -97,6 +97,17 @@ The make file supports several targets:
   fails.  This should not fail unless the distributed boot files are
   out of sync with the sources.
 
+  When you make a modification to the system that causes the C side to
+  get out of sync with the Scheme side so that the build fails, try
+  the following from $W if you have a recent version of Chez Scheme
+  installed in your path:
+
+    make -C s clean all patchfile=patch Scheme=scheme SCHEMEHEAPDIRS={see below}
+    make build
+
+  Set SCHEMEHEAPDIRS to /usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m on
+  Unix-like systems and to %x/../../boot/%m on Windows systems.
+
   To run Chez Scheme without installing, you need to tell the executable
   where to find the boot files.  This can be done via command-line
   arguments, e.g.:
@@ -157,7 +168,7 @@ The make file supports several targets:
   can take 5 minutes or more.
 
   'make bootfiles' builds boot files for each machine type for which
-  a subdirectory exists in the top-level boot directory.  to build
+  a subdirectory exists in the top-level boot directory.  To build
   for a supported machine type that isn't built by default, simply
   add the appropriate subdirectory, i.e., 'mkdir boot/$M', where M
   is the machine type, before running 'make bootfiles'.  You can

LOG

@@ -972,17 +972,29 @@
   procedure names, so we don't have to rebuild the boot files as often.
     Mf-base
 - Fix tests for cp0 procedure-name change
-    misc.ms, patch-compile-0-f-t-f
+    misc.ms, patch-compile-0-f-t-f, patch-interpret-0-f-t-f
-- add ordered guardians through a new optional argument to make-guardian
+- add load-compiled-from-port and Sregister_boot_file_fd for loading modes
-    prims.ss, primdata.ss, cp0.ss, cpnanopass.ss,
+  based on open files instead of paths
-    cmacros.ss, mkheader.ss, gc.c, segment.c, types.h,
+    7.ss, primdata.ss, mkheader.ss, scheme.c
-    4.ms, smgmt.stex, release_notes.stex
+    7.ms, foreign.stex, system.stex
+- auto-config improvement, detect if X11 exist on Mac OS X
+    configure
 - added box-cas! and vector-cas!
     prims.ss, cpnanopass.ss, np-languages.ss,
     cmacros.ss, library.ss, primdata.ss
     x86_64.ss x86.ss, ppc32.ss, arm32.ss,
     5_6.ms, 5_8.ms, root-experr*,
     objects.stex, release_notes.stex
+- add generate-procedure-source-information
+    cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss,
+    primdata.ss, prims.ss, misc.ms,
+    system.stex, release_notes.stex
+- fix boot_call and the invoke code object to handle multiple values
+    scheme.c, cpnanopass.ss, 7.ms, release_notes.stex, system.stex
+- add ordered guardians through a new optional argument to make-guardian
+    prims.ss, primdata.ss, cp0.ss, cpnanopass.ss,
+    cmacros.ss, mkheader.ss, gc.c, segment.c, types.h,
+    4.ms, smgmt.stex, release_notes.stex
 - add object-backreferences and enable-object-backreferences as an aid
   to debugging memory leaks
      back.ss, cmacros.ss, inspect.ss, primdata.ss,
@@ -993,14 +1005,11 @@
     cmacros.ss, cpnanopass.ss, interpret.ss, library.ss,
     primdata.ss, prims.ss, gc.c, objects.stex, release_notes.stex
     misc.ms, mats/patch*, mats/root*
-- add generate-procedure-source-information
-    cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss,
-    primdata.ss, prims.ss, misc.ms,
-    system.stex, release_notes.tex
 - add current-generate-id and expand-omit-library-invocations, which can be
   useful for avoiding library recompilation and redundant invocation checks
     syntax.ss, record.ss, primdata.ss, front.ss, misc.ms, system.stex
-- add load-compiled-from-port and Sregister_boot_file_fd for loading modes
+- add support for continuation attachments
-  based on open files instead of paths
+    cpnanopass.ss, np-languages.ss, 4.ss, prims.ss, inspect.ss,
-    7.ss, primdata.ss, mkheader.ss, scheme.c
+    cmacro.ss, primdata.ss, library.ss types.ss, mkheader.ss,
-    7.ms, foreign.stex, system.stex
+    alloc.c, gc.c, schsig.c, thread.c, externs.h,
+    4.ms, control.stex

c/alloc.c

@@ -599,9 +599,9 @@ ptr S_closure(cod, n) ptr cod; iptr n; {
 }
 
 /* S_mkcontinuation is always called with mutex */
-ptr S_mkcontinuation(s, g, nuate, stack, length, clength, link, ret, winders)
+ptr S_mkcontinuation(s, g, nuate, stack, length, clength, link, ret, winders, attachments)
         ISPC s; IGEN g; ptr nuate; ptr stack; iptr length; iptr clength; ptr link;
-        ptr ret; ptr winders; {
+        ptr ret; ptr winders; ptr attachments; {
     ptr p;
 
     find_room(s, g, type_closure, size_continuation, p);
@@ -612,6 +612,7 @@ ptr S_mkcontinuation(s, g, nuate, stack, length, clength, link, ret, winders)
     CONTLINK(p) = link;
     CONTRET(p) = ret;
     CONTWINDERS(p) = winders;
+    CONTATTACHMENTS(p) = attachments;
     return p;
 }
 

c/externs.h

@@ -74,7 +74,8 @@ extern ptr S_null_immutable_string PROTO((void));
 extern ptr S_record PROTO((iptr n));
 extern ptr S_closure PROTO((ptr cod, iptr n));
 extern ptr S_mkcontinuation PROTO((ISPC s, IGEN g, ptr nuate, ptr stack,
-                iptr length, iptr clength, ptr link, ptr ret, ptr winders));
+                iptr length, iptr clength, ptr link, ptr ret, ptr winders,
+                ptr attachments));
 extern ptr S_inexactnum PROTO((double rp, double ip));
 extern ptr S_exactnum PROTO((ptr a, ptr b));
 extern ptr S_thread PROTO((ptr tc));

c/gc.c

@@ -549,6 +549,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
             CONTLENGTH(p) = CONTLENGTH(pp);
             CONTCLENGTH(p) = CONTCLENGTH(pp);
             CONTWINDERS(p) = CONTWINDERS(pp);
+            CONTATTACHMENTS(p) = CONTATTACHMENTS(pp);
             if (CONTLENGTH(p) != scaled_shot_1_shot_flag) {
                 CONTLINK(p) = CONTLINK(pp);
                 CONTRET(p) = CONTRET(pp);
@@ -556,24 +557,23 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
             }
         } else {
             iptr len, n;
-            ISPC s;
             len = CLOSLEN(pp);
             n = size_closure(len);
 #ifdef ENABLE_OBJECT_COUNTS
             S_G.countof[tg][countof_closure] += 1;
             S_G.bytesof[tg][countof_closure] += n;
 #endif /* ENABLE_OBJECT_COUNTS */
-            if (BACKREFERENCES_ENABLED)
+            if (BACKREFERENCES_ENABLED) {
-              s = space_closure;
+              find_room(space_closure, tg, type_closure, n, p);
-            else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
+            } else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
               /* Using `space_impure` is ok because the code slot of a mutable
                  closure is never mutated, so the code is never newer than the
                  closure. If it were, then because the code pointer looks like
                  a fixnum, an old-generation sweep wouldn't update it properly. */
-              s = space_impure;
+              find_room(space_impure, tg, type_closure, n, p);
-            } else
+            } else {
-              s = space_pure;
+              find_room(space_pure, tg, type_closure, n, p);
-            find_room(s, tg, type_closure, n, p);
+            }
             copy_ptrs(type_closure, p, pp, n);
             SETCLOSCODE(p,code);
          /* pad if necessary */
@@ -1772,6 +1772,7 @@ static void sweep_thread(p) ptr p; {
     relocate(&STACKLINK(tc))
     /* iptr SCHEMESTACKSIZE */
     relocate(&WINDERS(tc))
+    relocate(&ATTACHMENTS(tc))
     relocate_return_addr(&FRAME(tc,0))
     sweep_stack((uptr)SCHEMESTACK(tc), (uptr)SFP(tc), (uptr)FRAME(tc,0));
     relocate(&U(tc))
@@ -1821,6 +1822,7 @@ static void sweep_thread(p) ptr p; {
 static void sweep_continuation(p) ptr p; {
   PUSH_BACKREFERENCE(p)
   relocate(&CONTWINDERS(p))
+  relocate(&CONTATTACHMENTS(p))
 
  /* bug out for shot 1-shot continuations */
   if (CONTLENGTH(p) == scaled_shot_1_shot_flag) return;

c/scheme.c

@@ -340,7 +340,7 @@ static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; {
             p = Svoid;
             break;
         default:
-            p = S_get_scheme_arg(tc, 0);
+            p = S_get_scheme_arg(tc, 1);
             break;
     }
     return p;

c/schsig.c

@@ -65,7 +65,8 @@ static void split(k, s) ptr k; ptr *s; {
                                  m, m,
                                  CONTLINK(k),
                                  *s,
-                                 Snil);
+                                 Snil,
+                                 Sfalse);
     CONTLENGTH(k) = CONTCLENGTH(k) = n;
     CONTSTACK(k) = (ptr)s;
     *s = (ptr)DOUNDERFLOW;
@@ -279,7 +280,8 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; {
                                         split_stack_clength,
                                         STACKLINK(tc),
                                         *split_point,
-                                        Snil);
+                                        Snil,
+                                        Sfalse);
             tc_mutex_release()
 
           /* overwrite old return address with dounderflow */
@@ -686,7 +688,8 @@ void S_schsig_init() {
                            scaled_shot_1_shot_flag, scaled_shot_1_shot_flag,
                            FIX(0),
                            FIX(0),
-                           Snil));
+                           Snil,
+                           Sfalse));
 
         S_protect(&S_G.error_id);
         S_G.error_id = S_intern((const unsigned char *)"$c-error");

c/thread.c

@@ -80,6 +80,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
   CCHAIN(tc) = Snil;
 
   WINDERS(tc) = Snil;
+  ATTACHMENTS(tc) = Snil;
   STACKLINK(tc) = SYMVAL(S_G.null_continuation_id);
   STACKCACHE(tc) = Snil;
 

configure

@@ -260,6 +260,14 @@ if [ "$installman" = "" ] ; then
   installman=$installprefix/$installmansuffix
 fi
 
+if [ "$disablex11" = "no" ] ; then
+  if [ $m = a6osx ] || [ $m = ta6osx ] ; then
+    if [ ! -d /opt/X11/include/ ] ; then
+      disablex11=yes
+    fi
+  fi
+fi
+
 if [ "$help" = "yes" ]; then
   echo "Purpose:"
   echo "  $0 determines the machine type and constructs a custom Makefile"

csug/control.stex

@@ -208,6 +208,18 @@ One-shot continuations are continuations that may be invoked at most
 once, whether explicitly or implicitly.
 They are obtained with \scheme{call/1cc}.
 
+Continuation \textit{attachment}s support efficient annotation and
+inspection of continuations. Each continution has either one immediate
+attachment or none, and an immediate attachment is added or replaced
+using \scheme{call-setting-continuation-attachment}. The
+\scheme{call-with-current-continuation-attachment} function retrieves
+the current continuation's attachment, if any. Although each
+continuation has a single immediate attachment, a continuation may
+extend another continuation that has its own separate attachment, and
+the \scheme{current-continuation-attachments} function returns a list
+of attachments for the current continuation and all continuations that
+it extends.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{call/1cc}{\categoryprocedure}{(call/1cc \var{procedure})}
@@ -293,6 +305,132 @@ Extreme caution must be taken with this form of \scheme{dynamic-wind},
 since an error or long-running computation can leave interrupts
 and automatic garbage collection disabled.
 
+%----------------------------------------------------------------------------
+\entryheader\label{call-setting-continuation-attachment}\label{call-with-current-continuation-attachment}
+\formdef{call-setting-continuation-attachment}{\categoryprocedure}{(call-setting-continuation-attachment \var{val} \var{procedure})}
+\formdef{call-with-current-continuation-attachment}{\categoryprocedure}{(call-with-current-continuation-attachment \var{default-val} \var{procedure})}
+\returns the values returned by \var{procedure}
+\listlibraries
+\endentryheader
+
+\noindent \scheme{call-setting-continuation-attachment} calls
+\var{procedure} with no arguments while setting the attachment of the
+current continuation to \var{val}. The continuation of the call to
+\var{procedure} is the same as the continuation of the call to
+\scheme{call-setting-continuation-attachment} (i.e., it is still the
+current continuation). If the current continuation already has an
+attachment, it is replaced by \var{val}.
+
+\scheme{call-with-current-continuation-attachment} calls
+\var{procedure} with one argument: the current continuation's
+attachment, if any, or the value of \var{default-val} if the current
+continuation has no attachment. The continuation of the call to
+\var{procedure} is the same as the continuation of the call to
+\scheme{call-with-current-continuation-attachment} (i.e., it is still
+the current continuation).
+
+\schemedisplay
+(call-setting-continuation-attachment
+ 'milk
+ (lambda ()
+  (call-with-current-continuation-attachment
+   'nothing
+   (lambda (a) a)))) ; => milk
+
+(call-setting-continuation-attachment
+ 'milk
+ (lambda ()
+  (list
+   (call-with-current-continuation-attachment
+    'nothing
+    (lambda (a) a))))) ; => (nothing)
+
+(list
+ (call-setting-continuation-attachment
+  'milk
+  (lambda ()
+   (call-with-current-continuation-attachment
+    'nothing
+    (lambda (a) a))))) ; => (milk)
+
+(call-setting-continuation-attachment
+ 'milk
+ (lambda ()
+  (call-setting-continuation-attachment
+   'water
+   (lambda ()
+     (call-with-current-continuation-attachment
+       'nothing
+       (lambda (a) a)))))) ; => water
+\endschemedisplay
+
+%----------------------------------------------------------------------------
+\entryheader\label{current-continuation-attachments}
+\formdef{current-continuation-attachments}{\categoryprocedure}{(current-continuation-attachments)}
+\returns a list
+\listlibraries
+\endentryheader
+
+\noindent \scheme{current-continuation-attachments} returns a list of
+attachments starting with the current continuation's attachment, if
+any, followed by the attachment of continuation that is extended by
+the current continuation, and so on. If a continuation has no
+attachment, then no corresponding element is included in the result
+list.
+
+\schemedisplay
+(call-setting-continuation-attachment
+ 'milk
+ (lambda ()
+  (current-continuation-attachments))) ; => (milk)
+
+(call-setting-continuation-attachment
+ 'milk
+ (lambda ()
+   (vector
+    (call-setting-continuation-attachment
+     'cookies
+     (lambda ()
+       (current-continuation-attachments)))))) ; => #((cookies milk))
+
+(call-setting-continuation-attachment
+ 'milk
+ (lambda ()
+   (call-setting-continuation-attachment
+    'water
+    (lambda ()
+      (current-continuation-attachments))))) ; => (water)
+\endschemedisplay
+
+%----------------------------------------------------------------------------
+\entryheader\label{continuation-next-attachments}
+\formdef{continuation-next-attachments}{\categoryprocedure}{(continuation-next-attachments \var{continuation})}
+\returns a list
+\listlibraries
+\endentryheader
+
+\noindent \scheme{continuation-next-attachments} takes a continuation
+and returns the list of attachments that
+\scheme{current-continuation-attachments} would return if it were
+called as the next step of \var{continuation}. Note that the result
+list will not include any attachment on the immediate continuation
+that is captured by \var{continuation}---only the attachments of continuations
+that are extended by \var{continuation}.
+
+\schemedisplay
+(define about-to-snack
+  (call/cc
+   (lambda (esc)
+    (call-setting-continuation-attachment
+     'milk
+     (lambda ()
+       (snack (call-setting-continuation-attachment
+               'cookies
+               (lambda () (call/cc esc)))))))))
+
+(continuation-next-attachments about-to-snack) ; => (milk)
+\endschemedisplay
+
 \section{Engines\label{SECTENGINES}}
 
 \index{engines}Engines are a high-level process abstraction supporting

csug/system.stex

@@ -3671,8 +3671,8 @@ If the current caf\'e is the original caf\'e, or if \scheme{exit}
 is called from a script, \scheme{exit} exits from Scheme.
 In this case, the exit code for the Scheme process is 0 if
 no arguments were supplied or if the first argument is void,
-the value of the first argument
+the value of the first argument cast to a C int if
-if it is a 32-bit exact integer, and -1 otherwise.
+it is an exact integer of the host machine's bit width, and 1 otherwise.
 
 %----------------------------------------------------------------------------
 \entryheader

mats/4.ms

@@ -3176,6 +3176,256 @@
        (get-output-string p))
      "EIEIO")
  )
+
+(mat continuation-attachments
+  (error? (current-continuation-attachments '()))
+
+  (error? (call-setting-continuation-attachment 'any))
+  (error? (call-setting-continuation-attachment 'any 10))
+  (error? (call-setting-continuation-attachment 'any void 'bad-more))
+  (error? (call-setting-continuation-attachment 'any (lambda (x) x)))
+
+  (error? (call-with-current-continuation-attachment 'none))
+  (error? (call-with-current-continuation-attachment 'none 10))
+  (error? (call-with-current-continuation-attachment 'none (lambda (a) a) 'bad-more))
+  (error? (call-with-current-continuation-attachment 'none void))
+
+  (error? (continuation-next-attachments))
+  (error? (continuation-next-attachments 10))
+  (error? (continuation-next-attachments (lambda (x) x)))
+  (error? (continuation-next-attachments (call/cc (lambda (x) x)) 'bad-more))
+
+  (equal? (void) (call-setting-continuation-attachment 'any void))
+  (equal? 'none (call-with-current-continuation-attachment 'none (lambda (a) a)))
+  (equal? '() (continuation-next-attachments (call/cc (lambda (x) x))))
+
+  (equal? '() (current-continuation-attachments))
+  (equal? '(#&(1 2 3))
+          (call-setting-continuation-attachment
+           3
+           (lambda ()
+            (list
+             (call-setting-continuation-attachment
+              2
+              (lambda ()
+               (box
+                (call-setting-continuation-attachment
+                 1
+                 (lambda ()
+                   (current-continuation-attachments))))))))))
+  (equal? '() (current-continuation-attachments))
+  (equal? '#((left) (right))
+          (vector (call-setting-continuation-attachment
+                   'left
+                   (lambda () (current-continuation-attachments)))
+                  (call-setting-continuation-attachment
+                   'right
+                   (lambda () (current-continuation-attachments)))))
+  (equal? '#((left2) (right2))
+          (vector (call-setting-continuation-attachment
+                   'left2
+                   current-continuation-attachments)
+                  (call-setting-continuation-attachment
+                   'right2
+                   current-continuation-attachments)))
+  (equal? 'yes
+          (call-setting-continuation-attachment
+           'yes
+           (lambda ()
+            (call-with-current-continuation-attachment
+             'no
+             (lambda (v) v)))))
+  (equal? 'yes
+          (call-setting-continuation-attachment
+           'yes
+           (lambda ()
+            (call-with-current-continuation-attachment
+             'no
+             values))))
+  (equal? '(no)
+          (call-setting-continuation-attachment
+           'yes
+           (lambda ()
+            (list
+             (call-with-current-continuation-attachment
+              'no
+              (lambda (v) v))))))
+  (equal? '(no)
+          (call-setting-continuation-attachment
+           'yes
+           (lambda ()
+            (list
+             (call-with-current-continuation-attachment
+              'no
+              values)))))
+  (begin
+   (define (call-with-yep f)
+     (call-setting-continuation-attachment
+      'yep
+       (lambda () (f))))
+   (define (call-with-yeah f)
+     (call-setting-continuation-attachment
+      'yeah
+       f))
+   (define-syntax call-with-yeah*
+     (syntax-rules ()
+       [(_ f)
+        (call-setting-continuation-attachment
+         'yeah
+         f)]))
+   (define (get-or-nope)
+     (call-with-current-continuation-attachment
+      'nope
+      (lambda (x) x)))
+   (define (return-one) 1)
+   (define (act-like-list . l) l)
+   (define not-a-procedure 'something-else)
+   (define (returns-not-a-procedure) 'also-something-else)
+   (define (return-three-values) (values 1 2 3))
+   (define (return-the-same-value v) v)
+    #t)
+  (equal? 'yep (call-with-yep get-or-nope))
+  (equal? 'yeah (call-with-yep (lambda () (call-with-yeah get-or-nope))))
+  (equal? '(yeah) (call-with-yep (lambda () (call-with-yeah current-continuation-attachments))))
+  (equal? '((yeah yep)) (call-with-yep (lambda () (list (call-with-yeah current-continuation-attachments)))))
+  (equal? '((yeah yep)) (call-with-yep (lambda () (act-like-list (call-with-yeah current-continuation-attachments)))))
+  (equal? '(yeah yep) (call-with-yep (lambda () (let ([v #f])
+                                                  (set! v (call-with-yeah current-continuation-attachments))
+                                                  v))))
+  (equal? '(nope) (call-with-yep (lambda () (list (get-or-nope)))))
+  (equal? '(nope) (call-with-yep (lambda () (act-like-list (get-or-nope)))))
+  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah (lambda () (list (get-or-nope)))))))
+  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah (lambda () (act-like-list (get-or-nope)))))))
+  (equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah (lambda () (get-or-nope)))))))
+  (equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah (lambda () (get-or-nope)))))))
+  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah* (lambda () (list (get-or-nope)))))))
+  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah* (lambda () (act-like-list (get-or-nope)))))))
+  (equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah* (lambda () (get-or-nope)))))))
+  (equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (get-or-nope)))))))
+
+  (error? (call-with-yep (lambda () (call-with-yeah* (lambda () (not-a-procedure))))))
+  (error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () (not-a-procedure)))))))
+  (error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (not-a-procedure)))))))
+  (error? (call-with-yep (lambda () (call-with-yeah* (lambda () ((returns-not-a-procedure)))))))
+  (error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
+  (error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
+  
+  (equal? '() (if (call-with-yep list)
+                  (current-continuation-attachments)
+                  #f))
+  (equal? '() (if (call-setting-continuation-attachment 'here (lambda () #t))
+                  (current-continuation-attachments)
+                  #f))
+  (equal? 1 (let loop ([i 10000])
+              (if (zero? i)
+                  (length (current-continuation-attachments))
+                  (call-setting-continuation-attachment
+                   'here
+                   (lambda ()
+                     (loop (sub1 i)))))))
+  (equal? 10000 (let loop ([i 10000])
+                  (if (zero? i)
+                      (length (current-continuation-attachments))
+                      (call-setting-continuation-attachment
+                       'here
+                       (lambda ()
+                         (return-the-same-value (loop (sub1 i))))))))
+  (equal? '#((forget-me yeah yep) (yeah yep))
+          (call/cc
+           (lambda (esc)
+             (call-with-yep
+              (lambda ()
+                (list (call-with-yeah
+                       (lambda ()
+                         (list (call-setting-continuation-attachment
+                                'forget-me
+                                (lambda ()
+                                  (call/cc
+                                   (lambda (k)
+                                     (esc (vector
+                                           (current-continuation-attachments)
+                                           (continuation-next-attachments k))))))))))))))))
+  (equal? '#(((yep) (yep))
+             ((yeah yep))
+             ((yep) (yep)))
+          (let ([pre '()]
+                [body '()]
+                [post '()])
+            ((call/cc
+              (lambda (esc)
+                (call-with-yep
+                 (lambda ()
+                   (dynamic-wind
+                       (lambda ()
+                         (set! pre (cons (current-continuation-attachments) pre)))
+                       (lambda ()
+                         (call-with-yeah
+                          (lambda ()
+                            ((call/cc
+                              (lambda (retry)
+                                (set! body (cons (current-continuation-attachments) body))
+                                (esc retry)))))))
+                       (lambda ()
+                         (set! post (cons (current-continuation-attachments) post))))))))
+             (lambda () (lambda (self) void)))
+            (vector pre body post)))
+
+  (equal? 'ok
+          (call-setting-continuation-attachment
+           'ok
+           (lambda ()
+             (call-with-values (lambda () (return-three-values))
+               (case-lambda
+                [(x y z)
+                 (get-or-nope)])))))
+  (equal? '(ok 1 2 3)
+          (call-setting-continuation-attachment
+           'ok
+           (lambda ()
+             (call-with-values (lambda () (return-three-values))
+               (case-lambda
+                [(x y z)
+                 (call-with-current-continuation-attachment
+                  'nope
+                  (lambda (a) (list a x y z)))])))))
+
+  ;; intended to trigger `mvcall` in the `np-recognize-attachment` pass:
+  (equal? '(1)
+          (call-setting-continuation-attachment
+           'ok
+           (lambda ()
+             (call-with-values (lambda () (return-one)) act-like-list))))
+  (equal? '(1)
+          (letrec ([act-like-list (lambda l
+                                    (if (equal? l '(never))
+                                        (act-like-list (cdr l))
+                                        l))])
+            (call-setting-continuation-attachment
+             'ok
+             (lambda ()
+               ;; `call-with-values` can see that `act-like-list` has
+               ;; a rest argument, and it generates a direct call
+               (call-with-values (lambda () (return-one)) act-like-list)))))
+  (equal? '(1)
+          ;; Like the previous example, but in tail position
+          (call-with-yep ; just to ensure the argument `lambda` isn't inlined
+           (lambda ()
+             (letrec ([act-like-list (lambda l
+                                       (if (equal? l '(never))
+                                           (act-like-list (cdr l))
+                                           l))])
+               (call-setting-continuation-attachment
+                'ok
+                (lambda ()
+                  (call-with-values (lambda () (return-one)) act-like-list)))))))
+  (equal? '(1)
+          (call-with-yep ; just to ensure the argument `lambda` isn't inlined
+           (lambda ()
+             (call-setting-continuation-attachment
+              'ok
+              (lambda ()
+                (call-with-values (lambda () (return-one)) act-like-list))))))
+ )
  
 ;;; section 4-7:
 

mats/7.ms

@@ -114,10 +114,10 @@
 
 (mat load-compiled-from-port
   (begin
-   (define-values (o get) (open-bytevector-output-port))
+    (define-values (o get) (open-bytevector-output-port))
-   (compile-to-port '((define lcfp1 'worked) 'loaded) o)
+    (compile-to-port '((define lcfp1 'worked) 'loaded) o)
-   (equal? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
+    (eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
-  (equal? 'worked lcfp1)
+  (eq? 'worked lcfp1)
 )
 
 (mat compile-to-file
@@ -3619,6 +3619,35 @@ evaluating module init
   (error? ; unexpected return from handler
     (parameterize ([exit-handler values])
       (exit 5)))
+  (begin
+    (define (exit-code expr)
+      (if (windows?)
+          (system (format "echo ~s | ~a -q" expr (patch-exec-path *scheme*)))
+          (system (format "echo '~s' | ~a -q" expr *scheme*))))
+    #t)
+  (eqv? (exit-code '(exit)) 0)
+  (eqv? (exit-code '(exit 15)) 15)
+  (eqv? (exit-code '(exit 0)) 0)
+  (eqv? (exit-code '(exit 24 7)) 24)
+  (eqv? (exit-code '(exit 0 1 2)) 0)
+  (eqv? (exit-code '(exit 3.14)) 1)
+  (eqv? (exit-code '(exit 9.8 3.14)) 1)
+  (begin
+    (with-output-to-file "testfile-exit.ss"
+      (lambda ()
+        (for-each pretty-print
+          '((import (scheme))
+            (apply exit (map string->number (command-line-arguments))))))
+      'replace)
+    #t)
+  (eqv? (system (format "~a --script testfile-exit.ss" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --script testfile-exit.ss 5" (patch-exec-path *scheme*))) 5)
+  (eqv? (system (format "~a --script testfile-exit.ss 0 1 2" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --script testfile-exit.ss 3 4 5" (patch-exec-path *scheme*))) 3)
+  (eqv? (system (format "~a --program testfile-exit.ss" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --program testfile-exit.ss 2" (patch-exec-path *scheme*))) 2)
+  (eqv? (system (format "~a --program testfile-exit.ss 0 1 2" (patch-exec-path *scheme*))) 0)
+  (eqv? (system (format "~a --program testfile-exit.ss 6 7 8" (patch-exec-path *scheme*))) 6)
  )
 
 (mat abort

mats/patch-compile-0-f-t-f

@@ -1,5 +1,5 @@
-*** errors-compile-0-f-f-f	2018-07-16 14:43:05.195920036 -0400
+*** errors-compile-0-f-f-f	2018-07-24 22:17:12.000000000 -0600
---- errors-compile-0-f-t-f	2018-07-16 14:11:48.751983271 -0400
+--- errors-compile-0-f-t-f	2018-07-24 21:07:12.000000000 -0600
 ***************
 *** 125,131 ****
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
@@ -58,7 +58,7 @@
   3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
   3.mo:Expected error in mat mrvs: "returned two values to single value return context".
 ***************
-*** 3697,3703 ****
+*** 3716,3722 ****
   misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@@ -66,7 +66,7 @@
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
---- 3697,3703 ----
+--- 3716,3722 ----
   misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@@ -75,7 +75,7 @@
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
 ***************
-*** 7168,7175 ****
+*** 7180,7187 ****
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -84,7 +84,7 @@
   record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
---- 7168,7175 ----
+--- 7180,7187 ----
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -94,7 +94,7 @@
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
 ***************
-*** 7177,7191 ****
+*** 7189,7203 ****
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -110,7 +110,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid input #f".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
---- 7177,7191 ----
+--- 7189,7203 ----
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -127,7 +127,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
 ***************
-*** 7198,7223 ****
+*** 7210,7235 ****
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -154,7 +154,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
---- 7198,7223 ----
+--- 7210,7235 ----
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -182,7 +182,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
 ***************
-*** 7348,7386 ****
+*** 7360,7398 ****
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -222,7 +222,7 @@
   record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
---- 7348,7386 ----
+--- 7360,7398 ----
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -263,7 +263,7 @@
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
 ***************
-*** 7395,7451 ****
+*** 7407,7463 ****
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@@ -321,7 +321,7 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
---- 7395,7451 ----
+--- 7407,7463 ----
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".

mats/patch-interpret-0-f-f-f

@@ -1,5 +1,5 @@
-*** errors-compile-0-f-f-f	2018-07-15 22:22:57.502803909 -0600
+*** errors-compile-0-f-f-f	2018-07-24 22:17:12.000000000 -0600
---- errors-interpret-0-f-f-f	2018-07-15 21:46:11.227902570 -0600
+--- errors-interpret-0-f-f-f	2018-07-24 21:35:45.000000000 -0600
 ***************
 *** 1,7 ****
   primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@@ -196,44 +196,7 @@
   3.mo:Expected error in mat mrvs: "returned two values to single value return context".
   3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
 ***************
-*** 3829,3845 ****
+*** 4088,4103 ****
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: 1.0 is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: #<procedure> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
-  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
---- 3835,3851 ----
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: 1.0 is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
-  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
-***************
-*** 4076,4091 ****
   6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
   6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
   6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@@ -250,9 +213,9 @@
   6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
   6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
   6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
---- 4082,4091 ----
+--- 4094,4103 ----
 ***************
-*** 7031,7037 ****
+*** 7043,7049 ****
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@@ -260,7 +223,7 @@
   7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
---- 7031,7037 ----
+--- 7043,7049 ----
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@@ -269,7 +232,7 @@
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
 ***************
-*** 7359,7365 ****
+*** 7371,7377 ****
   record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
   record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
   record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@@ -277,7 +240,7 @@
   record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
   record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
   record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
---- 7359,7365 ----
+--- 7371,7377 ----
   record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
   record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
   record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@@ -286,7 +249,7 @@
   record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
   record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
 ***************
-*** 8576,8588 ****
+*** 8588,8600 ****
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -300,7 +263,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
---- 8576,8588 ----
+--- 8588,8600 ----
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -315,7 +278,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
 ***************
-*** 9343,9367 ****
+*** 9355,9379 ****
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@@ -341,7 +304,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
---- 9343,9367 ----
+--- 9355,9379 ----
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@@ -368,7 +331,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
 ***************
-*** 9374,9405 ****
+*** 9386,9417 ****
   foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@@ -401,7 +364,7 @@
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
---- 9374,9405 ----
+--- 9386,9417 ----
   foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@@ -435,7 +398,7 @@
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
 ***************
-*** 9407,9432 ****
+*** 9419,9444 ****
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@@ -462,7 +425,7 @@
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
---- 9407,9432 ----
+--- 9419,9444 ----
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@@ -490,7 +453,7 @@
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 ***************
-*** 9437,9471 ****
+*** 9449,9483 ****
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@@ -526,7 +489,7 @@
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
---- 9437,9471 ----
+--- 9449,9483 ----
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@@ -563,7 +526,7 @@
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
 ***************
-*** 10072,10081 ****
+*** 10084,10093 ****
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@@ -574,7 +537,7 @@
   oop.mo:Expected error in mat oop: "m1: not applicable to 17".
   oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
   oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
---- 10072,10081 ----
+--- 10084,10093 ----
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

mats/patch-interpret-0-f-t-f

@@ -1,5 +1,5 @@
-*** errors-compile-0-f-t-f	2018-07-16 14:11:48.751983271 -0400
+*** errors-compile-0-f-t-f	2018-07-24 21:07:12.000000000 -0600
---- errors-interpret-0-f-t-f	2018-07-16 14:33:23.391939643 -0400
+--- errors-interpret-0-f-t-f	2018-07-24 21:50:02.000000000 -0600
 ***************
 *** 1,7 ****
   primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@@ -169,44 +169,7 @@
   3.mo:Expected error in mat letrec: "variable f is not bound".
   3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
 ***************
-*** 3829,3845 ****
+*** 4088,4103 ****
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: 1.0 is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: #<procedure> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
-  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
---- 3835,3851 ----
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "make-arity-wrapper-procedure: 1.0 is not an arity mask".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "arity-wrapper-procedure-data: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data!)".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "incorrect argument count in call (set-arity-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f))".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: 1 is not an arity wrapper procedure".
-! misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure-data!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  misc.mo:Expected error in mat arity-wrapper-procedure: "set-arity-wrapper-procedure!: #<procedure $arity-wrapper-apply> is not an arity wrapper procedure".
-  cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
-  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
-***************
-*** 4076,4091 ****
   6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
   6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
   6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@@ -223,9 +186,9 @@
   6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
   6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
   6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
---- 4082,4091 ----
+--- 4094,4103 ----
 ***************
-*** 7031,7037 ****
+*** 7043,7049 ****
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@@ -233,7 +196,7 @@
   7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
---- 7031,7037 ----
+--- 7043,7049 ----
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@@ -242,7 +205,7 @@
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
 ***************
-*** 7168,7175 ****
+*** 7180,7187 ****
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -251,7 +214,7 @@
   record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
---- 7168,7175 ----
+--- 7180,7187 ----
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -261,7 +224,7 @@
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
 ***************
-*** 7177,7191 ****
+*** 7189,7203 ****
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -277,7 +240,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid input #f".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
---- 7177,7191 ----
+--- 7189,7203 ----
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -294,7 +257,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
 ***************
-*** 7198,7223 ****
+*** 7210,7235 ****
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -321,7 +284,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
---- 7198,7223 ----
+--- 7210,7235 ----
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -349,7 +312,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
 ***************
-*** 7348,7386 ****
+*** 7360,7398 ****
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -389,7 +352,7 @@
   record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
---- 7348,7386 ----
+--- 7360,7398 ----
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -430,7 +393,7 @@
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
 ***************
-*** 7395,7451 ****
+*** 7407,7463 ****
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@@ -488,7 +451,7 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
---- 7395,7451 ----
+--- 7407,7463 ----
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@@ -547,7 +510,7 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
 ***************
-*** 8576,8588 ****
+*** 8588,8600 ****
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -561,7 +524,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
---- 8576,8588 ----
+--- 8588,8600 ----
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -576,7 +539,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
 ***************
-*** 10072,10081 ****
+*** 10084,10093 ****
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@@ -587,7 +550,7 @@
   oop.mo:Expected error in mat oop: "m1: not applicable to 17".
   oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
   oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
---- 10072,10081 ----
+--- 10084,10093 ----
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

mats/patch-interpret-3-f-f-f

@@ -1,5 +1,5 @@
-*** errors-compile-3-f-f-f	2018-07-15 21:17:33.694898701 -0600
+*** errors-compile-3-f-f-f	2018-07-24 21:00:04.000000000 -0600
---- errors-interpret-3-f-f-f	2018-07-15 22:38:15.063904376 -0600
+--- errors-interpret-3-f-f-f	2018-07-24 22:34:46.000000000 -0600
 ***************
 *** 1,3 ****
 --- 1,9 ----

mats/patch-interpret-3-f-t-f

@@ -1,5 +1,5 @@
-*** errors-compile-3-f-t-f	2018-07-15 21:28:23.140744647 -0600
+*** errors-compile-3-f-t-f	2018-07-24 21:14:04.000000000 -0600
---- errors-interpret-3-f-t-f	2018-07-15 22:04:18.093436772 -0600
+--- errors-interpret-3-f-t-f	2018-07-24 21:57:03.000000000 -0600
 ***************
 *** 1,3 ****
 --- 1,9 ----

mats/root-experr-compile-0-f-f-f

@@ -527,6 +527,25 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
 4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
 4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
 4.mo:Expected error in mat call/1cc: "attempt to invoke shot one-shot continuation".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (current-continuation-attachments (quote ()))".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-setting-continuation-attachment (quote any))".
+4.mo:Expected error in mat continuation-attachments: "call-setting-continuation-attachment: 10 is not a procedure".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-setting-continuation-attachment (quote any) void (quote bad-more))".
+4.mo:Expected error in mat continuation-attachments: "incorrect number of arguments to #<procedure>".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-with-current-continuation-attachment (quote none))".
+4.mo:Expected error in mat continuation-attachments: "call-with-current-continuation-attachment: 10 is not a procedure".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-with-current-continuation-attachment (quote none) (lambda (a) a) (quote bad-more))".
+4.mo:Expected error in mat continuation-attachments: "incorrect number of arguments to #<procedure void>".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (continuation-next-attachments)".
+4.mo:Expected error in mat continuation-attachments: "continuation-next-attachments: 10 is not a continuation".
+4.mo:Expected error in mat continuation-attachments: "continuation-next-attachments: #<procedure> is not a continuation".
+4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (continuation-next-attachments (call/cc (lambda (...) x)) (quote bad-more))".
+4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure something-else".
+4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure something-else".
+4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure something-else".
+4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure also-something-else".
+4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure also-something-else".
+4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure also-something-else".
 4.mo:Expected error in mat $primitive: "fx+: a is not a fixnum".
 4.mo:Expected error in mat $primitive: "invalid primitive name fubar".
 4.mo:Expected error in mat $primitive: "incorrect argument count in call (car (quote a) (quote b))".

release_notes/release_notes.stex

@@ -58,13 +58,6 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
-\subsection{Procedure source location without inspector information (9.5.1)}
-
-When \scheme{generate-inspector-information} is set to \scheme{#f} and
-\scheme{generate-procedure-source-information} is set to \scheme{#t},
-source location information is preserved for a procedure, even though
-other inspector information is not preserved.
-
 \subsection{Procedure arity-mask adjustment and redirection (9.5.1)}
 
 The new procedure \scheme{make-arity-wrapper-procedure} creates a
@@ -78,14 +71,6 @@ for triggering just-in-time conversions of a procedure's
 implementation while imposing a minimal overhead on calls to the
 procedure before or after conversion.
 
-\subsection{Atomic compare-and-set (9.5.1)}
-
-The new procedures \scheme{box-cas!} and \scheme{vector-cas!}
-atomically update a box or vector with a given new value when the
-current content is \scheme{eq?} to a given old value. Atomicity is
-guaranteed even if multiple threads attempt to update the same box or
-vector.
-
 \subsection{Ordered guardians (9.5.1)}
 
 The \scheme{make-guardian} function now accepts an optional argument to
@@ -94,6 +79,21 @@ unordered by default. An ordered guardian's objects are classified as
 inaccessible only when they are not reachable from the represetative
 of any inaccessible object in any other guardian.
 
+\subsection{Procedure source location without inspector information (9.5.1)}
+
+When \scheme{generate-inspector-information} is set to \scheme{#f} and
+\scheme{generate-procedure-source-information} is set to \scheme{#t},
+source location information is preserved for a procedure, even though
+other inspector information is not preserved.
+
+\subsection{Atomic compare-and-set (9.5.1)}
+
+The new procedures \scheme{box-cas!} and \scheme{vector-cas!}
+atomically update a box or vector with a given new value when the
+current content is \scheme{eq?} to a given old value. Atomicity is
+guaranteed even if multiple threads attempt to update the same box or
+vector.
+
 \subsection{Foreign-procedure thread activation (9.5.1)}
 
 A new \scheme{__collect_safe} foreign-procedure convention, which can
@@ -1613,6 +1613,11 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
+\subsection{Incorrect return code when \protect\scheme{exit} is called with multiple arguments}
+
+A bug in the implementation of the default exit handler with multiple
+values has been fixed.
+
 \subsection{Boot files containing compiled library code fail to load}
 
 Compiled library code may now appear within fasl objects loaded during

s/4.ss

@@ -281,13 +281,16 @@
                  (map car more)))))]))
 )
 
+
 (let ()
-  (define disable/enable (make-winder #f disable-interrupts enable-interrupts))
+  (include "types.ss")
+  
+  (define disable/enable (make-winder disable-interrupts enable-interrupts '()))
 
   (define (dwind in body out)
     (let ((old-winders ($current-winders)))
       (in)
-      ($current-winders (cons (make-winder #f in out) old-winders))
+      ($current-winders (cons (make-winder in out ($current-attachments)) old-winders))
       (call-with-values
         body
         (case-lambda
@@ -306,7 +309,7 @@
       (disable-interrupts)
       ($current-winders d/e+old-winders)
       (in)
-      ($current-winders (cons (make-winder #t in out) old-winders))
+      ($current-winders (cons (make-critical-winder in out ($current-attachments)) old-winders))
       (enable-interrupts)
       (call-with-values
         body
@@ -361,33 +364,46 @@
         (let f ((old old))
           (unless (eq? old tail)
             (let ([w (car old)] [old (cdr old)])
-              (if (winder-critical? w)
+              (if (critical-winder? w)
                   (begin
                     (disable-interrupts)
                     ($current-winders (cons disable/enable old))
+                    ($current-attachments (winder-attachments w))
                     ((winder-out w))
                     ($current-winders old)
                     (enable-interrupts))
                   (begin
                     ($current-winders old)
+                    ($current-attachments (winder-attachments w))
                     ((winder-out w))))
               (f old))))
         (let f ([new new])
           (unless (eq? new tail)
             (let ([w (car new)])
               (f (cdr new))
-              (if (winder-critical? w)
+              (if (critical-winder? w)
                   (begin
                     (disable-interrupts)
                     ($current-winders (cons disable/enable (cdr new)))
+                    ($current-attachments (winder-attachments w))
                     ((winder-in w))
                     ($current-winders new)
                     (enable-interrupts))
                   (begin
+                    ($current-attachments (winder-attachments w))
                     ((winder-in w))
                     ($current-winders new)))))))))
-)
+  )
 
+(define current-continuation-attachments
+  (lambda ()
+    ($current-attachments)))
+
+(define-who continuation-next-attachments
+  (lambda (c)
+    (unless ($continuation? c)
+      ($oops who "~s is not a continuation" c))
+    ($continuation-attachments c)))
 
 ;;; make-promise and force
 

s/cmacros.ss

@@ -1314,7 +1314,8 @@
    [iptr stack-clength]
    [ptr link]
    [ptr return-address]
-   [ptr winders]))
+   [ptr winders]
+   [ptr attachments])) ; #f => not recorded
 
 (define-primitive-structure-disps record type-typed-object
   ([ptr type]
@@ -1353,6 +1354,7 @@
    [ptr stack-link]
    [iptr scheme-stack-size]
    [ptr winders]
+   [ptr attachments]
    [ptr U]
    [ptr V]
    [ptr W]
@@ -1900,23 +1902,6 @@
 (define-constant time-collector-cpu 5)
 (define-constant time-collector-real 6)
 
-(define-syntax make-winder
-  (syntax-rules ()
-    [(_ critical? in out) (vector critical? in out)]))
-(define-syntax winder-critical? (syntax-rules () [(_ w) (vector-ref w 0)]))
-(define-syntax winder-in (syntax-rules () [(_ w) (vector-ref w 1)]))
-(define-syntax winder-out (syntax-rules () [(_ w) (vector-ref w 2)]))
-
-(define-syntax winder?
-  (syntax-rules ()
-    [(_ ?w)
-     (let ([w ?w])
-       (and (vector? w)
-            (fx= (vector-length w) 3)
-            (boolean? (winder-critical? w))
-            (procedure? (winder-in w))
-            (procedure? (winder-out w))))]))
-
 (define-syntax default-run-cp0
   (lambda (x)
     (syntax-case x ()
@@ -2586,6 +2571,7 @@
      (ormap1 #f 2 #f #t)
      (put-bytevector-some #f 4 #f #t)
      (put-string-some #f 4 #f #t)
+     (reify-cc #f 0 #f #f)
      (dofretu8* #f 1 #f #f)
      (dofretu16* #f 1 #f #f)
      (dofretu32* #f 1 #f #f)
@@ -2622,6 +2608,7 @@
      (set-virtual-register! #f 1 #t #t)
      ($arity-wrapper-apply #f 0 #f #f)
      (arity-wrapper-apply #f 0 #f #f)
+     ($shift-attachment #f 0 #f #f)
   ))
 
 (let ()

s/cpnanopass.ss

@@ -903,6 +903,7 @@
       (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp) (%ac0) (%xp))
       (declare-intrinsic get-room get-room () (%xp) (%xp))
       (declare-intrinsic scan-remembered-set scan-remembered-set () () ())
+      (declare-intrinsic reify-cc reify-cc (%xp %ac0 %ts) () ())
       (declare-intrinsic dooverflow dooverflow () () ())
       (declare-intrinsic dooverflood dooverflood () (%xp) ())
       ; a dorest routine takes all of the register and frame arguments from the rest
@@ -1549,7 +1550,112 @@
         [,pr pr]
         [else ($oops who "unexpected Expr ~s" ir)]))
 
-    (define-pass np-name-anonymous-lambda : L4.875 (ir) -> L5 ()
+    (define-pass np-recognize-attachment : L4.875 (ir) -> L4.9375 ()
+      (definitions
+        (define return
+          (lambda (mode x)
+            (case mode
+              [(pop) (with-output-language (L4.9375 Expr)
+                       `(seq
+                          (attachment-set pop)
+                          ,x))]
+              [else x])))
+        (define ->in-wca
+          (lambda (mode)
+            (case mode
+              [(non-tail pop) 'pop]
+              [(tail tail/reified) 'tail/reified]))))
+      (CaseLambdaClause : CaseLambdaClause (cl) -> CaseLambdaClause ()
+        [(clause (,x* ...) ,interface ,[Expr : body 'tail '() -> body])
+         `(clause (,x* ...) ,interface ,body)])
+      (Expr : Expr (ir [mode 'non-tail] [loop-x* '()]) -> Expr ()
+        [,x (return mode x)]
+        [(letrec ([,x* ,[le* 'non-tail '() -> le*]] ...) ,[body])
+         `(letrec ([,x* ,le*] ...) ,body)]
+        [(call ,info ,mdcl ,pr ,[e1 'non-tail '() -> e1]
+               (case-lambda ,info2 (clause () ,interface ,[body (->in-wca mode) '() -> body])))
+         (guard (and (eq? (primref-name pr) 'call-setting-continuation-attachment)
+                     (= interface 0)))
+         (case mode
+           [(pop tail/reified)
+            ;; Definitely an attachment in place
+            `(seq (attachment-set set ,e1) ,body)]
+           [(tail)
+            ;; Check dynamically for reified continuation and attachment
+            `(seq (attachment-set reify-and-set ,e1) ,body)]
+           [(non-tail)
+            ;; Push attachment; `body` has been adjusted to pop
+            `(seq (attachment-set push ,e1) ,body)])]
+        [(call ,info ,mdcl ,pr ,[e1 'non-tail '() -> e1]
+               (case-lambda ,info2 (clause (,x) ,interface ,[body])))
+         (guard (and (eq? (primref-name pr) 'call-with-current-continuation-attachment)
+                     (= interface 1)))
+         (case mode
+           [(non-tail)
+            ;; No surrounding `with-continuation-attachment`
+            `(let ([,x ,e1]) ,body)]
+           [(pop tail/reified)
+            ;; Defintely an attachment in place
+            `(seq ,e1 (let ([,x (attachment-get)]) ,body))]
+           [else
+            ;; Check dynamically for attachment
+            `(let ([,x (attachment-get ,e1)]) ,body)])]
+        [(call ,info ,mdcl ,x ,[e* 'non-tail '() -> e*] ...)
+         (guard (memq x loop-x*))
+         ;; No convert for a loop call, even if mode is 'pop
+         `(call ,info ,mdcl ,x ,e* ...)]
+        [(call ,info ,mdcl ,[e 'non-tail '() -> e] ,[e* 'non-tail '() -> e*] ...)
+         (let ([new-e (case mode
+                        [(pop)
+                         (let ([level (if (info-call-check? info) 2 3)]
+                               [p-info (make-info-call #f #f #f #f #f)])
+                           `(call ,p-info #f ,(lookup-primref level '$make-shift-attachment) ,e))]
+                        [else e])])
+           `(call ,info ,(and (eq? new-e e) mdcl) ,new-e ,e* ...))]
+        [(foreign-call ,info ,[e 'non-tail '() -> e] ,[e* 'non-tail '() -> e*] ...)
+         (return mode `(foreign-call ,info ,e ,e* ...))]
+        [(fcallable ,info) (return mode `(fcallable ,info))]
+        [(label ,l ,[body]) `(label ,l ,body)]
+        [(mvlet ,[e 'non-tail '() -> e] ((,x** ...) ,interface* ,body*) ...)
+         (let ([body* (map (lambda (body interface)
+                             (case (and (fx< interface 0)
+                                        mode)
+                               [(pop)
+                                ;; If `body` is a direct call, then we need to change
+                                ;; to an `apply`, since the last argument is turned
+                                ;; into a list already. It would have been better to
+                                ;; avoid the direct-call setup in the first place.
+                                (nanopass-case (L4.875 Expr) body
+                                  [(call ,info ,mdcl ,e ,e* ...)
+                                   (guard mdcl)
+                                   (%primcall info #f apply
+                                              ,(%primcall #f #f $make-shift-attachment ,e)
+                                              ,e* ...)]
+                                  [else
+                                   (Expr body 'pop loop-x*)])]
+                               [else
+                                (Expr body mode loop-x*)]))
+                           body* interface*)])
+           `(mvlet ,e ((,x** ...) ,interface* ,body*) ...))]
+        [(mvcall ,info ,[e1 'non-tail '() -> e1] ,[e2 'non-tail '() -> e2])
+         (let ([e2 (case mode
+                     [(pop) (%primcall #f #f $make-shift-attachment ,e2)]
+                     [else e2])])
+           `(mvcall ,info ,e1 ,e2))]
+        [(let ([,x* ,[e* 'non-tail '() -> e*]] ...) ,[body])
+         `(let ([,x* ,e*] ...) ,body)]
+        [(case-lambda ,info ,[cl] ...) (return mode `(case-lambda ,info ,cl ...))]
+        [(quote ,d) (return mode `(quote ,d))]
+        [(if ,[e0 'non-tail '() -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
+        [(seq ,[e0 'non-tail '() -> e0] ,[e1]) `(seq ,e0 ,e1)]
+        [(profile ,src) `(profile ,src)]
+        [(pariah) `(pariah)]
+        [,pr (return mode pr)]
+        [(loop ,x (,x* ...) ,[body mode (cons x loop-x*) -> body])
+         `(loop ,x (,x* ...) ,body)]
+        [else ($oops who "unexpected Expr ~s" ir)]))
+
+    (define-pass np-name-anonymous-lambda : L4.9375 (ir) -> L5 ()
       (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ())
       (Expr : Expr (ir) -> Expr ()
         [(case-lambda ,info ,[cl] ...)
@@ -1559,7 +1665,7 @@
            (uvar-info-lambda-set! anon info)
            `(letrec ([,anon (case-lambda ,info ,cl ...)])
               ,anon))])
-      (nanopass-case (L4.875 CaseLambdaExpr) ir
+      (nanopass-case (L4.9375 CaseLambdaExpr) ir
         [(case-lambda ,info ,[CaseLambdaClause : cl] ...) `(case-lambda ,info ,cl ...)]))
 
     (define-pass np-convert-closures : L5 (x) -> L6 ()
@@ -2692,6 +2798,32 @@
              ,[e*] ...)
            (guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d)))
            `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...)]
+          [(call ,info0 ,mdcl0
+             (call ,info1 ,mdcl1 ,pr
+               (call ,info2 ,mdcl2 ,pr2 (quote ,d)))
+             ,[e*] ...)
+           (guard (and (eq? (primref-name pr) '$make-shift-attachment)
+                       (eq? (primref-name pr2) '$top-level-value) (symbol? d)))
+           `(call ,info0 ,mdcl0 (call ,info1 ,mdcl1 ,(Symref (primref-name pr)) ,(Symref d)) ,e* ...)]
+          [(call ,info ,mdcl (call ,info2 ,mdcl2 ,pr0 ,pr) ,e* ...)
+           (guard (eq? (primref-name pr0) '$make-shift-attachment)
+                  ;; FIXME: need a less fragile way to avoid multiple results
+                  ;; Exclude inlined primitives that return more than one value:
+                  (not (memq (primref-name pr) '(values call/cc call-with-current-continuation call/1cc))))
+           (cond
+            [(handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)
+             => (lambda (e)
+                  (let ([t (make-tmp 't)])
+                    `(let ([,t ,(Expr e)])
+                       (seq
+                        (attachment-set pop)
+                        ,t))))]
+            [else
+             (let ([e* (map Expr e*)])
+                (let ([info (if (any-set? (prim-mask abort-op) (primref-flags pr))
+                                (make-info-call (info-call-src info) (info-call-sexpr info) (info-call-check? info) #t #t)
+                                info)])
+                  `(call ,info ,mdcl (call ,info2 ,mdcl2 ,(Symref (primref-name pr0)) ,(Symref (primref-name pr))) ,e* ...)))])]
           [(call ,info ,mdcl ,pr ,e* ...)
            (cond
              [(handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*) => Expr]
@@ -5022,6 +5154,7 @@
           (inline-accessor $code-pinfo* code-pinfo*-disp)
           (inline-accessor $continuation-link continuation-link-disp)
           (inline-accessor $continuation-winders continuation-winders-disp)
+          (inline-accessor $continuation-attachments continuation-attachments-disp)
           (inline-accessor csv7:record-type-descriptor record-type-disp)
           (inline-accessor $record-type-descriptor record-type-disp)
           (inline-accessor record-rtd record-type-disp)
@@ -5293,7 +5426,8 @@
           (define hand-coded-closure?
             (lambda (name)
               (not (memq name '(nuate nonprocedure-code error-invoke invoke
-                                      arity-wrapper-apply $arity-wrapper-apply)))))
+                                      arity-wrapper-apply $arity-wrapper-apply
+                                      $shift-attachment)))))
           (define-inline 2 $hand-coded
             [(name)
              (nanopass-case (L7 Expr) name
@@ -5382,6 +5516,7 @@
           (define-tc-parameter $target-machine target-machine)
           (define-tc-parameter $current-stack-link stack-link)
           (define-tc-parameter $current-winders winders)
+          (define-tc-parameter $current-attachments attachments)
           (define-tc-parameter default-record-equal-procedure default-record-equal-procedure)
           (define-tc-parameter default-record-hash-procedure default-record-hash-procedure)
           )
@@ -5408,6 +5543,18 @@
              (bind #f (e-proc e-arity-mask)
                (make-wrapper-closure-alloc e-proc e-arity-mask #f 3 (lookup-libspec $arity-wrapper-apply)))]))
 
+        (define-inline 3 $make-shift-attachment
+          [(e-proc)
+           (bind #f (e-proc)
+             (bind #t ([c (%constant-alloc type-closure (fx* 3 (constant ptr-bytes)))])
+               (%seq
+                 (set! ,(%mref ,c ,(constant closure-code-disp))
+                       (literal ,(make-info-literal #f 'library
+                                      (lookup-libspec $shift-attachment)
+                                      (constant code-data-disp))))
+                 (set! ,(%mref ,c ,(constant closure-data-disp)) ,e-proc)
+                 ,c)))])
+
         (define-inline 3 $install-guardian
           [(e-obj e-rep e-tconc ordered?)
            (bind #f (e-obj e-rep e-tconc ordered?)
@@ -9591,6 +9738,14 @@
          (if e0?
              (Triv* (cons e0? e1*) (lambda (t*) (k `(call ,info ,mdcl ,(car t*) ,(cdr t*) ...))))
              (Triv* e1* (lambda (t*) (k `(call ,info ,mdcl #f ,t* ...)))))]
+        [(attachment-get ,e* ...)
+         (Triv* e*
+           (lambda (t*)
+             (k `(attachment-get ,t* ...))))]
+        [(attachment-set ,aop ,e* ...)
+         (Triv* e*
+           (lambda (t*)
+             (k `(attachment-set ,aop ,t* ...))))]
         [(foreign-call ,info ,e0 ,e1* ...)
          (Triv* (cons e0 e1*)
            (lambda (t*)
@@ -9934,6 +10089,8 @@
         [(set! ,[lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
          (guard (info-call-error? info) (fx< (debug-level) 2))
          `(tail (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...)))]
+        [(set! ,[lvalue] (attachment-get ,[t*] ...))
+         `(set! ,lvalue (attachment-get ,t* ...))]
         [(label ,l ,[ebody]) `(seq (label ,l) ,ebody)]
         [(trap-check ,ioc ,[ebody]) `(seq (trap-check ,ioc) ,ebody)]
         [(overflow-check ,[ebody]) `(seq (overflow-check) ,ebody)]
@@ -9951,7 +10108,8 @@
                      (%seq ,e (goto ,join)
                        ,(f `(seq (label ,(car l*)) ,(car e*)) (cdr l*) (cdr e*)))))
               (label ,join)))]
-        [(values ,info ,t* ...) `(nop)])
+        [(values ,info ,t* ...) `(nop)]
+        [(attachment-get ,t* ...) `(nop)])
       (Tail : Expr (ir) -> Tail ()
         [(inline ,info ,prim ,[t*] ...)
          (guard (pred-primitive? prim))
@@ -10977,6 +11135,11 @@
                              ; (new) stack base in sfp, clength in ac1, old frame base in yp
                              ; set up return address and stack link
                              (set! ,(%tc-ref stack-link) ,(%mref ,xp/cp ,(constant continuation-link-disp)))
+                             ; potentially pop an attachment
+                             (set! ,%ts ,(%mref ,xp/cp ,(constant continuation-attachments-disp)))
+                             (if ,(%inline eq? ,(%constant sfalse) ,%ts)
+                                 (nop)
+                                 (set! ,(%tc-ref attachments) ,%ts))
                              ; set %td to end of the destination area / base of stack values dest
                              (set! ,%td ,(%inline + ,%td ,%sfp))
                              ; don't shift if no stack values
@@ -11094,7 +11257,52 @@
                                              (set! ,%xp ,(%mref ,xp/cp ,(constant continuation-return-address-disp)))
                                              (set! ,fv0 ,%xp)
                                              (jump ,(%mref ,%xp ,(constant return-address-mv-return-address-disp))
-                                               (,%ac0 ,arg-registers ... ,fv0))))]))))))))))))
+                                               (,%ac0 ,arg-registers ... ,fv0))))])))))))))))
+        (define reify-cc-help
+          (lambda (finish)
+            (with-output-language (L13 Tail)
+              (let ([Ltop (make-local-label 'Ltop)])
+                (%seq
+                  (set! ,%td ,(%tc-ref stack-link))
+                  (set! ,%xp ,%td)
+                  (label ,Ltop)
+                  (set! ,%ac0 ,(%mref ,%xp ,(constant continuation-stack-clength-disp)))
+                  (if ,(%inline eq?
+                          ,(%mref ,%xp ,(constant continuation-stack-length-disp))
+                          ,%ac0)
+                       ,(%seq
+                          (set! ,%ac0
+                            (literal ,(make-info-literal #f 'library-code
+                                        (lookup-libspec dounderflow)
+                                        (fx+ (constant code-data-disp) (constant size-rp-header)))))
+                          (if (if ,(%inline eq?
+                                        ,(%mref ,%td ,(constant continuation-attachments-disp))
+                                        ,(%constant sfalse))
+                                   (false)
+                                   ,(%inline eq? ,%ref-ret ,%ac0))
+                              ,(finish %td)
+                              ,(%seq
+                                 (set! ,%xp ,(%constant-alloc type-closure (constant size-continuation)))
+                                 (set! ,(%mref ,%xp ,(constant continuation-code-disp))
+                                   (literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp))))
+                                 (set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
+                                 (set! ,(%mref ,%xp ,(constant continuation-winders-disp)) ,(%tc-ref winders))
+                                 (set! ,(%mref ,%xp ,(constant continuation-attachments-disp)) ,(%tc-ref attachments))
+                                 (set! ,%ref-ret ,%ac0)
+                                 (set! ,(%mref ,%xp ,(constant continuation-link-disp)) ,%td)
+                                 (set! ,(%tc-ref stack-link) ,%xp)
+                                 (set! ,%ac0 ,(%tc-ref scheme-stack))
+                                 (set! ,(%tc-ref scheme-stack) ,%sfp)
+                                 (set! ,(%mref ,%xp ,(constant continuation-stack-disp)) ,%ac0)
+                                 (set! ,%ac0 ,(%inline - ,%sfp ,%ac0))
+                                 (set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
+                                 (set! ,(%mref ,%xp ,(constant continuation-stack-clength-disp)) ,%ac0)
+                                 (set! ,(%tc-ref scheme-stack-size) ,(%inline - ,(%tc-ref scheme-stack-size) ,%ac0))
+                                 ,(finish %xp))))
+                       ,(%seq
+                          (set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
+                          (set! ,%xp ,(%mref ,%xp ,(constant continuation-link-disp)))
+                          (goto ,Ltop)))))))))
       (Program : Program (ir) -> Program ()
         [(labels ([,l* ,le*] ...) ,l)
          `(labels ([,l* ,(map CaseLambdaExpr le* l*)] ...) ,l)])
@@ -11120,55 +11328,41 @@
            [(dorest3) (make-do-rest 3 frame-args-offset)]
            [(dorest4) (make-do-rest 4 frame-args-offset)]
            [(dorest5) (make-do-rest 5 frame-args-offset)]
+           [(reify-cc)
+            (let ([other-reg* (fold-left (lambda (live* kill) (remq kill live*))
+                                         (vector->list regvec)
+                                         ;; Registers used by `reify-cc-help` output,
+                                         ;; plus `%ts` so that we have one to allocate
+                                         (reg-list %xp %td %ac0 %ts))])
+              `(lambda ,(make-named-info-lambda "reify-cc" '(0)) 0 ()
+                ,(asm-enter
+                   (%seq
+                     (check-live ,other-reg* ...)
+                     ,(reify-cc-help
+                       (lambda (reg)
+                         (if (eq? reg %td)
+                             `(asm-return ,%td ,other-reg* ...)
+                             `(seq
+                                (set! ,%td ,reg)
+                                (asm-return ,%td ,other-reg* ...)))))))))]
            [(callcc)
-            (let ([Ltop (make-local-label 'Ltop)])
+            ;; Could be implemented using the `reify-cc` intrinsic, as follows,
-              `(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
+            ;; but, we inline `reify-cc` to save a few instructions
-                 ,(%seq
+            #;
-                    (set! ,(ref-reg %cp) ,(make-arg-opnd 1))
+            `(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
-                    (set! ,%td ,(%tc-ref stack-link))
+               ,(%seq
-                    (set! ,%xp ,%td)
+                  (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
-                    (label ,Ltop)
+                  (set! ,(ref-reg %cp) ,(make-arg-opnd 1))
-                    (set! ,%ac0 ,(%mref ,%xp ,(constant continuation-stack-clength-disp)))
+                  (set! ,(make-arg-opnd 1) ,%td)
-                    (if ,(%inline eq?
+                  ,(do-call 1)))
-                           ,(%mref ,%xp ,(constant continuation-stack-length-disp))
+            `(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
-                           ,%ac0)
+               ,(%seq
-                        ,(%seq
+                  (set! ,(ref-reg %cp) ,(make-arg-opnd 1))
-                           (set! ,%ac0
+                  ,(reify-cc-help
-                             (literal ,(make-info-literal #f 'library-code
+                    (lambda (reg)
-                                         (lookup-libspec dounderflow)
+                      (%seq
-                                         (fx+ (constant code-data-disp) (constant size-rp-header)))))
+                        (set! ,(make-arg-opnd 1) ,reg)
-                           (if (if ,(%inline eq? ,%ref-ret ,%ac0)
+                        ,(do-call 1))))))]
-                                   ,(%inline eq?
-                                      ,(%mref ,%td ,(constant continuation-winders-disp))
-                                      ,(%tc-ref winders))
-                                   (false))
-                               ,(%seq
-                                  (set! ,(make-arg-opnd 1) ,%td)
-                                  ,(do-call 1))
-                               ,(%seq
-                                  (set! ,%xp ,(%constant-alloc type-closure (constant size-continuation)))
-                                  ; TODO: remove next line once get-room preserves %td
-                                  (set! ,%td ,(%tc-ref stack-link))
-                                  (set! ,(%mref ,%xp ,(constant continuation-code-disp))
-                                    (literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp))))
-                                  (set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
-                                  (set! ,(%mref ,%xp ,(constant continuation-winders-disp)) ,(%tc-ref winders))
-                                  (set! ,%ref-ret ,%ac0)
-                                  (set! ,(%mref ,%xp ,(constant continuation-link-disp)) ,%td)
-                                  (set! ,(%tc-ref stack-link) ,%xp)
-                                  (set! ,%ac0 ,(%tc-ref scheme-stack))
-                                  (set! ,(%tc-ref scheme-stack) ,%sfp)
-                                  (set! ,(%mref ,%xp ,(constant continuation-stack-disp)) ,%ac0)
-                                  (set! ,%ac0 ,(%inline - ,%sfp ,%ac0))
-                                  (set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
-                                  (set! ,(%mref ,%xp ,(constant continuation-stack-clength-disp)) ,%ac0)
-                                  (set! ,(%tc-ref scheme-stack-size) ,(%inline - ,(%tc-ref scheme-stack-size) ,%ac0))
-                                  (set! ,(make-arg-opnd 1) ,%xp)
-                                  ,(do-call 1))))
-                        ,(%seq
-                           (set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
-                           (set! ,%xp ,(%mref ,%xp ,(constant continuation-link-disp)))
-                           (goto ,Ltop))))))]
            [(call1cc)
             `(lambda ,(make-named-info-lambda 'call1cc '(1)) 0 ()
                ,(%seq
@@ -11178,11 +11372,11 @@
                     (literal ,(make-info-literal #f 'library-code
                                    (lookup-libspec dounderflow)
                                    (fx+ (constant code-data-disp) (constant size-rp-header)))))
-                  (if (if ,(%inline eq? ,%ref-ret ,%ac0)
+                  (if (if ,(%inline eq?
-                          ,(%inline eq?
+                               ,(%mref ,%td ,(constant continuation-attachments-disp))
-                             ,(%mref ,%td ,(constant continuation-winders-disp))
+                               ,(%constant sfalse))
-                             ,(%tc-ref winders))
+                           (false)
-                          (false))
+                           ,(%inline eq? ,%ref-ret ,%ac0))
                       ,(%seq
                          (set! ,(make-arg-opnd 1) ,%td)
                          ,(do-call 1))
@@ -11193,8 +11387,8 @@
                          (set! ,(%mref ,%xp ,(constant continuation-code-disp))
                            (literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp))))
                          (set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
-                         (set! ,(%mref ,%xp ,(constant continuation-winders-disp))
+                         (set! ,(%mref ,%xp ,(constant continuation-winders-disp)) ,(%tc-ref winders))
-                           ,(%tc-ref winders))
+                         (set! ,(%mref ,%xp ,(constant continuation-attachments-disp)) ,(%tc-ref attachments))
                          ,(meta-cond
                             [(real-register? '%ret) `(set! ,%ret ,%ac0)]
                             [else `(nop)])
@@ -11309,7 +11503,9 @@
         [(mref ,x1 ,x2 ,imm) (%mref ,(Ref x1) ,(Ref x2) ,imm)])
       (Rhs : Rhs (ir) -> Rhs ()
         [(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))
-         ($oops who "Effect is responsible for handling mvcalls")])
+         ($oops who "Effect is responsible for handling mvcalls")]
+        [(attachment-get ,t* ...)
+         ($oops who "Effect is responsible for handling attachment-gets")])
       (Effect : Effect (ir) -> Effect ()
         [(do-rest ,fixed-args)
          (if (fx<= fixed-args dorest-intrinsic-max)
@@ -11353,7 +11549,64 @@
         [(foreign-call ,info ,[t0] ,[t1*] ...)
          (build-foreign-call info t0 t1* #f #t)]
         [(set! ,[lvalue] (foreign-call ,info ,[t0] ,[t1*] ...))
-         (build-foreign-call info t0 t1* lvalue #t)])
+         (build-foreign-call info t0 t1* lvalue #t)]
+        [(set! ,[lvalue] (attachment-get))
+         ;; No default expression => an attachment is certainly available
+         (let ([ats (make-tmp 'ats)])
+           (%seq
+            (set! ,ats ,(%tc-ref attachments))
+            (set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))))]
+        [(set! ,[lvalue] (attachment-get ,[t]))
+         ;; Default expression => need to check for reified continuation
+         ;; and attachment beyond it. For now, we always reify the continuation
+         ;; to simplify the check
+         (let ([ats (make-tmp 'ats)])
+           (%seq
+             (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
+             (set! ,ats ,(%tc-ref attachments))
+             (if ,(%inline eq? ,(%mref ,%td ,(constant continuation-attachments-disp)) ,ats)
+                 (set! ,lvalue ,t)
+                 (set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp))))))]
+        [(attachment-set ,aop)
+         (case aop
+           [(pop)
+            (let ([ats (make-tmp 'ats)])
+              (%seq
+                (set! ,ats ,(%tc-ref attachments))
+                (set! ,(%tc-ref attachments) ,(%mref ,ats ,(constant pair-cdr-disp)))))]
+           [else
+            ($oops who "unexpected attachment-set mode ~s" aop)])]
+        [(attachment-set ,aop ,[t])
+         (let ([ats (make-tmp 'ats)])
+           (define (make-push)
+             (let ([p (make-tmp 'pr)])
+               ;; Generate
+               ;;  ($current-attachments (cons t ($current-attachments)))
+               (%seq
+                (set! ,p ,(%constant-alloc type-pair (constant size-pair)))
+                (set! ,(%mref ,p ,(constant pair-car-disp)) ,t)
+                (set! ,(%mref ,p ,(constant pair-cdr-disp)) ,ats)
+                (set! ,(%tc-ref attachments) ,p))))
+           (case aop
+             [(push)
+              (%seq
+               (set! ,ats ,(%tc-ref attachments))
+               ,(make-push))]
+             [(set)
+              (%seq
+               (set! ,ats ,(%tc-ref attachments))
+               (set! ,ats ,(%mref ,ats ,(constant pair-cdr-disp)))
+               ,(make-push))]
+             [(reify-and-set)
+              (%seq
+               (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
+               (set! ,ats ,(%tc-ref attachments))
+               (if ,(%inline eq? ,(%mref ,%td ,(constant continuation-attachments-disp)) ,ats)
+                   (nop)
+                   (set! ,ats ,(%mref ,ats ,(constant pair-cdr-disp))))
+               ,(make-push))]
+             [else
+              ($oops who "unexpected attachment-set mode ~s" aop)]))])
       (Tail : Tail  (ir) -> Tail  ()
         [(entry-point (,x* ...) ,dcl ,mcp ,tlbody)
          (unless (andmap (lambda (x) (eq? (uvar-type x) 'ptr)) x*)
@@ -12231,6 +12484,32 @@
                        (set! ,(ref-reg %cp) ,%td)
                        (jump ,(%mref ,%td ,(constant closure-code-disp))
                              (,%ac0 ,(reg-cons* %ret arg-registers) ...)))]))))]
+           [($shift-attachment)
+            ;; Reify the continuation, but dropping the first `attachments` element,
+            ;; which must be present, so that the attachment will be popped
+            ;; on return from the continuation
+            (let ([info (make-info "$shift-attachment" '())])
+              (info-lambda-fv*-set! info '(proc))
+              `(lambda ,info 0 ()
+                ,(%seq
+                  (set! ,(ref-reg %ac1) ,%ac0) ; save argument count
+                  (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
+                  (set! ,%ts ,(%mref ,%td ,(constant continuation-attachments-disp)))
+                  (set! ,(%mref ,%td ,(constant continuation-attachments-disp)) ,(%mref ,%ts ,(constant pair-cdr-disp)))
+                  (set! ,%ac0 ,(ref-reg %ac1)) ; restore argument count
+                  ,(meta-cond
+                    [(real-register? '%cp)
+                     (%seq
+                       (set! ,%cp ,(%mref ,%cp ,(constant closure-data-disp)))
+                       (jump ,(%mref ,%cp ,(constant closure-code-disp))
+                             (,%ac0 ,%cp ,(reg-cons* %ret arg-registers) ...)))]
+                    [else
+                     (%seq
+                       (set! ,%td ,(ref-reg %cp))
+                       (set! ,%td ,(%mref ,%td ,(constant closure-data-disp)))
+                       (set! ,(ref-reg %cp) ,%td)
+                       (jump ,(%mref ,%td ,(constant closure-code-disp))
+                             (,%ac0 ,(reg-cons* %ret arg-registers) ...)))]))))]
            [(bytevector=?)
             (let ([bv1 (make-tmp 'bv1)] [bv2 (make-tmp 'bv2)] [idx (make-tmp 'idx)] [len2 (make-tmp 'len2)])
               (define (argcnt->max-fv n) (max (- n (length arg-registers)) 0))
@@ -12329,13 +12608,16 @@
                     (label ,Lret)
                     (rp-header ,Lmvreturn ,(* 2 (constant ptr-bytes)) 1) ; cchain is live at sfp[ptr-bytes]
                     (set! ,(ref-reg %ac1) (immediate 1)) ; single-value as expected
-                    (label ,Lexit)
                     ,(save-scheme-state
                        (in %ac0 %ac1)
                        (out %cp %xp %yp %ts %td scheme-args extra-regs))
+                    (label ,Lexit)
                     (inline ,(make-info-c-simple-call #f (lookup-c-entry Sreturn)) ,%c-simple-call)
                     (label ,Lmvreturn)
                     (set! ,(ref-reg %ac1) ,%ac0)
+                    ,(save-scheme-state
+                       (in %ac0 %ac1 scheme-args)
+                       (out %cp %xp %yp %ts %td extra-regs))
                     (goto ,Lexit))))]
            [else ($oops who "unrecognized hand-coded name ~s" sym)])]))
 
@@ -16008,6 +16290,7 @@
               (pass np-recognize-mrvs unparse-L4.5)
               (pass np-expand-foreign unparse-L4.75)
               (pass np-recognize-loops unparse-L4.875)
+              (pass np-recognize-attachment unparse-L4.9375)
               (pass np-name-anonymous-lambda unparse-L5)
               (pass np-convert-closures unparse-L6)
               (pass np-optimize-direct-call unparse-L6)

s/inspect.ss

@@ -2510,7 +2510,8 @@
                                                (compute-size ($continuation-return-code x))
                                                (compute-size ($closure-code x))
                                                (compute-size ($continuation-link x))
-                                               (compute-size ($continuation-winders x)))])
+                                               (compute-size ($continuation-winders x))
+                                               (compute-size ($continuation-attachments x)))])
                               (if (fx>= i len)
                                   size
                                   (loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size)))))))
@@ -2665,6 +2666,7 @@
                      (compute-composition! ($closure-code x))
                      (compute-composition! ($continuation-link x))
                      (compute-composition! ($continuation-winders x))
+                     (compute-composition! ($continuation-attachments x))
                      (let ([len ($continuation-stack-length x)])
                        (incr! stack (align (fx* len (constant ptr-bytes))))
                        (let loop ([i 1] [lpm ($continuation-return-livemask x)])
@@ -2803,7 +2805,8 @@
                                  (let ([len ($continuation-stack-length x)])
                                    (let loop ([i 1] [lpm ($continuation-return-livemask x)])
                                      (if (fx>= i len)
-                                         (construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x) ($continuation-winders x) next-proc)
+                                         (construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x)
+                                                         ($continuation-winders x) ($continuation-attachments x) next-proc)
                                          (if (odd? lpm)
                                              (construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1))) 
                                              (loop (fx+ i 1) (ash lpm -1))))))))

s/library.ss

@@ -111,6 +111,7 @@
 ;;; dounderflow & nuate must come before callcc
 (define-hand-coded-library-entry dounderflow)
 (define-hand-coded-library-entry nuate)
+(define-hand-coded-library-entry reify-cc)
 (define-hand-coded-library-entry callcc)
 (define-hand-coded-library-entry call1cc)
 (define-hand-coded-library-entry dofargint32)
@@ -124,6 +125,7 @@
 (define-hand-coded-library-entry dofretu32*)
 (define-hand-coded-library-entry domvleterr)
 (define-hand-coded-library-entry values-error)
+(define-hand-coded-library-entry $shift-attachment)
 (define-hand-coded-library-entry bytevector=?)
 (define-hand-coded-library-entry arity-wrapper-apply)
 (define-hand-coded-library-entry $arity-wrapper-apply)

s/mkheader.ss

@@ -885,12 +885,14 @@
         (defref RELOCCODE reloc-table code)
         (defref RELOCIT reloc-table data)
 
+        (defref CONTCODE continuation code)
         (defref CONTSTACK continuation stack)
         (defref CONTLENGTH continuation stack-length)
         (defref CONTCLENGTH continuation stack-clength)
         (defref CONTLINK continuation link)
         (defref CONTRET continuation return-address)
         (defref CONTWINDERS continuation winders)
+        (defref CONTATTACHMENTS continuation attachments)
 
         (defref RTDCOUNTSTYPE rtd-counts type)
         (defref RTDCOUNTSTIMESTAMP rtd-counts timestamp)

s/np-languages.ss

@@ -45,7 +45,7 @@
     block-pariah! block-seen! block-finished! block-return-point! block-repeater! block-loop-header!
     block-pariah? block-seen? block-finished? block-return-point? block-repeater? block-loop-header?
     L1 unparse-L1 L2 unparse-L2 L3 unparse-L3 L4 unparse-L4
-    L4.5 unparse-L4.5 L4.75 unparse-L4.75 L4.875 unparse-L4.875
+    L4.5 unparse-L4.5 L4.75 unparse-L4.75 L4.875 unparse-L4.875 L4.9375 unparse-L4.9375
     L5 unparse-L5 L6 unparse-L6 L7 unparse-L7
     L9 unparse-L9 L9.5 unparse-L9.5 L9.75 unparse-L9.75
     L10 unparse-L10 L10.5 unparse-L10.5 L11 unparse-L11
@@ -382,8 +382,21 @@
     (Expr (e body)
       (+ (loop x (x* ...) body) => (loop x body))))
 
+  (define attachment-op?
+    (lambda (x)
+      (memq x '(push pop set reify-and-set))))
+
+ ; exposes continuation-attachment operations
+  (define-language L4.9375 (extends L4.875)
+    (terminals
+     (+ (attachment-op (aop))))
+    (entry CaseLambdaExpr)
+    (Expr (e body)
+      (+ (attachment-set aop e* ...)
+         (attachment-get e* ...))))
+
  ; moves all case lambda expressions into rhs of letrec
-  (define-language L5 (extends L4.875)
+  (define-language L5 (extends L4.9375)
     (entry CaseLambdaExpr)
     (Expr (e body)
       (- le)))
@@ -655,7 +668,8 @@
          (alloc info t)                          => (alloc info t)
          (inline info prim t* ...)               => (inline info prim t* ...)
          (mvcall info e t)                       => (mvcall e t)
-         (foreign-call info t t* ...)))
+         (foreign-call info t t* ...)
+         (attachment-get t* ...)))
     (Expr (e body)
       (- lvalue
          (values info e* ...)
@@ -668,7 +682,8 @@
          (let ([x e] ...) body)
          (set! lvalue e)
          (mvcall info e1 e2)
-         (foreign-call info e e* ...))
+         (foreign-call info e e* ...)
+         (attachment-get e* ...))
       (+ rhs
          (values info t* ...)
          (set! lvalue rhs))))
@@ -716,7 +731,8 @@
          (pariah)
          (trap-check ioc e)
          (overflow-check e)
-         (profile src)))
+         (profile src)
+         (attachment-set aop e* ...)))
     (Tail (tl tlbody)
       (+ rhs
          (if p0 tl1 tl2)
@@ -747,6 +763,7 @@
             (mvset (mdcl t0 t1 ...) (t* ...) ((x** ...) interface* l*) ...)
          (mvcall info mdcl (maybe t0) t1 ... (t* ...)) => (mvcall mdcl t0 t1 ... (t* ...))
          (foreign-call info t t* ...)
+         (attachment-set aop t* ...)
          (tail tl))))
 
   (define-language L11.5 (extends L11)

s/primdata.ss

@@ -1175,8 +1175,10 @@
   (bytevector-compress [sig [(ptr) -> (ptr)]] [flags])
   (bytevector-uncompress [sig [(ptr) -> (ptr)]] [flags])
   (call/1cc [sig [(procedure) -> (ptr ...)]] [flags])
+  (call-with-current-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
   (call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs])      ; has options argument
   (call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs])     ; has options argument
+  (call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
   (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
   (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
   (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
@@ -1224,6 +1226,7 @@
   (condition-wait [feature pthreads] [sig [(condition-object mutex) (condition-object mutex timeout) -> (boolean)]] [flags])
   (conjugate [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
   (continuation-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
+  (continuation-next-attachments [sig [(ptr) -> (list)]] [flags])
   (copy-environment [sig [(environment) (environment ptr) (environment ptr sub-list) -> (environment)]] [flags alloc])
   (copy-time [sig [(time) -> (time)]] [flags alloc])
   (cosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
@@ -1233,6 +1236,7 @@
   (cost-center-time [sig [(cost-center) -> (time)]] [flags mifoldable discard true])
   (cpu-time [sig [() -> (uint)]] [flags unrestricted alloc])
   (create-exception-state [sig [() (procedure) -> (void)]] [flags alloc])
+  (current-continuation-attachments [sig [() -> (list)]] [flags alloc])
   (current-memory-bytes [sig [() -> (uint)]] [flags alloc])
   (date-and-time [sig [() (date) -> (string)]] [flags unrestricted alloc])
   (datum->syntax-object [sig [(identifier ptr) -> (ptr)]] [flags pure mifoldable discard true])
@@ -1779,6 +1783,7 @@
   ($continuation-stack-length [flags])
   ($continuation-stack-ref [flags])
   ($continuation-winders [flags])
+  ($continuation-attachments [flags])
   ($cp0 [flags])
   ($cpcheck [flags])
   ($cpcheck-prelex-flags [flags])
@@ -1788,6 +1793,7 @@
   ($c-stlv! [flags])
   ($cte-optimization-info [flags])
   ($c-tlv [flags])
+  ($current-attachments [flags])
   ($current-stack-link [flags])
   ($current-winders [flags])
   ($distinct-bound-ids? [flags])
@@ -2098,6 +2104,7 @@
   ($make-record-type #;[sig [(rtd maybe-rtd sub-ptr sub-list ptr ptr ptr ...) -> (rtd)]] [flags pure alloc cp02])
   ($make-relocation-table! [flags])
   ($make-rnrs-libraries [flags])
+  ($make-shift-attachment [flags])
   ($make-source-oops [flags])
   ($make-src-condition [flags])
   ($make-textual-input/output-port #;[sig [(string port-handler string string) (string port-handler string string ptr) -> (textual-input/output-port)]] [flags alloc])

s/prims.ss

@@ -369,6 +369,24 @@
       ($oops who "~s is not a procedure" p))
     (#3%call/cc p)))
 
+(define-who call-setting-continuation-attachment
+  (lambda (v p)
+    (unless (procedure? p)
+      ($oops who "~s is not a procedure" p))
+    (#3%call-setting-continuation-attachment v (lambda () (p)))))
+
+(define-who call-with-current-continuation-attachment
+  (lambda (default-val p)
+    (unless (procedure? p)
+      ($oops who "~s is not a procedure" p))
+    (#3%call-with-current-continuation-attachment default-val (lambda (x) (p x)))))
+
+(define $make-shift-attachment
+  (lambda (proc)
+    (if (procedure? proc)
+        (#3%$make-shift-attachment proc)
+        ($oops #f "attempt to apply non-procedure ~s" proc))))
+
 (define $code? (lambda (x) ($code? x)))
 
 (define $system-code? (lambda (x) ($system-code? x)))
@@ -501,6 +519,12 @@
          ($oops '$continuation-winders "~s is not a continuation" x))
       ($continuation-winders x)))
 
+(define $continuation-attachments
+   (lambda (x)
+      (unless ($continuation? x)
+         ($oops '$continuation-attachments "~s is not a continuation" x))
+      ($continuation-attachments x)))
+
 (define $continuation-return-code
    (lambda (x)
       (unless ($continuation? x)
@@ -1414,13 +1438,23 @@
        ($oops '$current-stack-link "invalid argument ~s" k))
      ($current-stack-link k)]))
 
-(define $current-winders
+(define-who $current-winders
+  (let ()
+    (include "types.ss")
+    (case-lambda
+      [() ($current-winders)]
+      [(w)
+       (unless (and (list? w) (andmap winder? w))
+         ($oops who "malformed winders ~s" w))
+       ($current-winders w)])))
+
+(define $current-attachments
   (case-lambda
-    [() ($current-winders)]
+    [() ($current-attachments)]
     [(w)
-     (unless (and (list? w) (andmap (lambda (x) (winder? x)) w))
+     (unless (list? w)
-       ($oops '$current-winders "malformed winders ~s" w))
+       ($oops '$current-attachments "malformed attachments ~s" w))
-     ($current-winders w)]))
+     ($current-attachments w)]))
 
 (define lock-object
   (foreign-procedure "(cs)lock_object" (scheme-object) void))

s/types.ss

@@ -109,3 +109,13 @@
                            (define profile-counter-count (record-accessor '#,rtd 0))
                            (define profile-counter-count-set! (record-mutator '#,rtd 0))))]))])
   (a profile-counter? make-profile-counter profile-counter-count profile-counter-count-set!))
+
+
+(define-record-type winder
+  (fields (immutable in) (immutable out) (immutable attachments))
+  (nongenerative #{winder qnbz1n5f3x1ldovscan3nu-0}))
+
+(define-record-type critical-winder
+  (parent winder)
+  (sealed #t)
+  (nongenerative #{critical-winder qnbz1n5f3x1ldovscan3nu-2}))