From 2fb4547c48e3767b8f69418aa423b62f8e8db4e6 Mon Sep 17 00:00:00 2001 From: "Lu, Kuang-Chen" Date: Mon, 4 Oct 2021 16:19:16 -0400 Subject: [PATCH 1/5] fix --- dyn-scope-is-bad/semantics.rkt | 49 +++++++++++++++++++++++----------- dyn-scope-is-bad/tests/all.rkt | 48 ++++++++------------------------- 2 files changed, 44 insertions(+), 53 deletions(-) diff --git a/dyn-scope-is-bad/semantics.rkt b/dyn-scope-is-bad/semantics.rkt index a3b3d3e..e9360b4 100644 --- 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 @@ -13,34 +11,47 @@ letrec let set! - #%top]) + #%top + #%app]) (provide defvar deffun) (provide [rename-out (dyn-λ λ) (dyn-λ lambda) (dyn-let let) (dyn-let letrec) - (dyn-set! set!)]) + (dyn-set! set!) + (dyn-app #%app)]) -(define dvs (make-hasheq)) +(define dvs (make-parameter (make-hasheq))) (define (store name v) - (hash-set! dvs name v)) + (hash-set! (dvs) (syntax->datum name) (box v))) + +(define (internal-fetch name) + (hash-ref (dvs) (syntax->datum name) + (lambda () + (raise-syntax-error + (syntax->datum name) + "unbound identifier" + name)))) + +(define (update name v) + (define loc (internal-fetch name)) + (set-box! loc v)) (define (fetch name) - (hash-ref dvs name - (lambda () - (error name "undefined")))) + (define loc (internal-fetch name)) + (unbox loc)) (define-syntax (defvar stx) (syntax-parse stx [(_ var:id rhs:expr) #'(let ([tmp rhs]) - (store 'var tmp))])) + (store #'var tmp))])) (define-syntax (deffun stx) (syntax-parse stx [(_ (fname:id arg:id ...) body:expr ...+) - #'(store 'fname + #'(store #'fname (dyn-λ (arg ...) body ...))])) (define-syntax (dyn-λ stx) @@ -49,7 +60,7 @@ (with-syntax ([(tmp-arg ...) (generate-temporaries #'(arg ...))]) #'(lambda (tmp-arg ...) - (store 'arg tmp-arg) + (store #'arg tmp-arg) ... body ...))])) @@ -59,19 +70,25 @@ (with-syntax ([(tmp ...) (generate-temporaries #'(var ...))]) #'(let ([tmp val] ...) - (store 'var tmp) + (store #'var tmp) ... body ...))))) (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))])) + (with-syntax ([stx stx]) + #'(fetch #'any))])) + +(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 index e1d532b..d396fa4 100644 --- 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) @@ -80,3 +45,12 @@ ((lambda () (set! to-set-1 6))) (test to-set-1 6) + +; ----- + +(deffun (fibber x) + (if (< x 2) + (if (<= x 0) 0 1) + (+ (fibber (- x 1)) (fibber (- x 2))))) + +(test (fibber 5) 5) From cf0447a1afd2ff605f07276012fdb2ef12486bfe Mon Sep 17 00:00:00 2001 From: "Lu, Kuang-Chen" Date: Mon, 4 Oct 2021 16:55:31 -0400 Subject: [PATCH 2/5] `let` was done wrong --- dyn-scope-is-bad/semantics.rkt | 17 ++++++----------- dyn-scope-is-bad/tests/all.rkt | 10 ++++++++++ 2 files changed, 16 insertions(+), 11 deletions(-) diff --git a/dyn-scope-is-bad/semantics.rkt b/dyn-scope-is-bad/semantics.rkt index e9360b4..04c5e67 100644 --- a/dyn-scope-is-bad/semantics.rkt +++ b/dyn-scope-is-bad/semantics.rkt @@ -28,11 +28,11 @@ (define (internal-fetch name) (hash-ref (dvs) (syntax->datum name) - (lambda () - (raise-syntax-error - (syntax->datum name) - "unbound identifier" - name)))) + (lambda () + (raise-syntax-error + (syntax->datum name) + "unbound identifier" + name)))) (define (update name v) (define loc (internal-fetch name)) @@ -67,12 +67,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-set! stx) (syntax-parse stx diff --git a/dyn-scope-is-bad/tests/all.rkt b/dyn-scope-is-bad/tests/all.rkt index d396fa4..d7a9485 100644 --- a/dyn-scope-is-bad/tests/all.rkt +++ b/dyn-scope-is-bad/tests/all.rkt @@ -54,3 +54,13 @@ (+ (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)) + "y: unbound identifier") From 14871558fe122aa7c9b252fa457c048be6be3c23 Mon Sep 17 00:00:00 2001 From: "Lu, Kuang-Chen" Date: Sun, 17 Oct 2021 11:39:21 -0400 Subject: [PATCH 3/5] remove a test case. This test doesn't work because the error was raised by raise-syntax-error rather than plai's error --- dyn-scope-is-bad/tests/all.rkt | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/dyn-scope-is-bad/tests/all.rkt b/dyn-scope-is-bad/tests/all.rkt index d7a9485..d396fa4 100644 --- a/dyn-scope-is-bad/tests/all.rkt +++ b/dyn-scope-is-bad/tests/all.rkt @@ -54,13 +54,3 @@ (+ (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)) - "y: unbound identifier") From d26e472c1f3d7111709a01fb5bdd707ee90d273d Mon Sep 17 00:00:00 2001 From: "Lu, Kuang-Chen" Date: Thu, 18 Aug 2022 00:46:01 -0400 Subject: [PATCH 4/5] get ride of the syntactic error nonsense --- dyn-scope-is-bad/semantics.rkt | 21 +++++++++------------ dyn-scope-is-bad/tests/all.rkt | 10 ++++++++++ 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/dyn-scope-is-bad/semantics.rkt b/dyn-scope-is-bad/semantics.rkt index 8a1f59b..5463070 100644 --- a/dyn-scope-is-bad/semantics.rkt +++ b/dyn-scope-is-bad/semantics.rkt @@ -24,15 +24,12 @@ (define dvs (make-parameter (make-hasheq))) (define (store name v) - (hash-set! (dvs) (syntax->datum name) (box v))) + (hash-set! (dvs) name (box v))) (define (internal-fetch name) - (hash-ref (dvs) (syntax->datum name) + (hash-ref (dvs) name (lambda () - (raise-syntax-error - (syntax->datum name) - "unbound identifier" - name)))) + (error name "undefined")))) (define (update name v) (define loc (internal-fetch name)) @@ -46,12 +43,12 @@ (syntax-parse stx [(_ var:id rhs:expr) #'(let ([tmp rhs]) - (store #'var tmp))])) + (store 'var tmp))])) (define-syntax (deffun stx) (syntax-parse stx [(_ (fname:id arg:id ...) body:expr ...+) - #'(store #'fname + #'(store 'fname (dyn-λ (arg ...) body ...))])) (define-syntax (dyn-λ stx) @@ -60,7 +57,7 @@ (with-syntax ([(tmp-arg ...) (generate-temporaries #'(arg ...))]) #'(lambda (tmp-arg ...) - (store #'arg tmp-arg) + (store 'arg tmp-arg) ... body ...))])) @@ -72,15 +69,15 @@ (define-syntax (dyn-set! stx) (syntax-parse stx ([_ var:id val:expr] - #'(update #'var val)))) + #'(update 'var val)))) (provide (rename-out [handle-id #%top])) (define-syntax (handle-id stx) (syntax-case stx () - [(_ . any) + [(_ . var) (with-syntax ([stx stx]) - #'(fetch #'any))])) + #'(fetch 'var))])) (define-syntax (dyn-app stx) (syntax-parse stx diff --git a/dyn-scope-is-bad/tests/all.rkt b/dyn-scope-is-bad/tests/all.rkt index d396fa4..9f20a94 100644 --- a/dyn-scope-is-bad/tests/all.rkt +++ b/dyn-scope-is-bad/tests/all.rkt @@ -54,3 +54,13 @@ (+ (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)) + "") From e4acf8da2903b77809b9f82c4a1e75e4901e7829 Mon Sep 17 00:00:00 2001 From: "Lu, Kuang-Chen" Date: Thu, 18 Aug 2022 00:49:00 -0400 Subject: [PATCH 5/5] implement deffun with defvar --- dyn-scope-is-bad/semantics.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dyn-scope-is-bad/semantics.rkt b/dyn-scope-is-bad/semantics.rkt index 5463070..edff10f 100644 --- a/dyn-scope-is-bad/semantics.rkt +++ b/dyn-scope-is-bad/semantics.rkt @@ -48,8 +48,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