envlang-rkt-for-test.rkt (7089B)
1 #lang racket 2 3 (require racket/provide 4 phc-toolkit/untyped/syntax-parse 5 (for-syntax syntax/parse 6 phc-toolkit/untyped/stx)) 7 8 (provide 9 (rename-out [check-for-test check]) 10 (filtered-out 11 (λ (name) (substring name 1)) 12 (combine-out -#%datum -#%top -#%app -#%module-begin -#%top-interaction -env -.. -@ -\\ -ffi #;-require/ffi -list -delay -force -closure -begin))) 13 14 (define-syntax-rule (-begin . rest) (begin . rest)) 15 16 ;; Printable procedure 17 (struct pproc (proc repr) 18 #:property prop:procedure (struct-field-index proc) 19 #:methods gen:custom-write 20 [(define write-proc (λ (v port mode) 21 (match mode 22 [#t (display "#;pproc:" port) (write (pproc-repr v) port)] 23 [#f (display "#;pproc:" port) (display (pproc-repr v) port)] 24 [_ (display "#;pproc:" port) (print (pproc-repr v) port 1)])))]) 25 26 (define-for-syntax (ds stx symbol) (datum->syntax stx symbol stx stx)) 27 (define-syntax-rule (quasisyntax/top-loc loc stx) #`stx) 28 29 (define -promise-e 30 (pproc (λ (.env x) (match (pproc-repr x) [`(\\ ,cl env arg ,body) body])) 31 'promise-e)) 32 33 (define -envlang->racket 34 (pproc (λ (.env args) 35 (parameterize ([envparam .env]) 36 (let* ([forced-args (map (curry -force (envparam)) (-force (envparam) args))] 37 [f (car forced-args)] 38 [captured-env (cadr forced-args)]) 39 (λ args (f captured-env args))))) 40 'envlang->racket)) 41 42 (define/contract (env-guard new-env) 43 (-> hash? hash?) 44 (begin #;(println new-env) new-env)) 45 (define closureparam 46 (make-parameter #hash() 47 env-guard)) 48 (define envparam 49 (make-parameter 50 `#hash(["#%datum" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) 51 (match (-force (envparam) args) [(list arg) (force arg)]))) 52 '#%datum)] 53 ["λ" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) 54 (match (-force (envparam) args) 55 [(list arg-name-thunk body-thunk) 56 (define arg-name (-promise-e (envparam) arg-name-thunk)) 57 (define body (-promise-e (envparam) body-thunk)) 58 (let ([saved-env (envparam)]) 59 (pproc (λ (.env args) 60 (parameterize ([envparam saved-env]) 61 (parameterize ([envparam (hash-set (envparam) 62 (symbol->string arg-name) 63 (map (curry -force (envparam)) (-force (envparam) args)))]) 64 (-@ body-thunk (envparam) args)))) 65 `(λ ,arg-name ,body)))]))) 66 'λ)] 67 ["debug" . ,(pproc (λ (.env arg) 68 (parameterize ([envparam .env]) 69 (displayln (list (envparam) arg)) 70 (displayln (-force (envparam) arg)) 71 '())) 72 'debug)] 73 ["symbol->string" . ,(-ffi racket symbol->string)] 74 ["envlang->racket" . ,-envlang->racket] 75 ["hash-set" . ,(-ffi racket hash-set)] 76 ["hash-ref" . ,(-ffi racket hash-ref)] 77 ["car" . ,(-ffi racket car)] 78 ["cdr" . ,(-ffi racket cdr)] 79 ["map" . ,(-ffi racket map)] 80 ["empty-hash" . #hash()] 81 ["promise-e" . ,-promise-e]) 82 env-guard)) 83 84 (define-syntax-rule (-delay x) 85 (pproc (λ (.env arg) 86 (parameterize ([envparam .env]) 87 x)) 88 `(\\ #hash() env arg x))) 89 90 (define (-force .env x) (parameterize ([envparam .env]) (x (envparam) '()))) 91 (define-syntax (-env stx) (syntax-case stx () [-env (identifier? #'-env) #'(envparam)])) 92 (define-syntax (-closure stx) (syntax-case stx () [-closure (identifier? #'-closure) #'(closureparam)])) 93 94 (define (-@ f .env args) (parameterize ([envparam .env]) (f (envparam) args))) 95 (define-syntax/parse (-\\ cl {~and env-stx {~datum env}} {~and args {~datum args}} body) 96 #`(let ([saved-cl cl]) 97 (pproc (λ (e args) (parameterize ([envparam e] [closureparam saved-cl]) body)) 98 `(\\ ,saved-cl env-stx args body)))) 99 (define-syntax/parse (-ffi lib f) 100 (quasisyntax/top-loc stx 101 (pproc (λ (.env args) 102 (parameterize ([envparam .env]) 103 (apply (let () (local-require (only-in lib f)) f) 104 (map (curry -force (envparam)) (-force (envparam) args))))) 105 '(ffi lib f)))) 106 (define-syntax/parse (-require/ffi lib f ...) 107 (quasisyntax/top-loc stx 108 (begin (define f (-ffi lib f)) 109 ...))) 110 (define -.. hash-ref) 111 112 (define-syntax (-list stx) 113 (syntax-case stx () 114 [(-list . args) #'(#%app list . args)] 115 [-list (identifier? #'-list) #'(pproc (λ (.env args) 116 (parameterize ([envparam .env]) 117 (apply (let () (local-require (only-in racket list)) list) 118 (map (curry -force (envparam)) (-force (envparam) args))))) 119 '(ffi racket list f))])) 120 121 (define-syntax (-#%top stx) 122 (syntax-parse stx 123 [(-#%top . var) (quasisyntax/top-loc stx (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'var))))])) 124 125 (define (debug) 126 (displayln "lalal") 127 (displayln (closureparam)) 128 (displayln (envparam)) 129 (displayln "")) 130 131 (define-syntax (-#%app stx) 132 (syntax-parse stx 133 [(-#%app {~and @ {~datum @}} f env-expr args) (quasisyntax/top-loc stx (#%app -@ f env-expr args))] 134 [(-#%app f arg ...) (quasisyntax/top-loc stx (-#%app @ (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'envlang#%app))) (#%app envparam) (-delay (-list (-delay f) (-delay arg) ...))))])) 135 136 (define-syntax/parse (-#%datum . d) (quasisyntax/top-loc stx (#%app -@ (-#%top . #%datum) (#%app envparam) (-delay (#%datum d))))) 137 (define-syntax-rule (-#%module-begin . body) (#%module-begin . body)) 138 (define-syntax-rule (-#%top-interaction . body) (#%top-interaction . body)) 139 140 (require rackunit) 141 (define-syntax/parse (check-for-test expected-pattern actual) 142 (quasisyntax/top-loc 143 stx 144 (check-pred (match-lambda 145 [#,(datum->syntax #'here (syntax->datum #'expected-pattern)) 146 #t]) 147 actual)))