unified loop with named-loop, break with break-from; continue labels

src/codegen/ast.lisp

@@ -71,17 +71,13 @@
    #: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-loop-label                    ; ACCESSOR 
    #:node-break                         ; STRUCT
    #:make-node-break                    ; CONSTRUCTOR
-   #:node-break-from                    ; STRUCT
-   #:make-node-break-from               ; CONSTRUCTOR
-   #:node-break-from-label              ; ACCESSOR
+   #:node-break-label                   ; ACCESSOR
    #:node-continue                      ; STRUCT
    #:make-node-continue                 ; CONSTRUCTOR
+   #:node-continue-label                ; ACCESSOR
    #:node-seq                           ; STRUCT
    #:make-node-seq                      ; CONSTRUCTOR
    #:node-seq-nodes                     ; ACCESSOR
@@ -213,24 +209,18 @@ in the match."
   (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))
-
-(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."
+  "A labelled looping construct. Loops forever until broken out of by a
+call to (break)."
   (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))
+  (label (util:required 'label) :type (or null keyword) :read-only t))
 
 (defstruct (node-continue (:include node))
-  "A continue statment used to skip to the next iteration of a loop.")
+  "A continue statment used to skip to the next iteration of a loop."
+  (label (util:required 'label) :type (or null keyword) :read-only t))
 
 (defstruct (node-seq (:include node))
   "A series of statements to be executed sequentially"
@@ -416,24 +406,14 @@ 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)
 
-
-
   (:method ((node node-seq) &key variable-namespace-only)
     (declare (values parser:identifier-list &optional))
     (mapcan

src/codegen/codegen-expression.lisp

@@ -171,37 +171,30 @@
   (:method ((expr node-loop) current-function env)
     (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-label+
-             :while t 
-             :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)))
+    (let ((body-expr (codegen-expression (node-loop-body expr) current-function env))
+          (label (node-loop-label expr)))
       `(block ,+break-label+
-         (loop :named ,(node-named-loop-label expr)
-               :while t 
-               :do (block ,+continue-label+
-                     ,body-expr)))))
+         (loop ,@(when label (list :named label))
+               :do ,(if label
+                        `(tagbody ,label
+                            (block ,+continue-label+
+                              ,body-expr))
+                        `(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-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)))
+    (if (node-break-label expr)
+        `(return-from ,(node-break-label expr))
+        `(return-from ,+break-label+)))
 
   (:method ((expr node-continue) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
-    `(return-from ,+continue-label+))
+    (if (node-continue-label expr)
+        `(go ,(node-continue-label expr))
+        `(return-from ,+continue-label+)))
 
   (:method ((expr node-match) current-function env)
     (declare (type tc:environment env)

src/codegen/transformations.lisp

@@ -153,26 +153,14 @@
     (let ((node
             (make-node-loop
              :type tc:*unit-type*
+             :label (node-loop-label node)
              :body (traverse (node-loop-body node) funs bound-variables))))
       (call-if node :loop funs bound-variables)))
 
-  (:method ((node node-named-loop) funs bound-variables)
-    (declare (type util:symbol-list bound-variables))
-    (let ((node
-            (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-break) funs bound-variables)
     (declare (type util:symbol-list 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))

src/codegen/translate-expression.lisp

@@ -662,36 +662,24 @@ Returns a `node'.")
              (values node))
     (make-node-loop
      :type tc:*unit-type*
+     :label (tc:node-loop-label expr)
      :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
+    (make-node-break
      :type tc:*unit-type*
-     :label (tc:node-break-from-label expr)))
+     :label (tc:node-break-label expr)))
 
   (:method ((expr tc:node-continue) ctx env)
     (declare (type pred-context ctx)
              (type tc:environment env)
              (values node))
-    (make-node-continue :type tc:*unit-type*))
+    (make-node-continue
+     :type tc:*unit-type*
+     :label (tc:node-continue-label expr)))
 
   (:method ((expr tc:node-cond) ctx env)
     (declare (type pred-context ctx)

src/codegen/typecheck-node.lisp

@@ -136,21 +136,11 @@
              (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,9 +71,7 @@
    #:while
    #:while-let
    #:loop
-   #:named-loop
    #:break
-   #:break-from 
    #:continue
    #:for
    #:in                                 ; Syntax

src/parser/collect.lisp

@@ -251,18 +251,10 @@ 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))
     nil)