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

in the middle of making the expressions close to the racket machine

Browse Source
This commit is contained in:
Danny Yoo 2011-03-19 00:02:19 -04:00
parent afe489e4f4
commit a794c9cf68
4 changed files with 147 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
expression-structs.rkt
View File

@ -5,33 +5,48 @@
;; Expressions
(define-type ExpressionCore (U Top Constant Var Branch Def Lam Seq App
(define-type ExpressionCore (U Top Constant
ToplevelRef LocalRef
SetToplevel
Branch Lam Seq App
Let1 Let LetRec))
(define-struct: Top ([prefix : Prefix]
[code : ExpressionCore]) #:transparent)
(define-struct: Constant ([v : Any]) #:transparent)
(define-struct: Var ([id : Symbol]) #:transparent)
(define-struct: ToplevelRef ([depth : Natural]
[pos : Natural])
#:transparent)
(define-struct: LocalRef ([depth : Natural])
#:transparent)
(define-struct: SetToplevel ([depth : Natural]
[pos : Natural]
[name : Symbol]
[value : ExpressionCore]) #:transparent)
(define-struct: Branch ([predicate : ExpressionCore]
[consequent : ExpressionCore]
[alternative : ExpressionCore]) #:transparent)
(define-struct: Def ([variable : Symbol]
[value : ExpressionCore]) #:transparent)
(define-struct: Lam ([parameters : (Listof Symbol)]
(define-struct: Lam ([num-parameters : Natural]
[body : ExpressionCore]) #:transparent)
(define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent)
(define-struct: App ([operator : ExpressionCore]
[operands : (Listof ExpressionCore)]) #:transparent)
(define-struct: Let1 ([name : Symbol]
[rhs : ExpressionCore ]
(define-struct: Let1 ([rhs : ExpressionCore ]
[body : ExpressionCore])
#:transparent)
(define-struct: Let ([names : (Listof Symbol)]
(define-struct: Let ([count : Natural]
[rhss : (Listof ExpressionCore)]
[body : ExpressionCore])
#:transparent)
(define-struct: LetRec ([names : (Listof Symbol)]
(define-struct: LetRec ([count : Natural]
[rhss : (Listof ExpressionCore)]
[body : ExpressionCore])
#:transparent)
@ -48,8 +63,4 @@
(define (rest-exps seq) (cdr seq))
(define-struct: Assign ([variable : Symbol]
[value : Expression]) #:transparent)
(define-type Expression (U ExpressionCore #;Assign))
(define-type Expression (U ExpressionCore))

12
lexical-env.rkt
View File

@ -13,9 +13,8 @@
place-prefix-mask)
;; find-variable: symbol compile-time-environment -> lexical-address
;; Find where the variable should be located.
(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
;; Find where the variable is located in the lexical environment
(: find-variable (Symbol CompileTimeEnvironment -> (U LexicalAddress False)))
(define (find-variable name cenv)
(: find-pos (Symbol (Listof (U Symbol False)) -> Natural))
(define (find-pos sym los)
@ -24,10 +23,11 @@
0]
[else
(add1 (find-pos sym (cdr los)))]))
(let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0])
(let: loop : (U LexicalAddress False)
([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0])
(cond [(empty? cenv)
(error 'find-variable "Unable to find ~s in the environment" name)]
#f]
[else
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
(cond

3
lexical-structs.rkt
View File

@ -10,7 +10,8 @@
;; 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)
#:transparent
#:mutable)
(define-struct: NamedBinding ([name : Symbol]))

149
parse.rkt
View File

@ -1,8 +1,48 @@
#lang racket/base
(require "expression-structs.rkt")
(provide parse)
(define (parse exp)
(require "expression-structs.rkt"
"lexical-env.rkt"
"lexical-structs.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))))
;; find-prefix: CompileTimeEnvironment -> Natural
(define (find-prefix cenv)
(cond
[(empty? cenv)
(error 'impossible)]
[(Prefix? (first cenv))
0]
[else
(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)
(cond
[(self-evaluating? exp)
(make-Constant exp)]
@ -11,26 +51,56 @@
(make-Constant (text-of-quotation exp))]
[(variable? exp)
(make-Var exp)]
(let ([address (find-variable* exp cenv)])
(cond
[(EnvLexicalReference? address)
(make-LocalRef (EnvLexicalReference-depth address))]
[(EnvPrefixReference? address)
(make-ToplevelRef (EnvPrefixReference-depth address)
(EnvPrefixReference-pos address))]))]
[(definition? exp)
(make-Def (definition-variable exp)
(parse (definition-value exp)))]
(let ([address (find-variable* exp cenv)])
(cond
[(EnvLexicalReference? address)
(error 'parse "Can't define except in toplevel context")]
[(EnvPrefixReference? address)
(make-SetToplevel (EnvPrefixReference-depth address)
(EnvPrefixReference-pos address)
(EnvPrefixReference-name address)
(parse (definition-value exp) cenv))]))]
[(if? exp)
(make-Branch (parse (if-predicate exp))
(parse (if-consequent exp))
(parse (if-alternative exp)))]
(make-Branch (parse (if-predicate exp) cenv)
(parse (if-consequent exp) cenv)
(parse (if-alternative exp) cenv))]
[(cond? exp)
(parse (desugar-cond exp))]
(parse (desugar-cond exp) cenv)]
[(lambda? exp)
(make-Lam (lambda-parameters exp)
(make-Seq (map parse (lambda-body 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 ([lam-body (make-Seq (map (lambda (b)
(parse b (cons prefix 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))))])))]
[(begin? exp)
(let ([actions (map parse (begin-actions exp))])
(let ([actions (map (lambda (e)
(parse e cenv))
(begin-actions exp))])
(cond
[(= 1 (length actions))
(car actions)]
@ -38,20 +108,23 @@
(make-Seq actions)]))]
[(named-let? exp)
(parse-named-let exp)]
(parse-named-let exp cenv)]
[(let? exp)
(parse-let exp)]
(parse-let exp cenv)]
[(let*? exp)
(parse-let* exp)]
(parse-let* exp cenv)]
[(letrec? exp)
(parse-letrec exp)]
(parse-letrec exp cenv)]
[(application? exp)
(make-App (parse (operator exp))
(map parse (operands exp)))]
(let ([cenv-with-scratch-space
(extend-lexical-environment/placeholders cenv (length (operands exp)))])
(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)]))
@ -152,7 +225,7 @@
(define (parse-let exp)
(define (parse-let exp cenv)
(let ([vars (let-variables exp)]
[rhss (let-rhss exp)]
[body (let-body exp)])
@ -160,27 +233,31 @@
[(= 0 (length vars))
(parse `(begin ,@body))]
[(= 1 (length vars))
(make-Let1 (car vars)
(parse (car rhss))
(parse `(begin ,@body)))]
(make-Let1 (parse (car rhss) (extend-lexical-environment/placeholders cenv 1))
(parse `(begin ,@body)
(extend-lexical-environment/names cenv (list (first vars)))))]
[else
(make-Let vars
(map parse rhss)
(parse `(begin ,@body)))])))
(let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))])
(make-Let (length vars)
(map (lambda (rhs) (parse rhs rhs-cenv)) rhss)
(parse `(begin ,@body)
(extend-lexical-environment/names vars))))])))
(define (parse-letrec exp)
(define (parse-letrec exp cenv)
(let ([vars (let-variables exp)]
[rhss (let-rhss exp)]
[body (let-body exp)])
(cond
[(= 0 (length vars))
(parse `(begin ,@body))]
(parse `(begin ,@body) cenv)]
[else
(make-LetRec vars
(map parse rhss)
(parse `(begin ,@body)))])))
(let ([new-cenv (extend-lexical-environment/names cenv vars)])
(make-LetRec (length vars)
(map (lambda (rhs) (parse rhs new-cenv)) rhss)
(parse `(begin ,@body) new-cenv)))])))
(define (parse-let* exp)
(define (parse-let* exp cenv)
(parse
(let ([body (let-body exp)])
(let loop ([vars (let-variables exp)]
@ -190,16 +267,18 @@
`(begin ,@body)]
[else
`(let ([,(car vars) ,(car rhss)])
,(loop (cdr vars) (cdr rhss)))])))))
,(loop (cdr vars) (cdr rhss)))])))
cenv))
(define (parse-named-let exp)
(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)))))
(,(named-let-name exp) ,@(named-let-rhss exp)))
cenv))
(define (named-let? exp)