From a155db36a0bc93faeee970738a52824787912942 Mon Sep 17 00:00:00 2001 From: "O'Keefe, Colin B" Date: Tue, 26 Sep 2023 09:06:18 -0700 Subject: [PATCH] Unit elision feature in when and unless body --- src/codegen/translate-expression.lisp | 32 +++++++++--- src/typechecker/define.lisp | 70 +++++++++------------------ 2 files changed, 50 insertions(+), 52 deletions(-) diff --git a/src/codegen/translate-expression.lisp b/src/codegen/translate-expression.lisp index 13c6689c5..e3e7786e6 100644 --- a/src/codegen/translate-expression.lisp +++ b/src/codegen/translate-expression.lisp @@ -500,7 +500,17 @@ Returns a `node'.") (let* ((coalton-package (find-package "COALTON")) (true-value (util:find-symbol "TRUE" coalton-package)) (false-value (util:find-symbol "FALSE" coalton-package)) - (unit-value (util:find-symbol "UNIT" coalton-package))) + (unit-value (util:find-symbol "UNIT" coalton-package)) + (translated-body (translate-expression (tc:node-when-body expr) ctx env))) + + (unless (equalp tc:*unit-type* (node-type translated-body)) + (setf translated-body + (make-node-seq + :type tc:*unit-type* + :nodes (list translated-body + (make-node-variable + :type tc:*unit-type* + :value unit-value))))) (make-node-match :type tc:*unit-type* @@ -511,7 +521,7 @@ Returns a `node'.") :type tc:*boolean-type* :name true-value :patterns nil) - :body (translate-expression (tc:node-when-body expr) ctx env)) + :body translated-body) (make-match-branch :pattern (make-pattern-constructor :type tc:*boolean-type* @@ -529,7 +539,17 @@ Returns a `node'.") (let* ((coalton-package (find-package "COALTON")) (true-value (util:find-symbol "TRUE" coalton-package)) (false-value (util:find-symbol "FALSE" coalton-package)) - (unit-value (util:find-symbol "UNIT" coalton-package))) + (unit-value (util:find-symbol "UNIT" coalton-package)) + (translated-body (translate-expression (tc:node-unless-body expr) ctx env))) + + (unless (equalp tc:*unit-type* (node-type translated-body)) + (setf translated-body + (make-node-seq + :type tc:*unit-type* + :nodes (list translated-body + (make-node-variable + :type tc:*unit-type* + :value unit-value))))) (make-node-match :type tc:*unit-type* @@ -538,13 +558,13 @@ Returns a `node'.") (make-match-branch :pattern (make-pattern-constructor :type tc:*boolean-type* - :name false-value + :name true-value :patterns nil) - :body (translate-expression (tc:node-unless-body expr) ctx env)) + :body translated-body) (make-match-branch :pattern (make-pattern-constructor :type tc:*boolean-type* - :name true-value + :name false-value :patterns nil) :body (make-node-variable :type tc:*unit-type* diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index 6ba224f94..87c9b0527 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -1144,35 +1144,24 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (multiple-value-bind (body-ty preds_ accessors_ body-node subs) (infer-expression-type (parser:node-when-body node) - tc:*unit-type* + (tc:make-variable) subs env file) + (declare (ignore body-ty)) (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-when - :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))))))))) + (values + tc:*unit-type* + preds + accessors + (make-node-when + :type (tc:qualify nil tc:*unit-type*) + :source (parser:node-source node) + :expr expr-node + :body body-node) + subs)))) (:method ((node parser:node-unless) expected-type subs env file) (declare (type tc:ty expected-type) @@ -1191,35 +1180,24 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (multiple-value-bind (body-ty preds_ accessors_ body-node subs) (infer-expression-type (parser:node-unless-body node) - tc:*unit-type* + (tc:make-variable) subs env file) + (declare (ignore body-ty)) (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-unless - :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))))))))) + (values + tc:*unit-type* + preds + accessors + (make-node-unless + :type (tc:qualify nil tc:*unit-type*) + :source (parser:node-source node) + :expr expr-node + :body body-node) + subs)))) (:method ((node parser:node-cond-clause) expected-type subs env file) (declare (type tc:ty expected-type)