From 902c4958ed483ed460c3ab69927df30c6b4b4fff Mon Sep 17 00:00:00 2001 From: "O'Keefe, Colin B" Date: Tue, 12 Sep 2023 08:56:26 -0700 Subject: [PATCH] Adds while loops Add while parser expression implement renamer for while Add while typechecker expression and impl infer-expression-type while codegen imple node-variables-g for node-while --- src/codegen/ast.lisp | 14 ++++++++ src/codegen/codegen-expression.lisp | 9 +++++ src/codegen/transformations.lisp | 9 +++++ src/codegen/translate-expression.lisp | 10 ++++++ src/package.lisp | 1 + src/parser/expression.lisp | 45 +++++++++++++++++++++++++ src/parser/renamer.lisp | 10 ++++++ src/typechecker/define.lisp | 47 +++++++++++++++++++++++++++ src/typechecker/expression.lisp | 19 +++++++++++ 9 files changed, 164 insertions(+) diff --git a/src/codegen/ast.lisp b/src/codegen/ast.lisp index e291b6613..d1b718c23 100644 --- a/src/codegen/ast.lisp +++ b/src/codegen/ast.lisp @@ -54,6 +54,10 @@ #:make-node-match ; CONSTRUCTOR #:node-match-expr ; ACCESSOR #:node-match-branches ; ACCESSOR + #:node-while ; STRUCT + #:make-node-while ; CONSTRUCTOR + #:node-while-expr ; ACCESSOR + #:node-while-body ; ACESSOR #:node-seq ; STRUCT #:make-node-seq ; CONSTRUCTOR #:node-seq-nodes ; ACCESSOR @@ -165,6 +169,11 @@ (expr (util:required 'expr) :type node :read-only t) (branches (util:required 'branches) :type branch-list :read-only t)) +(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)) + (defstruct (node-seq (:include node)) "A series of statements to be executed sequentially" (nodes (util:required 'nodes) :type node-list :read-only t)) @@ -329,6 +338,11 @@ both CL namespaces appearing in NODE" (node-variables-g node :variable-namespace-only variable-namespace-only)) (node-match-branches node)))) + (:method ((node node-while) &key variable-namespace-only) + (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-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 fde84023a..23e1b1f3b 100644 --- a/src/codegen/codegen-expression.lisp +++ b/src/codegen/codegen-expression.lisp @@ -107,6 +107,15 @@ ,inner) inner))) + (:method ((expr node-while) current-function env) + (declare (type tc:environment env) + (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 :while ,pred-expr + :do ,body-expr))) + (:method ((expr node-match) current-function env) (declare (type tc:environment env) (type (or null symbol) current-function)) diff --git a/src/codegen/transformations.lisp b/src/codegen/transformations.lisp index aa7773838..d6f0331ea 100644 --- a/src/codegen/transformations.lisp +++ b/src/codegen/transformations.lisp @@ -119,6 +119,15 @@ (node-match-branches node))))) (call-if node :match funs bound-variables))) + (:method ((node node-while) funs bound-variables) + (declare (type util:symbol-list bound-variables)) + (let ((node + (make-node-while + :type (node-type 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))) + (:method ((node node-seq) funs bound-variables) (declare (type util:symbol-list bound-variables)) (let ((node diff --git a/src/codegen/translate-expression.lisp b/src/codegen/translate-expression.lisp index 13c6689c5..9e7dc4c0a 100644 --- a/src/codegen/translate-expression.lisp +++ b/src/codegen/translate-expression.lisp @@ -550,6 +550,16 @@ Returns a `node'.") :type tc:*unit-type* :value unit-value)))))) + (:method ((expr tc:node-while) ctx env) + (declare (type pred-context ctx) + (type tc:environment env) + (values node)) + + (make-node-while + :type tc:*unit-type* + :expr (translate-expression (tc:node-while-expr expr) ctx env) + :body (translate-expression (tc:node-while-body expr) ctx env))) + (:method ((expr tc:node-cond) ctx env) (declare (type pred-context ctx) (type tc:environment env) diff --git a/src/package.lisp b/src/package.lisp index 6eba68ccd..a8de2210a 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -73,6 +73,7 @@ (:export #:if #:when + #:while #:unless #:and #:or diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index 32adc704b..eb6841cd4 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -128,6 +128,10 @@ #:node-do-body-element ; TYPE #:node-body-element-list ; TYPE #:node-do ; STRUCT + #:node-while ; STRUCT + #:make-node-while ; CONSTRUCTOR + #:node-while-expr ; ACCESSOR + #:node-while-body ; ACCESSOR #:make-node-do ; CONSTRUCTOR #:node-do-nodes ; ACCESSOR #:node-do-last-node ; ACCESSOR @@ -462,6 +466,13 @@ (nodes (util:required 'nodes) :type node-do-body-element-list :read-only t) (last-node (util:required 'last-node) :type node :read-only t)) +(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)) + + (defun parse-expression (form file) (declare (type cst:cst form) (type coalton-file file) @@ -875,6 +886,10 @@ (eq 'coalton:do (cst:raw (cst:first form)))) (parse-do form file)) + ((and (cst:atom (cst:first form)) + (eq 'coalton:while (cst:raw (cst:first form)))) + (parse-while form file)) + ;; ;; Macros ;; @@ -1337,6 +1352,36 @@ (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 predicate"))) + + ;; (while pred) + (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-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 9ff6ff317..9b3aae8fe 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -279,6 +279,16 @@ :source (node-source node)) ctx)) + (:method ((node node-while) ctx) + (declare (type algo:immutable-map ctx) + (values node algo:immutable-map)) + (values + (make-node-while + :expr (rename-variables-generic% (node-while-expr node) ctx) + :body (rename-variables-generic% (node-while-body node) ctx) + :source (node-source node)) + ctx)) + (:method ((node node-unless) ctx) (declare (type algo:immutable-map ctx) (values node algo:immutable-map)) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index 6ba224f94..8d825be8c 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -1221,6 +1221,53 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (tc:apply-substitution subs body-ty) (tc:apply-substitution subs expected-type))))))))) + + (:method ((node parser:node-while) 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 tc:substitution-list)) + (multiple-value-bind (expr-ty preds accessors expr-node subs) + (infer-expression-type (parser:node-while-expr node) + tc:*boolean-type* + subs + env + file) + (declare (ignore expr-ty)) + + (multiple-value-bind (body-ty preds_ accessors_ body-node subs) + (infer-expression-type (parser:node-while-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 + :type (tc:qualify nil tc:*unit-type*) + :source (parser:node-source 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 ee01fcc87..cf6bf0ee3 100644 --- a/src/typechecker/expression.lisp +++ b/src/typechecker/expression.lisp @@ -111,6 +111,10 @@ #:make-node-unless ; CONSTRUCTOR #:node-unless-expr ; ACCESSOR #:node-unless-body ; ACCESSOR + #:node-while ; STRUCT + #:make-node-while ; CONSTRUCTOR + #:node-while-expr ; ACCESSOR + #:node-while-body ; ACCESSOR #:node-cond-clause ; STRUCT #:make-node-cond-clause ; CONSTRUCTOR #:node-cond-clause-expr ; ACCESSOR @@ -302,6 +306,12 @@ (expr (util:required 'expr) :type node :read-only t) (body (util:required 'body) :type node-body :read-only t)) +(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)) + (defstruct (node-cond-clause (:copier nil)) (expr (util:required 'expr) :type node :read-only t) @@ -518,6 +528,15 @@ :expr (tc:apply-substitution subs (node-unless-expr node)) :body (tc:apply-substitution subs (node-unless-body node)))) +(defmethod tc:apply-substitution (subs (node node-while)) + (declare (type tc:substitution-list subs) + (values node-while)) + (make-node-while + :type (tc:apply-substitution subs (node-type node)) + :source (node-source node) + :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-cond-clause)) (declare (type tc:substitution-list subs) (values node-cond-clause))