From b36b3400db9e47a07e5ec7e1ac6f1e37d2bfb929 Mon Sep 17 00:00:00 2001 From: "O'Keefe, Colin B" Date: Fri, 22 Sep 2023 11:59:09 -0700 Subject: [PATCH] Labels for all loop varieties --- coalton.asd | 1 + src/codegen/ast.lisp | 30 +- src/codegen/codegen-expression.lisp | 132 +++++--- src/codegen/transformations.lisp | 3 + src/codegen/translate-expression.lisp | 3 + src/constants.lisp | 15 + src/parser/expression.lisp | 430 +++++++++++++------------- src/parser/renamer.lisp | 3 + src/typechecker/define.lisp | 9 +- src/typechecker/expression.lisp | 23 +- src/typechecker/traverse.lisp | 3 + 11 files changed, 375 insertions(+), 277 deletions(-) create mode 100644 src/constants.lisp diff --git a/coalton.asd b/coalton.asd index 6e137bcaf..adb9eeac0 100644 --- a/coalton.asd +++ b/coalton.asd @@ -32,6 +32,7 @@ (:file "settings") (:file "utilities") (:file "global-lexical") + (:file "constants") (:module "algorithm" :serial t :components ((:file "tarjan-scc") diff --git a/src/codegen/ast.lisp b/src/codegen/ast.lisp index cdba5d075..88a00e23a 100644 --- a/src/codegen/ast.lisp +++ b/src/codegen/ast.lisp @@ -56,15 +56,18 @@ #:node-match-branches ; ACCESSOR #:node-while ; STRUCT #:make-node-while ; CONSTRUCTOR + #:node-while-label ; ACCESSOR #:node-while-expr ; ACCESSOR #:node-while-body ; ACESSOR #:node-while-let ; STRUCT #:make-node-while-let ; CONSTRUCTOR + #:node-while-let-label ; ACESSOR #:node-while-let-pattern ; ACCESSPR #:node-while-let-expr ; ACCESSOR #:node-while-let-body ; ACESSOR #:node-for ; STRUCT #:make-node-for ; CONSTRUCTOR + #:node-for-label ; ACCESSOR #:node-for-pattern ; ACCESSPR #:node-for-iter ; ACCESSOR #:node-for-body ; ACESSOR @@ -191,36 +194,39 @@ (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)) + (label (util:required 'label) :type keyword :read-only t) + (expr (util:required 'expr) :type node :read-only t) + (body (util:required 'body) :type node :read-only t)) (defstruct (node-while-let (:include node)) "A looping construct. Executes a body until a pattern match fails." - (pattern (util:required 'pattern) :type pattern :read-only t) - (expr (util:required 'expr) :type node :read-only t) - (body (util:required 'body) :type node :read-only t)) + (label (util:required 'label) :type keyword :read-only t) + (pattern (util:required 'pattern) :type pattern :read-only t) + (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)) + (label (util:required 'label) :type keyword :read-only t) + (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 labelled looping construct. Loops forever until broken out of by a call to (break)." - (label (util:required 'label) :type (or keyword null) :read-only t) - (body (util:required 'body) :type node :read-only t)) + (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." - (label (util:required 'label) :type (or null keyword) :read-only t)) + (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." - (label (util:required 'label) :type (or null keyword) :read-only t)) + (label (util:required 'label) :type keyword :read-only t)) (defstruct (node-seq (:include node)) "A series of statements to be executed sequentially" diff --git a/src/codegen/codegen-expression.lisp b/src/codegen/codegen-expression.lisp index 152e4f297..b757eef30 100644 --- a/src/codegen/codegen-expression.lisp +++ b/src/codegen/codegen-expression.lisp @@ -13,15 +13,19 @@ (#:settings #:coalton-impl/settings) (#:util #:coalton-impl/util) (#:rt #:coalton-impl/runtime) - (#:tc #:coalton-impl/typechecker)) + (#:tc #:coalton-impl/typechecker) + (#:const #:coalton-impl/constants)) (:export #:codegen-expression ; FUNCTION )) (in-package #:coalton-impl/codegen/codegen-expression) -(defconstant +break-label+ '%break) -(defconstant +continue-label+ '%continue) +(defun continue-label (label) + (alexandria:make-keyword (format nil "~a-CONTINUE" label))) + +(defun break-label (label) + (alexandria:make-keyword (format nil "~a-BREAK" label))) (defgeneric codegen-expression (node current-function env) (:method ((node node-literal) current-function env) @@ -115,11 +119,21 @@ (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 - :named ,+break-label+ - :while ,pred-expr - :do (block ,+continue-label+ ,body-expr)))) + (body-expr (codegen-expression (node-while-body expr) current-function env)) + (label (node-while-label expr))) + (if (eq label const:+default-loop-label+) + `(loop + :named ,(break-label label) + :while ,pred-expr + :do + (block ,(continue-label label) ,body-expr)) + `(block ,(break-label const:+default-loop-label+) + (loop + :named ,(break-label label) + :while ,pred-expr + :do + (block ,(continue-label const:+default-loop-label+) + (block ,(continue-label label) ,body-expr))))))) (:method ((expr node-while-let) current-function env) (declare (type tc:environment env) @@ -127,22 +141,38 @@ (let ((match-expr (codegen-expression (node-while-let-expr expr) current-function env)) (body-expr (codegen-expression (node-while-let-body expr) current-function env)) + (label (node-while-let-label expr)) (match-var (gensym "MATCH"))) (multiple-value-bind (pred bindings) (codegen-pattern (node-while-let-pattern expr) match-var env) - `(loop - :named ,+break-label+ - :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-label+ - ,(cond ((null bindings) body-expr) - (t `(let ,bindings - (declare (ignorable ,@(mapcar #'car bindings))) - ,body-expr)))))))) - + (if (eq label const:+default-loop-label+) + `(loop + :named ,(break-label label) + :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-label label) + ,(cond ((null bindings) body-expr) + (t `(let ,bindings + (declare (ignorable ,@(mapcar #'car bindings))) + ,body-expr))))) + + `(block ,(break-label const:+default-loop-label+) + (loop + :named ,(break-label label) + :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-label const:+default-loop-label+) + (block ,(continue-label label) + ,(cond ((null bindings) body-expr) + (t `(let ,bindings + (declare (ignorable ,@(mapcar #'car bindings))) + ,body-expr))))))))))) (:method ((expr node-for) current-function env) (declare (type tc:environment env) @@ -150,51 +180,63 @@ (let ((body-expr (codegen-expression (node-for-body expr) current-function env)) (iter-expr (codegen-expression (node-for-iter expr) current-function env)) + (label (node-for-label expr)) (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-label+ - :with ,iter-var := ,iter-expr - :for ,match-var := (,next! ,iter-var) - :while ,pred - :do (block ,+continue-label+ - ,(cond ((null bindings) body-expr) - (t `(let ,bindings - (declare (ignorable ,@(mapcar #'car bindings))) - ,body-expr)))))))) + (if (eq label const:+default-loop-label+) + `(loop + :named ,(break-label label) + :with ,iter-var := ,iter-expr + :for ,match-var := (,next! ,iter-var) + :while ,pred + :do (block ,(continue-label label) + ,(cond ((null bindings) body-expr) + (t `(let ,bindings + (declare (ignorable ,@(mapcar #'car bindings))) + ,body-expr))))) + + `(block ,(break-label const:+default-loop-label+) + (loop + :named ,(break-label label) + :with ,iter-var := ,iter-expr + :for ,match-var := (,next! ,iter-var) + :while ,pred + :do (block ,(continue-label const:+default-loop-label+) + (block ,(continue-label label) + ,(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) (type (or null symbol) current-function)) (let ((body-expr (codegen-expression (node-loop-body expr) current-function env)) (label (node-loop-label expr))) - `(block ,+break-label+ - (loop ,@(when label (list :named label)) - :do ,(if label - `(tagbody ,label - (block ,+continue-label+ - ,body-expr)) - `(block ,+continue-label+ - ,body-expr)))))) + (if (eq label const:+default-loop-label+) + `(loop ,(break-label label) + :do (block ,(continue-label label) + ,body-expr)) + + `(block ,(break-label const:+default-loop-label+) + (loop ,(break-label label) + :do (block ,(continue-label const:+default-loop-label+) + (block ,(continue-label label) + ,body-expr))))))) (:method ((expr node-break) current-function env) (declare (type tc:environment env) (type (or null symbol) current-function)) - (if (node-break-label expr) - `(return-from ,(node-break-label expr)) - `(return-from ,+break-label+))) + `(return-from ,(break-label (node-break-label expr)))) (:method ((expr node-continue) current-function env) (declare (type tc:environment env) (type (or null symbol) current-function)) - (if (node-continue-label expr) - `(go ,(node-continue-label expr)) - `(return-from ,+continue-label+))) + `(return-from ,(continue-label (node-continue-label expr)))) (: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 ec130ea4f..214c96c40 100644 --- a/src/codegen/transformations.lisp +++ b/src/codegen/transformations.lisp @@ -124,6 +124,7 @@ (let ((node (make-node-while :type (node-type node) + :label (node-while-label 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))) @@ -133,6 +134,7 @@ (let ((node (make-node-while-let :type tc:*unit-type* + :label (node-while-let-label node) :pattern (node-while-let-pattern node) :expr (traverse (node-while-let-expr node) funs bound-variables) :body (traverse (node-while-let-body node) funs bound-variables)))) @@ -143,6 +145,7 @@ (let ((node (make-node-for :type tc:*unit-type* + :label (node-for-label node) :pattern (node-for-pattern node) :iter (traverse (node-for-iter node) funs bound-variables) :body (traverse (node-for-body node) funs bound-variables)))) diff --git a/src/codegen/translate-expression.lisp b/src/codegen/translate-expression.lisp index c65b8bdb4..3d65fb34c 100644 --- a/src/codegen/translate-expression.lisp +++ b/src/codegen/translate-expression.lisp @@ -558,6 +558,7 @@ Returns a `node'.") (make-node-while :type tc:*unit-type* + :label (tc:node-while-label expr) :expr (translate-expression (tc:node-while-expr expr) ctx env) :body (translate-expression (tc:node-while-body expr) ctx env))) @@ -568,6 +569,7 @@ Returns a `node'.") (make-node-while-let :type tc:*unit-type* :pattern (translate-pattern (tc:node-while-let-pattern expr)) + :label (tc:node-while-let-label expr) :expr (translate-expression (tc:node-while-let-expr expr) ctx env) :body (translate-expression (tc:node-while-let-body expr) ctx env))) @@ -652,6 +654,7 @@ Returns a `node'.") (make-node-for :type tc:*unit-type* + :label (tc:node-for-label expr) :pattern some-pattern :iter into-iter-node :body (translate-expression (tc:node-for-body expr) ctx env)))) diff --git a/src/constants.lisp b/src/constants.lisp new file mode 100644 index 000000000..bc1445152 --- /dev/null +++ b/src/constants.lisp @@ -0,0 +1,15 @@ +;;;; constants.lisp +;;;; +;;;; This file contains constant values used throughout compilation. + +(defpackage #:coalton-impl/constants + (:use #:cl) + (:export + #:+default-loop-label+ ; VARIABLE + )) + +(in-package #:coalton-impl/constants) + +(defparameter +default-loop-label+ :coalton-loop + "Supplied as a loop label for while, while-let, for, loop, break, and +continue when a label is not supplied by the user.") diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index 2b813b949..ad4966f39 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -11,7 +11,8 @@ #:parse-error) (:local-nicknames (#:cst #:concrete-syntax-tree) - (#:util #:coalton-impl/util)) + (#:util #:coalton-impl/util) + (#:const #:coalton-impl/constants)) (:export #:node ; STRUCT #:node-source ; ACCESSOR @@ -130,10 +131,12 @@ #:node-do ; STRUCT #:node-while ; STRUCT #:make-node-while ; CONSTRUCTOR + #:node-while-label ; ACCESSOR #:node-while-expr ; ACCESSOR #:node-while-body ; ACCESSOR #:node-while-let ; STRUCT #:make-node-while-let ; CONSTRUCTOR + #:node-while-let-label ; ACCESSOR #:node-while-let-pattern ; ACCESSOR #:node-while-let-expr ; ACCESSOR #:node-while-let-body ; ACCESSOR @@ -149,6 +152,7 @@ #:node-continue-label ; ACCESSOR #:node-for ; STRUCT #:make-node-for ; CONSTRUCTOR + #:node-for-label ; ACCESSOR #:node-for-pattern ; ACCESSOR #:node-for-expr ; ACCESSOR #:node-for-body ; ACCESSOR @@ -164,9 +168,6 @@ (defvar *macro-expansion-count* 0) -(defvar *escapable-loop-context* nil - "Indicates whether (BREAK) or (CONTINUE) are valid expressions.") - (defvar *loop-label-context* nil "A list of known labels encountered during parse. @@ -498,38 +499,41 @@ this list.") (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)) + (label (util:required 'label) :type keyword :read-only t) + (expr (util:required 'expr) :type node :read-only t) + (body (util:required 'body) :type node-body :read-only t)) (defstruct (node-while-let (: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)) + (label (util:required 'label) :type keyword :read-only t) + (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)) (defstruct (node-break (:include node) (:copier nil)) - (label (util:required 'label) :type (or null keyword) :read-only t)) + (label (util:required 'label) :type keyword :read-only t)) (defstruct (node-continue (:include node) (:copier nil)) - (label (util:required 'label) :type (or null keyword) :read-only t)) + (label (util:required 'label) :type keyword :read-only t)) (defstruct (node-loop (:include node) (:copier nil)) - (label (util:required 'label) :type (or null keyword) :read-only t) - (body (util:required 'body) :type node-body :read-only t)) + (label (util:required 'label) :type keyword :read-only t) + (body (util:required 'body) :type node-body :read-only t)) (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)) + (label (util:required 'label) :type keyword :read-only t) + (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) @@ -947,19 +951,19 @@ this list.") ((and (cst:atom (cst:first form)) (eq 'coalton:while (cst:raw (cst:first form)))) - (let ((*escapable-loop-context* t)) - ;; (while) - (unless (cst:consp (cst:rest form)) + + (multiple-value-bind (label labelled-body) (take-label form) + ;; (while [label]) + (unless (cst:consp labelled-body) (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))) + :primary-note "expected condition"))) + ;; (while [label] condition) + (unless (cst:consp (cst:rest labelled-body)) (error 'parse-error :err (coalton-error :span (cst:source form) @@ -967,228 +971,214 @@ this list.") :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)))) + (let ((*loop-label-context* + (if label + (list* label const:+default-loop-label+ *loop-label-context*) + (cons const:+default-loop-label+ *loop-label-context*)))) + + (make-node-while + :source (cst:source form) + :label (or label const:+default-loop-label+) + :expr (parse-expression (cst:first labelled-body) file) + :body (parse-body (cst:rest labelled-body) form file))))) ((and (cst:atom (cst:first form)) (eq 'coalton:while-let (cst:raw (cst:first form)))) - ;; (while-let) - (unless (cst:consp (cst:nthrest 1 form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected pattern"))) + (multiple-value-bind (label labelled-body) (take-label form) + ;; (while-let [label]) + (unless (cst:consp labelled-body) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed while-let expression" + :primary-note "expected pattern"))) + + ;; (while-let [label] pattern) + (unless (and (cst:consp (cst:rest labelled-body)) + (eq 'coalton:= (cst:raw (cst:second labelled-body)))) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed while-let expression" + :primary-note "expected ="))) - ;; (while-let pattern) - (unless (and (cst:consp (cst:nthrest 2 form)) - (eq 'coalton:= (cst:raw (cst:nth 2 form)))) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected ="))) - - ;; (when-let pattern =) - (unless (cst:consp (cst:nthrest 3 form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected expression"))) + ;; (when-let [label] pattern =) + (unless (cst:consp (cst:nthrest 2 labelled-body)) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed while-let expression" + :primary-note "expected expression"))) ;; (when-let pattern = expr) - - (unless (cst:consp (cst:nthrest 4 form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed while-let expression" - :primary-note "exptected body"))) - - (let ((*escapable-loop-context* t)) - (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)))) + (unless (cst:consp (cst:nthrest 3 labelled-body)) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed while-let expression" + :primary-note "exptected body"))) + (let* ((*loop-label-context* + (if label + (list* label const:+default-loop-label+ *loop-label-context*) + (cons const:+default-loop-label+ *loop-label-context*)))) + (make-node-while-let + :source (cst:source form) + :label (or label const:+default-loop-label+) + :pattern (parse-pattern (cst:second labelled-body) file) + :expr (parse-expression (cst:fourth labelled-body) file) + :body (parse-body (cst:nthrest 3 labelled-body) form file))))) ((and (cst:atom (cst:first form)) (eq 'coalton:loop (cst:raw (cst:first form)))) - - (let* ((label - (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 - (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)))) + (multiple-value-bind (label labelled-body) (take-label form) + (unless (cst:consp labelled-body) + (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* ((*loop-label-context* + (if label + (list* label const:+default-loop-label+ *loop-label-context*) + (cons const:+default-loop-label+ *loop-label-context*)))) + (make-node-loop + :source (cst:source form) + :label (or label const:+default-loop-label+) + :body (parse-body labelled-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 (cst:second form)) - :file file - :message "Invalid label in break" - :primary-note "expected a keyword")))))) - (when label - (unless (member label *loop-label-context*) - (error 'parse-error - :err (coalton-error - :span (cst:source (cst:second form)) - :file file - :message "Invalid label in break" - :primary-note "Label not found in any enclosing loop")))) - (unless *escapable-loop-context* + (multiple-value-bind (label postlabel) (take-label form) + (unless (cst:null postlabel) (error 'parse-error :err (coalton-error :span (cst:source form) :file file - :message "Invalid break expression" - :primary-note "no enclosing loop"))) + :message "Invalid argument in break" + :primary-note (if label + "unexpected argument after label" + "expected a keyword")))) + + (if label + (unless (member label *loop-label-context*) + (error 'parse-error + :err (coalton-error + :span (cst:source (cst:second form)) + :file file + :message "Invalid label in break" + :primary-note "label not found in any enclosing loop"))) + (unless (member const:+default-loop-label+ *loop-label-context*) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :message "Invalid break" + :primary-note "break does not appear in an enclosing loop")))) - (make-node-break :source (cst:source form) :label label))) - + (make-node-break :source (cst:source form) :label (or label const:+default-loop-label+)))) ((and (cst:atom (cst:first form)) (eq 'coalton:continue (cst:raw (cst:first form)))) - (let ((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 (cst:second form)) - :file file - :message "Invalid label in continue" - :primary-note "expected a keyword")))))) - (when label - (unless (member label *loop-label-context*) - (error 'parse-error - :err (coalton-error - :span (cst:source (cst:second form)) - :file file - :message "Invalid label in continue" - :primary-note "Label not found in any enclosing loop")))) - (unless *escapable-loop-context* + (multiple-value-bind (label postlabel) (take-label form) + (unless (cst:null postlabel) (error 'parse-error :err (coalton-error :span (cst:source form) :file file - :message "Invalid continue expression" - :primary-note "no enclosing loop"))) - - (make-node-continue :source (cst:source form) :label label))) + :message "Invalid argument in continue" + :primary-note (if label + "unexpected argument after label" + "expected a keyword")))) + + (if label + (unless (member label *loop-label-context*) + (error 'parse-error + :err (coalton-error + :span (cst:source (cst:second form)) + :file file + :message "Invalid label in continue" + :primary-note "label not found in any enclosing loop"))) + (unless (member const:+default-loop-label+ *loop-label-context*) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :message "Invalid continue" + :primary-note "continue does not appear in an enclosing loop")))) + + (make-node-continue :source (cst:source form) :label (or label const:+default-loop-label+)))) ((and (cst:atom (cst:first form)) (eq 'coalton:for (cst:raw (cst:first form)))) - ;; (for) - (unless (cst:consp (cst:nthrest 1 form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed for expression" - :primary-note "expected pattern"))) + (multiple-value-bind (label labelled-body) (take-label form) + ;; (for [label]) + (unless (cst:consp labelled-body) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed for expression" + :primary-note "expected pattern"))) - ;; (for pattern) - (unless (and (cst:consp (cst:nthrest 2 form)) - (eq 'coalton:in (cst:raw (cst:nth 2 form)))) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed for expression" - :primary-note "expected in"))) + ;; (for [label] pattern) + (unless (and (cst:consp (cst:rest labelled-body)) + (cst:atom (cst:second labelled-body)) + (eq 'coalton:in (cst:raw (cst:second labelled-body)))) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed for expression" + :primary-note "expected in"))) - ;; (for pattern in) - (unless (cst:consp (cst:nthrest 3 form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed for expression" - :primary-note "expected expression"))) + ;; (for [label] pattern in) + (unless (cst:consp (cst:nthrest 2 labelled-body)) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed for expression" + :primary-note "expected expression"))) - ;; (for pattern in expr) - (unless (cst:consp (cst:nthrest 4 form)) - (error 'parse-error - :err (coalton-error - :span (cst:source form) - :file file - :highlight :end - :message "Malformed for expression" - :primary-note "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)))) + ;; (for [label] pattern in expr) + (unless (cst:consp (cst:nthrest 3 labelled-body)) + (error 'parse-error + :err (coalton-error + :span (cst:source form) + :file file + :highlight :end + :message "Malformed for expression" + :primary-note "exptected body"))) + + (let ((*loop-label-context* + (if label + (list* label const:+default-loop-label+ *loop-label-context*) + (cons const:+default-loop-label+ *loop-label-context*)))) + (make-node-for + :source (cst:source form) + :label (or label const:+default-loop-label+) + :pattern (parse-pattern (cst:first labelled-body) file) + :expr (parse-expression (cst:third labelled-body) file) + :body (parse-body (cst:nthrest 3 labelled-body) form file))))) ;; ;; Macros @@ -1677,3 +1667,23 @@ this list.") :name (parse-variable (cst:second form) file) :type (parse-qualified-type (cst:third form) file) :source (cst:source form))) + +(defun take-label (form) + "Takes form (HEAD . (MAYBEKEYWORD . REST)) and returns two values, +either + +MAYBEKEYWORD REST + +if MAYBEKEYWORD is a keyword, or else + +NIL (MAYBEKEYWORD . REST) + +if (CST:SECOND FORM) is not a keyword." + (declare (type cst:cst form) + (values (or keyword null) cst:cst)) + (if (and (cst:consp (cst:rest form)) + (cst:atom (cst:second form)) + (keywordp (cst:raw (cst:second form)))) + (values (cst:raw (cst:second form)) + (cst:nthrest 2 form)) + (values nil (cst:rest form)))) diff --git a/src/parser/renamer.lisp b/src/parser/renamer.lisp index bad5eab62..c64923cee 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -285,6 +285,7 @@ (values (make-node-while :expr (rename-variables-generic% (node-while-expr node) ctx) + :label (node-while-label node) :body (rename-variables-generic% (node-while-body node) ctx) :source (node-source node)) ctx)) @@ -304,6 +305,7 @@ (values (make-node-while-let + :label (node-while-let-label node) :pattern (rename-variables-generic% (node-while-let-pattern node) new-ctx) :expr (rename-variables-generic% (node-while-let-expr node) ctx) :body (rename-variables-generic% (node-while-let-body node) new-ctx) @@ -324,6 +326,7 @@ (values (make-node-for + :label (node-for-label node) :pattern (rename-variables-generic% (node-for-pattern node) new-ctx) :expr (rename-variables-generic% (node-for-expr node) ctx) :body (rename-variables-generic% (node-for-body node) new-ctx) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index e3cf25e3e..332f2cac0 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -1182,8 +1182,8 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") file) (declare (ignore body-ty)) - (setf preds (append preds preds_) - accessors (append accessors accessors_)) + (setf preds (append preds preds_)) + (setf accessors (append accessors accessors_)) (handler-case (progn @@ -1195,11 +1195,12 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (make-node-while :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node) + :label (parser:node-while-label node) :expr expr-node :body body-node) subs)) (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*)))))) + (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*)))))) (:method ((node parser:node-while-let) expected-type subs env file) (declare (type tc:ty expected-type) @@ -1239,6 +1240,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (make-node-while-let :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node) + :label (parser:node-while-let-label node) :pattern pat-node :expr expr-node :body body-node) @@ -1289,6 +1291,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (make-node-for :type (tc:qualify nil tc:*unit-type*) :source (parser:node-source node) + :label (parser:node-for-label node) :pattern pat-node :expr expr-node :body body-node) diff --git a/src/typechecker/expression.lisp b/src/typechecker/expression.lisp index e867f88d2..bf792c59d 100644 --- a/src/typechecker/expression.lisp +++ b/src/typechecker/expression.lisp @@ -113,22 +113,25 @@ #:node-unless-body ; ACCESSOR #:node-while ; STRUCT #:make-node-while ; CONSTRUCTOR + #:node-while-label ; ACCESSOR #:node-while-expr ; ACCESSOR #:node-while-body ; ACCESSOR #:node-while-let ; STRUCT #:make-node-while-let ; CONSTRUCTOR + #:node-while-let-label ; ACCESSOR #:node-while-let-pattern ; ACCESSOR #:node-while-let-expr ; ACCESSOR #:node-while-let-body ; ACCESSOR #:node-for ; STRUCT #:make-node-for ; CONSTRUCTOR + #:node-for-label ; ACCESSOR #:node-for-pattern ; ACCESSOR #:node-for-expr ; ACCESSOR #:node-for-body ; ACCESSOR #:node-loop ; STRUCT #:make-node-loop ; CONSTRUCTOR - #:node-loop-body ; ACCESSOR #:node-loop-label ; ACCESSOR + #:node-loop-body ; ACCESSOR #:node-break ; STRUCT #:make-node-break ; CONSTRUCTOR #:node-break-label ; ACCESSOR @@ -329,12 +332,14 @@ (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)) + (label (util:required 'label) :type keyword :read-only t) + (expr (util:required 'expr) :type node :read-only t) + (body (util:required 'body) :type node-body :read-only t)) (defstruct (node-while-let (:include node) (:copier nil)) + (label (util:required 'label) :type keyword :read-only t) (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)) @@ -342,6 +347,7 @@ (defstruct (node-for (:include node) (:copier nil)) + (label (util:required 'label) :type keyword :read-only t) (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)) @@ -349,18 +355,18 @@ (defstruct (node-loop (:include node) (:copier nil)) - (label (util:required 'label) :type (or null keyword) :read-only t) - (body (util:required 'body) :type node-body :read-only t)) + (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)) - (label (util:required 'label) :type (or null keyword) :read-only t)) + (label (util:required 'label) :type keyword :read-only t)) (defstruct (node-continue (:include node) (:copier nil)) - (label (util:required 'label) :type (or null keyword) :read-only t)) + (label (util:required 'label) :type keyword :read-only t)) (defstruct (node-cond-clause (:copier nil)) @@ -584,6 +590,7 @@ (make-node-while :type (tc:apply-substitution subs (node-type node)) :source (node-source node) + :label (node-while-label node) :expr (tc:apply-substitution subs (node-while-expr node)) :body (tc:apply-substitution subs (node-while-body node)))) @@ -593,6 +600,7 @@ (make-node-while-let :type (tc:apply-substitution subs (node-type node)) :source (node-source node) + :label (node-while-let-label node) :pattern (tc:apply-substitution subs (node-while-let-pattern node)) :expr (tc:apply-substitution subs (node-while-let-expr node)) :body (tc:apply-substitution subs (node-while-let-body node)))) @@ -603,6 +611,7 @@ (make-node-for :type (tc:apply-substitution subs (node-type node)) :source (node-source node) + :label (node-for-label node) :pattern (tc:apply-substitution subs (node-for-pattern node)) :expr (tc:apply-substitution subs (node-for-expr node)) :body (tc:apply-substitution subs (node-for-body node)))) diff --git a/src/typechecker/traverse.lisp b/src/typechecker/traverse.lisp index f1884c188..99a8f00f2 100644 --- a/src/typechecker/traverse.lisp +++ b/src/typechecker/traverse.lisp @@ -284,6 +284,7 @@ (make-node-while :type (node-type node) :source (node-source node) + :label (node-while-label node) :expr (traverse (node-while-expr node) block) :body (traverse (node-while-body node) block)))) @@ -295,6 +296,7 @@ (make-node-while-let :type (node-type node) :source (node-source node) + :label (node-while-let-label node) :pattern (node-while-let-pattern node) :expr (traverse (node-while-let-expr node) block) :body (traverse (node-while-let-body node) block)))) @@ -307,6 +309,7 @@ (make-node-for :type (node-type node) :source (node-source node) + :label (node-for-label node) :pattern (node-for-pattern node) :expr (traverse (node-for-expr node) block) :body (traverse (node-for-body node) block))))