diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8d663eb --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +/compiled/ diff --git a/envlang-rkt-for-test.rkt b/envlang-rkt-for-test.rkt new file mode 100644 index 0000000..396a68f --- /dev/null +++ b/envlang-rkt-for-test.rkt @@ -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))) \ No newline at end of file diff --git a/envlang-rkt.rkt b/envlang-rkt.rkt new file mode 100644 index 0000000..fcc11c2 --- /dev/null +++ b/envlang-rkt.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(except-in "envlang-rkt-for-test.rkt" check) \ No newline at end of file diff --git a/envlang.rkt b/envlang.rkt index 6ec6d83..2e4bdfc 100644 --- a/envlang.rkt +++ b/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 - - - - - - - - - diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..1548dfd --- /dev/null +++ b/info.rkt @@ -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|)) diff --git a/racket-utils.rkt b/racket-utils.rkt new file mode 100644 index 0000000..cbf5bd8 --- /dev/null +++ b/racket-utils.rkt @@ -0,0 +1,6 @@ +#lang racket + +(provide make-racket-proc) + +(define (make-racket-proc f env) + (λ args (f env args))) \ No newline at end of file diff --git a/test-rkt.rkt b/test-rkt.rkt new file mode 100644 index 0000000..899113d --- /dev/null +++ b/test-rkt.rkt @@ -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)) \ No newline at end of file