suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

testing parse

Browse Source
This commit is contained in:
Danny Yoo 2011-03-19 18:39:14 -04:00
parent a794c9cf68
commit 7e30883490
4 changed files with 113 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
expression-structs.rkt
View File

@ -33,25 +33,30 @@
[alternative : ExpressionCore]) #:transparent)
(define-struct: Lam ([num-parameters : Natural]
[body : ExpressionCore]) #:transparent)
[body : ExpressionCore]
[closure-map : (Listof EnvReference)]) #:transparent)
(define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent)
(define-struct: App ([operator : ExpressionCore]
[operands : (Listof ExpressionCore)]) #:transparent)
(define-struct: Let1 ([rhs : ExpressionCore ]
(define-struct: Let1 ([rhs : ExpressionCore]
[body : ExpressionCore])
#:transparent)
(define-struct: Let ([count : Natural]
[rhss : (Listof ExpressionCore)]
[body : ExpressionCore])
#:transparent)
(define-struct: LetRec ([count : Natural]
[rhss : (Listof ExpressionCore)]
[body : ExpressionCore])
#:transparent)
(: last-exp? ((Listof Expression) -> Boolean))
(define (last-exp? seq)
(null? (cdr seq)))

6
lexical-env.rkt
View File

@ -14,7 +14,7 @@
;; Find where the variable is located in the lexical environment
(: find-variable (Symbol CompileTimeEnvironment -> (U LexicalAddress False)))
(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
(define (find-variable name cenv)
(: find-pos (Symbol (Listof (U Symbol False)) -> Natural))
(define (find-pos sym los)
@ -23,11 +23,11 @@
0]
[else
(add1 (find-pos sym (cdr los)))]))
(let: loop : (U LexicalAddress False)
(let: loop : LexicalAddress
([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0])
(cond [(empty? cenv)
#f]
(error 'find-variable "~s not in lexical environment" cenv)]
[else
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
(cond

3
lexical-structs.rkt
View File

@ -10,8 +10,7 @@
;; A toplevel prefix contains a list of toplevel variables. Some of the
;; names may be masked out by #f.
(define-struct: Prefix ([names : (Listof (U Symbol False))])
#:transparent
#:mutable)
#:transparent)
(define-struct: NamedBinding ([name : Symbol]))

162
parse.rkt
View File

@ -3,15 +3,14 @@
(require "expression-structs.rkt"
"lexical-env.rkt"
"lexical-structs.rkt"
"helpers.rkt"
racket/list)
(provide (rename-out (-parse parse)))
(define (-parse exp)
(let* ([prefix (make-Prefix '())]
[cenv (list prefix)])
(let ([expr (parse exp cenv)])
(make-Top prefix expr))))
(let* ([prefix (make-Prefix (find-unbound-names exp))])
(make-Top prefix (parse exp (extend-lexical-environment '() prefix)))))
;; find-prefix: CompileTimeEnvironment -> Natural
@ -25,21 +24,6 @@
(add1 (find-prefix (rest cenv)))]))
;; find-variable*: Any CompileTimeEnvironment -> LexicalAddress
(define (find-variable* exp cenv)
(let ([address (find-variable exp cenv)])
(cond
[(eq? address #f)
(let* ([prefix-depth (find-prefix cenv)]
[prefix (list-ref cenv prefix-depth)])
(set-Prefix-names! prefix (append (Prefix-names prefix)
(list exp)))
(find-variable* exp cenv))]
[else
address])))
;; parse: Any CompileTimeEnvironment -> ExpressionCore
;; Compile an expression.
(define (parse exp cenv)
@ -51,7 +35,7 @@
(make-Constant (text-of-quotation exp))]
[(variable? exp)
(let ([address (find-variable* exp cenv)])
(let ([address (find-variable exp cenv)])
(cond
[(EnvLexicalReference? address)
(make-LocalRef (EnvLexicalReference-depth address))]
@ -60,7 +44,7 @@
(EnvPrefixReference-pos address))]))]
[(definition? exp)
(let ([address (find-variable* exp cenv)])
(let ([address (find-variable (definition-variable exp) cenv)])
(cond
[(EnvLexicalReference? address)
(error 'parse "Can't define except in toplevel context")]
@ -79,23 +63,22 @@
(parse (desugar-cond exp) cenv)]
[(lambda? exp)
;; Fixme: need to know what variables are treated as free here!
(let* ([prefix (list-ref cenv (find-prefix cenv))]
[prefix-length (length (Prefix-names prefix))]
[body-cenv (extend-lexical-environment/names
'()
(lambda-parameters exp))])
(let* ([unbound-names (find-unbound-names exp)]
[closure-references (collect-lexical-references
(map (lambda (var)
(find-variable var cenv))
unbound-names))]
[body-cenv (lexical-references->compile-time-environment
closure-references
cenv
(extend-lexical-environment/names '() (lambda-parameters exp))
unbound-names)])
(let ([lam-body (make-Seq (map (lambda (b)
(parse b (cons prefix body-cenv)))
(parse b body-cenv))
(lambda-body exp)))])
(cond [(= prefix-length (length (Prefix-names prefix)))
(make-Lam (length (lambda-parameters exp))
lam-body)]
[else
(make-Lam (length (lambda-parameters exp))
(make-Seq (map (lambda (b)
(parse b body-cenv))
(lambda-body exp))))])))]
(make-Lam (length (lambda-parameters exp))
lam-body
closure-references)))]
[(begin? exp)
(let ([actions (map (lambda (e)
@ -108,13 +91,13 @@
(make-Seq actions)]))]
[(named-let? exp)
(parse-named-let exp cenv)]
[(let? exp)
(parse-let exp cenv)]
(parse (desugar-named-let exp) cenv)]
[(let*? exp)
(parse-let* exp cenv)]
(parse (desugar-let* exp) cenv)]
[(let? exp)
(parse-let exp cenv)]
[(letrec? exp)
(parse-letrec exp cenv)]
@ -125,12 +108,73 @@
(make-App (parse (operator exp) cenv-with-scratch-space)
(map (lambda (rand) (parse rand cenv-with-scratch-space))
(operands exp))))]
[else
(error 'compile "Unknown expression type ~e" exp)]))
;; 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)]))
;; expression selectors
(define (self-evaluating? exp)
@ -257,28 +301,26 @@
(parse `(begin ,@body) new-cenv)))])))
(define (parse-let* exp cenv)
(parse
(let ([body (let-body exp)])
(let loop ([vars (let-variables exp)]
[rhss (let-rhss exp)])
(cond
[(null? vars)
`(begin ,@body)]
[else
(define (desugar-let* exp)
(let ([body (let-body exp)])
(let loop ([vars (let-variables exp)]
[rhss (let-rhss exp)])
(cond
[(null? vars)
`(begin ,@body)]
[else
`(let ([,(car vars) ,(car rhss)])
,(loop (cdr vars) (cdr rhss)))])))
cenv))
,(loop (cdr vars) (cdr rhss)))]))))
(define (parse-named-let exp cenv)
(parse
`(letrec [(,(named-let-name exp)
(lambda ,(named-let-variables exp)
,@(named-let-body exp)))]
(,(named-let-name exp) ,@(named-let-rhss exp)))
cenv))
(define (desugar-named-let exp)
`(letrec [(,(named-let-name exp)
(lambda ,(named-let-variables exp)
,@(named-let-body exp)))]
(,(named-let-name exp) ,@(named-let-rhss exp))))
(define (named-let? exp)