Adds while loops

Add while parser expression

implement renamer for while

Add while typechecker expression and impl infer-expression-type

while codegen

imple node-variables-g for node-while

src/codegen/ast.lisp

@@ -54,6 +54,10 @@
    #:make-node-match                    ; CONSTRUCTOR
    #:node-match-expr                    ; ACCESSOR
    #:node-match-branches                ; ACCESSOR
+   #:node-while                         ; STRUCT
+   #:make-node-while                    ; CONSTRUCTOR
+   #:node-while-expr                    ; ACCESSOR
+   #:node-while-body                    ; ACESSOR
    #:node-seq                           ; STRUCT
    #:make-node-seq                      ; CONSTRUCTOR
    #:node-seq-nodes                     ; ACCESSOR
@@ -165,6 +169,11 @@
   (expr (util:required 'expr) :type node :read-only t)
   (branches (util:required 'branches) :type branch-list :read-only t))
 
+(defstruct (node-while (:include node))
+  "A looping construct. Executes a body until an expression is false."
+  (expr (util:required 'expr) :type node :read-only t)
+  (body (util:required 'body) :type node :read-only t))
+
 (defstruct (node-seq (:include node))
   "A series of statements to be executed sequentially"
   (nodes (util:required 'nodes) :type node-list :read-only t))
@@ -329,6 +338,11 @@ both CL namespaces appearing in NODE"
         (node-variables-g node :variable-namespace-only variable-namespace-only))
       (node-match-branches node))))
 
+  (:method ((node node-while) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    (nconc (node-variables-g (node-while-expr node) :variable-namespace-only variable-namespace-only)
+           (node-variables-g (node-while-body node) :variable-namespace-only variable-namespace-only)))
+
   (:method ((node node-seq) &key variable-namespace-only)
     (declare (values parser:identifier-list &optional))
     (mapcan

src/codegen/codegen-expression.lisp

@@ -107,6 +107,15 @@
                 ,inner)
           inner)))
 
+  (:method ((expr node-while) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+
+    (let ((pred-expr (codegen-expression (node-while-expr expr) current-function env))
+          (body-expr (codegen-expression (node-while-body expr) current-function env)))
+      `(loop :while ,pred-expr
+             :do ,body-expr)))
+
   (:method ((expr node-match) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))

src/codegen/transformations.lisp

@@ -119,6 +119,15 @@
                         (node-match-branches node)))))
       (call-if node :match funs bound-variables)))
 
+  (:method ((node node-while) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (let ((node
+            (make-node-while
+             :type (node-type node)
+             :expr (traverse (node-while-expr node) funs bound-variables)
+             :body (traverse (node-while-body node) funs bound-variables))))
+      (call-if node :while funs bound-variables)))
+
   (:method ((node node-seq) funs bound-variables)
     (declare (type util:symbol-list bound-variables))
     (let ((node

src/codegen/translate-expression.lisp

@@ -550,6 +550,16 @@ Returns a `node'.")
                           :type tc:*unit-type*
                           :value unit-value))))))
 
+  (:method ((expr tc:node-while) ctx env)
+    (declare (type pred-context ctx)
+             (type tc:environment env)
+             (values node))
+
+    (make-node-while 
+     :type tc:*unit-type*
+     :expr (translate-expression (tc:node-while-expr expr) ctx env)
+     :body (translate-expression (tc:node-while-body expr) ctx env)))
+
   (:method ((expr tc:node-cond) ctx env)
     (declare (type pred-context ctx)
              (type tc:environment env)

src/package.lisp

@@ -73,6 +73,7 @@
   (:export
    #:if
    #:when
+   #:while
    #:unless
    #:and
    #:or

src/parser/expression.lisp

@@ -128,6 +128,10 @@
    #:node-do-body-element               ; TYPE
    #:node-body-element-list             ; TYPE
    #:node-do                            ; STRUCT
+   #:node-while                         ; STRUCT
+   #:make-node-while                    ; CONSTRUCTOR
+   #:node-while-expr                    ; ACCESSOR
+   #:node-while-body                    ; ACCESSOR
    #:make-node-do                       ; CONSTRUCTOR
    #:node-do-nodes                      ; ACCESSOR
    #:node-do-last-node                  ; ACCESSOR
@@ -462,6 +466,13 @@
   (nodes     (util:required 'nodes)     :type node-do-body-element-list :read-only t)
   (last-node (util:required 'last-node) :type node                      :read-only t))
 
+(defstruct (node-while
+            (:include node)
+            (:copier nil))
+  (expr (util:required 'expr) :type node      :read-only t)
+  (body (util:required 'body) :type node-body :read-only t))
+
+
 (defun parse-expression (form file)
   (declare (type cst:cst form)
            (type coalton-file file)
@@ -875,6 +886,10 @@
           (eq 'coalton:do (cst:raw (cst:first form))))
      (parse-do form file))
 
+    ((and (cst:atom (cst:first form))
+          (eq 'coalton:while (cst:raw (cst:first form))))
+     (parse-while form file))
+
     ;;
     ;; Macros
     ;;
@@ -1337,6 +1352,36 @@
 
   (parse-expression form file))
 
+(defun parse-while (form file)
+  (declare (type cst:cst form)
+           (type coalton-file file)
+           (values node-while))
+
+  ;; (while)
+  (unless (cst:consp (cst:rest form))
+    (error 'parse-error
+           :err (coalton-error
+                 :span (cst:source form)
+                 :file file
+                 :highlight :end
+                 :message "Malformed while expression"
+                 :primary-note "expected predicate")))
+
+  ;; (while pred)
+  (unless (cst:consp (cst:rest (cst:rest form)))
+    (error 'parse-error
+           :err (coalton-error
+                 :span (cst:source form)
+                 :file file
+                 :highlight :end
+                 :message "Malformed while expression"
+                 :primary-note "expected body")))
+
+  (make-node-while
+   :source (cst:source form)
+   :expr (parse-expression (cst:second form) file)
+   :body (parse-body (cst:rest (cst:rest form)) form file)))
+
 (defun parse-let-declare (form file)
   (declare (type cst:cst form)
            (type coalton-file file)

src/parser/renamer.lisp

@@ -279,6 +279,16 @@
       :source (node-source node))
      ctx))
 
+  (:method ((node node-while) ctx)
+    (declare (type algo:immutable-map ctx)
+             (values node algo:immutable-map))
+    (values
+     (make-node-while
+      :expr (rename-variables-generic% (node-while-expr node) ctx)
+      :body (rename-variables-generic% (node-while-body node) ctx)
+      :source (node-source node))
+     ctx))
+
   (:method ((node node-unless) ctx)
     (declare (type algo:immutable-map ctx)
              (values node algo:immutable-map))

src/typechecker/define.lisp

@@ -1221,6 +1221,53 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)")
                                                (tc:apply-substitution subs body-ty)
                                                (tc:apply-substitution subs expected-type)))))))))
 
+
+  (:method ((node parser:node-while) expected-type subs env file)
+    (declare (type tc:ty expected-type)
+             (type tc:substitution-list subs)
+             (type tc-env env)
+             (type coalton-file file)
+             (values tc:ty tc:ty-predicate-list accessor-list node-while tc:substitution-list))
+    (multiple-value-bind (expr-ty preds accessors expr-node subs)
+        (infer-expression-type (parser:node-while-expr node)
+                               tc:*boolean-type*
+                               subs
+                               env
+                               file)
+      (declare (ignore expr-ty))
+
+      (multiple-value-bind (body-ty preds_ accessors_ body-node subs)
+          (infer-expression-type (parser:node-while-body node)
+                                 tc:*unit-type*
+                                 subs
+                                 env
+                                 file)
+        (setf preds (append preds preds_))
+        (setf accessors (append accessors accessors_))
+
+        (handler-case
+            (progn
+              (setf subs (tc:unify subs body-ty expected-type))
+              (values
+               tc:*unit-type*
+               preds
+               accessors
+               (make-node-while
+                :type (tc:qualify nil tc:*unit-type*)
+                :source (parser:node-source node)
+                :expr expr-node
+                :body body-node)
+               subs))
+          (error:coalton-internal-type-error ()
+            (error 'tc-error
+                   :err (coalton-error
+                         :span (parser:node-source node)
+                         :file file
+                         :message "Type mismatch"
+                         :primary-note (format nil "Expected type '~S' but got '~S'"
+                                               (tc:apply-substitution subs body-ty)
+                                               (tc:apply-substitution subs expected-type)))))))))
+
   (:method ((node parser:node-cond-clause) expected-type subs env file)
     (declare (type tc:ty expected-type)
              (type tc:substitution-list subs)

src/typechecker/expression.lisp

@@ -111,6 +111,10 @@
    #:make-node-unless                   ; CONSTRUCTOR
    #:node-unless-expr                   ; ACCESSOR
    #:node-unless-body                   ; ACCESSOR
+   #:node-while                         ; STRUCT
+   #:make-node-while                    ; CONSTRUCTOR
+   #:node-while-expr                    ; ACCESSOR
+   #:node-while-body                    ; ACCESSOR
    #:node-cond-clause                   ; STRUCT
    #:make-node-cond-clause              ; CONSTRUCTOR
    #:node-cond-clause-expr              ; ACCESSOR
@@ -302,6 +306,12 @@
   (expr (util:required 'expr) :type node      :read-only t)
   (body (util:required 'body) :type node-body :read-only t))
 
+(defstruct (node-while
+            (:include node)
+            (:copier nil))
+  (expr (util:required 'expr) :type node      :read-only t)
+  (body (util:required 'body) :type node-body :read-only t))
+
 (defstruct (node-cond-clause
             (:copier nil))
   (expr   (util:required 'expr)   :type node      :read-only t)
@@ -518,6 +528,15 @@
    :expr (tc:apply-substitution subs (node-unless-expr node))
    :body (tc:apply-substitution subs (node-unless-body node))))
 
+(defmethod tc:apply-substitution (subs (node node-while))
+  (declare (type tc:substitution-list subs)
+           (values node-while))
+  (make-node-while
+   :type (tc:apply-substitution subs (node-type node))
+   :source (node-source node)
+   :expr (tc:apply-substitution subs (node-while-expr node))
+   :body (tc:apply-substitution subs (node-while-body node))))
+
 (defmethod tc:apply-substitution (subs (node node-cond-clause))
   (declare (type tc:substitution-list subs)
            (values node-cond-clause))