(define impc:ti:ret-check
(lambda (ast vars kts request?)
;; (println 'retcheck: request? 'a: ast)
;; (println 'vars: vars)
;; grab function name from ret->
(let* ((sym (if (equal? (caddr ast) (cadr ast))
'()
(impc:ti:get-var (cadr ast) vars)))
(t (if (null? sym) #f
(if (null? (cdr sym))
#f
(if (impc:ir:type? (cdr sym))
(cdr sym)
(car (cdr sym))))))
;;(car (cdr sym)))))
;; if closure has a return type set
;; pass it as a request
(a (impc:ti:type-unify
(impc:ti:type-check (caddr ast) vars kts
(if (and t
(impc:ir:type? t)
(impc:ir:closure? t))
(if (list? t) (cadr t) request?)
;#f)))) ;; or else pass #f
request?))
vars))) ;; or pass on request
;; (println 'retchecked-> a 'request? request? 'ast: ast 't: t)
;; if t is not a closure type we have a problem!
(if (and t
(or (not (list? t));(not (impc:ir:type? t))
(not (impc:ir:closure? t))))
(impc:compiler:print-compiler-error "type error calculating return type - have you specified an incorrect closure type?" ast))
(if (and (impc:ir:type? t)
(impc:ir:closure? t)
(string? a)
(string? request?)
(regex:match? request? "^%.*")
(regex:match? a "^%.*")
(not (equal? request? a)))
(impc:compiler:print-compiler-error (string-append "type error calculating return type - expected named type '" a "' got '" request? "'") ast))
(if *impc:ti:print-sub-checks* (println 'ret:> 'ast: ast 'a: a 'sym: sym))
(if (and (impc:ir:type? t)
(impc:ir:closure? t))
(if (symbol? (caddr ast))
(impc:ti:update-var (caddr ast) vars kts (list (cadr t)))
;; else the return value is not a symbol
;; and we should use it's value to update the lambda's type
(impc:ti:update-var (car sym) vars kts
(list (impc:ir:pointer++ (impc:ir:pointer++ (list* *impc:ir:closure* a (cddr t))))))))
;; (println 'ret: a)
a)))