impc:ti:ret-check   scheme

Defined in:


(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))
                      (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
               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)

Back to Index