diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index ccc9a2d81..3a41f6405 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -142,7 +142,7 @@ #:node-loop-body ; ACCESSOR #:node-named-loop ; STRUCT #:make-node-named-loop ; CONSTRUCTOR - #:node-named-loop-label ; ACCESSOR + #:node-named-loop-label ; ACCESSOR #:node-named-loop-body ; ACCESSOR #:node-break ; STRUCT #:make-node-break ; CONSTRUCTOR diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index abac38572..a336a28c6 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -1176,16 +1176,18 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (multiple-value-bind (body-ty preds_ accessors_ body-node subs) (infer-expression-type (parser:node-while-body node) - tc:*unit-type* + (tc:make-variable) subs env file) - (setf preds (append preds preds_)) - (setf accessors (append accessors accessors_)) + (declare (ignore body-ty)) + + (setf preds (append preds preds_) + accessors (append accessors accessors_)) (handler-case (progn - (setf subs (tc:unify subs body-ty expected-type)) + (setf subs (tc:unify subs tc:*unit-type* expected-type)) (values tc:*unit-type* preds @@ -1197,7 +1199,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :body body-node) subs)) (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type body-ty)))))) + (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) @@ -1219,17 +1221,17 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (multiple-value-bind (body-ty preds_ accessors_ body-node subs) (infer-expression-type (parser:node-while-let-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)) + (setf subs (tc:unify subs tc:*unit-type* expected-type)) (values tc:*unit-type* preds @@ -1242,7 +1244,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :body body-node) subs)) (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type body-ty))))))) + (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*))))))) (:method ((node parser:node-for) expected-type subs env file) @@ -1265,7 +1267,9 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (infer-expression-type (parser:node-for-expr node) (tc:make-variable) subs env file) (multiple-value-bind (body-ty preds_ accessors_ body-node subs) - (infer-expression-type (parser:node-for-body node) tc:*unit-type* subs env file) + (infer-expression-type (parser:node-for-body node) (tc:make-variable) subs env file) + + (declare (ignore body-ty)) (setf preds (append preds preds_) @@ -1273,7 +1277,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (handler-case (progn - (setf subs (tc:unify subs body-ty expected-type)) + (setf subs (tc:unify subs tc:*unit-type* expected-type)) (values tc:*unit-type* (cons @@ -1291,7 +1295,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :body body-node) subs)) (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type body-ty)))))))) + (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type*)))))))) (:method ((node parser:node-loop) expected-type subs env file) (declare (type tc:ty expected-type) @@ -1301,13 +1305,14 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (values tc:ty tc:ty-predicate-list accessor-list node-loop tc:substitution-list)) (multiple-value-bind (body-ty preds accessors body-node subs) (infer-expression-type (parser:node-loop-body node) - tc:*unit-type* + (tc:make-variable) subs env file) + (declare (ignore body-ty)) (handler-case (progn - (setf subs (tc:unify subs body-ty expected-type)) + (setf subs (tc:unify subs tc:*unit-type* expected-type)) (values tc:*unit-type* preds @@ -1318,7 +1323,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :body body-node) subs)) (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type body-ty))))) + (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) @@ -1328,13 +1333,14 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (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:*unit-type* + (tc:make-variable) subs env file) + (declare (ignore body-ty)) (handler-case (progn - (setf subs (tc:unify subs body-ty expected-type)) + (setf subs (tc:unify subs tc:*unit-type* expected-type)) (values tc:*unit-type* preds @@ -1346,7 +1352,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :body body-node) subs)) (error:coalton-internal-type-error () - (standard-expression-type-mismatch-error node file subs expected-type body-ty))))) + (standard-expression-type-mismatch-error node file subs expected-type tc:*unit-type* ))))) (:method ((node parser:node-break) expected-type subs env file) (declare (type tc:ty expected-type)