From befceb1751e6e5b9d2c0a5af3688421e6acbced4 Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Sat, 26 Mar 2011 17:46:28 -0400
Subject: [PATCH] getting the compiler to recognize language primitives

---
 lexical-env.rkt     | 19 ++++++++++++++-----
 lexical-structs.rkt |  2 +-
 parse.rkt           | 33 ++++++++++++++++++++++++++++++---
 test-parse.rkt      | 16 +++++++++-------
 4 files changed, 54 insertions(+), 16 deletions(-)

diff --git a/lexical-env.rkt b/lexical-env.rkt
index dbb714a..740a5b5 100644
--- a/lexical-env.rkt
+++ b/lexical-env.rkt
@@ -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
diff --git a/lexical-structs.rkt b/lexical-structs.rkt
index c63549b..4649431 100644
--- a/lexical-structs.rkt
+++ b/lexical-structs.rkt
@@ -13,7 +13,7 @@
   #:transparent)
 
 (define-struct: ModuleVariable ([name : Symbol]
-                                [module-path : 'kernel])
+                                [module-path : Symbol])
   #:transparent)
 
 
diff --git a/parse.rkt b/parse.rkt
index 0fe6a2a..23b69a4 100644
--- a/parse.rkt
+++ b/parse.rkt
@@ -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
diff --git a/test-parse.rkt b/test-parse.rkt
index 1b901a3..bea88aa 100644
--- a/test-parse.rkt
+++ b/test-parse.rkt
@@ -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)))