Merge pull request #14 from shriram/textbook-dyn-scope

Change #lang dyn-scope-is-bad to match 2021Fall textbook
shriram · Aug 19, 2022 · fff99a6 · fff99a6
2 parents a74082a + 143d531
commit fff99a6
Show file tree

Hide file tree

Showing 2 changed files with 50 additions and 57 deletions.
diff --git a/dyn-scope-is-bad/semantics.rkt b/dyn-scope-is-bad/semantics.rkt
@@ -4,8 +4,6 @@
 
 (require smol/hof/semantics)
 
-(require [only-in mzscheme fluid-let])
-
 (provide [except-out [all-from-out smol/hof/semantics]
                      ;defvar
                      ;deffun
@@ -14,25 +12,35 @@
                      let
                      let*
                      set!
-                     #%top])
+                     #%top
+                     #%app])
 (provide defvar deffun)
 (provide [rename-out (dyn-λ λ)
                      (dyn-λ lambda)
                      (dyn-let let)
+                     (dyn-let let*)
                      (dyn-let letrec)
-                     (dyn-let* let*)
+                     (dyn-app #%app)
                      (dyn-set! set!)])
 
-(define dvs (make-hasheq))
+(define dvs (make-parameter (make-hasheq)))
 
 (define (store name v)
-  (hash-set! dvs name v))
+  (hash-set! (dvs) name (box v)))
 
-(define (fetch name)
-  (hash-ref dvs name
+(define (internal-fetch name)
+  (hash-ref (dvs) name
             (lambda ()
               (error name "undefined"))))
 
+(define (update name v)
+  (define loc (internal-fetch name))
+  (set-box! loc v))
+
+(define (fetch name)
+  (define loc (internal-fetch name))
+  (unbox loc))
+
 (define-syntax (defvar stx)
   (syntax-parse stx
     [(_ var:id rhs:expr)
@@ -42,8 +50,8 @@
 (define-syntax (deffun stx)
   (syntax-parse stx
     [(_ (fname:id arg:id ...) body:expr ...+)
-     #'(store 'fname
-              (dyn-λ (arg ...) body ...))]))
+     #'(defvar fname
+         (dyn-λ (arg ...) body ...))]))
 
 (define-syntax (dyn-λ stx)
   (syntax-parse stx
@@ -58,12 +66,7 @@
 (define-syntax (dyn-let stx)
   (syntax-parse stx
     ([_ ([var:id val:expr] ...) body:expr ...+]
-     (with-syntax ([(tmp ...)
-                    (generate-temporaries #'(var ...))])
-       #'(let ([tmp val] ...)
-           (store 'var tmp)
-           ...
-           body ...)))))
+     #'(dyn-app (dyn-λ (var ...) body ...) val ...))))
 
 (define-syntax dyn-let*
   (syntax-rules ()
@@ -76,12 +79,18 @@
 (define-syntax (dyn-set! stx)
   (syntax-parse stx
     ([_ var:id val:expr]
-     #'(store 'var val))))
+     #'(update 'var val))))
 
 (provide (rename-out [handle-id #%top]))
 
 (define-syntax (handle-id stx)
   (syntax-case stx ()
-    [(_ . any)
-    (with-syntax ([stx stx])
-      #'(fetch 'any))]))
+    [(_ . var)
+     (with-syntax ([stx stx])
+       #'(fetch 'var))]))
+
+(define-syntax (dyn-app stx)
+  (syntax-parse stx
+    [(_ fun:expr arg:expr ...)
+     #'(parameterize ([dvs (hash-copy (dvs))])
+         (#%app fun arg ...))]))
diff --git a/dyn-scope-is-bad/tests/all.rkt b/dyn-scope-is-bad/tests/all.rkt
@@ -15,43 +15,6 @@
 
 ; -----
 
-(defvar dx 0.0001)
-(deffun (d/dx-1 f)
-  ;; note: param named `p` to not clash with f's param
-  (lambda (p)
-    (/ (- (f (+ p dx)) (f p))
-       dx)))
-
-(defvar d-dx-sq-1 (d/dx-1 (lambda (x) (* x x))))
-(defvar d-dx-sq-1@10 (d-dx-sq-1 10))
-(test/pred d-dx-sq-1@10
-           (λ (ans) (< 20 ans 21)))
-
-(defvar d-dx-cb-1 (d/dx-1 (λ (x) (* x x x))))
-(defvar d-dx-cb-1@10 (d-dx-cb-1 10))
-(test/pred d-dx-cb-1@10
-           (λ (ans) (< 300 ans 301)))
-;; note: test/not
-(test/not (d-dx-sq-1 10) d-dx-sq-1@10)
-
-; - - -
-
-(deffun (d/dx-2 f)
-  (lambda (x)
-    ;; param is now named x, same as f's param
-    (/ (- (f (+ x dx)) (f x))
-       dx)))
-
-(defvar d-dx-sq-2 (d/dx-2 (lambda (x) (* x x))))
-;; note: test/not (value comes out to be 0)
-(test/not (d-dx-sq-2 10) d-dx-sq-1@10)
-
-(defvar d-dx-cb-2 (d/dx-2 (λ (x) (* x x x))))
-;; note: test/not (value comes out to be 0)
-(test/not (d-dx-cb-2 10) d-dx-cb-1@10)
-
-; -----
-
 (test
  (let ([fact (λ (n)
                (if (zero? n)
@@ -60,6 +23,8 @@
    (fact 10))
  3628800)
 
+; -----
+
 (test
  (let ([even? (λ (n)
                 (if (zero? n)
@@ -83,6 +48,25 @@
 
 ; -----
 
+(deffun (fibber x)
+  (if (< x 2)
+      (if (<= x 0) 0 1)
+      (+ (fibber (- x 1)) (fibber (- x 2)))))
+
+(test (fibber 5) 5)
+
+; -----
+
+(test/exn
+ (let ((x 1))
+   (+ (let ((f (lambda () x)))
+        (let ((x 2) (y 3))
+          (f)))
+      y))
+ "")
+
+; -----
+
 (test
  (let* ([x 1]
         [f (lambda () x)]