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