suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
Adds the continuation-attachments PR.

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

original commit: c2ade1be5da80378529c20ab830d863032961e2b
This commit is contained in:
Matthew Flatt 2018-07-25 18:47:46 -06:00
commit 65fe38f11d
31 changed files with 1440 additions and 645 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
BUILDING
View File

@ -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

35
LOG
View File

@ -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
- 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
misc.ms, patch-compile-0-f-t-f, patch-interpret-0-f-t-f
- add load-compiled-from-port and Sregister_boot_file_fd for loading modes
based on open files instead of paths
7.ss, primdata.ss, mkheader.ss, scheme.c
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
based on open files instead of paths
7.ss, primdata.ss, mkheader.ss, scheme.c
7.ms, foreign.stex, system.stex
- add support for continuation attachments
cpnanopass.ss, np-languages.ss, 4.ss, prims.ss, inspect.ss,
cmacro.ss, primdata.ss, library.ss types.ss, mkheader.ss,
alloc.c, gc.c, schsig.c, thread.c, externs.h,
4.ms, control.stex

5
c/alloc.c
View File

@ -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;
}

3
c/externs.h
View File

@ -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));

18
c/gc.c
View File

@ -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)
s = space_closure;
else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
if (BACKREFERENCES_ENABLED) {
find_room(space_closure, tg, type_closure, n, p);
} 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;
} else
s = space_pure;
find_room(s, tg, type_closure, n, p);
find_room(space_impure, tg, type_closure, n, p);
} else {
find_room(space_pure, 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;

2
c/scheme.c
View File

@ -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;

9
c/schsig.c
View File

@ -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");

1
c/thread.c
View File

@ -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;

8
configure vendored
View File

@ -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"

138
csug/control.stex
View File

@ -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

4
csug/system.stex
View File

@ -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
if it is a 32-bit exact integer, and -1 otherwise.
the value of the first argument cast to a C int if
it is an exact integer of the host machine's bit width, and 1 otherwise.
%----------------------------------------------------------------------------
\entryheader

250
mats/4.ms
View File

@ -3177,6 +3177,256 @@
"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:
(mat engine

33
mats/7.ms
View File

@ -116,8 +116,8 @@
(begin
(define-values (o get) (open-bytevector-output-port))
(compile-to-port '((define lcfp1 'worked) 'loaded) o)
(equal? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
(equal? 'worked lcfp1)
(eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
(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

28
mats/patch-compile-0-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f 2018-07-16 14:43:05.195920036 -0400
--- errors-compile-0-f-t-f 2018-07-16 14:11:48.751983271 -0400
*** errors-compile-0-f-f-f 2018-07-24 22:17:12.000000000 -0600
--- 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".

759
mats/patch-compile-0-t-f-f
View File

File diff suppressed because it is too large Load Diff

77
mats/patch-interpret-0-f-f-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f 2018-07-15 22:22:57.502803909 -0600
--- errors-interpret-0-f-f-f 2018-07-15 21:46:11.227902570 -0600
*** errors-compile-0-f-f-f 2018-07-24 22:17:12.000000000 -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 ****
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 ****
*** 4088,4103 ****
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 ...)))".

77
mats/patch-interpret-0-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-t-f 2018-07-16 14:11:48.751983271 -0400
--- errors-interpret-0-f-t-f 2018-07-16 14:33:23.391939643 -0400
*** errors-compile-0-f-t-f 2018-07-24 21:07:12.000000000 -0600
--- 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 ****
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 ****
*** 4088,4103 ****
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 ...)))".

4
mats/patch-interpret-3-f-f-f
View File

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

4
mats/patch-interpret-3-f-t-f
View File

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

19
mats/root-experr-compile-0-f-f-f
View File

@ -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))".

35
release_notes/release_notes.stex
View File

@ -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

26
s/4.ss
View File

@ -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

23
s/cmacros.ss
View File

@ -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 ()

409
s/cpnanopass.ss
View File

@ -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,28 +11328,55 @@
[(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,
;; but, we inline `reify-cc` to save a few instructions
#;
`(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
,(%seq
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
(set! ,(make-arg-opnd 1) ,%td)
,(do-call 1)))
`(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
,(%seq
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
(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)
,(reify-cc-help
(lambda (reg)
(%seq
(set! ,(make-arg-opnd 1) ,reg)
,(do-call 1))))))]
[(call1cc)
`(lambda ,(make-named-info-lambda 'call1cc '(1)) 0 ()
,(%seq
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
(set! ,%td ,(%tc-ref stack-link))
(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? ,%ref-ret ,%ac0)
,(%inline eq?
,(%mref ,%td ,(constant continuation-winders-disp))
,(%tc-ref winders))
(false))
(if (if ,(%inline eq?
,(%mref ,%td ,(constant continuation-attachments-disp))
,(%constant sfalse))
(false)
,(%inline eq? ,%ref-ret ,%ac0))
,(%seq
(set! ,(make-arg-opnd 1) ,%td)
,(do-call 1))
@ -11153,48 +11388,7 @@
(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
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
(set! ,%td ,(%tc-ref stack-link))
(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? ,%ref-ret ,%ac0)
,(%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! ,(%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)

7
s/inspect.ss
View File

@ -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))))))))

2
s/library.ss
View File

@ -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)

2
s/mkheader.ss
View File

@ -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)

27
s/np-languages.ss
View File

@ -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)

7
s/primdata.ss
View File

@ -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])

42
s/prims.ss
View File

@ -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 (lambda (x) (winder? x)) w))
($oops '$current-winders "malformed winders ~s" w))
($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-attachments)]
[(w)
(unless (list? w)
($oops '$current-attachments "malformed attachments ~s" w))
($current-attachments w)]))
(define lock-object
(foreign-procedure "(cs)lock_object" (scheme-object) void))

10
s/types.ss
View File

@ -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}))