impc:ti:compare-check   scheme


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

Implementation

(define impc:ti:compare-check
  (lambda (ast vars kts request?)
    (let* ((n1 (if (number? (cadr ast)) (caddr ast) (cadr ast)))
           (n2 (if (number? (cadr ast)) (cadr ast) (caddr ast)))
           (a (impc:ti:type-unify (impc:ti:type-check n1 vars kts #f) vars)) ;; removed request?
           (b (impc:ti:type-unify (impc:ti:type-check n2 vars kts #f) vars)) ;; removed request?
           (t (impc:ti:type-unify (list a b) vars)))
      ;; (println 'a a 'b b 't t 'req? request?)
      ;; if we can unify on 't'
      ;; then we might need to retypecheck a or b
      (if (impc:ir:type? t)
          (begin
            (if (and (list? a)
                     (list? n1)
                     (assoc-strcmp (car n1) vars))
                (begin (impc:ti:force-var (car n1) vars kts '())
                       (impc:ti:type-check n1 vars kts t)))
            (if (and (list? b)
                     (list? n2)
                     (assoc-strcmp (car n2) vars))
                (begin (impc:ti:force-var (car n2) vars kts '())
                       (impc:ti:type-check n2 vars kts t)))))
      (if *impc:ti:print-sub-checks* (println 'compare:> 'ast: ast 'a: a 'b: b 't: t 'request? request?))
      (if (not (null? t))
          (begin (if (symbol? (cadr ast)) (impc:ti:force-var (cadr ast) vars kts t))
                 (if (symbol? (caddr ast)) (impc:ti:force-var (caddr ast) vars kts t))
                 (if (and (not (null? t))
                          (impc:ir:vector? t))
                     (if (impc:ir:pointer? t)
                         (list (- (car t) *impc:ir:pointer*) (cadr t) *impc:ir:i1*)
                         (list (car t) (cadr t) *impc:ir:i1*))
                     ;; (if (and (impc:ir:tuple? t)
                     ;;          (not (impc:ir:pointer? t)))
                     (if (impc:ir:tuple? t)
                         t
                         (list *impc:ir:i1*))))
          (cond ((impc:ir:vector? a)
                 (if (symbol? (cadr ast)) (impc:ti:update-var (cadr ast) vars kts a))
                 (let ((retvec (if (impc:ir:pointer? a) (impc:ir:pointer-- a) a)))
                   (list (car retvec) (cadr retvec) *impc:ir:i1*)))
                ((impc:ir:vector? b)
                 (if (symbol? (caddr ast)) (impc:ti:update-var (cadr ast) vars kts b))
                 (let ((retvec (if (impc:ir:pointer? b) (impc:ir:pointer-- b) b)))
                   (list (car retvec) (cadr retvec) *impc:ir:i1*)))
                ;; ((or (and (impc:ir:tuple? a) (not (impc:ir:pointer? a)))
                ;;      (and (impc:ir:tuple? b) (not (impc:ir:pointer? b))))
                ;;  (list (if (impc:ir:tuple? a) a b)))
                ((or (impc:ir:tuple? a)
                     (impc:ir:tuple? b))
                 (list (if (impc:ir:tuple? a) a b)))
                ((not (cl:find-if symbol? (cdr ast))) (list *impc:ir:i1*)) ;; return t
                ((and (symbol? n1)
                      (symbol? n2)
                      (not (null? (cdr (impc:ti:get-var n1 vars))))
                      (not (null? (cdr (impc:ti:get-var n2 vars)))))
                 ;; if both are symbols and their types cannot unify on anything
                 ;; then we have a problem!  So force both types to NULL
                 (impc:ti:force-var n1 vars kts '())
                 (impc:ti:force-var n2 vars kts '())
                 (list *impc:ir:i1*)) ;; and return t (which should be NULL)
                ((and (symbol? n1) (not (null? b)))
                 (impc:ti:update-var n1 vars kts b)
                 (list *impc:ir:i1*)) ;; return b
                ((and (symbol? n2) (not (null? a)))
                 (impc:ti:update-var n2 vars kts a)
                 (list *impc:ir:i1*)) ;; return a
                (else (list *impc:ir:i1*)))))))


Back to Index