impc:ti:run-type-check*   scheme

Defined in:


;; run the type checker
;; if we fail to unify completely the first time
;; try some possible substitutions!
(define impc:ti:run-type-check*
  (lambda (vars forced-types ast . cnt)
    (set! *impc:ti:nativef-generics:calls* 0)
    (set! *impc:ti:type-check:calls* 0)
    ;; (println '------------------------------------)
    ;; (println 'run-type-check*: (caaadr ast))
    ;; (println 'forced-types* forced-types)
    ;; (println 'ast: ast)
    ;; (println 'vars*: vars)
    (define *impc:ti:nativef-generics-recurse-test* 0)
    (set! *impc:ti:type-check-function-symbol* (caaadr ast))
    (set! *impc:ti:type-check-function-symbol-short*
           (car (regex:split (symbol->string *impc:ti:type-check-function-symbol*) "(_poly_)|(_adhoc_)"))))
    ;; (if (null? cnt) (sys:clear-log-view))
    (let* ((fvars (map (lambda (t) ;; add any forced-type values to vars
                         (if (assoc-strcmp (car t) forced-types)
                             (let ((tt (cdr (assoc-strcmp (car t) forced-types))))
                               (cons (car t) (list tt)))
           ;; (lll (println 'vars1: vars))
           (kts (map (lambda (x) (car x)) forced-types)) ;; just need symbols from forced-types
           ;; fvars gets modified 'in place' during this next
           ;; operation
           (t1 (clock:clock))
           (ret (impc:ti:type-check ast fvars kts #f))
           ;; (llllllll (println 'pre-unified-vars: fvars))
           (t2 (clock:clock))
           (u1 (impc:ti:unify fvars))
           (u (cl:remove-if (lambda (x)
                              (and (not (impc:ir:type? (cdr x)))
                                   (regex:match? (symbol->string (car x)) "(^!|[A-Za-z]\\:\\<|[A-Za-z]{)")))
           (t3 (clock:clock))
           ;; (lllll (println 'post-unified-vars: u))
           (t (impc:ti:unity? u))
           (t4 (clock:clock))
           ;; (lllllll (println (println 'cccccc)))
           (tt (cl:every (lambda (x) x) t))
           (a (if tt #t
                  (impc:ti:find-unresolved-simple-types u))))
                                        ;(println 'fvars: fvars)
                                        ;(println 'types: u)
      (if *impc:ti:print-unifications* (println 'tirun:> a '-> u))

Back to Index