impc:ti:nativef-poly-check   scheme


Defined in:  https://github.com/digego/extempore/tree/v0.8.9/runtime/llvmti.xtm

Implementation

(define impc:ti:nativef-poly-check
  (lambda (ast vars kts request?)
    ;; (println 'poly-checking: ast 'req? request?) ;; 'v: vars)
    (cond ((assoc-strcmp (car ast) kts)
           (begin
             (for-each (lambda (a r)
                         (impc:ti:type-unify (impc:ti:type-check a vars kts r) vars))
                       (cdr ast)
                       (cddr (cdr (assoc-strcmp (car ast) vars)) vars))
             (list (cadr (cdr (assoc-strcmp (car ast) kts))))))
          ((and (impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars))
                (or (equal? request? #f)
                    (equal? request? (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars))))
           (begin
             (for-each (lambda (a r)
                         (impc:ti:type-unify (impc:ti:type-check a vars kts r) vars))
                       (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)))))
          (else
           (let* ((polyf (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))
                  (ftypes (impc:ti:get-polyfunc-candidate-types (symbol->string polyf)))
                  (args (map (lambda (x) (impc:ti:type-unify (impc:ti:type-check x vars kts #f) vars)) (cdr ast)))
                  (valid-polys (impc:ti:nativef-poly-check-match-ftypes args ftypes request?)))
             ;; (println 'valid: ast 'fs: valid-polys 'args: args 'req: request?)
             (if (null? valid-polys) (impc:compiler:print-compiler-error "no valid polymorphic options" ast))
             (let ((returns (map (lambda (t) (cadr t)) valid-polys)))
               ;; if we have a single valid poly
               ;; then we can try type-checking against
               ;; the correct function signature!
               (if (= 1 (length valid-polys))
                   (map (lambda (a t)
                          (let ((t2 (impc:ti:type-unify (impc:ti:type-check a vars kts t) vars)))
                            ;; (println 'a: a 't: t 't2: t2)
                            t2))
                        (cdr ast)
                        (cddr (car valid-polys))))
               ;; (println 'updatepoly: (car ast) 'with: valid-polys)
               ;; update valid-polys to reflect return types (from request?)
               (impc:ti:update-var (car ast) vars kts valid-polys)
               ;;(println 'returns: returns)
               returns))))))


Back to Index

Similar Entries