Add labelled loops

src/codegen/ast.lisp

@@ -63,16 +63,23 @@
    #: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-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
+   #:node-named-loop                    ; STRUCT
+   #:make-node-named-loop               ; CONSTRUCTOR
+   #:node-named-loop-label              ; ACCESSOR
+   #:node-named-loop-body               ; ACCESSOR
    #:node-break                         ; STRUCT
    #:make-node-break                    ; CONSTRUCTOR
+   #:node-break-from                    ; STRUCT
+   #:make-node-break-from               ; CONSTRUCTOR
+   #:node-break-from-label              ; ACCESSOR
    #:node-continue                      ; STRUCT
    #:make-node-continue                 ; CONSTRUCTOR
    #:node-seq                           ; STRUCT
@@ -209,9 +216,19 @@ in the match."
   "A looping construct. Loops forever until (break)."
   (body (util:required 'body) :type node :read-only t))
 
+(defstruct (node-named-loop (:include node))
+  "A labelled looping construct. Loops forever until (break)
+or (break-from label) appears where LABEL matchies this node's label."
+  (label (util:required 'label) :type keyword :read-only t)
+  (body  (util:required 'body)  :type node    :read-only t))
+
 (defstruct (node-break (:include node))
   "A break statment used to exit a loop.")
 
+(defstruct (node-break-from (:include node))
+  "A break statment used to exit a loop."
+  (label (util:required 'label) :type keyword :read-only t))
+
 (defstruct (node-continue (:include node))
   "A continue statment used to skip to the next iteration of a loop.")
 
@@ -399,10 +416,18 @@ both CL namespaces appearing in NODE"
     (declare (values parser:identifier-list &optional))
     (node-variables-g (node-loop-body node) :variable-namespace-only variable-namespace-only))
 
+  (:method ((node node-named-loop) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    (node-variables-g (node-named-loop-body node) :variable-namespace-only variable-namespace-only))
+
   (:method ((node node-break) &key variable-namespace-only)
     (declare (values parser:identifier-list &optional))
     nil)
 
+  (:method ((node node-break-from) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    nil)
+
   (:method ((node node-continue) &key variable-namespace-only)
     (declare (values parser:identifier-list &optional))
     nil)

src/codegen/codegen-expression.lisp

@@ -20,6 +20,9 @@
 
 (in-package #:coalton-impl/codegen/codegen-expression)
 
+(defconstant +break-label+ '%break)
+(defconstant +continue-label+ '%continue)
+
 (defgeneric codegen-expression (node current-function env)
   (:method ((node node-literal) current-function env)
     (declare (type tc:environment env)
@@ -114,9 +117,9 @@
     (let ((pred-expr (codegen-expression (node-while-expr expr) current-function env))
           (body-expr (codegen-expression (node-while-body expr) current-function env)))
       `(loop
-         :named :break
+         :named ,+break-label+ 
          :while ,pred-expr
-         :do (block :continue ,body-expr))))
+         :do (block ,+continue-label+ ,body-expr))))
 
   (:method ((expr node-while-let) current-function env)
     (declare (type tc:environment env)
@@ -129,12 +132,12 @@
       (multiple-value-bind (pred bindings)
           (codegen-pattern (node-while-let-pattern expr) match-var env)
         `(loop
-           :named :break
+           :named 
            :for ,match-var := ,(if settings:*emit-type-annotations*
                                    `(the ,(tc:lisp-type (node-type (node-while-let-expr expr)) env) ,match-expr)
                                    match-expr)
            :while ,pred
-           :do (block :continue
+           :do (block ,+continue-label+
                  ,(cond ((null bindings) body-expr)
                         (t `(let ,bindings
                               (declare (ignorable ,@(mapcar #'car bindings)))
@@ -155,11 +158,11 @@
           (codegen-pattern (node-for-pattern expr) match-var env)
 
         `(loop
-           :named :break
+           :named ,+break-label+
            :with ,iter-var := ,iter-expr
            :for ,match-var := (,next! ,iter-var)
            :while ,pred
-           :do (block :continue
+           :do (block ,+continue-label+
                  ,(cond ((null bindings) body-expr)
                         (t `(let ,bindings
                               (declare (ignorable ,@(mapcar #'car bindings)))
@@ -169,20 +172,36 @@
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
     (let ((body-expr (codegen-expression (node-loop-body expr) current-function env)))
-      `(loop :named :break
+      `(loop :named ,+break-label+
              :while t 
-             :do (block :continue
+             :do (block ,+continue-label+
                    ,body-expr))))
 
+
+  (:method ((expr node-named-loop) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+    (let ((body-expr (codegen-expression (node-named-loop-body expr) current-function env)))
+      `(block ,+break-label+
+         (loop :named ,(node-named-loop-label expr)
+               :while t 
+               :do (block ,+continue-label+
+                     ,body-expr)))))
+
   (:method ((expr node-break) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
-    '(return-from :break))
+    `(return-from ,+break-label+))
+
+  (:method ((expr node-break-from) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+    `(return-from ,(node-break-from-label expr)))
 
   (:method ((expr node-continue) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
-    '(return-from :continue))
+    `(return-from ,+continue-label+))
 
   (:method ((expr node-match) current-function env)
     (declare (type tc:environment env)

src/codegen/transformations.lisp

@@ -156,21 +156,26 @@
              :body (traverse (node-loop-body node) funs bound-variables))))
       (call-if node :loop funs bound-variables)))
 
-  (:method ((node node-break) funs bound-variables)
+  (:method ((node node-named-loop) funs bound-variables)
     (declare (type util:symbol-list bound-variables))
     (let ((node
-            (make-node-break 
-             :type tc:*unit-type*)))
-      (call-if node :break funs bound-variables)))
+            (make-node-named-loop
+             :type tc:*unit-type*
+             :label (node-named-loop-label node)
+             :body (traverse (node-named-loop-body node) funs bound-variables))))
+      (call-if node :loop funs bound-variables)))
 
-  (:method ((node node-continue) funs bound-variables)
+  (:method ((node node-break) funs bound-variables)
     (declare (type util:symbol-list bound-variables))
-    (let ((node
-            (make-node-continue
-             :type tc:*unit-type*)))
-      (call-if node :continue funs bound-variables)))
+    (call-if node :break funs bound-variables))
 
+  (:method ((node node-break-from) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (call-if node :break-from funs bound-variables))
 
+  (:method ((node node-continue) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (call-if node :continue funs bound-variables))
 
   (:method ((node node-seq) funs bound-variables)
     (declare (type util:symbol-list bound-variables))

src/codegen/translate-expression.lisp

@@ -664,12 +664,29 @@ Returns a `node'.")
      :type tc:*unit-type*
      :body (translate-expression (tc:node-loop-body expr) ctx env)))
 
+  (:method ((expr tc:node-named-loop) ctx env)
+    (declare (type pred-context ctx)
+             (type tc:environment env)
+             (values node))
+    (make-node-named-loop
+     :type tc:*unit-type*
+     :label (tc:node-named-loop-label expr)
+     :body (translate-expression (tc:node-named-loop-body expr) ctx env)))
+
   (:method ((expr tc:node-break) ctx env)
     (declare (type pred-context ctx)
              (type tc:environment env)
              (values node))
     (make-node-break :type tc:*unit-type*))
 
+  (:method ((expr tc:node-break-from) ctx env)
+    (declare (type pred-context ctx)
+             (type tc:environment env)
+             (values node))
+    (make-node-break-from
+     :type tc:*unit-type*
+     :label (tc:node-break-from-label expr)))
+
   (:method ((expr tc:node-continue) ctx env)
     (declare (type pred-context ctx)
              (type tc:environment env)

src/codegen/typecheck-node.lisp

@@ -136,11 +136,21 @@
              (values tc:ty))
     (typecheck-node (node-loop-body expr) env))
 
+  (:method ((expr node-named-loop) env)
+    (declare (type tc:environment env)
+             (values tc:ty))
+    (typecheck-node (node-named-loop-body expr) env))
+
   (:method ((expr node-break) env)
     (declare (type tc:environment env)
              (values tc:ty))
     tc:*unit-type*)
 
+  (:method ((expr node-break-from) env)
+    (declare (type tc:environment env)
+             (values tc:ty))
+    tc:*unit-type*)
+
   (:method ((expr node-continue) env)
     (declare (type tc:environment env)
              (values tc:ty))

src/package.lisp

@@ -71,7 +71,9 @@
    #:while
    #:while-let
    #:loop
+   #:named-loop
    #:break
+   #:break-from 
    #:continue
    #:for
    #:in                                 ; Syntax

src/parser/collect.lisp

@@ -251,9 +251,17 @@ in expressions. May not include all bound variables."
     (declare (values node-variable-list))
     (collect-variables-generic% (node-loop-body node)))
 
+  (:method ((node node-named-loop))
+    (declare (values node-variable-list))
+    (collect-variables-generic% (node-named-loop-body node)))
+
   (:method ((node node-break))
     (declare (values node-variable-list &optional))
     nil)
+
+  (:method ((node node-break-from))
+    (declare (values node-variable-list &optional))
+    nil)
 
   (:method ((node node-continue))
     (declare (values node-variable-list &optional))