test-rkt.rkt (6068B)
1 #lang s-exp "envlang-rkt-for-test.rkt" 2 3 (require/ffi racket list map car cdr + hash-ref hash-set hash symbol->string) 4 (check (? (curry equal? (envparam))) env) 5 (check '0 6 0) 7 (check '(1 2) 8 (list 1 2)) 9 (check '3 10 (+ 1 2)) 11 (check '4 12 (@ (ffi racket *) env (delay (list (delay 2) (delay 2))))) 13 (check '5 14 (@ (\\ env env args 5) env (delay (list (delay 2) (delay 2))))) 15 (check (hash-table) 16 (@ (\\ env env args env) #hash() (delay (list (delay 2) (delay 2))))) 17 (check (app pproc-repr `(\\ ,(hash-table) env arg (list (delay 2) (delay 2)))) 18 (@ (\\ env env args args) env (delay (list (delay 2) (delay 2))))) 19 (check (list (app pproc-repr `(\\ ,(hash-table) env arg 2)) (app pproc-repr `(\\ ,(hash-table) env arg 2))) 20 (@ force env (delay (list (delay 2) (delay 2))))) 21 (check (list (app pproc-repr `(\\ ,(hash-table) env arg 2)) (app pproc-repr `(\\ ,(hash-table) env arg 2))) 22 (@ (\\ env env args (@ force env args)) env (delay (list (delay 2) (delay 2))))) 23 (check (app pproc-repr '(ffi racket +)) 24 +) 25 (check (app pproc-repr '(ffi racket *)) 26 (ffi racket *)) 27 (check (app pproc-repr '#%datum) 28 (hash-ref env "#%datum")) 29 (check (app pproc-repr '(λ x 1)) 30 (λ x 1)) 31 (check (? (λ (h) (hash-has-key? h "x"))) 32 ((λ x env) 2)) 33 (check '2 34 ((λ xs (car xs)) 2)) 35 (check '3 36 (((λ xs (λ xs (car xs))) 2) 3)) 37 (check '(3) 38 (((λ xs (λ xs xs)) 2) 3)) 39 (check '(3) 40 (((λ xs (λ ys ys)) 2) 3)) 41 (check '(2) 42 (((λ xs (λ ys xs)) 2) 3)) 43 44 45 #;(λ (.env args) (parameterize ([envparam .env]) 46 (match (-force (envparam) args) 47 [(list arg-name-thunk body-thunk) 48 (define arg-name (-inspect-promise-root (envparam) arg-name-thunk)) 49 (define body (-inspect-promise-root (envparam) body-thunk)) 50 (let ([saved-env (envparam)]) 51 (pproc (λ (.env args) 52 (parameterize ([envparam saved-env]) 53 (parameterize ([envparam (hash-set (envparam) 54 (symbol->string arg-name) 55 (map (curry -force (envparam)) (-force (envparam) args)))]) 56 (-@ body-thunk (envparam) args)))) 57 `(λ ,arg-name ,body)))]))) 58 59 (check '2 60 ((ffi racket procedure-arity) (\\ #hash() env args args))) 61 (require/ffi "racket-utils.rkt" make-racket-proc) 62 (check (? (curry equal? (arity-at-least 0))) 63 ((ffi racket procedure-arity) (make-racket-proc (\\ #hash() env args args) env))) 64 65 ((\\ #hash() env args 66 (@ force env args)) 67 x 1) 68 69 ((\\ #hash() env args 70 (map (make-racket-proc (\\ #hash() env args 71 (car args)) 72 env) 73 (@ force env args))) 74 x 1) 75 76 ((\\ #hash() env args 77 (@ inspect-promise-root env (car (@ force env args)))) 78 x 1) 79 80 ((\\ #hash() env args 81 (car (cdr (@ force env args)))) 82 x 1) 83 84 ((\\ #hash() env args 85 (car (cdr (@ force env args)))) 86 x x) 87 88 (\\ #hash(("a" . 1)) env args closure) 89 ((\\ #hash(("a" . 1)) env args closure) 2) 90 91 (\\ (hash "a" (+ 1 2)) env args closure) 92 ((\\ (hash "a" (+ 1 2)) env args closure) 2) 93 94 (((\\ #hash() env args 95 (\\ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args)))) 96 "body" (car (cdr (@ force env args)))) 97 env 98 args 99 (@ (hash-ref closure "body") 100 (hash-set env 101 (hash-ref closure "arg-name") 102 (map (make-racket-proc (\\ #hash() env args 103 (@ force env (car args))) 104 env) 105 (@ force env args))) 106 args))) 107 x 1) 108 2) 109 110 111 (@ (\\ #hash() env args 112 ((λλ x 1) 113 2)) 114 (hash-set env "λλ" (\\ #hash() env args 115 (\\ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args)))) 116 "body" (car (cdr (@ force env args)))) 117 env 118 args 119 (@ (hash-ref closure "body") 120 (hash-set env 121 (hash-ref closure "arg-name") 122 (map (make-racket-proc (\\ #hash() env args 123 (@ force env (car args))) 124 env) 125 (@ force env args))) 126 args)))) 127 (list)) 128 129 (@ (\\ #hash() env args 130 ((λλ x 1) 1) 131 #;(list (((λλ x (λλ x 1)) 1) 2) 132 (((λλ x (λλ x x)) 1) 2) 133 (((λλ x (λλ y y)) 1) 2) 134 (((λλ x (λλ y x)) 1) 2))) 135 (hash-set env "λλ" (\\ #hash() env args 136 (\\ (hash "arg-name" (symbol->string (@ inspect-promise-root env (car (@ force env args)))) 137 "body" (car (cdr (@ force env args))) 138 "saved-env" env) 139 env 140 args 141 (hash-ref closure "body") #;(@ (hash-ref closure "body") 142 (hash-set (hash-ref closure "saved-env") 143 (hash-ref closure "arg-name") 144 (map (make-racket-proc (\\ #hash() env args 145 (@ force env (car args))) 146 env) 147 (@ force env args))) 148 args)))) 149 (list))