User-defined lamnbda with a single (list) argument works.
This commit is contained in:
Suzanne Soy
parent
b2fbddcba0
commit
488d3afa75
2
.gitignore
vendored
Normal file
2
.gitignore
vendored
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
*~
|
||||
/compiled/
|
||||
109
envlang-rkt-for-test.rkt
Normal file
109
envlang-rkt-for-test.rkt
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
#lang racket
|
||||
|
||||
(require racket/provide
|
||||
phc-toolkit/untyped/syntax-parse
|
||||
(for-syntax syntax/parse
|
||||
phc-toolkit/untyped/stx))
|
||||
|
||||
(provide
|
||||
(rename-out [check-for-test check])
|
||||
(filtered-out
|
||||
(λ (name) (substring name 1))
|
||||
(combine-out -#%datum -#%top -#%app -#%module-begin -#%top-interaction -env -.. -@ -\\ -ffi -require/ffi -delay -force -inspect-promise-root -closure)))
|
||||
|
||||
;; Printable procedure
|
||||
(struct pproc (proc repr)
|
||||
#:property prop:procedure (struct-field-index proc)
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc (λ (v port mode)
|
||||
(match mode
|
||||
[#t (write (pproc-repr v) port)]
|
||||
[#f (display (pproc-repr v) port)]
|
||||
[_ (print (pproc-repr v) port 1)])))])
|
||||
|
||||
(define-for-syntax (ds stx symbol) (datum->syntax stx symbol stx stx))
|
||||
;(define-syntax-rule (quasisyntax/top-loc loc stx) #`stx)
|
||||
|
||||
(define/contract (env-guard new-env)
|
||||
(-> hash? hash?)
|
||||
(begin #;(println new-env) new-env))
|
||||
(define closureparam
|
||||
(make-parameter #hash()
|
||||
env-guard))
|
||||
(define envparam
|
||||
(make-parameter
|
||||
`#hash(["#%datum" . ,(pproc (λ (.env args) (parameterize ([envparam .env])
|
||||
(match (-force (envparam) args) [(list arg) (force arg)])))
|
||||
'#%datum)]
|
||||
["λ" . ,(pproc (λ (.env args) (parameterize ([envparam .env])
|
||||
(match (-force (envparam) args)
|
||||
[(list arg-name-thunk body-thunk)
|
||||
(define arg-name (-inspect-promise-root (envparam) arg-name-thunk))
|
||||
(define body (-inspect-promise-root (envparam) body-thunk))
|
||||
(let ([saved-env (envparam)])
|
||||
(pproc (λ (.env args)
|
||||
(parameterize ([envparam saved-env])
|
||||
(parameterize ([envparam (hash-set (envparam)
|
||||
(symbol->string arg-name)
|
||||
(map (curry -force (envparam)) (-force (envparam) args)))])
|
||||
(-@ body-thunk (envparam) args))))
|
||||
`(λ ,arg-name ,body)))])))
|
||||
'λ)]
|
||||
["debug" . ,(pproc (λ (.env arg)
|
||||
(parameterize ([envparam .env])
|
||||
(displayln (list (envparam) arg))
|
||||
(displayln (-force (envparam) arg))
|
||||
'()))
|
||||
'debug)])
|
||||
env-guard))
|
||||
|
||||
(define-syntax-rule (-delay x)
|
||||
(pproc (λ (.env arg)
|
||||
(parameterize ([envparam .env])
|
||||
x))
|
||||
`(\\ #hash() env arg x)))
|
||||
|
||||
(define (-force .env x) (parameterize ([envparam .env]) (x (envparam) '())))
|
||||
(define (-inspect-promise-root .env x) (match (pproc-repr x) [`(\\ ,cl env arg ,body) body]))
|
||||
(define-syntax (-env stx) (syntax-case stx () [-env (identifier? #'-env) #'(envparam)]))
|
||||
(define-syntax (-closure stx) (syntax-case stx () [-closure (identifier? #'-closure) #'(closureparam)]))
|
||||
|
||||
(define (-@ f .env args) (parameterize ([envparam .env]) (f (envparam) args)))
|
||||
(define-syntax/parse (-\\ cl {~and env-stx {~datum env}} {~and args {~datum args}} body)
|
||||
#`(let ([saved-cl cl])
|
||||
(pproc (λ (e args) (parameterize ([envparam e] [closureparam saved-cl]) body))
|
||||
`(\\ ,saved-cl env-stx args body))))
|
||||
(define-syntax/parse (-ffi lib f)
|
||||
(quasisyntax/top-loc stx
|
||||
(pproc (λ (.env args)
|
||||
(parameterize ([envparam .env])
|
||||
(apply (let () (local-require (only-in lib f)) f)
|
||||
(map (curry -force (envparam)) (-force (envparam) args)))))
|
||||
'(ffi lib f))))
|
||||
(define-syntax/parse (-require/ffi lib f ...)
|
||||
(quasisyntax/top-loc stx
|
||||
(begin (define f (-ffi lib f))
|
||||
...)))
|
||||
(define -.. hash-ref)
|
||||
|
||||
(define-syntax (-#%top stx)
|
||||
(syntax-parse stx
|
||||
[(-#%top . var) (quasisyntax/top-loc stx (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'var))))]))
|
||||
|
||||
(define-syntax (-#%app stx)
|
||||
(syntax-parse stx
|
||||
[(-#%app {~and @ {~datum @}} f env-expr args) (quasisyntax/top-loc stx (#%app -@ f env-expr args))]
|
||||
[(-#%app f arg ...) (quasisyntax/top-loc stx (-#%app @ f (#%app envparam) (-delay (list (-delay arg) ...))))]))
|
||||
|
||||
(define-syntax/parse (-#%datum . d) (quasisyntax/top-loc stx (#%app -@ (-#%top . #%datum) (#%app envparam) (-delay (#%datum d)))))
|
||||
(define-syntax-rule (-#%module-begin . body) (#%module-begin . body))
|
||||
(define-syntax-rule (-#%top-interaction . body) (#%top-interaction . body))
|
||||
|
||||
(require rackunit)
|
||||
(define-syntax/parse (check-for-test expected-pattern actual)
|
||||
(quasisyntax/top-loc
|
||||
stx
|
||||
(check-pred (match-lambda
|
||||
[#,(datum->syntax #'here (syntax->datum #'expected-pattern))
|
||||
#t])
|
||||
actual)))
|
||||
2
envlang-rkt.rkt
Normal file
2
envlang-rkt.rkt
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#lang reprovide
|
||||
(except-in "envlang-rkt-for-test.rkt" check)
|
||||
282
envlang.rkt
282
envlang.rkt
|
|
@ -1,4 +1,177 @@
|
|||
#lang racket
|
||||
(define-syntax-rule (matches? pat ...) (match-lambda [pat #t] ... [else #f]))
|
||||
(define ((procedure/arity? a) p) (and (procedure? p) (procedure-arity-includes? p a)))
|
||||
(define v? (matches? `(\\ env χ ,_) (? hash?) (? string?) (? number?) `(ffi ,(? (procedure/arity? 3)))))
|
||||
(define e-not-v? (matches? `(@ ,e-f ,e-env ,e-arg) `(thunk ,e) 'env 'χ (? symbol?)))
|
||||
|
||||
(define (eval debug? env+χ+redex+k-frames)
|
||||
(when debug? (println (third env+χ+redex+k-frames)))
|
||||
(define (r debug env+χ+redex+k-frames) (when debug? (displayln debug)) (eval debug? env+χ+redex+k-frames))
|
||||
(match env+χ+redex+k-frames
|
||||
[`{,E ,X ,(? v? v) ()}
|
||||
v]
|
||||
;; Primitive application
|
||||
[ `{,E ,X (@ (\\ env χ ,e) ,(? v? v-env) (\\ env χ ,e-arg)) ,… }
|
||||
(r "APP" `{,v-env (\\ env χ ,e-arg) ,e ,… })]
|
||||
[ `{,E ,X (@ (ffi ,f) ,(? v? v-env) (\\ env χ ,e-arg)) ,… }
|
||||
(r "FFI" `{,E ,X ,(f r v-env `(\\ env χ ,e-arg)) ,… })]
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
;; Evaluation of sub-parts of an application
|
||||
[ `{,E ,X (@ ,(? e-not-v? e-f) ,e-env ,e-arg) ,… }
|
||||
(r "@-F" `{,E ,X ,e-f ((,E ,X (@ _ ,e-env ,e-arg)) . ,…)})]
|
||||
[ `{,E ,X (@ ,(? v? v-f) ,(? e-not-v? e-env) ,e-arg) ,… }
|
||||
(r "@-ENV" `{,E ,X ,e-env ((,E ,X (@ ,v-f _ ,e-arg)) . ,…)})]
|
||||
[ `{,E ,X (@ ,(? v? v-f) ,(? v? v-env) ,(? e-not-v? e-arg)) ,… }
|
||||
(r "@-ARG" `{,E ,X ,e-arg ((,E ,X (@ ,v-f ,v-env _ )) . ,…)})]
|
||||
|
||||
[ `{,E ,X ,(? v? v-f) ((,E′ ,X′ (@ _ ,e-env ,e-arg)) . ,…)}
|
||||
(r "K-F" `{,E′ ,X′ (@ ,v-f ,e-env ,e-arg) ,… })]
|
||||
[ `{,E ,X ,(? v? v-env) ((,E′ ,X′ (@ ,v-f _ ,e-arg)) . ,…)}
|
||||
(r "K-ENV" `{,E′ ,X′ (@ ,v-f ,v-env ,e-arg) ,… })]
|
||||
[ `{,E ,X ,(? v? v-arg) ((,E′ ,X′ (@ ,v-f ,v-env _ )) . ,…)}
|
||||
(r "K-ARG" `{,E′ ,X′ (@ ,v-f ,v-env ,v-arg) ,… })]
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
;; Syntactic sugar
|
||||
;; insertion of #%app at the front of all parentheses that don't start with an @ or \ or ffi or thunk or #%app
|
||||
[ `{,E ,X (,(and (not '@ '\\ 'ffi 'thunk '#%app) e-f) ,e-arg) ,… }
|
||||
(r "#%app" `{,E ,X (#%app ,e-f ,e-arg) ,… })]
|
||||
[ `{,E ,X (#%app ,e-f ,e-arg) ,… }
|
||||
(r "@%app" `{,E ,X (@ (@ (@ #%get env (\\ env χ "#%app"))
|
||||
env (\\ env χ ,e-f))
|
||||
env (\\ env χ ,e-arg)) ,… })]
|
||||
[ `{,E ,X (λ ,var-name ,e) ,… }
|
||||
(r "LAM" `{,E ,X (#%app (#%app λ ,var-name) ,e) ,… })]
|
||||
[ `{,E ,X (thunk ,e) ,… }
|
||||
(r "THUNK" `{,E ,X (\\ env χ (@ (\\ env χ ,e) env ,X)) ,… })]
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
;; Built-ins and variables
|
||||
[ `{,E ,X env ,… }
|
||||
(r "VAR" `{,E ,X ,E ,… })]
|
||||
[ `{,E ,X χ ,… }
|
||||
(r "VAR" `{,E ,X ,X ,… })]
|
||||
[ `{,E ,X #%get ,… }
|
||||
(r "VAR" `{,E ,X ,(car (hash-ref E "#%get")) ,… })]
|
||||
[ `{,E ,X ,(? symbol? var-name) ,… }
|
||||
(r "VAR" `{,E ,X (@ #%get env (\\ env χ ,(symbol->string var-name))) ,… })]
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
[other
|
||||
`(stuck . ,other)]))
|
||||
|
||||
(define unit '(\\ env χ χ))
|
||||
(define (#%force eval env t) (eval "FFI:FORCE" `{,env ,unit (@ ,t ,env ,unit) ()}))
|
||||
(define (#%get eval env χ) (car (hash-ref env (#%force eval env χ))))
|
||||
(define (#%push ev1 env1 χ) `(ffi ,(λ (ev2 env2 v) (hash-update env1 (#%force ev1 env1 χ) (λ (vs) (cons (#%force ev2 env2 v) vs)) '()))))
|
||||
(define (#%drop eval env χ) (hash-update env (#%force eval env χ) (λ (vs) (cdr vs))))
|
||||
(define (-#%app ev1 env1 f) `(ffi ,(λ (ev2 env2 a) `(@ ,(#%force ev1 env1 f) env (\\ env χ ,(#%force ev2 env2 a))))))
|
||||
(define (#%lam ev1 env1 a) `(ffi ,(λ (ev2 env2 e)
|
||||
(let ([astr (match ([`(\\ env χ (? symbol? a)) (symbol->string a)]))])
|
||||
`(@ capture
|
||||
env
|
||||
(\ env χ (@ (\ env χ ,e)
|
||||
(@ (@ #%push env ,astr) env χ)
|
||||
χ)))))))
|
||||
(define (#%capture eval E f) `(\ env χ (@ ,f ,E χ)))
|
||||
(define-syntax-rule (ffis f ...) (make-hash (list (cons (symbol->string 'f) `((ffi ,f))) ...)))
|
||||
(define initial-env
|
||||
(let ([#%app -#%app]) (ffis #%force #%get #%push #%drop #%app)))
|
||||
|
||||
|
||||
|
||||
(define e-or-v? (or? e-not-v? v?))
|
||||
|
||||
|
||||
(require rackunit predicates)
|
||||
(define (ev e [debug? #f]) (eval debug? `(,initial-env (\\ env χ "argv") ,e ())))
|
||||
|
||||
(check-pred v? '(\\ env χ 1))
|
||||
(check-pred v? '(\\ env χ (\\ env χ 1)))
|
||||
(check-pred v? #hash())
|
||||
(check-pred v? initial-env)
|
||||
(check-pred v? "foo")
|
||||
(check-pred v? 1)
|
||||
(check-pred v? `(ffi ,(lambda (eval env χ) 42)))
|
||||
(check-pred v? `(ffi ,#%get))
|
||||
(check-pred v? `(ffi ,#%push))
|
||||
(check-pred v? `(ffi ,#%drop))
|
||||
(check-pred e-not-v? '(@ (\\ env χ 1) #hash() 2))
|
||||
(check-pred (not? v?) '(@ (\\ env χ 1) #hash() 2))
|
||||
(check-pred (not? e-not-v?) '(\\ env χ 1))
|
||||
(check-pred (not? e-not-v?) '(\\ env χ (\\ env χ 1)))
|
||||
(check-pred (not? e-not-v?) #hash())
|
||||
(check-pred (not? e-not-v?) "foo")
|
||||
(check-pred (not? e-not-v?) 1)
|
||||
(check-pred (not? e-not-v?) `(ffi ,(lambda (env χ) 42)))
|
||||
(check-pred e-or-v? '(\\ env χ 1))
|
||||
(check-pred e-or-v? '(\\ env χ (\\ env χ 1)))
|
||||
(check-pred e-or-v? #hash())
|
||||
(check-pred e-or-v? "foo")
|
||||
(check-pred e-or-v? 1)
|
||||
(check-pred e-or-v? `(ffi ,(lambda (eval env χ) 42)))
|
||||
(check-pred e-or-v? '(@ (\\ env χ 1) #hash() 2))
|
||||
|
||||
(check-equal? (ev '(\\ env χ 1)) '(\\ env χ 1))
|
||||
(check-equal? (ev #hash()) #hash())
|
||||
(check-equal? (ev "foo") "foo")
|
||||
(check-equal? (ev 1) 1)
|
||||
(let ([example-ffi `(ffi ,(lambda (eval env χ) 42))])
|
||||
(check-equal? (ev example-ffi) example-ffi))
|
||||
(check-equal? (ev `(ffi ,#%get)) `(ffi ,#%get))
|
||||
(check-equal? (ev `(ffi ,#%push)) `(ffi ,#%push))
|
||||
(check-equal? (ev `(ffi ,#%drop)) `(ffi ,#%drop))
|
||||
(check-equal? (ev '#%get) `(ffi ,#%get))
|
||||
(check-equal? (ev '#%push) `(ffi ,#%push))
|
||||
(check-equal? (ev '#%drop) `(ffi ,#%drop))
|
||||
;; TODO: test #%get, #%push, pop, FFI
|
||||
(check-equal? (ev '(@ (\\ env χ 1) #hash() (\\ env χ 2))) 1)
|
||||
(check-equal? (ev '(@ (\\ env χ 1) env (\\ env χ 2))) 1)
|
||||
(check-equal? (ev 'env) initial-env)
|
||||
(check-equal? (ev 'χ) '(\\ env χ "argv"))
|
||||
(check-equal? (ev '(@ #%force env χ)) '"argv")
|
||||
(check-equal? (ev '(@ (\\ env χ 1) env (\\ env χ 2))) 1)
|
||||
(check-equal? (ev '(@ (\\ env χ #%get) env (\\ env χ χ))) `(ffi ,#%get))
|
||||
(check-equal? (ev '(@ (\\ env χ #%push) env (\\ env χ χ))) `(ffi ,#%push))
|
||||
(check-equal? (ev '(@ (\\ env χ #%drop) env (\\ env χ χ))) `(ffi ,#%drop))
|
||||
(check-equal? (ev '(@ #%force env (\\ env χ χ))) unit)
|
||||
(check-equal? (ev '(@ #%force env (\\ env χ 42))) 42)
|
||||
(check-equal? (ev '(@ #%force env (\\ env χ (\\ env χ χ)))) '(\\ env χ χ))
|
||||
(check-equal? (ev '(thunk χ)) '(\\ env χ (@ (\\ env χ χ) env (\\ env χ "argv"))))
|
||||
(check-equal? (ev '(@ #%force env (thunk (@ #%force env χ)))) "argv")
|
||||
(check-equal? (ev '(@ #%force env (thunk 3))) 3)
|
||||
(check-equal? (ev '(#%force 3)) 3)
|
||||
|
||||
|
||||
|
||||
|
||||
#;(
|
||||
;; Primitive application
|
||||
;; defaults to:
|
||||
=> env=[E], χ=X (@ e-f env (\ env χ e-arg)) …
|
||||
|
||||
;; In particular, the sugared λ is just a function
|
||||
;; defaults to:
|
||||
=> env=[E], χ=X (@ capture
|
||||
env
|
||||
(\ env χ (@ (\ env χ e)
|
||||
(@ (@ #%push env "var-name") env χ)
|
||||
χ)))
|
||||
|
||||
CAPTURE env=[E], χ=X (@ capture v-env (\ env χ e)) …
|
||||
=> env=[E], χ=X (\ env χ (@ (λ env χ e) v-env χ)) …
|
||||
|
||||
FORCE env=[E], χ=(\ env χ e-arg) (@ #%force v-env (\ env χ e)) …
|
||||
=> env=[E], χ=() (@ (\ env χ e) v-env dummy) …
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#|
|
||||
;; Syntax of the language:
|
||||
|
|
@ -267,6 +440,8 @@ location of expr current-continuation
|
|||
CONTINUE-ARG [E] v-arg … E′,(v-f _) Optimization: [],(v-f _)
|
||||
=> [E′] (v-f v-arg) …
|
||||
|
||||
DEREFERENCE [E,x=v,E′] x …
|
||||
=> [E,x=v,E′] v …
|
||||
|
||||
;; Reduction example:
|
||||
env redex continuation frames rule to use
|
||||
|
|
@ -298,7 +473,7 @@ location of expr current-continuation
|
|||
|
||||
#;(
|
||||
;; Using first-class environments and lazy evaluations:
|
||||
;; λ, env, χ, get, push, drop are keywords
|
||||
;; λ, env, χ, get, push, #%drop are keywords
|
||||
;; v-env
|
||||
v ::= (\ env χ e) ;; open term, expects an env to close the term
|
||||
|| […] ;; mapping from names to values
|
||||
|
|
@ -308,7 +483,7 @@ location of expr current-continuation
|
|||
|| push
|
||||
|| pop
|
||||
e ::= v
|
||||
|| (@ e e e)
|
||||
|| (@ e-f e-env e-arg)
|
||||
|
||||
|
||||
TODO: instead of ad-hoc var-to-string conversion, use a functional env
|
||||
|
|
@ -318,80 +493,69 @@ TODO: instead of ad-hoc var-to-string conversion, use a functional env
|
|||
=> environment′ redex′ continuation frames′
|
||||
|
||||
;; Primitive application
|
||||
APP env=E, χ=X (@ (\ env χ e) v-env (\ env () e-arg)) …
|
||||
=> env=v-env,χ=(\ env () e-arg) e …
|
||||
APP env=[E], χ=X (@ (\ env χ e) v-env (\ env χ e-arg)) …
|
||||
=> env=v-env,χ=(\ env χ e-arg) e …
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
;; Evaluation of sub-parts of an application
|
||||
APP-F env=E, χ=X (@ e-f e-env e-arg) …
|
||||
=> env=E, χ=X e-f … [env=E,χ=X],(@ _ e-env e-arg)
|
||||
APP-F env=[E], χ=X (@ e-f e-env e-arg) …
|
||||
=> env=[E], χ=X e-f … env=[E],χ=X,(@ _ e-env e-arg)
|
||||
|
||||
APP-ENV env=E, χ=X (@ e-f e-env e-arg) …
|
||||
=> env=E, χ=X e-env … [env=E,χ=X],(@ v-f _ e-arg)
|
||||
APP-ENV env=[E], χ=X (@ v-f e-env e-arg) …
|
||||
=> env=[E], χ=X e-env … env=[E],χ=X,(@ v-f _ e-arg)
|
||||
|
||||
APP-ARG env=[E], χ=X (@ v-f v-env e-arg) …
|
||||
=> env=[E], χ=X e-arg … env=[E],χ=X,(@ v-f v-env _ )
|
||||
|
||||
CONTINUE-F env=[E], χ=X v-f … E′,χ=X′,(_ e-env e-arg)
|
||||
=> env=[E′], χ=X′ (@ v-f e-env e-arg) …
|
||||
|
||||
CONTINUE-ENV env=[E], χ=X v-env … E′,χ=X′,(v-f _ e-arg)
|
||||
=> env=[E′], χ=X′ (@ v-f v-env e-arg) …
|
||||
|
||||
CONTINUE-ARG env=[E], χ=X v-arg … E′,χ=X′,(v-f v-env _ )
|
||||
=> env=[E′], χ=X′ (@ v-f v-env v-arg) …
|
||||
|
||||
APP-ARG env=E, χ=X (@ e-f e-env e-arg) …
|
||||
=> env=E, χ=X e-arg … [env=E,χ=X],(@ v-f v-env _ )
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
;; Syntactic sugar (insertion of #%app)
|
||||
SUGAR-APP env=E, χ=X (#%app e-f e-arg ) …
|
||||
=> env=E′, χ=X (@ (@ (get env "#%app")
|
||||
;; Syntactic sugar
|
||||
|
||||
;; insertion of #%app at the front of all parentheses that don't start with an @ or \ or #%app
|
||||
SUGAR-APP env=[E], χ=X ( e-f e-arg ) …
|
||||
=> env=[E], χ=X (#%app e-f e-arg ) …
|
||||
=> env=[E], χ=X (@ (@ (@ get env (\ env χ "#%app"))
|
||||
env
|
||||
(\ env () e-f))
|
||||
(\ env χ e-f))
|
||||
env
|
||||
(\ env () e-arg)) …
|
||||
(\ env χ e-arg)) …
|
||||
;; defaults to:
|
||||
=> env=E′, χ=X (@ e-f env (\ env () e-arg)) …
|
||||
=> env=[E], χ=X (@ e-f env (\ env χ e-arg)) …
|
||||
|
||||
SUGAR-LAM env=E, χ=X (λ var-name e) …
|
||||
=> env=E′, χ=X (#%app (#%app λ var-name) e) …
|
||||
;; In particular, the sugared λ is just a function
|
||||
SUGAR-LAM env=[E], χ=X (λ var-name e) …
|
||||
=> env=[E], χ=X (#%app (#%app λ var-name) e) …
|
||||
;; defaults to:
|
||||
=> env=E′, χ=X (@ capture
|
||||
=> env=[E], χ=X (@ capture
|
||||
env
|
||||
(λ env χ (@ (λ env χ e)
|
||||
(add env "var-name" χ)
|
||||
(\ env χ (@ (\ env χ e)
|
||||
(@ (@ push env "var-name") env χ)
|
||||
χ)))
|
||||
|
||||
SUGAR-STR env=[E], χ=X "str" …
|
||||
=> env=[E], χ=X (#%datum "str") …
|
||||
|
||||
SUGAR-NUM env=[E], χ=X 0 …
|
||||
=> env=[E], χ=X (#%datum 0) …
|
||||
|
||||
SUGAR-VAR env=[E], χ=X var-name …
|
||||
=> env=[E], χ=X (get env var-name) …
|
||||
;;---------------------------------------------------------------------------------------------------------------------------
|
||||
CAPTURE env=E, χ=X (@ capture v-env (λ env χ e)) …
|
||||
=> env=E, χ=X (λ env χ (@ (λ env χ e) v-env χ)) …
|
||||
|
||||
FORCE env=E, χ=(λ env () e-arg) (@ force v-env (λ env χ e)) …
|
||||
=> env=E, χ=() TODO … [env=E,χ=(λ env () e-arg)],???
|
||||
|
||||
CONTINUE-F [E] v-f … E′,(_ e-arg)
|
||||
=> [E′] (v-f e-arg) …
|
||||
|
||||
CONTINUE-ARG [E] v-arg … E′,(v-f _) Optimization: [],(v-f _)
|
||||
=> [E′] (v-f v-arg) …
|
||||
CAPTURE env=[E], χ=X (@ capture v-env (\ env χ e)) …
|
||||
=> env=[E], χ=X (\ env χ (@ (λ env χ e) v-env χ)) …
|
||||
|
||||
FORCE env=[E], χ=(\ env χ e-arg) (@ #%force v-env (\ env χ e)) …
|
||||
=> env=[E], χ=() (@ (\ env χ e) v-env dummy) …
|
||||
)
|
||||
|
||||
|
||||
;; "x" ::= "x","y","z"… String
|
||||
;;
|
||||
;; v ::= (pλ -env e) promise: (unit) -> env -> α
|
||||
;; | (kλ -arg e) continuation: α -> void
|
||||
;; | (cλ -arg e) closure: (α -> β)
|
||||
;;
|
||||
;; e ::= (-λ -env -arg -k e) Abstraction (lambda) which takes
|
||||
;; * an environment always named -env (not in the -env)
|
||||
;; * a promise for an argument always named -arg (not in the -env)
|
||||
;; * a continuation always named -k (not in the -env)
|
||||
;; | (v e-env e-arg e-k) Tail call
|
||||
;; | (v e-env () e-k) Forcing a promise
|
||||
;; | (v () e-ret ()) Calling a continuation
|
||||
;; | -env the -env
|
||||
;; | -arg the -arg of the innermost lambda
|
||||
;; | -k the continuation of the innermost lambda
|
||||
;; | (-get e-env e-str) Get variable from environment
|
||||
;; | (-add e-env e-str e-val) Extend environment with new binding
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
8
info.rkt
Normal file
8
info.rkt
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#lang info
|
||||
(define collection "envlang")
|
||||
(define deps '("phc-toolkit"))
|
||||
(define build-deps '("reprovide-lang-lib"))
|
||||
(define scribblings '(("scribblings/envlang.scrbl" (multi-page))))
|
||||
(define pkg-desc "A language with first-class-environments")
|
||||
(define version "0.1")
|
||||
(define pkg-authors '(|Suzanne Soy|))
|
||||
6
racket-utils.rkt
Normal file
6
racket-utils.rkt
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#lang racket
|
||||
|
||||
(provide make-racket-proc)
|
||||
|
||||
(define (make-racket-proc f env)
|
||||
(λ args (f env args)))
|
||||
148
test-rkt.rkt
Normal file
148
test-rkt.rkt
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
#lang s-exp "envlang-rkt-for-test.rkt"
|
||||
|
||||
(require/ffi racket list map car cdr + hash-ref hash-set hash symbol->string)
|
||||
(check (? (curry equal? (envparam))) env)
|
||||
(check '0
|
||||
0)
|
||||
(check '(1 2)
|
||||
(list 1 2))
|
||||
(check '3
|
||||
(+ 1 2))
|
||||
(check '4
|
||||
(@ (ffi racket *) env (delay (list (delay 2) (delay 2)))))
|
||||
(check '5
|
||||
(@ (\\ env env args 5) env (delay (list (delay 2) (delay 2)))))
|
||||
(check (hash-table)
|
||||
(@ (\\ env env args env) #hash() (delay (list (delay 2) (delay 2)))))
|
||||
(check (app pproc-repr `(\\ ,(hash-table) env arg (list (delay 2) (delay 2))))
|
||||
(@ (\\ env env args args) env (delay (list (delay 2) (delay 2)))))
|
||||
(check (list (app pproc-repr `(\\ ,(hash-table) env arg 2)) (app pproc-repr `(\\ ,(hash-table) env arg 2)))
|
||||
(@ force env (delay (list (delay 2) (delay 2)))))
|
||||
(check (list (app pproc-repr `(\\ ,(hash-table) env arg 2)) (app pproc-repr `(\\ ,(hash-table) env arg 2)))
|
||||
(@ (\\ env env args (@ force env args)) env (delay (list (delay 2) (delay 2)))))
|
||||
(check (app pproc-repr '(ffi racket +))
|
||||
+)
|
||||
(check (app pproc-repr '(ffi racket *))
|
||||
(ffi racket *))
|
||||
(check (app pproc-repr '#%datum)
|
||||
(hash-ref env "#%datum"))
|
||||
(check (app pproc-repr '(λ x 1))
|
||||
(λ x 1))
|
||||
(check (? (λ (h) (hash-has-key? h "x")))
|
||||
((λ x env) 2))
|
||||
(check '2
|
||||
((λ xs (car xs)) 2))
|
||||
(check '3
|
||||
(((λ xs (λ xs (car xs))) 2) 3))
|
||||
(check '(3)
|
||||
(((λ xs (λ xs xs)) 2) 3))
|
||||
(check '(3)
|
||||
(((λ xs (λ ys ys)) 2) 3))
|
||||
(check '(2)
|
||||
(((λ xs (λ ys xs)) 2) 3))
|
||||
|
||||
|
||||
#;(λ (.env args) (parameterize ([envparam .env])
|
||||
(match (-force (envparam) args)
|
||||
[(list arg-name-thunk body-thunk)
|
||||
(define arg-name (-inspect-promise-root (envparam) arg-name-thunk))
|
||||
(define body (-inspect-promise-root (envparam) body-thunk))
|
||||
(let ([saved-env (envparam)])
|
||||
(pproc (λ (.env args)
|
||||
(parameterize ([envparam saved-env])
|
||||
(parameterize ([envparam (hash-set (envparam)
|
||||
(symbol->string arg-name)
|
||||
(map (curry -force (envparam)) (-force (envparam) args)))])
|
||||
(-@ body-thunk (envparam) args))))
|
||||
`(λ ,arg-name ,body)))])))
|
||||
|
||||
(check '2
|
||||
((ffi racket procedure-arity) (\\ #hash() env args args)))
|
||||
(require/ffi "racket-utils.rkt" make-racket-proc)
|
||||
(check (? (curry equal? (arity-at-least 0)))
|
||||
((ffi racket procedure-arity) (make-racket-proc (\\ #hash() env args args) env)))
|
||||
|
||||
((\\ #hash() env args
|
||||
(@ force env args))
|
||||
x 1)
|
||||
|
||||
((\\ #hash() env args
|
||||
(map (make-racket-proc (\\ #hash() env args
|
||||
(car args))
|
||||
env)
|
||||
(@ force env args)))
|
||||
x 1)
|
||||
|
||||
((\\ #hash() env args
|
||||
(@ inspect-promise-root env (car (@ force env args))))
|
||||
x 1)
|
||||
|
||||
((\\ #hash() env args
|
||||
(car (cdr (@ force env args))))
|
||||
x 1)
|
||||
|
||||
((\\ #hash() env args
|
||||
(car (cdr (@ force env args))))
|
||||
x x)
|
||||
|
||||
(\\ #hash(("a" . 1)) env args closure)
|
||||
((\\ #hash(("a" . 1)) env args closure) 2)
|
||||
|
||||
(\\ (hash "a" (+ 1 2)) env args closure)
|
||||
((\\ (hash "a" (+ 1 2)) env args closure) 2)
|
||||
|
||||
(((\\ #hash() env args
|
||||
(\\ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args))))
|
||||
"body" (car (cdr (@ force env args))))
|
||||
env
|
||||
args
|
||||
(@ (hash-ref closure "body")
|
||||
(hash-set env
|
||||
(hash-ref closure "arg-name")
|
||||
(map (make-racket-proc (\\ #hash() env args
|
||||
(@ force env (car args)))
|
||||
env)
|
||||
(@ force env args)))
|
||||
args)))
|
||||
x 1)
|
||||
2)
|
||||
|
||||
|
||||
(@ (\\ #hash() env args
|
||||
((λλ x 1)
|
||||
2))
|
||||
(hash-set env "λλ" (\\ #hash() env args
|
||||
(\\ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args))))
|
||||
"body" (car (cdr (@ force env args))))
|
||||
env
|
||||
args
|
||||
(@ (hash-ref closure "body")
|
||||
(hash-set env
|
||||
(hash-ref closure "arg-name")
|
||||
(map (make-racket-proc (\\ #hash() env args
|
||||
(@ force env (car args)))
|
||||
env)
|
||||
(@ force env args)))
|
||||
args))))
|
||||
(list))
|
||||
|
||||
(@ (\\ #hash() env args
|
||||
(list (((λλ x (λλ x 1)) 1) 2)
|
||||
(((λλ x (λλ x x)) 1) 2)
|
||||
(((λλ x (λλ y y)) 1) 2)
|
||||
(((λλ x (λλ y x)) 1) 2)))
|
||||
(hash-set env "λλ" (\\ #hash() env args
|
||||
(\\ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args))))
|
||||
"body" (car (cdr (@ force env args)))
|
||||
"saved-env" env)
|
||||
env
|
||||
args
|
||||
(@ (hash-ref closure "body")
|
||||
(hash-set (hash-ref closure "saved-env")
|
||||
(hash-ref closure "arg-name")
|
||||
(map (make-racket-proc (\\ #hash() env args
|
||||
(@ force env (car args)))
|
||||
env)
|
||||
(@ force env args)))
|
||||
args))))
|
||||
(list))
|
||||
Loading…
Reference in New Issue
Block a user