From e3aba9aba4ca0ab8fabf53429c62a1cfedf1f526 Mon Sep 17 00:00:00 2001 From: "O'Keefe, Colin B" Date: Tue, 19 Sep 2023 13:50:42 -0700 Subject: [PATCH] unified loop with named-loop, break with break-from; continue labels --- src/codegen/ast.lisp | 36 +- src/codegen/codegen-expression.lisp | 37 +- src/codegen/transformations.lisp | 14 +- src/codegen/translate-expression.lisp | 24 +- src/codegen/typecheck-node.lisp | 10 - src/package.lisp | 2 - src/parser/collect.lisp | 8 - src/parser/expression.lisp | 430 +++++++++----------- src/parser/renamer.lisp | 21 +- src/typechecker/define.lisp | 59 +-- src/typechecker/expression.lisp | 41 +- src/typechecker/traverse.lisp | 23 +- tests/looping-native-tests.lisp | 49 +++ tests/looping-tests.lisp | 49 +-- tests/parser/parse-break-from.1.bad.coalton | 4 - tests/parser/parse-break-from.2.bad.coalton | 4 - tests/parser/parse-break-from.3.bad.coalton | 4 - tests/parser/parse-break-from.4.bad.coalton | 9 - tests/parser/parse-break-from.good.coalton | 9 - tests/parser/parse-break.good.coalton | 4 +- tests/parser/parse-continue.good.coalton | 4 +- tests/parser/parse-named-loop.1.bad.coalton | 4 - tests/parser/parse-named-loop.2.bad.coalton | 4 - 23 files changed, 291 insertions(+), 558 deletions(-) create mode 100644 tests/looping-native-tests.lisp delete mode 100644 tests/parser/parse-break-from.1.bad.coalton delete mode 100644 tests/parser/parse-break-from.2.bad.coalton delete mode 100644 tests/parser/parse-break-from.3.bad.coalton delete mode 100644 tests/parser/parse-break-from.4.bad.coalton delete mode 100644 tests/parser/parse-break-from.good.coalton delete mode 100644 tests/parser/parse-named-loop.1.bad.coalton delete mode 100644 tests/parser/parse-named-loop.2.bad.coalton diff --git a/src/codegen/ast.lisp b/src/codegen/ast.lisp index ac1bfb335..6c9d9e3cd 100644 --- a/src/codegen/ast.lisp +++ b/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 diff --git a/src/codegen/codegen-expression.lisp b/src/codegen/codegen-expression.lisp index 7f360d13b..152e4f297 100644 --- a/src/codegen/codegen-expression.lisp +++ b/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) diff --git a/src/codegen/transformations.lisp b/src/codegen/transformations.lisp index e9f849f55..ec130ea4f 100644 --- a/src/codegen/transformations.lisp +++ b/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)) diff --git a/src/codegen/translate-expression.lisp b/src/codegen/translate-expression.lisp index bf7f39b22..c65b8bdb4 100644 --- a/src/codegen/translate-expression.lisp +++ b/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) diff --git a/src/codegen/typecheck-node.lisp b/src/codegen/typecheck-node.lisp index f0a437794..2a9b0e3b6 100644 --- a/src/codegen/typecheck-node.lisp +++ b/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)) diff --git a/src/package.lisp b/src/package.lisp index 1b1f78c07..400d22312 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -71,9 +71,7 @@ #:while #:while-let #:loop - #:named-loop #:break - #:break-from #:continue #:for #:in ; Syntax diff --git a/src/parser/collect.lisp b/src/parser/collect.lisp index a24a119e8..d58a0f971 100644 --- a/src/parser/collect.lisp +++ b/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) diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index 3a41f6405..84b907442 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -140,22 +140,18 @@ #: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-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 #:node-do-last-node ; ACCESSOR @@ -168,16 +164,13 @@ (defvar *macro-expansion-count* 0) -(defvar *breakable-loop-context* nil - "Indicates whether (BREAK) is a valid expression.") +(defvar *escapable-loop-context* nil + "Indicates whether (BREAK) or (CONTINUE) are valid expressions.") -(defvar *continuable-loop-context* nil - "Indicates whether (CONTINUE) is a valid expression.") - -(defvar *breakable-from-loop-context* nil +(defvar *loop-label-context* nil "A list of known labels encountered during parse. -Parsing (BREAK-FROM label) forms fails unless the label is found in +Parsing (BREAK label) and (CONTINUE label) forms fails unless the label is found in this list.") (defconstant +macro-expansion-max+ 500) @@ -515,29 +508,21 @@ this list.") (expr (util:required 'expr) :type node :read-only t) (body (util:required 'body) :type node-body :read-only t)) -(defstruct (node-loop - (:include node) - (:copier nil)) - (body (util:required 'body) :type node-body :read-only t)) - (defstruct (node-break - (:include node) - (:copier nil))) - -(defstruct (node-break-from (:include node) (:copier nil)) - (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) - (:copier nil))) + (:copier nil)) + (label (util:required 'label) :type (or null keyword) :read-only t)) -(defstruct (node-named-loop +(defstruct (node-loop (:include node) (:copier nil)) - (label (util:required 'label) :type keyword :read-only t) - (body (util:required 'body) :type node-body :read-only t)) + (label (util:required 'label) :type (or null keyword) :read-only t) + (body (util:required 'body) :type node-body :read-only t)) (defstruct (node-for (:include node) @@ -962,140 +947,204 @@ this list.") ((and (cst:atom (cst:first form)) (eq 'coalton:while (cst:raw (cst:first form)))) - (let ((*breakable-loop-context* t) - (*continuable-loop-context* t)) - (parse-while form file))) + (let ((*escapable-loop-context* t)) + ;; (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 match"))) + + ;; (while match) + (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)))) ((and (cst:atom (cst:first form)) (eq 'coalton:while-let (cst:raw (cst:first form)))) - (let ((*breakable-loop-context* t) - (*continuable-loop-context* t)) - (parse-while-let form file))) - - ((and (cst:atom (cst:first form)) - (eq 'coalton:loop (cst:raw (cst:first form)))) - - ;; (loop) - (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed loop expression" - :primary-note "expected a loop body"))) - (let ((*breakable-loop-context* t) - (*continuable-loop-context* t)) - (make-node-loop + (macrolet ((while-let-error (note) + `(error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed while-let expression" + :primary-note ,note)))) + + ;; (while-let) + (unless (cst:consp (cst:nthrest 1 form)) + (while-let-error "expected pattern")) + + ;; (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 pattern =) + (unless (cst:consp (cst:nthrest 3 form)) + (while-let-error "expected expression")) + + ;; (when-let pattern = expr) + (unless (cst:consp (cst:nthrest 4 form)) + (while-let-error "exptected body"))) + + (let ((*escapable-loop-context* t)) + (make-node-while-let :source (cst:source form) - :body (parse-body (cst:rest form) form file)))) + :pattern (parse-pattern (cst:second form) file) + :expr (parse-expression (cst:fourth form) file) + :body (parse-body (cst:nthrest 4 form) form file)))) + ((and (cst:atom (cst:first form)) - (eq 'coalton:named-loop (cst:raw (cst:first form)))) + (eq 'coalton:loop (cst:raw (cst:first form)))) (let* ((label - ;; (named-loop) - (if (and - (cst:consp (cst:rest form)) - (cst:atom (cst:second form)) - (keywordp (cst:raw (cst:second form)))) - (cst:raw (cst:second form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed named-loop expression" - :primary-note "expected a keyword loop label")))) + ;; (loop) + (when (and + (cst:consp (cst:rest form)) + (cst:atom (cst:second form)) + (keywordp (cst:raw (cst:second form)))) + (cst:raw (cst:second form)))) (unparsed-body - ;; (named-loop label) - (if (cst:consp (cst:nthrest 2 form)) - (cst:nthrest 2 form) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed named-loop expression" - :primary-note "expected a loop body")))) - (*breakable-loop-context* t) - (*continuable-loop-context* t) - (*breakable-from-loop-context* (cons label *breakable-from-loop-context*))) - - (make-node-named-loop + (cond (label + ;; (loop label) + (if (cst:consp (cst:nthrest 2 form)) + (cst:nthrest 2 form) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed loop expression" + :primary-note "expected a loop body")))) + ;; (loop) + ((not (cst:consp (cst:rest form))) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed loop expression" + :primary-note "expected a loop body or label"))) + + (t + (cst:rest form)))) + (*escapable-loop-context* t) + (*loop-label-context* + (if label + (cons label *loop-label-context*) + *loop-label-context*))) + + (make-node-loop :source (cst:source form) :label label :body (parse-body unparsed-body form file)))) ((and (cst:atom (cst:first form)) (eq 'coalton:break (cst:raw (cst:first form)))) + (let ((label + ;; (break) + (and (cst:consp (cst:rest form)) + (if (and (cst:atom (cst:second form)) + (keywordp (cst:raw (cst:second form)))) + (cst:raw (cst:second form)) + ;; (break not-a-keyword) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Invalid break expression" + :primary-note "expected a keyword label")))))) + (when label + (unless (member label *loop-label-context*) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Invalid break expression" + :primary-note (format nil "Label ~s not found in any enclosing loop" label))))) - ;; (break NOT-ALLOWED) - (unless (cst:null (cst:rest form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Invalid break expression" - :primary-note "break takes no arguments"))) - - (unless *breakable-loop-context* - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Invalid break expression" - :primary-note "break not inside a breakable loop"))) - (make-node-break :source (cst:source form))) + (make-node-break :source (cst:source form) :label label))) ((and (cst:atom (cst:first form)) - (eq 'coalton:break-from (cst:raw (cst:first form)))) + (eq 'coalton:continue (cst:raw (cst:first form)))) (let ((label - ;; (break-from) - (if (and - (cst:consp (cst:rest form)) - (cst:atom (cst:second form)) - (keywordp (cst:raw (cst:second form)))) - (cst:raw (cst:second form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Invalid break-from expression" - :primary-note "expected a break label"))))) - (unless (member label *breakable-from-loop-context*) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Invalid break-from expression" - :primary-note (format nil "Label ~s not found in any active loop" label)))) - (make-node-break-from :source (cst:source form) :label label))) + ;; (continue) + (and (cst:consp (cst:rest form)) + (if (and (cst:atom (cst:second form)) + (keywordp (cst:raw (cst:second form)))) + (cst:raw (cst:second form)) + ;; (continue not-a-keyword) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Invalid continue expression" + :primary-note "expected a keyword label")))))) + (when label + (unless (member label *loop-label-context*) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Invalid continue expression" + :primary-note (format nil "Label ~s not found in any enclosing loop" label))))) - ((and (cst:atom (cst:first form)) - (cst:null (cst:rest form)) - (eq 'coalton:continue (cst:raw (cst:first form)))) - (unless *continuable-loop-context* - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Invalid continue expression" - :primary-note "continue not inside a continuable loop"))) - - (make-node-continue :source (cst:source form))) +n (make-node-continue :source (cst:source form) :label label))) + ((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))) + (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"))) + + (let ((*escapable-loop-context* t)) + (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)))) ;; ;; Macros @@ -1559,109 +1608,6 @@ this list.") (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 match"))) - - ;; (while match) - (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-while-let (form file) - (declare (type cst:cst form) - (type coalton-file file) - (values node-while-let)) - (macrolet ((while-let-error (note) - `(error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed while-let expression" - :primary-note ,note)))) - - ;; (while-let) - (unless (cst:consp (cst:nthrest 1 form)) - (while-let-error "expected pattern")) - - ;; (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 pattern =) - (unless (cst:consp (cst:nthrest 3 form)) - (while-let-error "expected expression")) - - ;; (when-let pattern = expr) - (unless (cst:consp (cst:nthrest 4 form)) - (while-let-error "exptected body"))) - - (make-node-while-let - :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-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) diff --git a/src/parser/renamer.lisp b/src/parser/renamer.lisp index fcc9e3615..bad5eab62 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -336,19 +336,10 @@ (values (make-node-loop :source (node-source node) + :label (node-loop-label node) :body (rename-variables-generic% (node-loop-body node) ctx)) ctx)) - (:method ((node node-named-loop) ctx) - (declare (type algo:immutable-map ctx) - (values node algo:immutable-map)) - (values - (make-node-named-loop - :source (node-source node) - :label (node-named-loop-label node) - :body (rename-variables-generic% (node-named-loop-body node) ctx)) - ctx)) - (:method ((node node-break) ctx) (declare (type algo:immutable-map ctx) (values node algo:immutable-map)) @@ -356,19 +347,11 @@ node ctx)) - (:method ((node node-break-from) ctx) - (declare (type algo:immutable-map ctx) - (values node algo:immutable-map)) - (values - node - ctx)) - (:method ((node node-continue) ctx) (declare (type algo:immutable-map ctx) (values node algo:immutable-map)) (values - (make-node-continue - :source (node-source node)) + node ctx)) (:method ((node node-unless) ctx) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index a336a28c6..930b0e7a3 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -1320,41 +1320,13 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (make-node-loop :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node) - :body body-node) - subs)) - (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*))))) - - (:method ((node parser:node-named-loop) 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-named-loop tc:substitution-list)) - (multiple-value-bind (body-ty preds accessors body-node subs) - (infer-expression-type (parser:node-named-loop-body node) - (tc:make-variable) - subs - env - file) - (declare (ignore body-ty)) - (handler-case - (progn - (setf subs (tc:unify subs tc:*unit-type* expected-type)) - (values - tc:*unit-type* - preds - accessors - (make-node-named-loop - :type (tc:qualify nil tc:*unit-type*) - :source (parser:node-source node) - :label (parser:node-named-loop-label node) + :label (parser:node-loop-label node) :body body-node) subs)) (error:coalton-internal-type-error () (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type* ))))) - (:method ((node parser:node-break) expected-type subs env file) + (:method ((node parser:node-break) expected-type subs env file) (declare (type tc:ty expected-type) (type tc:substitution-list subs) (type tc-env env) @@ -1367,28 +1339,10 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") tc:*unit-type* nil nil - (make-node-break :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node)) - subs)) - (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*)))) - - (:method ((node parser:node-break-from) 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-break-from tc:substitution-list)) - (handler-case - (progn - (setf subs (tc:unify subs tc:*unit-type* expected-type)) - (values - tc:*unit-type* - nil - nil - (make-node-break-from + (make-node-break :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node) - :label (parser:node-break-from-label node)) + :label (parser:node-break-label node)) subs)) (error:coalton-internal-type-error () (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*)))) @@ -1406,7 +1360,10 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") tc:*unit-type* nil nil - (make-node-continue :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node)) + (make-node-continue + :type (tc:qualify nil tc:*unit-type*) + :source (parser:node-source node) + :label (parser:node-continue-label node)) subs)) (error:coalton-internal-type-error () (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*)))) diff --git a/src/typechecker/expression.lisp b/src/typechecker/expression.lisp index d95a85615..04202514e 100644 --- a/src/typechecker/expression.lisp +++ b/src/typechecker/expression.lisp @@ -128,17 +128,13 @@ #:node-loop ; STRUCT #:make-node-loop ; CONSTRUCTOR #:node-loop-body ; ACCESSOR - #:node-named-loop ; STRUCT - #:make-node-named-loop ; CONSTRUCTOR - #:node-named-loop-body ; ACCESSOR - #:node-named-loop-label ; 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-cond-clause ; STRUCT #:make-node-cond-clause ; CONSTRUCTOR #:node-cond-clause-expr ; ACCESSOR @@ -353,26 +349,18 @@ (defstruct (node-loop (:include node) (:copier nil)) - (body (util:required 'body) :type node-body :read-only t)) - -(defstruct (node-named-loop - (:include node) - (:copier nil)) (label (util:required 'label) :type keyword :read-only t) (body (util:required 'body) :type node-body :read-only t)) -(defstruct (node-break - (:include node) - (:copier nil))) - -(defstruct (node-break-from +(defstruct (node-break (:include node) (:copier nil)) - (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) - (:copier nil))) + (:copier nil)) + (label (util:required 'label) :type (or null keyword) :read-only t)) (defstruct (node-cond-clause (:copier nil)) @@ -625,27 +613,14 @@ (make-node-loop :type (tc:apply-substitution subs (node-type node)) :source (node-source node) + :label (node-loop-label node) :body (tc:apply-substitution subs (node-loop-body node)))) -(defmethod tc:apply-substitution (subs (node node-named-loop)) - (declare (type tc:substitution-list subs) - (values node-named-loop)) - (make-node-named-loop - :type (tc:apply-substitution subs (node-type node)) - :source (node-source node) - :label (node-named-loop-label node) - :body (tc:apply-substitution subs (node-named-loop-body node)))) - (defmethod tc:apply-substitution (subs (node node-break)) (declare (type tc:substitution-list subs) (values node-break)) node) -(defmethod tc:apply-substitution (subs (node node-break-from)) - (declare (type tc:substitution-list subs) - (values node-break-from)) - node) - (defmethod tc:apply-substitution (subs (node node-continue)) (declare (type tc:substitution-list subs) (values node-continue)) diff --git a/src/typechecker/traverse.lisp b/src/typechecker/traverse.lisp index f22d28885..f1884c188 100644 --- a/src/typechecker/traverse.lisp +++ b/src/typechecker/traverse.lisp @@ -38,9 +38,7 @@ (while-let #'identity :type function :read-only t) (for #'identity :type function :read-only t) (loop #'identity :type function :read-only t) - (named-loop #'identity :type function :read-only t) (break #'identity :type function :read-only t) - (break-from #'identity :type function :read-only t) (continue #'identity :type function :read-only t) (do-bind #'identity :type function :read-only t) (do #'identity :type function :read-only t)) @@ -321,18 +319,8 @@ (make-node-loop :type (node-type node) :source (node-source node) + :label (node-loop-label node) :body (traverse (node-loop-body node) block)))) - - (:method ((node node-named-loop) block) - (declare (type traverse-block block) - (values node &optional)) - (funcall - (traverse-loop block) - (make-node-named-loop - :type (node-type node) - :source (node-source node) - :label (node-named-loop-label node) - :body (traverse (node-named-loop-body node) block)))) (:method ((node node-break) block) (declare (type traverse-block block) @@ -340,15 +328,6 @@ (funcall (traverse-break block) node)) - - (:method ((node node-break-from) block) - (declare (type traverse-block block) - (values node &optional)) - (funcall - (traverse-break block) - (make-node-break - :type (node-type node) - :source (node-source node)))) (:method ((node node-continue) block) (declare (type traverse-block block) diff --git a/tests/looping-native-tests.lisp b/tests/looping-native-tests.lisp new file mode 100644 index 000000000..699e6c9de --- /dev/null +++ b/tests/looping-native-tests.lisp @@ -0,0 +1,49 @@ +(in-package #:coalton-native-tests) + +(define-test test-while-loop () + (let ((countdown (cell:new 10)) + (sum (cell:new 0))) + (while (< 0 (cell:decrement! countdown)) + (cell:update! (+ (cell:read countdown)) sum)) + (is (== 0 (cell:read countdown))) + (is (== 45 (cell:read sum))))) + + +(define-test test-while-loop-break () + (let ((countdown (cell:new 10)) + (sum (cell:new 0))) + (while (< 0 (cell:decrement! countdown)) + (cell:update! (+ (cell:read countdown)) sum) + (when (== (cell:read countdown) 5) + (break))) + (is (== 5 (cell:read countdown))) + (is (== 35 (cell:read sum))))) + +(define-test test-while-let () + (let ((iter (iter:up-to 10)) + (sum (cell:new 0))) + (while-let + (Some x) = (iter:next! iter) + (cell:update! (+ x) sum)) + (is (== 45 (cell:read sum))))) + + +(define-test test-for () + (let ((sum (cell:new 0))) + + (for x in (iter:up-to 10) (cell:update! (+ x) sum)) + + (is (== 45 (cell:read sum))) + + (cell:swap! sum 0) + + (for x in (iter:up-to 20) + (cell:update! (+ x) sum) + (when (== 9 x) (break))) + + (is (== 45 (cell:read sum ))))) + + + + + diff --git a/tests/looping-tests.lisp b/tests/looping-tests.lisp index b03f310a3..f2f42a5e8 100644 --- a/tests/looping-tests.lisp +++ b/tests/looping-tests.lisp @@ -1,49 +1,2 @@ -(in-package #:coalton-native-tests) +(in-package #:coalton-tests) -(define-test test-while-loop () - (let ((countdown (cell:new 10)) - (sum (cell:new 0))) - (while (< 0 (cell:decrement! countdown)) - (cell:update! (+ (cell:read countdown)) sum) - Unit) - (is (== 0 (cell:read countdown))) - (is (== 45 (cell:read sum))))) - - -(define-test test-while-loop-break () - (let ((countdown (cell:new 10)) - (sum (cell:new 0))) - (while (< 0 (cell:decrement! countdown)) - (cell:update! (+ (cell:read countdown)) sum) - (when (== (cell:read countdown) 5) - (break))) - (is (== 5 (cell:read countdown))) - (is (== 35 (cell:read sum))))) - -(define-test test-while-let () - (let ((iter (iter:up-to 10)) - (sum (cell:new 0))) - (while-let - (Some x) = (iter:next! iter) - (cell:update! (+ x) sum) - Unit) - (is (== 45 (cell:read sum))))) - - -(define-test test-for () - (let ((sum (cell:new 0))) - - (for x in (iter:up-to 10) (cell:update! (+ x) sum) Unit) - - (is (== 45 (cell:read sum))) - - (cell:swap! sum 0) - - - (for x in (iter:up-to 20) - (cell:update! (+ x) sum) - (when (== 9 x) (break))) - - (is (== 45 (cell:read sum )))) - -) diff --git a/tests/parser/parse-break-from.1.bad.coalton b/tests/parser/parse-break-from.1.bad.coalton deleted file mode 100644 index 51e1f1685..000000000 --- a/tests/parser/parse-break-from.1.bad.coalton +++ /dev/null @@ -1,4 +0,0 @@ -;; BAD: Parse Break-From -(package test-parser) - -(define f (named-loop :x (break-from))) \ No newline at end of file diff --git a/tests/parser/parse-break-from.2.bad.coalton b/tests/parser/parse-break-from.2.bad.coalton deleted file mode 100644 index 96ea272d8..000000000 --- a/tests/parser/parse-break-from.2.bad.coalton +++ /dev/null @@ -1,4 +0,0 @@ -;; BAD: Parse Break-From -(package test-parser) - -(define f (break-from :x)) \ No newline at end of file diff --git a/tests/parser/parse-break-from.3.bad.coalton b/tests/parser/parse-break-from.3.bad.coalton deleted file mode 100644 index 61ae7e649..000000000 --- a/tests/parser/parse-break-from.3.bad.coalton +++ /dev/null @@ -1,4 +0,0 @@ -;; BAD: Parse Break-From -(package test-parser) - -(define f (named-loop :x (break-from "foo"))) \ No newline at end of file diff --git a/tests/parser/parse-break-from.4.bad.coalton b/tests/parser/parse-break-from.4.bad.coalton deleted file mode 100644 index 0fbbf9979..000000000 --- a/tests/parser/parse-break-from.4.bad.coalton +++ /dev/null @@ -1,9 +0,0 @@ -;; BAD: Parse Break-From - -(define x - (named-loop - :outer - (named-loop - :inner - (break-from :outer)) - (break-from :inner))) ;; <-- this one is bad diff --git a/tests/parser/parse-break-from.good.coalton b/tests/parser/parse-break-from.good.coalton deleted file mode 100644 index 2ad4d01a7..000000000 --- a/tests/parser/parse-break-from.good.coalton +++ /dev/null @@ -1,9 +0,0 @@ -;; GOOD: Parse Break-From -(package test-package) - -(define x - (named-loop - :outer - (named-loop - :inner - (break-from :outer)))) diff --git a/tests/parser/parse-break.good.coalton b/tests/parser/parse-break.good.coalton index 789c121fa..5b2904538 100644 --- a/tests/parser/parse-break.good.coalton +++ b/tests/parser/parse-break.good.coalton @@ -18,5 +18,5 @@ (break))) (define m - (named-loop :alabel - (break))) + (loop :alabel (break))) + diff --git a/tests/parser/parse-continue.good.coalton b/tests/parser/parse-continue.good.coalton index 28f9a00c3..c377d679a 100644 --- a/tests/parser/parse-continue.good.coalton +++ b/tests/parser/parse-continue.good.coalton @@ -18,5 +18,5 @@ (continue))) (define m - (named-loop :alabel - (continue))) + (loop :alabel + (continue))) diff --git a/tests/parser/parse-named-loop.1.bad.coalton b/tests/parser/parse-named-loop.1.bad.coalton deleted file mode 100644 index 3c0d8091b..000000000 --- a/tests/parser/parse-named-loop.1.bad.coalton +++ /dev/null @@ -1,4 +0,0 @@ -;; BAD: Parse Named-Loop -(package test-parser) - -(define f (named-loop)) \ No newline at end of file diff --git a/tests/parser/parse-named-loop.2.bad.coalton b/tests/parser/parse-named-loop.2.bad.coalton deleted file mode 100644 index f405c9675..000000000 --- a/tests/parser/parse-named-loop.2.bad.coalton +++ /dev/null @@ -1,4 +0,0 @@ -;; BAD: Parse Named-Loop -(package test-parser) - -(define f (named-loop :alabel)) \ No newline at end of file