Add local variable capture to lisp nodes

Previously lisp nodes were rewritten with a code walker to allow them to
access renamed variables. This seemed to fragile so lisp nodes now must
declare which local variables they wish to use. The lisp node's form
will then be wrapped in a let block during codegen which will unrename
the requested variables.

Fixes #5

examples/quil-coalton/src/parser.lisp

@@ -9,7 +9,7 @@
 
   (declare incomplete-parse-error (String -> ParseError))
   (define (incomplete-parse-error str)
-    (Error (lisp String (cl:format cl:nil "Parser did not complete: ~A" str))))
+    (Error (lisp String (str) (cl:format cl:nil "Parser did not complete: ~A" str))))
 
   (define-type (Parser :a)
     (Parser (StringView -> (Result ParseError (Tuple :a StringView)))))

examples/quil-coalton/src/string-view.lisp

@@ -7,7 +7,7 @@
 
   (declare make-string-view (String -> StringView))
   (define (make-string-view str)
-    (lisp StringView
+    (lisp StringView (str)
       (StringView
        (coalton:veil
         (cl:make-array (cl:length (cl:the (cl:vector cl:character) str))
@@ -17,7 +17,7 @@
 
   (declare next-char (StringView -> (Optional (Tuple Char StringView))))
   (define (next-char str)
-    (lisp (Optional (Tuple Char StringView))
+    (lisp (Optional (Tuple Char StringView)) (str)
       (cl:let* ((arr (coalton:unveil (cl:slot-value str '_0))))
         (cl:declare (cl:type (cl:vector cl:character) arr)
                     ;; Muffle sbcl wanting to optimize aref. This cannot be optimized.
@@ -40,11 +40,11 @@
 
   (declare string-view-get (StringView -> String))
   (define (string-view-get str)
-    (lisp String (coalton:unveil (cl:slot-value str '_0))))
+    (lisp String (str) (coalton:unveil (cl:slot-value str '_0))))
 
   (declare string-view-empty-p (StringView -> Boolean))
   (define (string-view-empty-p str)
-    (lisp Boolean
+    (lisp Boolean (str)
       (cl:let* ((arr (coalton:unveil (cl:slot-value str '_0))))
         (cl:declare (cl:type (cl:vector cl:character) arr))
         (cl:if (cl:= 0 (cl:length arr))

examples/quil-coalton/src/value-parsers.lisp

@@ -10,7 +10,8 @@
     (Parser
      (fn (str)
        (match (next-char str)
-         ((Some (Tuple read-char _)) (Err (Error (lisp String (cl:format cl:nil "Unexpected character '~A' expected EOF" read-char)))))
+         ((Some (Tuple read-char _)) (Err (Error (lisp String (read-char)
+						   (cl:format cl:nil "Unexpected character '~A' expected EOF" read-char)))))
          ((None) (Ok (Tuple Unit str)))))))
 
   (declare take (Parser Char))
@@ -31,7 +32,7 @@
           (let ((read-char (fst t_)))
             (if (== c read-char)
                 (Ok t_)
-                (Err (Error (lisp String (cl:format cl:nil "Unexpected character '~A' expected '~A'" read-char c)))))))
+                (Err (Error (lisp String (read-char c) (cl:format cl:nil "Unexpected character '~A' expected '~A'" read-char c)))))))
          ((None) (Err parse-error-eof))))))
 
   (declare not-char (Char -> (Parser Char)))
@@ -42,7 +43,7 @@
          ((Some t_)
           (let ((read-char (fst t_)))
             (if (== c read-char)
-                (Err (Error (lisp String (cl:format cl:nil "Unexpected character '~A' expected not '~A'" read-char c))))
+                (Err (Error (lisp String (read-char c) (cl:format cl:nil "Unexpected character '~A' expected not '~A'" read-char c))))
                 (Ok t_))))
          ((None) (Err parse-error-eof))))))
 

src/ast/node.lisp

@@ -99,8 +99,9 @@
 (serapeum:defstruct-read-only
     (node-lisp
      (:include node)
-     (:constructor node-lisp (unparsed type form)))
+     (:constructor node-lisp (unparsed type variables form)))
   (type :type t)
+  (variables :type list)
   (form :type t))
 
 #+sbcl

src/ast/parse-form.lisp

@@ -25,14 +25,15 @@ This does not attempt to do any sort of analysis whatsoever. It is suitable for
        ((coalton:let bindings subexpr)
         (parse-let expr bindings subexpr sr package))
        ;; Lisp
-       ((coalton:lisp type lisp-expr)
-        (parse-lisp expr type lisp-expr sr))
+       ((coalton:lisp type variables lisp-expr)
+        (parse-lisp expr type variables lisp-expr sr))
        ;; Match
        ((coalton:match expr_ &rest patterns)
         (parse-match expr expr_ patterns sr package))
        ;; Seq
        ((coalton:seq &rest subnodes)
 	(parse-seq expr subnodes sr package))
+       ;; Application
        ((t &rest rands)
         (parse-application expr (first expr) rands sr package))))
     (t (error-parsing expr "The expression is not a valid value expression."))))
@@ -96,31 +97,18 @@ This does not attempt to do any sort of analysis whatsoever. It is suitable for
      (parse-form subexpr new-sr package)
      (invert-alist binding-local-names))))
 
-(defun rewrite-symbols (val sr)
+(defun parse-lisp (unparsed type variables lisp-expr sr)
   (declare (type shadow-realm sr))
-  (cond
-    ((null val)
-     nil)
-
-    ((listp val)
-     (mapcar
-      (lambda (val)
-	(rewrite-symbols val sr))
-      val))
-
-    ((symbolp val)
-     (progn
-       (lookup-or-key sr val)))
-
-    ((typep val 'literal-value)
-     val)
-
-    (t (coalton-impl::coalton-bug "Invalid structure in lisp node ~A~%" val))))
-
-(defun parse-lisp (unparsed type lisp-expr sr)
-  (declare (type shadow-realm sr))
-  ;; Do *NOT* parse LISP-EXPR!
-  (node-lisp unparsed type (rewrite-symbols lisp-expr sr)))
+  (node-lisp
+   unparsed
+   type
+   (loop :for var :in variables
+	 :collect (cons
+		   var
+		   (or (shadow-realm-lookup sr var)
+		       (coalton-impl::coalton-bug "Missing var ~A." var))))
+   ;; Do *NOT* parse LISP-EXPR!
+   lisp-expr))
 
 (defun parse-application (unparsed rator rands sr package)
   (declare (type shadow-realm sr)

src/codegen/compile-expression.lisp

@@ -70,9 +70,17 @@
                           env))
 
   (:method ((expr typed-node-lisp) ctx env)
-    (if *emit-type-annotations*
-        `(the (values ,(lisp-type expr) &optional) ,(typed-node-lisp-form expr))
-        (typed-node-lisp-form expr)))
+    (let ((inner
+	    (if *emit-type-annotations*
+		`(the (values ,(lisp-type expr) &optional) ,(typed-node-lisp-form expr))
+		(typed-node-lisp-form expr))))
+      (if (typed-node-lisp-variables expr)
+	  `(let ,(mapcar
+		  (lambda (vars)
+		    (list (car vars) (cdr vars)))
+		  (typed-node-lisp-variables expr))
+	     ,inner)
+	  inner)))
 
   (:method ((expr typed-node-match) ctx env)
     (let ((subexpr (compile-expression (typed-node-match-expr expr) ctx env))
@@ -86,8 +94,7 @@
          ;; information. The pattern exhastiveness checks should
          ;; make it so this should never be hit and this allows us
          ;; to avoid bloat with error allocations.
-	 ,@branches (_ (error "Pattern match not exaustive error")))
-      ))
+	 ,@branches (_ (error "Pattern match not exaustive error")))))
 
   (:method ((expr typed-node-seq) ctx env)
     `(progn ,@(mapcar (lambda (subnode)

src/faux-macros.lisp

@@ -49,5 +49,5 @@
 (define-coalton-editor-macro coalton:let (bindings &body form)
   "A lexical LET binding.")
 
-(define-coalton-editor-macro coalton:lisp (type &body lisp-expr)
+(define-coalton-editor-macro coalton:lisp (type vars &body lisp-expr)
   "An escape from Coalton into the Lisp world.")

src/library/builtin.lisp

@@ -11,18 +11,18 @@
 
   (define-instance (Show Int)
     (define (show x)
-      (lisp String (cl:write-to-string x))))
+      (lisp String (x) (cl:write-to-string x))))
 
   (define-instance (Eq Int)
     (define (== a b)
-      (lisp Boolean
+      (lisp Boolean (a b)
         (to-boolean (cl:= a b))))
     (define (/= a b)
       (not (== a b))))
 
   (define-instance (Ord Int)
       (define (<=> a b)
-        (lisp Ord
+        (lisp Ord (a b)
           (cl:cond
             ((cl:< a b)
              LT)
@@ -33,36 +33,36 @@
 
   (define-instance (Num Int)
     (define (+ a b)
-      (lisp Int (cl:+ a b)))
+      (lisp Int (a b) (cl:+ a b)))
     (define (- a b)
-      (lisp Int (cl:- a b)))
+      (lisp Int (a b) (cl:- a b)))
     (define (* a b)
-      (lisp Int (cl:* a b)))
+      (lisp Int (a b) (cl:* a b)))
     (define (fromInt x) x))
 
   (declare expt (Int -> Int -> Int))
   (define (expt base power)
-    (lisp Int (cl:expt base power)))
+    (lisp Int (base power) (cl:expt base power)))
 
   (declare mod (Int -> Int -> Int))
   (define (mod num base)
-    (lisp Int (cl:mod num base)))
+    (lisp Int (num base) (cl:mod num base)))
 
   (declare even (Int ->  Boolean))
   (define (even n)
-    (lisp Boolean (to-boolean (cl:evenp n))))
+    (lisp Boolean (n) (to-boolean (cl:evenp n))))
 
   (declare odd (Int -> Boolean))
   (define (odd n)
-    (lisp Boolean (to-boolean (cl:oddp n))))
+    (lisp Boolean (n) (to-boolean (cl:oddp n))))
 
   (declare gcd (Int -> Int -> Int))
   (define (gcd a b)
-    (lisp Int (cl:gcd a b)))
+    (lisp Int (a b) (cl:gcd a b)))
 
   (declare lcm (Int -> Int -> Int))
   (define (lcm a b)
-    (lisp Int (cl:lcm a b)))
+    (lisp Int (a b) (cl:lcm a b)))
 
 
   ;;
@@ -71,15 +71,15 @@
 
   (define-instance (Eq Char)
     (define (== x y)
-      (lisp Boolean (to-boolean (cl:char= x y))))
+      (lisp Boolean (x y) (to-boolean (cl:char= x y))))
     (define (/= x y)
       (not (== x y))))
 
   (define-instance (Ord Char)
     (define (<=> x y)
       (if (== x y)
           EQ
-          (if (lisp Boolean (to-boolean (cl:char> x y)))
+          (if (lisp Boolean (x y) (to-boolean (cl:char> x y)))
               GT
               LT))))
 
@@ -90,7 +90,6 @@
 
   (define-instance (Eq String)
     (define (== s1 s2)
-      (lisp Boolean (to-boolean (cl:string= s1 s2))))
+      (lisp Boolean (s1 s2) (to-boolean (cl:string= s1 s2))))
     (define (/= s1 s2)
-      (not (== s1 s2))))
-  )
+      (not (== s1 s2)))))

src/library/functions.lisp

@@ -4,7 +4,7 @@
 
   (declare error (String -> :a))
   (define (error str)
-    (lisp :a (cl:error str)))
+    (lisp :a (str) (cl:error str)))
 
   ;;
   ;; Function combinators

src/library/macros.lisp

@@ -11,7 +11,7 @@
                 (cl:if (cl:null (cl:cdr exprs))
                        `(coalton:if ,(cl:caar exprs)
                                     ,(cl:cadar exprs)
-                                    (lisp :a (cl:error "Non-exhaustive COND")))
+                                    (lisp :a ()  (cl:error "Non-exhaustive COND")))
                        `(coalton:if ,(cl:caar exprs)
                                     ,(cl:cadar exprs)
                                     ,(build-calls (cl:cdr exprs))))))

src/library/optional.lisp

@@ -11,18 +11,18 @@
   (define (fromSome str opt)
     (match opt
       ((Some x) x)
-      ((None) (lisp :a (cl:error str)))))
+      ((None) (lisp :a (str) (cl:error str)))))
 
   (declare isSome ((Optional :a) -> Boolean))
   (define (isSome x)
-    (lisp Boolean
+    (lisp Boolean (x)
       (cl:etypecase x
         (Optional/Some True)
 	(Optional/None False))))
 
   (declare isNone ((Optional :a) -> Boolean))
   (define (isNone x)
-    (lisp Boolean
+    (lisp Boolean (x)
       (cl:etypecase x
 	(Optional/None True)
 	(Optional/Some False))))

src/library/result.lisp

@@ -11,14 +11,14 @@
 
   (declare isOk ((Result :a :b) -> Boolean))
   (define (isOk x)
-    (lisp Boolean
+    (lisp Boolean (x)
       (cl:etypecase x
 	(Result/Ok True)
 	(Result/Err False))))
 
   (declare isErr ((Result :a :b) -> Boolean))
   (define (isErr x)
-    (lisp Boolean
+    (lisp Boolean (x)
       (cl:etypecase x
 	(Result/Err True)
 	(Result/Ok False))))

src/library/string.lisp

@@ -7,19 +7,19 @@
 
   (declare concat-string (String -> String -> String))
   (define (concat-string str1 str2)
-    (lisp String
+    (lisp String (str1 str2)
       (cl:concatenate 'cl:string str1 str2)))
 
   (declare unpack-string (String -> (List Char)))
   (define (unpack-string str)
-    (lisp (List Char)
+    (lisp (List Char) (str)
       (cl:reduce
        (cl:lambda (x xs) (Cons x xs))
        (cl:coerce str 'cl:list) :from-end cl:t :initial-value Nil)))
 
   (declare pack-string ((List Char) -> String))
   (define (pack-string xs)
-    (lisp String
+    (lisp String (xs)
       (cl:labels ((f (xs)
                     (cl:if (cl:typep xs 'List/Nil)
                            ""
@@ -32,7 +32,7 @@
 
   (declare parse-int (String -> (Optional Int)))
   (define (parse-int str)
-    (lisp (Optional Int)
+    (lisp (Optional Int) (str)
       (cl:let ((x (cl:parse-integer str :junk-allowed cl:t)))
 	(cl:if x
 	       (Some x)
@@ -43,17 +43,17 @@
 
   (define-instance (Eq String)
     (define (== a b)
-      (lisp Boolean (to-boolean (cl:string= a b))))
+      (lisp Boolean (a b) (to-boolean (cl:string= a b))))
     (define (/= a b)
       (not (== a b))))
 
   (define-instance (Ord String)
     (define (<=> a b)
-      (lisp Ord
-	(cl:cond
-	  ((cl:string> a b) GT)
-	  ((cl:string< a b) LT)
-	  (cl:t EQ)))))
+      (lisp Ord (a b)
+	 (cl:cond
+	   ((cl:string> a b) GT)
+	   ((cl:string< a b) LT)
+	   (cl:t EQ)))))
 
   (define-instance (Semigroup String)
     (define (<> a b) (concat-string a b)))