more tests on parsing
This commit is contained in:
Danny Yoo
parent
7e30883490
commit
3aa643720a
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
(define-type ExpressionCore (U Top Constant
|
||||
ToplevelRef LocalRef
|
||||
SetToplevel
|
||||
ToplevelSet
|
||||
Branch Lam Seq App
|
||||
Let1 Let LetRec))
|
||||
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
(define-struct: LocalRef ([depth : Natural])
|
||||
#:transparent)
|
||||
|
||||
(define-struct: SetToplevel ([depth : Natural]
|
||||
(define-struct: ToplevelSet ([depth : Natural]
|
||||
[pos : Natural]
|
||||
[name : Symbol]
|
||||
[value : ExpressionCore]) #:transparent)
|
||||
|
|
|
|||
124
parse.rkt
124
parse.rkt
|
|
@ -49,10 +49,10 @@
|
|||
[(EnvLexicalReference? address)
|
||||
(error 'parse "Can't define except in toplevel context")]
|
||||
[(EnvPrefixReference? address)
|
||||
(make-SetToplevel (EnvPrefixReference-depth address)
|
||||
(make-ToplevelSet (EnvPrefixReference-depth address)
|
||||
(EnvPrefixReference-pos address)
|
||||
(EnvPrefixReference-name address)
|
||||
(parse (definition-value exp) cenv))]))]
|
||||
(parse (definition-value exp) cenv))]))]
|
||||
|
||||
[(if? exp)
|
||||
(make-Branch (parse (if-predicate exp) cenv)
|
||||
|
|
@ -73,11 +73,13 @@
|
|||
cenv
|
||||
(extend-lexical-environment/names '() (lambda-parameters exp))
|
||||
unbound-names)])
|
||||
(let ([lam-body (make-Seq (map (lambda (b)
|
||||
(parse b body-cenv))
|
||||
(lambda-body exp)))])
|
||||
(let ([lam-body (map (lambda (b)
|
||||
(parse b body-cenv))
|
||||
(lambda-body exp))])
|
||||
(make-Lam (length (lambda-parameters exp))
|
||||
lam-body
|
||||
(if (= (length lam-body) 1)
|
||||
(first lam-body)
|
||||
(make-Seq lam-body))
|
||||
closure-references)))]
|
||||
|
||||
[(begin? exp)
|
||||
|
|
@ -117,58 +119,59 @@
|
|||
|
||||
;; find-unbound-names: Any -> (Listof Symbol)
|
||||
(define (find-unbound-names exp)
|
||||
(cond
|
||||
[(self-evaluating? exp)
|
||||
'()]
|
||||
|
||||
[(quoted? exp)
|
||||
'()]
|
||||
|
||||
[(variable? exp)
|
||||
(list exp)]
|
||||
|
||||
[(definition? exp)
|
||||
(let ([address (find-variable (definition-variable exp))])
|
||||
(cons (definition-variable address)
|
||||
(find-unbound-names (definition-value exp))))]
|
||||
|
||||
[(if? exp)
|
||||
(append (find-unbound-names (if-predicate exp))
|
||||
(find-unbound-names (if-consequent exp))
|
||||
(find-unbound-names (if-alternative exp)))]
|
||||
|
||||
[(cond? exp)
|
||||
(find-unbound-names (desugar-cond exp))]
|
||||
|
||||
[(lambda? exp)
|
||||
(list-difference (apply append (map find-unbound-names (lambda-body exp)))
|
||||
(lambda-parameters exp))]
|
||||
|
||||
[(begin? exp)
|
||||
(apply append (map find-unbound-names (begin-actions exp)))]
|
||||
|
||||
[(named-let? exp)
|
||||
(find-unbound-names (desugar-named-let exp))]
|
||||
|
||||
[(let*? exp)
|
||||
(find-unbound-names (desugar-let* exp))]
|
||||
|
||||
[(let? exp)
|
||||
(append (apply append (map find-unbound-names (let-rhss exp)))
|
||||
(list-difference (apply append (map find-unbound-names (let-body exp)))
|
||||
(let-variables exp)))]
|
||||
|
||||
[(letrec? exp)
|
||||
(list-difference (append (apply append (map find-unbound-names (let-rhss exp)))
|
||||
(apply append (map find-unbound-names (let-body exp))))
|
||||
(let-variables exp))]
|
||||
|
||||
[(application? exp)
|
||||
(append (find-unbound-names (operator exp))
|
||||
(apply append (map find-unbound-names (operands exp))))]
|
||||
|
||||
[else
|
||||
(error 'find-unbound-names "Unknown expression type ~e" exp)]))
|
||||
(unique/eq?
|
||||
(let loop ([exp exp])
|
||||
(cond
|
||||
[(self-evaluating? exp)
|
||||
'()]
|
||||
|
||||
[(quoted? exp)
|
||||
'()]
|
||||
|
||||
[(variable? exp)
|
||||
(list exp)]
|
||||
|
||||
[(definition? exp)
|
||||
(cons (definition-variable exp)
|
||||
(loop (definition-value exp)))]
|
||||
|
||||
[(if? exp)
|
||||
(append (loop (if-predicate exp))
|
||||
(loop (if-consequent exp))
|
||||
(loop (if-alternative exp)))]
|
||||
|
||||
[(cond? exp)
|
||||
(loop (desugar-cond exp))]
|
||||
|
||||
[(lambda? exp)
|
||||
(list-difference (apply append (map loop (lambda-body exp)))
|
||||
(lambda-parameters exp))]
|
||||
|
||||
[(begin? exp)
|
||||
(apply append (map loop (begin-actions exp)))]
|
||||
|
||||
[(named-let? exp)
|
||||
(loop (desugar-named-let exp))]
|
||||
|
||||
[(let*? exp)
|
||||
(loop (desugar-let* exp))]
|
||||
|
||||
[(let? exp)
|
||||
(append (apply append (map loop (let-rhss exp)))
|
||||
(list-difference (apply append (map loop (let-body exp)))
|
||||
(let-variables exp)))]
|
||||
|
||||
[(letrec? exp)
|
||||
(list-difference (append (apply append (map loop (let-rhss exp)))
|
||||
(apply append (map loop (let-body exp))))
|
||||
(let-variables exp))]
|
||||
|
||||
[(application? exp)
|
||||
(append (loop (operator exp))
|
||||
(apply append (map loop (operands exp))))]
|
||||
|
||||
[else
|
||||
(error 'find-unbound-names "Unknown expression type ~e" exp)]))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -226,10 +229,11 @@
|
|||
(cadr exp))
|
||||
(define (if-consequent exp)
|
||||
(caddr exp))
|
||||
|
||||
(define (if-alternative exp)
|
||||
(if (not (null? (cdddr exp)))
|
||||
(cadddr exp)
|
||||
'false))
|
||||
`',(void)))
|
||||
|
||||
(define (begin? exp)
|
||||
(tagged-list? exp 'begin))
|
||||
|
|
@ -258,7 +262,7 @@
|
|||
[else
|
||||
`(if ,question
|
||||
,answer
|
||||
(void))]))]
|
||||
',(void))]))]
|
||||
[else
|
||||
(let* ([clause (car clauses)]
|
||||
[question (car clause)]
|
||||
|
|
|
|||
194
test-parse.rkt
Normal file
194
test-parse.rkt
Normal file
|
|
@ -0,0 +1,194 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "parse.rkt"
|
||||
"lexical-structs.rkt"
|
||||
"expression-structs.rkt"
|
||||
(for-syntax racket/base))
|
||||
|
||||
; Test out the compiler, using the simulator.
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr expt)
|
||||
(with-syntax ([stx stx])
|
||||
(syntax/loc #'stx
|
||||
(begin
|
||||
(printf "Running ~s ...\n" (syntax->datum #'expr))
|
||||
(let ([expected expt]
|
||||
[actual
|
||||
(with-handlers ([void
|
||||
(lambda (exn)
|
||||
(raise-syntax-error #f (format "Runtime error: got ~s" exn)
|
||||
#'stx))])
|
||||
expr)])
|
||||
(unless (equal? actual expected)
|
||||
(raise-syntax-error #f (format "Expected ~s, got ~s" expected actual)
|
||||
#'stx))
|
||||
(printf "ok.\n\n")))))]))
|
||||
|
||||
|
||||
|
||||
(test (parse '1)
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Constant 1)))
|
||||
|
||||
(test (parse ''hello)
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Constant 'hello)))
|
||||
|
||||
(test (parse 'hello)
|
||||
(make-Top (make-Prefix '(hello))
|
||||
(make-ToplevelRef 0 0)))
|
||||
|
||||
(test (parse '(begin hello world))
|
||||
(make-Top (make-Prefix '(hello world))
|
||||
(make-Seq (list (make-ToplevelRef 0 0)
|
||||
(make-ToplevelRef 0 1)))))
|
||||
|
||||
(test (parse '(define x y))
|
||||
(make-Top (make-Prefix '(x y))
|
||||
(make-ToplevelSet 0 0 'x (make-ToplevelRef 0 1))))
|
||||
|
||||
(test (parse '(begin (define x 42)
|
||||
(define y x)))
|
||||
(make-Top (make-Prefix '(x y))
|
||||
(make-Seq (list (make-ToplevelSet 0 0 'x (make-Constant 42))
|
||||
(make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0))))))
|
||||
|
||||
(test (parse '(if x y z))
|
||||
(make-Top (make-Prefix '(x y z))
|
||||
(make-Branch (make-ToplevelRef 0 0)
|
||||
(make-ToplevelRef 0 1)
|
||||
(make-ToplevelRef 0 2))))
|
||||
|
||||
(test (parse '(if x (if y z 1) #t))
|
||||
(make-Top (make-Prefix '(x y z))
|
||||
(make-Branch (make-ToplevelRef 0 0)
|
||||
(make-Branch (make-ToplevelRef 0 1)
|
||||
(make-ToplevelRef 0 2)
|
||||
(make-Constant 1))
|
||||
(make-Constant #t))))
|
||||
|
||||
(test (parse '(if x y))
|
||||
(make-Top (make-Prefix '(x y))
|
||||
(make-Branch (make-ToplevelRef 0 0)
|
||||
(make-ToplevelRef 0 1)
|
||||
(make-Constant (void)))))
|
||||
|
||||
(test (parse '(cond [x y]))
|
||||
(make-Top (make-Prefix '(x y))
|
||||
(make-Branch (make-ToplevelRef 0 0)
|
||||
(make-ToplevelRef 0 1)
|
||||
(make-Constant (void)))))
|
||||
|
||||
(test (parse '(cond [x y] [else "ok"]))
|
||||
(make-Top (make-Prefix '(x y))
|
||||
(make-Branch (make-ToplevelRef 0 0)
|
||||
(make-ToplevelRef 0 1)
|
||||
(make-Constant "ok"))))
|
||||
|
||||
(test (parse '(lambda (x y z) x))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Lam 3 (make-LocalRef 0) '())))
|
||||
|
||||
(test (parse '(lambda (x y z) y))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Lam 3 (make-LocalRef 1) '())))
|
||||
|
||||
(test (parse '(lambda (x y z) z))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Lam 3 (make-LocalRef 2) '())))
|
||||
|
||||
|
||||
(test (parse '(lambda (x y z) x y z))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Lam 3 (make-Seq (list (make-LocalRef 0)
|
||||
(make-LocalRef 1)
|
||||
(make-LocalRef 2)))
|
||||
'())))
|
||||
|
||||
(test (parse '(lambda (x y z) k))
|
||||
(make-Top (make-Prefix '(k))
|
||||
(make-Lam 3 (make-ToplevelRef 0 0 )
|
||||
(list (make-EnvWholePrefixReference 0)))))
|
||||
|
||||
(test (parse '(lambda (x y z) k x y z))
|
||||
(make-Top (make-Prefix '(k))
|
||||
(make-Lam 3 (make-Seq (list (make-ToplevelRef 0 0 )
|
||||
(make-LocalRef 1)
|
||||
(make-LocalRef 2)
|
||||
(make-LocalRef 3)))
|
||||
(list (make-EnvWholePrefixReference 0)))))
|
||||
|
||||
(test (parse '(lambda (x)
|
||||
(lambda (y)
|
||||
(lambda (z)
|
||||
x
|
||||
y
|
||||
z
|
||||
w))))
|
||||
(make-Top (make-Prefix '(w))
|
||||
(make-Lam 1
|
||||
(make-Lam 1
|
||||
(make-Lam 1
|
||||
(make-Seq (list
|
||||
(make-LocalRef 1)
|
||||
(make-LocalRef 2)
|
||||
(make-LocalRef 3)
|
||||
(make-ToplevelRef 0 0)))
|
||||
(list (make-EnvWholePrefixReference 0) ;; w
|
||||
(make-EnvLexicalReference 1 #f) ;; x
|
||||
(make-EnvLexicalReference 2 #f) ;; y
|
||||
))
|
||||
(list (make-EnvWholePrefixReference 0) ;; w
|
||||
(make-EnvLexicalReference 1 #f) ;; x
|
||||
))
|
||||
(list (make-EnvWholePrefixReference 0)))))
|
||||
|
||||
(test (parse '(lambda (x)
|
||||
(lambda (y)
|
||||
x)))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Lam 1
|
||||
(make-Lam 1
|
||||
(make-LocalRef 0)
|
||||
(list (make-EnvLexicalReference 0 #f)))
|
||||
(list))))
|
||||
|
||||
(test (parse '(lambda (x)
|
||||
(lambda (y)
|
||||
y)))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-Lam 1
|
||||
(make-Lam 1
|
||||
(make-LocalRef 0)
|
||||
(list))
|
||||
(list))))
|
||||
|
||||
(test (parse '(+ x x))
|
||||
(make-Top (make-Prefix '(+ x))
|
||||
(make-App (make-ToplevelRef 2 0)
|
||||
(list (make-ToplevelRef 2 1)
|
||||
(make-ToplevelRef 2 1)))))
|
||||
|
||||
|
||||
(test (parse '(lambda (x) (+ x x)))
|
||||
(make-Top (make-Prefix '(+))
|
||||
(make-Lam 1
|
||||
(make-App (make-ToplevelRef 2 0)
|
||||
(list (make-LocalRef 3)
|
||||
(make-LocalRef 3)))
|
||||
(list (make-EnvWholePrefixReference 0)))))
|
||||
|
||||
(test (parse '(lambda (x)
|
||||
(+ (* x x) x)))
|
||||
(make-Top (make-Prefix '(* +))
|
||||
(make-Lam 1
|
||||
;; stack layout: [???, ???, prefix, x]
|
||||
(make-App (make-ToplevelRef 2 1)
|
||||
(list
|
||||
;; stack layout: [???, ???, ???, ???, prefix, x]
|
||||
(make-App (make-ToplevelRef 4 0)
|
||||
(list (make-LocalRef 5)
|
||||
(make-LocalRef 5)))
|
||||
(make-LocalRef 3)))
|
||||
(list (make-EnvWholePrefixReference 0)))))
|
||||
Loading…
Reference in New Issue
Block a user