impc:ti:update-var   scheme

Defined in:


;; don't allow update to add to kts values
(define impc:ti:update-var
  (lambda (sym vars kts t)
    ;; clean type
    ;; i.e. change (211 4 (0) (1) 0)) -> (211 4 0 1 0)
    (if (and (list? t)
             (= (length t) 1)
             (or (string? (car t))
                 (impc:ir:type? (car t))))
        (set! t (car t)))
    (set! t (impc:ti:type-clean t))
    ;; (println sym 'b1: t)
    (set! t (impc:ti:type-normalize t vars))
    ;; (println 'xym sym t (member sym vars) (member sym kts))
    ;; (println sym 'b2: t)
    ;; (if (and (string? t)
    ;;          #t
    ;;          (assoc-strcmp sym vars))
    ;;     (let* ((p (assoc-strcmp sym vars))
    ;;            (l (map (lambda (k) (string? k)) (cdr p))))
    ;;       (println 'p p 'l l)
    ;;       (if (and (member #t l)
    ;;                (not (member t (cdr p))))
    ;;           (begin
    ;;             (if (regex:match? t "^%")
    ;;                 (impc:compiler:print-type-mismatch-error (impc:ir:pretty-print-type (impc:ti:get-named-type t)) p)
    ;;                 (impc:compiler:print-type-mismatch-error t p))))))
    ;; don't ever add oursevles (i.e. sym) as a type arg or NULL
    (if (or (null? t)
            (equal? t #f)
            (and (list? t)
                 (equal? sym (car t)))
            (impc:ti:nativefunc-exists? (symbol->string sym)) ;; native funcs already have a type
            (equal? sym t))
        (begin ;; (println 'update-var:> sym 'in: vars 'with: t 'kts: kts)
          (if (member sym kts) ;; if in known types don't do anything
              (if (and (not (assoc-strcmp sym vars))
                       (not (regex:match? (symbol->string sym) ":\\["))
                       (not (impc:ti:closure-exists? (symbol->string sym)))
                       (not (impc:ti:globalvar-exists? (symbol->string sym))))
                  (begin ;; sometimes generic types don't spec all
                    ;; their !'s - weshould carry on anyway!
                    ;; (println 'sym sym)
                    ;;(if (not (regex:match? (symbol->string sym) "^!"))
                    (if (not (regex:match? (symbol->string sym) "!"))
                        (impc:compiler:print-missing-identifier-error sym 'type))
                  (let ((pair (assoc-strcmp sym vars)))
                    (if pair
                        (let ((pair-rest (cdr pair)))
                          (if (or (impc:ir:type? t)
                                  (impc:ti:complex-type? t))
                                ;; if 't' is a closure without a return type
                                ;; but has new argument types then we might be able
                                ;; to infer the return type from the arg types
                                (if (and (impc:ir:closure? t)
                                         (not (impc:ir:type? t)))
                                      (let ((res (impc:ti:type-check-bound-lambda sym vars kts t)))
                                        (if res
                                            (set-car! (cdr t) res)))))
                                ;; uncomment the following lines to do reverse bang tests
                                (if (and (string? t) ;; if a named type
                                         (string-contains? (symbol->string sym) "##"))
                                    (let ((gtd (impc:ti:generic-type-details sym)))
                                      (impc:ti:reverse-set-bangs-from-reified sym t (cadr gtd) vars)))
                                (if (and
                                     (string? t)
                                     (impc:ir:tuple? pair-rest))
                                    (set-cdr! pair (list t))
                                    (set-cdr! pair (cl:remove-duplicates (append (list t) pair-rest))))
                              ;(set-cdr! pair (cl:remove-if-not
                              ;                (lambda (x) (impc:ir:type? x))
                              ;                (cl:remove-duplicates
                              ;                 (append t pair-rest))))))
                              (set-cdr! pair (cl:remove-duplicates (append t pair-rest))))))

Back to Index