for loops

src/codegen/ast.lisp

@@ -63,6 +63,11 @@
    #:node-while-let-pattern             ; ACCESSPR 
    #:node-while-let-expr                ; ACCESSOR
    #:node-while-let-body                ; ACESSOR
+   #:node-for                     ; STRUCT
+   #:make-node-for                ; CONSTRUCTOR
+   #:node-for-pattern             ; ACCESSPR 
+   #:node-for-iter                ; ACCESSOR
+   #:node-for-body                ; ACESSOR
    #:node-loop                          ; STRUCT
    #:make-node-loop                     ; CONSTRUCTOR
    #:node-loop-body                     ; ACCESSOR
@@ -192,6 +197,14 @@
   (expr     (util:required  'expr)     :type  node     :read-only  t)
   (body     (util:required  'body)     :type  node     :read-only  t))
 
+(defstruct (node-for (:include node))
+  "A looping construct. Consumes an iterator, matching a pattern against
+its elements, and executes body in the context of any variables bond
+in the match."
+  (pattern  (util:required  'pattern)  :type  pattern  :read-only  t)
+  (iter     (util:required  'iter)     :type  node     :read-only  t)
+  (body     (util:required  'body)     :type  node     :read-only  t))
+
 (defstruct (node-loop (:include node))
   "A looping construct. Loops forever until (break)."
   (body (util:required 'body) :type node :read-only t))
@@ -375,6 +388,11 @@ both CL namespaces appearing in NODE"
     (declare (values parser:identifier-list &optional))
     (nconc (node-variables-g (node-while-let-expr node) :variable-namespace-only variable-namespace-only)
            (node-variables-g (node-while-let-body node) :variable-namespace-only variable-namespace-only)))
+
+  (:method ((node node-for) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    (nconc (node-variables-g (node-for-iter node) :variable-namespace-only variable-namespace-only)
+           (node-variables-g (node-for-body node) :variable-namespace-only variable-namespace-only)))
 
 
   (:method ((node node-loop) &key variable-namespace-only)

src/codegen/codegen-expression.lisp

@@ -128,7 +128,6 @@
 
       (multiple-value-bind (pred bindings)
           (codegen-pattern (node-while-let-pattern expr) match-var env)
-
         `(loop
            :named :break
            :for ,match-var := ,(if settings:*emit-type-annotations*
@@ -140,6 +139,31 @@
                         (t `(let ,bindings
                               (declare (ignorable ,@(mapcar #'car bindings)))
                               ,body-expr))))))))
+
+
+  (:method ((expr node-for) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+
+    (let ((body-expr (codegen-expression (node-for-body expr) current-function env))
+          (iter-expr (codegen-expression (node-for-iter expr) current-function env))
+          (iter-var (gensym "ITERATOR"))
+          (match-var (gensym "MATCH"))
+          (next! (util:find-symbol "NEXT!" (find-package "COALTON-LIBRARY/ITERATOR"))))
+
+      (multiple-value-bind (pred bindings)
+          (codegen-pattern (node-for-pattern expr) match-var env)
+
+        `(loop
+           :named :break
+           :with ,iter-var := ,iter-expr
+           :for ,match-var := (,next! ,iter-var)
+           :while ,pred
+           :do (block :continue
+                 ,(cond ((null bindings) body-expr)
+                        (t `(let ,bindings
+                              (declare (ignorable ,@(mapcar #'car bindings)))
+                              ,body-expr))))))))
 
   (:method ((expr node-loop) current-function env)
     (declare (type tc:environment env)

src/codegen/pattern.lisp

@@ -6,7 +6,8 @@
    (#:tc #:coalton-impl/typechecker))
   (:export
    #:pattern                            ; STRUCT
-   #:pattern-source                     ; ACCESSOR
+   #:pattern-source                     ; ACCESSOR THIS DOESN'T SEEM TO EXIST
+   #:pattern-type                       ; ACCESSOR
    #:pattern-list                       ; TYPE
    #:pattern-var                        ; STRUCT
    #:make-pattern-var                   ; ACCESSOR

src/codegen/transformations.lisp

@@ -137,6 +137,16 @@
              :expr (traverse (node-while-let-expr node) funs bound-variables)
              :body (traverse (node-while-let-body node) funs bound-variables))))
       (call-if node :while-let funs bound-variables)))
+
+  (:method ((node node-for) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (let ((node
+            (make-node-for
+             :type tc:*unit-type*
+             :pattern (node-for-pattern node)
+             :iter (traverse (node-for-iter node) funs bound-variables)
+             :body (traverse (node-for-body node) funs bound-variables))))
+      (call-if node :for funs bound-variables)))
 
   (:method ((node node-loop) funs bound-variables)
     (declare (type util:symbol-list bound-variables))

src/codegen/translate-expression.lisp

@@ -141,7 +141,8 @@ Returns a `node'.")
 
              (num-class (util:find-symbol "NUM" classes-package))
 
-             (num-pred (tc:make-ty-predicate :class num-class :types (list (tc:qualified-ty-type qual-ty))))
+             (num-pred (tc:make-ty-predicate :class num-class
+                                             :types (list (tc:qualified-ty-type qual-ty))))
 
              (from-int-method (util:find-symbol "FROMINT" classes-package)))
 
@@ -570,6 +571,91 @@ Returns a `node'.")
      :expr (translate-expression (tc:node-while-let-expr expr) ctx env)
      :body (translate-expression (tc:node-while-let-body expr) ctx env)))
 
+  (:method ((expr tc:node-for) ctx env)
+    (declare (type pred-context ctx)
+             (type tc:environment env)
+             (values node))
+    ;; to translate a tc:node-for into a node-for we need to
+
+    ;; 1) node-for-pattern -> (Some node-for-pattern)
+    ;; 2) node-for-expr    -> (into-iter node-for-expr)
+
+    (let* ((pat-arg
+             (translate-pattern (tc:node-for-pattern expr)))
+
+           (pat-arg-ty
+             (pattern-type pat-arg))
+
+           (classes-package
+             (find-package "COALTON-LIBRARY/CLASSES"))
+
+           (some
+             (util:find-symbol "SOME" classes-package))
+
+           (optional
+             (util:find-symbol "OPTIONAL" classes-package))
+
+           (optional-pat-arg-ty
+             (tc:apply-type-argument
+              (tc:make-tycon :name optional
+                             :kind (tc:make-kfun :from tc:+kstar+ :to tc:+kstar+))
+              pat-arg-ty))
+
+           (some-pattern
+             (make-pattern-constructor
+              :type optional-pat-arg-ty
+              :name some
+              :patterns (list pat-arg)))
+
+           (into-iter-arg
+             (translate-expression (tc:node-for-expr expr) ctx env))
+
+           (into-iter-arg-ty
+             (node-type into-iter-arg))
+
+           (iterator-package
+             (find-package "COALTON-LIBRARY/ITERATOR"))
+
+           (into-iter-method
+             (util:find-symbol "INTO-ITER" iterator-package))
+
+           (intoiter-class
+             (util:find-symbol "INTOITERATOR" iterator-package))
+
+           (iterator
+             (util:find-symbol "ITERATOR" iterator-package))
+
+           (iter-ty
+             (tc:apply-type-argument
+              (tc:make-tycon :name iterator
+                             :kind (tc:make-kfun :from tc:+kstar+ :to tc:+kstar+))
+              into-iter-arg-ty))
+
+           (intoiterator-pred
+             (tc:make-ty-predicate
+              :class intoiter-class
+              :types (list into-iter-arg-ty pat-arg-ty)
+              :source (tc:node-source expr)))
+
+           (into-iter-node
+             (make-node-application
+              :type optional-pat-arg-ty
+              :rator (make-node-variable
+                      :type (tc:make-function-type*
+                             (list (pred-type intoiterator-pred env)
+                                   (node-type into-iter-arg))
+                             iter-ty)
+                      :value into-iter-method)
+              :rands (list
+                      (resolve-dict intoiterator-pred ctx env)
+                      into-iter-arg))))
+
+      (make-node-for
+       :type tc:*unit-type*
+       :pattern some-pattern
+       :iter into-iter-node
+       :body (translate-expression (tc:node-for-body expr) ctx env))))
+
   (:method ((expr tc:node-loop) ctx env)
     (declare (type pred-context ctx)
              (type tc:environment env)

src/package.lisp

@@ -73,6 +73,8 @@
    #:loop
    #:break
    #:continue
+   #:for
+   #:in                                 ; Syntax
    )
 
   ;; Macros

src/parser/expression.lisp

@@ -143,6 +143,11 @@
    #:node-break                         ; STRUCT
    #:make-node-break                    ; CONSTRUCTOR
    #:node-continue                      ; STRUCT
+   #:node-for                           ; STRUCT
+   #:make-node-for                      ; CONSTRUCTOR
+   #:node-for-pattern                   ; ACCESSOR
+   #:node-for-expr                      ; ACCESSOR
+   #:node-for-body                      ; ACCESSOR
    #:make-node-continue                 ; CONSTRUCTOR
    #:make-node-do                       ; CONSTRUCTOR
    #:node-do-nodes                      ; ACCESSOR
@@ -510,6 +515,13 @@
             (:include node)
             (:copier nil)))
 
+(defstruct (node-for
+            (:include node)
+            (:copier nil))
+  (pattern        (util:required 'pattern)       :type pattern   :read-only t)
+  (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)
@@ -980,6 +992,12 @@
 
      (make-node-continue :source (cst:source form)))
 
+    ((and (cst:atom (cst:first form))
+          (eq 'coalton:for (cst:raw (cst:first form))))
+     (let ((*continuable-loop-context* t)
+           (*breakable-loop-context* t))
+       (parse-for form file)))
+
     ;;
     ;; Macros
     ;;
@@ -1487,17 +1505,18 @@
 
     ;; (while-let)
     (unless (cst:consp (cst:nthrest 1 form))
-      (while-let-error "expected match pattern")) 
+      (while-let-error "expected pattern")) 
 
-    ;; (while-let expr)
-    (unless (cst:consp (cst:nthrest 2 form))
+    ;; (while-let pattern)
+    (unless (and (cst:consp (cst:nthrest 2 form))
+                 (eq 'coalton:= (cst:raw (cst:nth 2 form))))
       (while-let-error "expected ="))
 
-    ;; (when-let expr =)
+    ;; (when-let pattern =)
     (unless (cst:consp (cst:nthrest 3 form))
-      (while-let-error "expected match expression"))
+      (while-let-error "expected expression"))
 
-    ;; (when-let expr = pattern)
+    ;; (when-let pattern = expr)
     (unless (cst:consp (cst:nthrest 4 form))
       (while-let-error "exptected body")))
 
@@ -1507,6 +1526,43 @@
    :expr (parse-expression (cst:fourth form) file)
    :body (parse-body (cst:nthrest 4 form) form  file)))
 
+(defun parse-for (form file)
+  (declare (type cst:cst form)
+           (type coalton-file file)
+           (values node-for))
+  (macrolet ((for-error (note)
+               `(error 'parse-error
+                       :err (coalton-error
+                             :span (cst:source form)
+                             :file file
+                             :highlight :end
+                             :message "Malformed for expression"
+                             :primary-note ,note))))
+
+    ;; (for)
+    (unless (cst:consp (cst:nthrest 1 form))
+      (for-error "expected pattern")) 
+
+    ;; (for pattern)
+    (unless (and (cst:consp (cst:nthrest 2 form))
+                 (eq 'coalton:in (cst:raw (cst:nth 2 form))))
+      (for-error "expected in"))
+
+    ;; (for pattern in)
+    (unless (cst:consp (cst:nthrest 3 form))
+      (for-error "expected expression"))
+
+    ;; (for pattern in expr)
+    (unless (cst:consp (cst:nthrest 4 form))
+      (for-error "exptected body")))
+
+  (make-node-for
+   :source (cst:source form)
+   :pattern (parse-pattern (cst:second form) file) 
+   :expr (parse-expression (cst:fourth form) file)
+   :body (parse-body (cst:nthrest 4 form) form  file)))
+
+
 (defun parse-let-declare (form file)
   (declare (type cst:cst form)
            (type coalton-file file)

src/parser/renamer.lisp

@@ -300,6 +300,17 @@
       :source (node-source node))
      ctx))
 
+  (:method ((node node-for) ctx)
+    (declare (type algo:immutable-map ctx)
+             (values node algo:immutable-map))
+    (values
+     (make-node-for
+      :pattern (rename-variables-generic% (node-for-pattern node) ctx)
+      :expr (rename-variables-generic% (node-for-expr node) ctx)
+      :body (rename-variables-generic% (node-for-body node) ctx)
+      :source (node-source node))
+     ctx))
+
   (:method ((node node-loop) ctx)
     (declare (type algo:immutable-map ctx)
              (values node algo:immutable-map))