impc:ti:nativef-generics   scheme

;; generics check
(define impc:ti:nativef-generics
  (lambda (ast vars kts request?)
    (set! *impc:ti:nativef-generics:calls* (+ *impc:ti:nativef-generics:calls* 1))
    ;; (println 'native: *impc:ti:nativef-generics:calls* ast 'request: request?)
    ;; (println 'vars: vars)
    ;; (println 'genericf-in: (assoc-strcmp (car ast) vars))
    (set! impc:ir:get-type-expand-poly #f)
    (if (or (null? request?)
            (and (list? request?)
                 (equal? (car request?) *impc:ir:notype*)))
        (set! request? #f))
    ;; flatten request
    (if (and request?
             (list? request?)
             ;; (not (impc:ir:complex-type? request?))
             (not (impc:ir:type? request?)) ;
             (impc:ir:type? (car request?)))
        (set! request? (car request?)))
    (if (not (impc:ir:type? request?))
        (set! request? #f))
    ;;
    ;; (println 'generics-check (car ast) 'request: request?)
    ;; only check if not already fully formed!
    (cond ((assoc-strcmp (car ast) kts)
           ;; (println 'leave-early1: ast ': (assoc-strcmp (car ast) kts))
           (begin
             (for-each (lambda (x r)
                         (impc:ti:type-check x vars kts r))
                       (cdr ast)
                       (cddr (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars)))
             (list (cadr (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars)))))
          ((impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars))
           ;; (println 'leave-early2: ast ': (assoc-strcmp (car ast) vars)) ;;(assoc-strcmp (car ast) vars))
           (begin
             (for-each (lambda (x r)
                         (impc:ti:type-check x vars kts r))
                       (cdr ast)
                       (cddr (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars)))
             ;; (println 'hit: (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars))
             (list (cadr (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars)))))
          (else
           (let* ((args (map (lambda (x)
                               ;; (println ast 'check x)
                               (impc:ti:type-unify (impc:ti:type-check x vars kts #f) vars))
                             (cdr ast)))
                  (gname (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))
                  (gnum (string->number (cadr (regex:split (symbol->string (car ast)) "##"))))
                  (arity (- (length ast) 1))
                  ;; (lll (println 'gname gname arity (if request? (cons request? args) args)))
                  (gpt (impc:ti:genericfunc-types gname arity (if request? (cons request? args) args)))
                  (gpt-valid (if (equal? #f gpt) 
                                 (impc:compiler:print-compiler-error "no valid generic options available for: " ast)
                                 #t))
                  ;; request? request? args)))
                  (gpoly-code (cadr gpt))
                  (constraint (cadddr gpt))
                  (constraint-code (if (not constraint) #f (if (symbol? constraint) (get-closure-code (eval constraint)) constraint)))
                  (lambda-code (caddr gpoly-code))
                  (gtype (impc:ir:get-type-from-pretty-str (symbol->string (car gpt))))
                  (gpoly-type (impc:ti:get-type-for-gpoly
                               (cadr (regex:type-split (symbol->string (cadr gpoly-code)) ":"))))
                  (gpoly-type-orig (impc:ti:nativef-generics-make-gtypes-unique gpoly-type gnum)))
             ;; (println "gpt:" gpt)
             ;; (println "gtype:" gtype)
             ;; (println "args:" args)
             ;; (println "args2:" args2)
             ;; (println "constraint:" constraint)
             ;; (println "constraint-code:" constraint-code)