Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2025-01-27 19:58:49 +01:00
Code Issues Projects Releases Packages Wiki Activity

dynamic-wind is fully operational

Browse source
This commit is contained in:
ESL 2023-03-30 13:08:16 -04:00
parent 5dd5ff2c07
commit a9aa80ea67
3 changed files with 36 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
i.c
View file

@ -4594,22 +4594,39 @@ static obj *init_module(obj *r, obj *sp, obj *hp, const char **mod)
return hp; return hp;
} }
/* hand-coded module */ /* partially hand-coded module (prototyped in i.scm) */
char *i_code[] = { char *i_code[] = {
"P", "%dynamic-state-reroot!", "P", "%dynamic-state-reroot!",
"%1.0,,#0.0,&1{%1.0,yq~?{${.2d,:0^[01}.0ad,.1aa,y,.1,.3c,.1sa.3,.1sdf,." "%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", "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: /* code for the continuation adapter:
* k! first attempt; does not return if nothing to un/re-wind * k! first attempt; does not return if nothing to un/re-wind
* , save argc by pushing it on top of args in stack * , save argc by pushing it on top of args in stack
* ${ push new frame for return from %dynamic-state-reroot! * ${ push new frame for return from %dynamic-state-reroot!
* :0 get old dynamic state from continuation's display * :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) * [01 call it with 1 argument (old dynamic state)
* } we will return here when d-s-r! is finished * } 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 * k! retry; should not return this time
* %% signal an (argument?) error if we return ?? */ * %% signal an (argument?) error if we return ?? */
"K", 0, "K", 0,

11
src/i.scm
View file

@ -24,3 +24,14 @@
(%set-dynamic-state! there)) (%set-dynamic-state! there))
(before))))) (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)))))

7
src/s.scm
View file

@ -1025,6 +1025,11 @@
; (values x ...) ; (values x ...)
; (call-with-values thunk receiver) ; (call-with-values thunk receiver)
; builtins:
;
; (dynamic-wind before during after)
(define (%apply p x . l) (define (%apply p x . l)
(apply-to-list p (apply-to-list p
(let loop ([x x] [l l]) (let loop ([x x] [l l])
@ -1049,8 +1054,6 @@
(define-syntax call-with-current-continuation call/cc) (define-syntax call-with-current-continuation call/cc)
;dynamic-wind
(define (%map1 p l) (define (%map1 p l)
(let loop ([l l] [r '()]) (let loop ([l l] [r '()])
(if (pair? l) (if (pair? l)