diff --git a/src/codegen/ast.lisp b/src/codegen/ast.lisp index d1b718c23..d3430b4e4 100644 --- a/src/codegen/ast.lisp +++ b/src/codegen/ast.lisp @@ -58,6 +58,11 @@ #:make-node-while ; CONSTRUCTOR #:node-while-expr ; ACCESSOR #:node-while-body ; ACESSOR + #:node-while-let ; STRUCT + #:make-node-while-let ; CONSTRUCTOR + #:node-while-let-pattern ; ACCESSPR + #:node-while-let-expr ; ACCESSOR + #:node-while-let-body ; ACESSOR #:node-seq ; STRUCT #:make-node-seq ; CONSTRUCTOR #:node-seq-nodes ; ACCESSOR @@ -174,6 +179,12 @@ (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)) + (defstruct (node-seq (:include node)) "A series of statements to be executed sequentially" (nodes (util:required 'nodes) :type node-list :read-only t)) @@ -342,6 +353,11 @@ both CL namespaces appearing in NODE" (declare (values parser:identifier-list &optional)) (nconc (node-variables-g (node-while-expr node) :variable-namespace-only variable-namespace-only) (node-variables-g (node-while-body node) :variable-namespace-only variable-namespace-only))) + + (:method ((node node-while-let) &key variable-namespace-only) + (declare (values parser:identifier-list &optional)) + (nconc (node-variables-g (node-while-let-expr node) :variable-namespace-only variable-namespace-only) + (node-variables-g (node-while-let-body node) :variable-namespace-only variable-namespace-only))) (:method ((node node-seq) &key variable-namespace-only) (declare (values parser:identifier-list &optional)) diff --git a/src/codegen/codegen-expression.lisp b/src/codegen/codegen-expression.lisp index 23e1b1f3b..92b6363f1 100644 --- a/src/codegen/codegen-expression.lisp +++ b/src/codegen/codegen-expression.lisp @@ -115,6 +115,27 @@ (body-expr (codegen-expression (node-while-body expr) current-function env))) `(loop :while ,pred-expr :do ,body-expr))) + + (:method ((expr node-while-let) current-function env) + (declare (type tc:environment env) + (type (or null symbol) current-function)) + + (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)) + (match-var (gensym "MATCH"))) + + (multiple-value-bind (pred bindings) + (codegen-pattern (node-while-let-pattern expr) match-var env) + + `(loop + :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 ,(cond ((null bindings) body-expr) + (t `(let ,bindings + (declare (ignorable ,@(mapcar #'car bindings))) + ,body-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 d6f0331ea..a57d69af0 100644 --- a/src/codegen/transformations.lisp +++ b/src/codegen/transformations.lisp @@ -127,6 +127,16 @@ :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))) + + (:method ((node node-while-let) funs bound-variables) + (declare (type util:symbol-list bound-variables)) + (let ((node + (make-node-while-let + :type (node-type 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)))) + (call-if node :while-let funs bound-variables))) (:method ((node node-seq) funs bound-variables) (declare (type util:symbol-list bound-variables)) diff --git a/src/codegen/translate-expression.lisp b/src/codegen/translate-expression.lisp index 9e7dc4c0a..be1d43aba 100644 --- a/src/codegen/translate-expression.lisp +++ b/src/codegen/translate-expression.lisp @@ -560,6 +560,16 @@ Returns a `node'.") :expr (translate-expression (tc:node-while-expr expr) ctx env) :body (translate-expression (tc:node-while-body expr) ctx env))) + (:method ((expr tc:node-while-let) ctx env) + (declare (type pred-context ctx) + (type tc:environment env) + (values node)) + (make-node-while-let + :type tc:*unit-type* + :pattern (translate-pattern (tc:node-while-let-pattern expr)) + :expr (translate-expression (tc:node-while-let-expr expr) ctx env) + :body (translate-expression (tc:node-while-let-body expr) ctx env))) + (:method ((expr tc:node-cond) ctx env) (declare (type pred-context ctx) (type tc:environment env) diff --git a/src/codegen/typecheck-node.lisp b/src/codegen/typecheck-node.lisp index d671a7992..322cd0690 100644 --- a/src/codegen/typecheck-node.lisp +++ b/src/codegen/typecheck-node.lisp @@ -113,6 +113,18 @@ (setf subs (tc:unify subs subexpr-ty type)))) type)) + (:method ((expr node-while) env) + (declare (type tc:environment env) + (values tc:ty)) + (typecheck-node (node-while-expr expr) env) + (typecheck-node (node-while-body expr) env)) + + (:method ((expr node-while-let) env) + (declare (type tc:environment env) + (values tc:ty)) + (typecheck-node (node-while-let-expr expr) env) + (typecheck-node (node-while-let-body expr) env)) + (:method ((expr node-seq) env) (declare (type tc:environment env) (values tc:ty)) diff --git a/src/package.lisp b/src/package.lisp index a8de2210a..2fd8dd9a4 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -74,6 +74,7 @@ #:if #:when #:while + #:while-let #:unless #:and #:or diff --git a/src/parser/collect.lisp b/src/parser/collect.lisp index 6bd776d46..adaa0f1ff 100644 --- a/src/parser/collect.lisp +++ b/src/parser/collect.lisp @@ -232,6 +232,16 @@ in expressions. May not include all bound variables." (declare (values node-variable-list)) (mapcan #'collect-variables-generic% (node-cond-clauses node))) + (:method ((node node-while)) + (declare (values node-variable-list)) + (nconc (collect-variables-generic% (node-while-expr node)) + (collect-variables-generic% (node-while-body node)))) + + (:method ((node node-while-let)) + (declare (values node-variable-list)) + (nconc (collect-variables-generic% (node-while-let-expr node)) + (collect-variables-generic% (node-while-let-body node)))) + (:method ((node node-do-bind)) (declare (values node-variable-list &optional)) (collect-variables-generic% (node-do-bind-expr node))) diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index eb6841cd4..a200f8765 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -132,6 +132,11 @@ #:make-node-while ; CONSTRUCTOR #:node-while-expr ; ACCESSOR #:node-while-body ; ACCESSOR + #:node-while-let ; STRUCT + #:make-node-while-let ; CONSTRUCTOR + #:node-while-let-pattern ; ACCESSOR + #:node-while-let-expr ; ACCESSOR + #:node-while-let-body ; ACCESSOR #:make-node-do ; CONSTRUCTOR #:node-do-nodes ; ACCESSOR #:node-do-last-node ; ACCESSOR @@ -472,6 +477,13 @@ (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)) + (defun parse-expression (form file) (declare (type cst:cst form) @@ -890,6 +902,10 @@ (eq 'coalton:while (cst:raw (cst:first form)))) (parse-while form file)) + ((and (cst:atom (cst:first form)) + (eq 'coalton:while-let (cst:raw (cst:first form)))) + (parse-while-let form file)) + ;; ;; Macros ;; @@ -1365,9 +1381,9 @@ :file file :highlight :end :message "Malformed while expression" - :primary-note "expected predicate"))) + :primary-note "expected match"))) - ;; (while pred) + ;; (while match) (unless (cst:consp (cst:rest (cst:rest form))) (error 'parse-error :err (coalton-error @@ -1382,6 +1398,41 @@ :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 match pattern")) + + ;; (while-let expr) + (unless (cst:consp (cst:nthrest 2 form)) + (while-let-error "expected =")) + + ;; (when-let expr =) + (unless (cst:consp (cst:nthrest 3 form)) + (while-let-error "expected match expression")) + + ;; (when-let expr = pattern) + (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-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 9b3aae8fe..a1b34fb53 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -288,6 +288,17 @@ :body (rename-variables-generic% (node-while-body node) ctx) :source (node-source node)) ctx)) + + (:method ((node node-while-let) ctx) + (declare (type algo:immutable-map ctx) + (values node algo:immutable-map)) + (values + (make-node-while-let + :pattern (rename-variables-generic% (node-while-let-pattern node) ctx) + :expr (rename-variables-generic% (node-while-let-expr node) ctx) + :body (rename-variables-generic% (node-while-let-body node) ctx) + :source (node-source node)) + ctx)) (:method ((node node-unless) ctx) (declare (type algo:immutable-map ctx) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index 8d825be8c..d3474170a 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -1268,6 +1268,58 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (tc:apply-substitution subs body-ty) (tc:apply-substitution subs expected-type))))))))) + (:method ((node parser:node-while-let) 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-while-let tc:substitution-list)) + + (multiple-value-bind (expr-ty preds accessors expr-node subs) + (infer-expression-type (parser:node-while-let-expr node) + (tc:make-variable) + subs + env + file) + + (multiple-value-bind (pat-ty pat-node subs) + (infer-pattern-type (parser:node-while-let-pattern node) expr-ty subs env file) + (declare (ignore pat-ty)) + + (multiple-value-bind (body-ty preds_ accessors_ body-node subs) + (infer-expression-type (parser:node-while-let-body node) + tc:*unit-type* + subs + env + file) + + (setf preds (append preds preds_)) + (setf accessors (append accessors accessors_)) + + (handler-case + (progn + (setf subs (tc:unify subs body-ty expected-type)) + (values + tc:*unit-type* + preds + accessors + (make-node-while-let + :type (tc:qualify nil tc:*unit-type*) + :source (parser:node-source node) + :pattern pat-node + :expr expr-node + :body body-node) + subs)) + (error:coalton-internal-type-error () + (error 'tc-error + :err (coalton-error + :span (parser:node-source node) + :file file + :message "Type mismatch" + :primary-note (format nil "Expected type '~S' but got '~S'" + (tc:apply-substitution subs body-ty) + (tc:apply-substitution subs expected-type)))))))))) + (:method ((node parser:node-cond-clause) expected-type subs env file) (declare (type tc:ty expected-type) (type tc:substitution-list subs) diff --git a/src/typechecker/expression.lisp b/src/typechecker/expression.lisp index cf6bf0ee3..df7aac28f 100644 --- a/src/typechecker/expression.lisp +++ b/src/typechecker/expression.lisp @@ -115,6 +115,11 @@ #:make-node-while ; CONSTRUCTOR #:node-while-expr ; ACCESSOR #:node-while-body ; ACCESSOR + #:node-while-let ; STRUCT + #:make-node-while-let ; CONSTRUCTOR + #:node-while-let-pattern ; ACCESSOR + #:node-while-let-expr ; ACCESSOR + #:node-while-let-body ; ACCESSOR #:node-cond-clause ; STRUCT #:make-node-cond-clause ; CONSTRUCTOR #:node-cond-clause-expr ; ACCESSOR @@ -312,6 +317,13 @@ (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)) + (defstruct (node-cond-clause (:copier nil)) (expr (util:required 'expr) :type node :read-only t) @@ -537,6 +549,16 @@ :expr (tc:apply-substitution subs (node-while-expr node)) :body (tc:apply-substitution subs (node-while-body node)))) +(defmethod tc:apply-substitution (subs (node node-while-let)) + (declare (type tc:substitution-list subs) + (values node-while-let)) + (make-node-while-let + :type (tc:apply-substitution subs (node-type node)) + :source (node-source 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)))) + (defmethod tc:apply-substitution (subs (node node-cond-clause)) (declare (type tc:substitution-list subs) (values node-cond-clause)) diff --git a/src/typechecker/traverse.lisp b/src/typechecker/traverse.lisp index c1c2ef3c5..9a2f2a31a 100644 --- a/src/typechecker/traverse.lisp +++ b/src/typechecker/traverse.lisp @@ -34,6 +34,8 @@ (unless #'identity :type function :read-only t) (cond-clause #'identity :type function :read-only t) (cond #'identity :type function :read-only t) + (while #'identity :type function :read-only t) + (while-let #'identity :type function :read-only t) (do-bind #'identity :type function :read-only t) (do #'identity :type function :read-only t)) @@ -270,6 +272,29 @@ :source (node-source node) :clauses (traverse (node-cond-clauses node) block)))) + (:method ((node node-while) block) + (declare (type traverse-block block) + (values node &optional)) + (funcall + (traverse-while block) + (make-node-while + :type (node-type node) + :source (node-source node) + :expr (traverse (node-while-expr node) block) + :body (traverse (node-while-body node) block)))) + + (:method ((node node-while-let) block) + (declare (type traverse-block block) + (values node &optional)) + (funcall + (traverse-while block) + (make-node-while-let + :type (node-type node) + :source (node-source node) + :pattern (node-while-let-pattern node) + :expr (traverse (node-while-let-expr node) block) + :body (traverse (node-while-let-body node) block)))) + (:method ((node node-do-bind) block) (declare (type traverse-block block) (values node-do-bind &optional))