;; vars is statefull and will be modified in place
(define impc:ti:type-check
(lambda (ast vars kts request?)
(set! *impc:ti:type-check:calls* (+ *impc:ti:type-check:calls* 1))
;; (println 'tc: ast); 'vars: vars)
;; (println 'type-check: ast 'vars: vars 'kts: kts 'request? request?)
(if *impc:ti:print-main-check* (println 'type-check: ast 'kts: kts 'request? request?))
(if *impc:ti:print-main-check* (println 'vars------: vars))
(cond ((null? ast) '())
((and (atom? ast) (number? ast)) (impc:ti:numeric-check ast vars kts request?))
((and (atom? ast) (symbol? ast)) (impc:ti:symbol-check ast vars kts request?))
((and (atom? ast) (string? ast)) (impc:ti:string-check ast vars kts request?))
((atom? ast) (impc:compiler:print-compiler-error "internal error unhandled atom" ast))
((and (list? ast) (member (car ast) *impc:letslist*)) (impc:ti:let-check ast vars kts request?))
((and (list? ast) (member (car ast) *impc:lambdaslist*)) (impc:ti:lambda-check ast vars kts request?))
((and (list? ast) (equal? (car ast) 't:))
(impc:ti:type-check (cadr ast) vars kts
(impc:ir:get-type-from-pretty-str
(symbol->string (caddr ast)))))
((and (list? ast) (member (car ast) *impc:mathbinaryaritylist*))
;; '(* / + - % modulo bitwise-and bitwise-or bitwise-eor bitwise-shift-left bitwise-shift-right bitwise-not)))
(let ((r (impc:ti:math-check ast vars kts request?)))
(if (impc:ir:tuple? r)
(begin ;; this is very dodgy!
(set! *unique-polynum* (+ 1 *unique-polynum*))
(let ((m (string->symbol (string-append (cond ((eq? (car ast) '*) "xtm_multiplication##")
((eq? (car ast) '+) "xtm_addition##")
((eq? (car ast) '/) "xtm_division##")
((eq? (car ast) '-) "xtm_subtraction##")
((eq? (car ast) '%) "xtm_modulo##")
(else (log-error "Error in math overloading")))
(number->string *unique-polynum*)))))
(insert-at-index 1 vars (list m))
(set-car! ast m)
(set! r (impc:ti:type-check ast vars kts request?)))))
r))
((and (list? ast) (member (car ast) '(< > = <>)))
(let ((r (impc:ti:compare-check ast vars kts request?)))
(if (impc:ir:tuple? r)
(begin ;; this is very dodgy!
(set! *unique-polynum* (+ 1 *unique-polynum*))
(let ((m (string->symbol (string-append (cond ((eq? (car ast) '<) "xtm_lessthan##")
((eq? (car ast) '>) "xtm_greaterthan##")
((eq? (car ast) '=) "xtm_equal##")
((eq? (car ast) '<>) "xtm_notequal##")
(else (log-error "Error in math overloading")))
(number->string *unique-polynum*)))))
(insert-at-index 1 vars (list m))
(set-car! ast m)
(set! r (impc:ti:type-check ast vars kts request?)))))
*impc:ir:i1*))
((and (list? ast) (member (car ast) *impc:mathintrinsicslist*)) (impc:ti:math-intrinsic-check ast vars kts request?))
((and (list? ast) (member (car ast) '(dotimes))) (impc:ti:dotimes-check ast vars kts request?))
((and (list? ast) (member (car ast) '(while))) (impc:ti:while-check ast vars kts request?))
((and (list? ast) (member (car ast) '(printf))) (impc:ti:printf-check ast vars kts request?))
((and (list? ast) (member (car ast) '(sprintf))) (impc:ti:sprintf-check ast vars kts request?))
((and (list? ast) (member (car ast) '(fprintf))) (impc:ti:fprintf-check ast vars kts request?))
((and (list? ast) (member (car ast) '(sscanf))) (impc:ti:sscanf-check ast vars kts request?))
((and (list? ast) (member (car ast) '(fscanf))) (impc:ti:fscanf-check ast vars kts request?))
((and (list? ast) (member (car ast) '(push_zone))) (impc:ti:push_zone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pop_zone))) (impc:ti:pop_zone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(push_new_zone))) (impc:ti:push_new_zone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(create_zone))) (impc:ti:create_zone-check ast vars kts request?))
;;((and (list? ast) (member (car ast) '(memzone))) (impc:ti:memzone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(llvm_callback))) (impc:ti:callback-check ast vars kts request?))
((and (list? ast) (member (car ast) '(make-vector))) (impc:ti:make-vector-check ast vars kts request?))
((and (list? ast) (member (car ast) '(vector-set!))) (impc:ti:vector-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(vector-ref))) (impc:ti:vector-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(vector-shuffle))) (impc:ti:vector-shuffle-check ast vars kts request?))
((and (list? ast) (member (car ast) '(make-array))) (impc:ti:make-array-check ast vars kts request?))
((and (list? ast) (member (car ast) '(array-set!))) (impc:ti:array-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(array-ref))) (impc:ti:array-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(array-ref-ptr))) (impc:ti:array-ref-ptr-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pointer-set!))) (impc:ti:pointer-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pointer-ref))) (impc:ti:pointer-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pointer-ref-ptr))) (impc:ti:pointer-ref-ptr-check ast vars kts request?))
((and (list? ast) (member (car ast) '(stack-alloc))) (impc:ti:stack-alloc-check ast vars kts request?))
((and (list? ast) (member (car ast) '(heap-alloc))) (impc:ti:heap-alloc-check ast vars kts request?))
((and (list? ast) (member (car ast) '(zone-alloc))) (impc:ti:zone-alloc-check ast vars kts request?))
((and (list? ast) (member (car ast) '(make-tuple))) (impc:ti:make-tuple-check ast vars kts request?))
((and (list? ast) (member (car ast) '(num-of-elts))) (impc:ti:num-of-elts-check ast vars kts request?))
((and (list? ast) (member (car ast) '(obj-size))) (impc:ti:obj-size-check ast vars kts request?))
((and (list? ast) (member (car ast) '(ref))) (impc:ti:ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(tuple-set!))) (impc:ti:tuple-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(tuple-ref))) (impc:ti:tuple-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(tuple-ref-ptr))) (impc:ti:tuple-ref-ptr-check ast vars kts request?))
((and (list? ast) (member (car ast) '(closure-set!))) (impc:ti:closure-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(closure-ref))) (impc:ti:closure-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(closure-refcheck))) (impc:ti:closure-refcheck-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pref))) (impc:ti:pref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pdref))) (impc:ti:pdref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(null?))) (impc:ti:null?-check ast vars kts request?))
((and (list? ast) (member (car ast) '(impc_null))) (impc:ti:null-check ast vars kts request?))
((and (list? ast) (member (car ast) '(bitcast))) (impc:ti:bitcast-check ast vars kts request?))
((and (list? ast) (member (car ast) '(bitconvert))) (impc:ti:bitconvert-check ast vars kts request?))
((and (list? ast) (member (car ast) '(void))) (impc:ti:void-check ast vars kts request?))
((and (list? ast) (member (car ast) '(fptrcall))) (impc:ti:fptrcall-check ast vars kts request?))
((and (list? ast) ;; poly func (specific match)
(symbol? (car ast))
request?
(string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ti:nativef-poly-exact-check ast vars kts request?))
;; (println 'poly-exact: ast 'r: request?)
request?)
((and (list? ast) ;; generic function
(symbol? (car ast))
(string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ti:genericfunc-exists? (string->symbol (car (regex:split (symbol->string (car ast)) "##")))
(length (cdr ast))))
;; (println 'generic: ast 'r: request?)
(impc:ti:nativef-generics ast vars kts request?))
((and (list? ast) ;; poly func (closest match)
(symbol? (car ast))
(string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ti:get-polyfunc-candidate-types (car (regex:split (symbol->string (car ast)) "##"))))
;; (println 'poly: ast 'r: request?)
(let ((reses (impc:ti:nativef-poly-check ast vars kts request?)))
;; (println 'polyclosest 'ast: ast reses 'r: request?)
reses))
((and (list? ast) ;; native function
(symbol? (car ast))
(or (impc:ti:nativefunc-exists? (symbol->string (car ast)))
(impc:ti:closure-exists? (symbol->string (car ast)))))
;; (println 'native: ast 'r: request?)
(impc:ti:nativef-check ast vars kts request?))
((and (list? ast) (member (car ast) '(begin))) (impc:ti:begin-check ast vars kts request?))
((and (list? ast) (member (car ast) '(if ifret))) (impc:ti:if-check ast vars kts request?))
((and (list? ast) (member (car ast) '(set!))) (impc:ti:set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(ret->))) (impc:ti:ret-check ast vars kts request?))
((and (list? ast) (assoc-strcmp (car ast) vars)) (impc:ti:closure-call-check ast vars kts request?))
((and (list? ast) (list? (car ast))) (impc:ti:closure-in-first-position ast vars kts request?))
((and (list? ast) ;; this is here to check against closures as global vars (i.e. not in local environment)
(symbol? (car ast))
(or (impc:ti:closure-exists? (symbol->string (car ast)))
(let ((gvar-type (impc:ti:get-globalvar-type (symbol->string (car ast)))))
(and gvar-type (impc:ir:closure? gvar-type)))))
(impc:ti:closure-call-check ast vars kts request?))
(else
(impc:ti:join (impc:ti:type-check (car ast) vars kts request?)
(impc:ti:type-check (cdr ast) vars kts request?))))))