From a9aa80ea67283e2c063d0333b68b796b1c0fdbd6 Mon Sep 17 00:00:00 2001
From: ESL <der.magen@hotmail.com>
Date: Thu, 30 Mar 2023 13:08:16 -0400
Subject: [PATCH] dynamic-wind is fully operational

---
 i.c       | 23 ++++++++++++++++++++---
 src/i.scm | 11 +++++++++++
 src/s.scm |  7 +++++--
 3 files changed, 36 insertions(+), 5 deletions(-)

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)