tiny.rkt (6655B)
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 -begin -@ -⧵ -env -captured -args -× -#%app -#%module-begin -#%top-interaction))) ; -#%datum -#%top -.. -⧵ -ffi -require/ffi -delay -force -inspect-promise-root 13 14 ;(define cons (gensym 'cons)) 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 (write (pproc-repr v) port)] 23 [#f (display (pproc-repr v) port)] 24 [_ (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 (init-env-1 bit-0 bit-1 null-bits cons-bits null-bytes cons-bytes cons-k-v env-null env-push env-ref) 30 '…) 31 32 (define init-env 33 (λ (env bit-0) 34 (λ (env bit-1) 35 (λ (env null-bits) 36 (λ (env cons-bits) 37 (λ (env null-bytes) 38 (λ (env cons-bytes) 39 (λ (env cons-k-v) 40 (λ (env env-null) 41 (λ (env env-push) 42 (λ (env env-ref) 43 (init-env-1 bit-0 bit-1 null-bits cons-bits null-bytes cons-bytes cons-k-v env-null env-push env-ref)))))))))))) 44 45 (define capturedparam (make-parameter #f)) 46 (define envparam (make-parameter init-env)) 47 (define argsparam (make-parameter #f)) 48 49 (define-syntax-rule (-begin . rest) (begin . rest)) 50 51 ;; our calculus can only capture one value at a time, the others are supplied by the caller (env 52 (define -× 53 (pproc (λ (a b) 54 (pproc (λ (env args) 55 ((args env a) env b)) 56 `(⧵ #f env args (@ (@ args env ,a) env ,b)))) 57 '×)) 58 59 #;(define envparam 60 (make-parameter 61 `#hash() 62 #;(["#%datum" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) 63 (match (-force (envparam) args) [(list arg) (force arg)]))) 64 '#%datum)] 65 ["λ" . ,(pproc (λ (.env args) (parameterize ([envparam .env]) 66 (match (-force (envparam) args) 67 [(list arg-name-thunk body-thunk) 68 (define arg-name (-inspect-promise-root (envparam) arg-name-thunk)) 69 (define body (-inspect-promise-root (envparam) body-thunk)) 70 (let ([saved-env (envparam)]) 71 (pproc (λ (.env args) 72 (parameterize ([envparam saved-env]) 73 (parameterize ([envparam (hash-set (envparam) 74 (symbol->string arg-name) 75 (map (curry -force (envparam)) (-force (envparam) args)))]) 76 (-@ body-thunk (envparam) args)))) 77 `(λ ,arg-name ,body)))]))) 78 'λ)] 79 ["debug" . ,(pproc (λ (.env arg) 80 (parameterize ([envparam .env]) 81 (displayln (list (envparam) arg)) 82 (displayln (-force (envparam) arg)) 83 '())) 84 'debug)]) 85 env-guard)) 86 87 (define-syntax-rule (-delay x) 88 (pproc (λ (.env arg) 89 (parameterize ([envparam .env]) 90 x)) 91 `(⧵ #hash() env arg x))) 92 93 (define (-force .env x) (parameterize ([envparam .env]) (x (envparam) '()))) 94 (define (-inspect-promise-root .env x) (match (pproc-repr x) [`(⧵ ,cl env arg ,body) body])) 95 96 (define-syntax (-env stx) (syntax-case stx () [-env (identifier? #'-env) #'(envparam)])) 97 (define-syntax (-captured stx) (syntax-case stx () [-captured (identifier? #'-captured) #'(capturedparam)])) 98 (define-syntax (-args stx) (syntax-case stx () [-args (identifier? #'-args) #'(argsparam)])) 99 100 (define (-@ f .env args) (parameterize ([envparam .env]) (f (envparam) args))) 101 (define-syntax/parse (-⧵ capture {~and env-stx {~datum env}} {~and args {~datum args}} body) 102 #`(let ([saved-capture capture]) 103 (pproc (λ (e args) (parameterize ([envparam e] [capturedparam saved-capture]) body)) 104 `(⧵ ,saved-capture env-stx args body)))) 105 (define-syntax/parse (-ffi lib f) 106 (quasisyntax/top-loc stx 107 (pproc (λ (.env args) 108 (parameterize ([envparam .env]) 109 (apply (let () (local-require (only-in lib f)) f) 110 (map (curry -force (envparam)) (-force (envparam) args))))) 111 '(ffi lib f)))) 112 (define-syntax/parse (-require/ffi lib f ...) 113 (quasisyntax/top-loc stx 114 (begin (define f (-ffi lib f)) 115 ...))) 116 (define -.. hash-ref) 117 118 (define-syntax (-#%top stx) 119 (syntax-parse stx 120 [(-#%top . var) (quasisyntax/top-loc stx (#%app -.. (#%app envparam) #,(symbol->string (syntax-e #'var))))])) 121 122 (define-syntax (-#%app stx) 123 (syntax-parse stx 124 [(-#%app {~and @ {~datum @}} #:debug dbg f env-expr args) (quasisyntax/top-loc stx (begin (#%app displayln (#%datum dbg)) (#%app -@ f env-expr args)))] 125 [(-#%app {~and @ {~datum @}} f env-expr args) (quasisyntax/top-loc stx (#%app -@ f env-expr args))] 126 ;[(-#%app f arg ...) (quasisyntax/top-loc stx (-#%app @ f (#%app envparam) (-delay (list (-delay arg) ...))))] 127 )) 128 129 (define-syntax/parse (-#%datum . d) (quasisyntax/top-loc stx (#%app -@ (-#%top . #%datum) (#%app envparam) (-delay (#%datum d))))) 130 (define-syntax-rule (-#%module-begin . body) (#%module-begin . body)) 131 (define-syntax-rule (-#%top-interaction . body) (#%top-interaction . body)) 132 133 (require rackunit) 134 (define-syntax/parse (check-for-test expected-pattern actual) 135 (quasisyntax/top-loc 136 stx 137 (check-pred (match-lambda 138 [#,(datum->syntax #'here (syntax->datum #'expected-pattern)) 139 #t]) 140 actual)))