diff --git a/i.c b/i.c index c9f992f..16021cc 100644 --- a/i.c +++ b/i.c @@ -4594,22 +4594,39 @@ static obj *init_module(obj *r, obj *sp, obj *hp, const char **mod) return hp; } -/* hand-coded module */ +/* partially hand-coded module (prototyped in i.scm) */ char *i_code[] = { "P", "%dynamic-state-reroot!", "%1.0,,#0.0,&1{%1.0,yq~?{${.2d,:0^[01}.0ad,.1aa,y,.1,.3c,.1sa.3,.1sdf,." "4san,.4sd.3sy_1.0[30}]1}.!0.0^_1[11", + /* code for dynamic-wind's internal lambda is modified as follows: + * , save argc by pushing it on top of args in stack + * ${ push new frame for return from %dynamic-state-reroot! + * :0 get 'here' dynamic state from internal lambda's display + * , put it on the stack for dynamic-state-reroot! + * @(y22:%25dynamic-state-reroot!) get the d-s-r! procedure + * [01 call it with 1 argument ('here' dynamic state) + * } we will return here when d-s-r! is finished + * _! pop saved argc from stack into ac register + * K6 use sdmv opcode to return args from the lambda + * also, %x procedure checks inserted for early error detection + */ + "P", "dynamic-wind", + "%3y,${.2,.6%x,.5%xcc,@(y22:%25dynamic-state-reroot!)[01}.0,&1{,${:0,@(" + "y22:%25dynamic-state-reroot!)[01}_!K6},.3,@(y16:call-with-values)[42", + /* code for the continuation adapter: * k! first attempt; does not return if nothing to un/re-wind * , save argc by pushing it on top of args in stack * ${ push new frame for return from %dynamic-state-reroot! * :0 get old dynamic state from continuation's display - * ,@(y22:%25dynamic-state-reroot!) get the d-s-r! procedure + * , put it on the stack for dynamic-state-reroot! + * @(y22:%25dynamic-state-reroot!) get the d-s-r! procedure * [01 call it with 1 argument (old dynamic state) * } we will return here when d-s-r! is finished - * _! pull saved argc from stack; we are ready to retry + * _! pop saved argc from stack; we are ready to retry * k! retry; should not return this time * %% signal an (argument?) error if we return ?? */ "K", 0, diff --git a/src/i.scm b/src/i.scm index 14352e8..904c7d7 100644 --- a/src/i.scm +++ b/src/i.scm @@ -24,3 +24,14 @@ (%set-dynamic-state! there)) (before))))) +; same %dynamic-state integrable is needed for dynamic-wind; the code in i_code module is +; later modified manually to make sure internal lambda does not list/unlist its arguments + +(define (dynamic-wind before during after) + (let ([here (%dynamic-state)]) + (%dynamic-state-reroot! (cons (cons before after) here)) + (call-with-values during + (lambda results + (%dynamic-state-reroot! here) + (apply values results))))) + diff --git a/src/s.scm b/src/s.scm index 26ac526..57c98a7 100644 --- a/src/s.scm +++ b/src/s.scm @@ -1025,6 +1025,11 @@ ; (values x ...) ; (call-with-values thunk receiver) +; builtins: +; +; (dynamic-wind before during after) + + (define (%apply p x . l) (apply-to-list p (let loop ([x x] [l l]) @@ -1049,8 +1054,6 @@ (define-syntax call-with-current-continuation call/cc) -;dynamic-wind - (define (%map1 p l) (let loop ([l l] [r '()]) (if (pair? l)