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

getting the compiler to recognize language primitives

Browse Source
This commit is contained in:
Danny Yoo 2011-03-26 17:46:28 -04:00
parent b51922310c
commit befceb1751
4 changed files with 54 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
lexical-env.rkt
View File

@ -39,11 +39,20 @@
(let: ([elt : ParseTimeEnvironmentEntry (first cenv)])
(cond
[(Prefix? elt)
(cond [(member name (Prefix-names elt))
(make-EnvPrefixReference depth
(find-pos name (Prefix-names elt)))]
[else
(loop (rest cenv) (add1 depth))])]
(let: prefix-loop : LexicalAddress
([names : (Listof (U Symbol False ModuleVariable)) (Prefix-names elt)]
[pos : Natural 0])
(cond [(empty? names)
(loop (rest cenv) (add1 depth))]
[else
(let: ([n : (U Symbol False ModuleVariable) (first names)])
(cond
[(and (symbol? n) (eq? name n))
(make-EnvPrefixReference depth pos)]
[(and (ModuleVariable? n) (eq? name (ModuleVariable-name n)))
(make-EnvPrefixReference depth pos)]
[else
(prefix-loop (rest names) (add1 pos))]))]))]
[(NamedBinding? elt)
(cond

2
lexical-structs.rkt
View File

@ -13,7 +13,7 @@
#:transparent)
(define-struct: ModuleVariable ([name : Symbol]
[module-path : 'kernel])
[module-path : Symbol])
#:transparent)

33
parse.rkt
View File

@ -13,18 +13,45 @@
set-private-lam-label-counter!)
(define (-parse exp)
(let* ([prefix (make-Prefix (find-unbound-names exp))])
(let* ([prefix (construct-the-prefix exp)])
(make-Top prefix (parse exp (extend-lexical-environment '() prefix)))))
(define (construct-the-prefix exp)
(let ([unbound-names (find-unbound-names exp)]
[mutated-names (find-mutated-names exp)])
(make-Prefix (map (lambda (s)
(cond
[(member s mutated-names)
s]
[(lookup-in-current-language s)
=>
(lambda (mv) mv)]
[else
s]))
unbound-names))))
;; a language maps identifiers to module variables.
(define current-language (make-parameter '(+)))
(define current-language
(make-parameter '(display newline displayln pi e
= < > <= >= + * - / cons
list car cdr pair? set-car!
set-cdr! not null null?
add1 sub1 zero? vector
vector->list list->vector
vector-ref vector-set! symbol?
symbol->string string-append
string-length box unbox set-box!
void eq? equal?)))
;; lookup-in-current-language: symbol -> (or ModuleVariable #f)
(define (lookup-in-current-language sym)
(cond
[(current-language)
=> (lambda (lang)
(if (member sym (lang))
(if (member sym lang)
(make-ModuleVariable sym '#%kernel)
#f))]
[else

16
test-parse.rkt
View File

@ -175,14 +175,15 @@
'lamEntry2)))
(test (parse '(+ x x))
(make-Top (make-Prefix '(+ x))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel)
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-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel)))
(make-Lam #f 1
(make-App (make-ToplevelRef 2 0)
(list (make-LocalRef 3 #f)
@ -192,7 +193,8 @@
(test (parse '(lambda (x)
(+ (* x x) x)))
(make-Top (make-Prefix '(* +))
(make-Top (make-Prefix `(,(make-ModuleVariable '* '#%kernel)
,(make-ModuleVariable '+ '#%kernel)))
(make-Lam #f 1
;; stack layout: [???, ???, prefix, x]
(make-App (make-ToplevelRef 2 1)
@ -251,7 +253,7 @@
(test (parse '(let* ([x 3]
[x (add1 x)])
(add1 x)))
(make-Top (make-Prefix '(add1))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
;; stack layout: [prefix]
@ -352,7 +354,7 @@
(test (parse '(let ([x 0])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix '(add1))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
(make-Let1 (make-Constant 0)
(make-BoxEnv 0
(make-Lam #f 0
@ -371,7 +373,7 @@
[y 1])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix '(add1))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
(make-LetVoid 2
(make-Seq (list
(make-InstallValue 0 (make-Constant 0) #t)
@ -399,7 +401,7 @@
(reset!)
(list a b)))
(make-Top
(make-Prefix '(a b list reset!))
(make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!))
(make-Seq
(list
(make-ToplevelSet 0 0 'a (make-Constant '(hello)))