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)]) (let: ([elt : ParseTimeEnvironmentEntry (first cenv)])
(cond (cond
[(Prefix? elt) [(Prefix? elt)
(cond [(member name (Prefix-names elt)) (let: prefix-loop : LexicalAddress
(make-EnvPrefixReference depth ([names : (Listof (U Symbol False ModuleVariable)) (Prefix-names elt)]
(find-pos name (Prefix-names elt)))] [pos : Natural 0])
[else (cond [(empty? names)
(loop (rest cenv) (add1 depth))])] (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) [(NamedBinding? elt)
(cond (cond

2
lexical-structs.rkt
View File

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

33
parse.rkt
View File

@ -13,18 +13,45 @@
set-private-lam-label-counter!) set-private-lam-label-counter!)
(define (-parse exp) (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))))) (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. ;; 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) ;; lookup-in-current-language: symbol -> (or ModuleVariable #f)
(define (lookup-in-current-language sym) (define (lookup-in-current-language sym)
(cond (cond
[(current-language) [(current-language)
=> (lambda (lang) => (lambda (lang)
(if (member sym (lang)) (if (member sym lang)
(make-ModuleVariable sym '#%kernel) (make-ModuleVariable sym '#%kernel)
#f))] #f))]
[else [else

16
test-parse.rkt
View File

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