1#lang racket 2(require "letrec.rkt" redex/reduction-semantics 3 racket/linklet racket/runtime-path) 4 5#| 6 7Tests to see if the model in letrec.rkt 8produces the same results as racket itself 9 10|# 11 12(define (namespace-mapped-symbols.2 ns) 13 (for/list ([x (in-list (namespace-mapped-symbols ns))] 14 #:when (with-handlers ([exn:fail? (λ (x) #f)]) 15 (eval x ns))) 16 x)) 17 18(define ns (make-base-empty-namespace)) 19(module all-the-stuff racket/base 20 (provide + - * set! = #%top 21 let letrec if begin 22 #%app λ void #%datum 23 writeln)) 24(module all-the-stuff-lang racket/base 25 (require (submod ".." all-the-stuff) 26 (for-syntax racket/base)) 27 (provide (except-out (all-from-out (submod ".." all-the-stuff)) 28 #%top 29 set!) 30 (rename-out [module-begin #%module-begin] 31 [top #%top] 32 [-set! set!])) 33 (define-syntax (-set! stx) 34 (syntax-case stx () 35 [(_ id e) #'(#%expression (real-set! id e))])) 36 (define-syntax (real-set! stx) 37 (syntax-case stx () 38 [(_ id e) 39 (if (identifier-binding #'id) 40 #'(set! id e) 41 #'(let () e (error 'set! "free variable ~s" 'id)))])) 42 (define-syntax (module-begin stx) 43 (syntax-case stx () 44 [(_ e) #'(#%plain-module-begin 45 (define the-answer e) 46 (provide the-answer))])) 47 (define-syntax (top stx) 48 (syntax-case stx () 49 [(_ . x) #'(error 'free-variable "~s" 'x)]))) 50 51(define-runtime-path letrec-vs-racket.rkt "letrec-vs-racket.rkt") 52(require (only-in (submod "." all-the-stuff)) ;; bind nothing 53 (only-in (submod "." all-the-stuff-lang))) 54(namespace-attach-module (current-namespace) 55 `(submod (file ,(path->string letrec-vs-racket.rkt)) all-the-stuff) 56 ns) 57(parameterize ([current-namespace ns]) 58 (namespace-require `(submod (file ,(path->string letrec-vs-racket.rkt)) all-the-stuff))) 59(define originally-mapped-symbols (namespace-mapped-symbols.2 ns)) 60 61(define (same-as-racket? t) 62 (define cleaned-up (clean-up t)) 63 (define redex-result (redex-eval cleaned-up #:steps 100)) 64 (cond 65 [(or (equal? redex-result 'infinite-loop) 66 (equal? redex-result 'ran-out-of-steps)) 67 #t] 68 [else 69 (define racket-result (racket-eval cleaned-up)) 70 (define racket-module-result (racket-module-eval cleaned-up)) 71 (define newly-mapped-symbols (namespace-mapped-symbols.2 ns)) 72 (cond 73 [(not (equal? newly-mapped-symbols originally-mapped-symbols)) 74 (printf "set of symbols mapped in the namespace changed to:\n") 75 (pretty-write newly-mapped-symbols) 76 (printf "cleaned up:\n") 77 (pretty-write cleaned-up) 78 #f] 79 [(not (equal? redex-result racket-result)) 80 (printf "cleaned up:\n") 81 (pretty-write cleaned-up) 82 (printf "from redex:\n") 83 (pretty-write redex-result) 84 (printf "from racket at the top-level:\n") 85 (pretty-write racket-result) 86 #f] 87 [(not (equal? redex-result racket-module-result)) 88 (printf "cleaned up:\n") 89 (pretty-write cleaned-up) 90 (printf "from redex:\n") 91 (pretty-write redex-result) 92 (printf "from racket in a module:\n") 93 (pretty-write racket-module-result) 94 #f] 95 [else #t])])) 96 97(define v? (redex-match? lang v)) 98(define lam? (redex-match? lang (λ (x ...) e))) 99(define (redex-eval prog #:steps [steps #f]) 100 (define-values (result io) (result-and-output-of prog #:steps steps)) 101 (define normalized-result 102 (cond 103 [(or (lam? result) (member result '(* - + =))) 'procedure] 104 [(equal? result 'infinite-loop) result] 105 [(v? result) result] 106 [else 'error])) 107 (list normalized-result io)) 108 109;; e -> (list/c (or/c 'error value) (listof value)) 110(define (racket-eval prog) 111 (define sp (open-output-string)) 112 (define result 113 (with-handlers ([exn:fail? (λ (x) 'error)]) 114 (parameterize ([current-output-port sp]) 115 (eval prog ns)))) 116 (close-output-port sp) 117 (list (normalize-result result) (normalize-io sp))) 118 119;; e -> (list/c (or/c 'error value) (listof value)) 120(define racket-module-eval-name-counter 0) 121(define (racket-module-eval prog) 122 (define sp (open-output-string)) 123 (define modname 124 (string->symbol (~a "racket-module-eval-module-name-" racket-module-eval-name-counter))) 125 (set! racket-module-eval-name-counter (+ racket-module-eval-name-counter 1)) 126 (define result 127 (with-handlers ([exn:fail? (λ (x) 'error)]) 128 (parameterize ([current-output-port sp]) 129 (eval `(,#'module ,modname 130 (submod (file ,(path->string letrec-vs-racket.rkt)) all-the-stuff-lang) 131 ,prog)) 132 (dynamic-require `',modname 'the-answer)))) 133 (close-output-port sp) 134 (list (normalize-result result) (normalize-io sp))) 135 136(define (normalize-io sp) 137 (for/list ([l (in-lines (open-input-string (get-output-string sp)))]) 138 (cond 139 [(regexp-match #rx"#<proc" l) 'procedure] 140 [(regexp-match #rx"#<void" l) '(void)] 141 [else (read (open-input-string l))]))) 142 143(define (normalize-result result) 144 (match result 145 [(? procedure?) 'procedure] 146 [(? void?) '(void)] 147 [_ result])) 148 149;; clean-up : any -> any 150;; removes (most of) the free variables 151(define (clean-up s) 152 (define primitives '(+ = * -)) 153 (let loop ([s s] 154 [bound '()]) 155 (define (pick-a-var x for-set!?) 156 (cond 157 [(member x bound) x] 158 [(zero? (random 20)) x] 159 [else 160 (unless for-set!? (set! bound (append primitives bound))) 161 (if (null? bound) 162 (if for-set!? x (random 10)) 163 (list-ref bound (random (length bound))))])) 164 (match s 165 [`(letrec ([,xs ,es] ...) ,e) 166 (define new-vars (append xs bound)) 167 `(letrec (,@(for/list ([x (in-list xs)] 168 [e (in-list es)]) 169 `[,x ,(loop e new-vars)])) 170 ,(loop e new-vars))] 171 [`(let ([,xs ,es] ...) ,e) 172 (define new-vars (append xs bound)) 173 `(let (,@(for/list ([x (in-list xs)] 174 [e (in-list es)]) 175 `[,x ,(loop e bound)])) 176 ,(loop e new-vars))] 177 [`(λ (,xs ...) ,e) 178 (define new-vars (append xs bound)) 179 `(λ (,@xs) ,(loop e new-vars))] 180 [`(set! ,x ,e) `(set! ,(pick-a-var x #t) ,(loop e bound))] 181 [`(if ,e1 ,e2 ,e3) `(if ,(loop e1 bound) ,(loop e2 bound) ,(loop e3 bound))] 182 [`(begin ,es ...) `(begin ,@(for/list ([e (in-list es)]) 183 (loop e bound)))] 184 [`(void) `(void)] 185 [`(,ef ,eas ...) `(,(loop ef bound) ,@(for/list ([ea (in-list eas)]) 186 (loop ea bound)))] 187 [(? symbol?) (pick-a-var s #f)] 188 [(? boolean?) s] 189 [(? number?) s]))) 190 191(module+ test 192 (redex-check surface-lang e 193 (same-as-racket? (term e)))) 194