Skip to content

Commit

Permalink
all loop expressions are implicitly of type Unit
Browse files Browse the repository at this point in the history
  • Loading branch information
@macrologist
macrologist committed Sep 19, 2023
1 parent 3d62624 commit 510e1f8
Show file tree
Hide file tree
Showing 2 changed files with 25 additions and 19 deletions.
2 changes: 1 addition & 1 deletion src/parser/expression.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
42 changes: 24 additions & 18 deletions src/typechecker/define.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -1265,15 +1267,17 @@ 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_)
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*
(cons
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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)
Expand Down

0 comments on commit 510e1f8

Please sign in to comment.