impc:ti:minimize-generic-type   scheme


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

Implementation

(define impc:ti:minimize-generic-type
  (lambda (t gtype)
    ;; (println 'minimize t gtype)
    (let* ((ags (map (lambda (x)
                       (if (impc:ti:generictype-exists? (car (impc:ti:split-namedtype x)))
                           (impc:ti:maximize-generic-type x)
                           x))
                     (impc:ir:get-pretty-tuple-arg-strings t)))
           ;; (llll (println 'ags: ags))
           (gags (map (lambda (x)
                        (if (impc:ti:generictype-exists? (car (impc:ti:split-namedtype x)))
                            (impc:ti:maximize-generic-type x)
                            x))
                      (impc:ir:get-pretty-tuple-arg-strings gtype)))
           ;; (lllllll (println 'gags: gags))
           (plst (map (lambda (x y) (cons x y))
                      gags
                      (if (< (length ags) (length gags))
                          (append ags (make-list (- (length gags) (length ags)) '_))
                          ags)))
           ;; (lllllllll (println 'lst1: plst))
           (typevars (cl:remove-duplicates
                      (cl:remove-if (lambda (x)
                                      (and (not (regex:match? (car x) "^!"))            ;; typevar
                                           (not (and (regex:match? (car x) "^[A-Za-z]") ;; or generic type
                                                     (impc:ti:generictype-exists?
                                                      (car (impc:ti:split-namedtype (car x)))))) ;;(regex:type-split (car x) ":")))))
                                           (not (and (regex:match? (car x) "^\\[")
                                                     (regex:match? (car x) "!")))))
                                    plst)))
           ;; (lllllllllll (println 'lst2: typevars))
           (tv2 (map (lambda (x)
                       ;; (println 'x: x)
                       (if (string-contains? (cdr x) ":")
                           (if (string-contains? (car x) ":")
                               (let* ((pdth (impc:ir:get-ptr-depth (cdr x)))
                                      (splita (impc:ti:split-namedtype (car x)))
                                      (splitb (impc:ti:split-namedtype (cdr x)))
                                      (sa (cadr splita))
                                      (sb (cadr splitb))
                                      (tvars (cl:remove-duplicates (regex:match-all sa "![A-Za-z_0-9]*")))
                                      ;; (lllll (println '--> sa sb gtype tvars))
                                      (minargs (if (string=? sb gtype) ;; for recursive types!
                                                   '() ;;(cl:remove-duplicates (regex:match-all sa "![A-Za-z_0-9]*")) ;; '()
                                                   (impc:ti:minimize-generic-type sb sa)))
                                      (res (cl:remove
                                            #f (map (lambda (x y) (if (equal? x y) #f (cons x y)))
                                                    (cl:remove-duplicates minargs)
                                                    tvars))))
                                 ;; (println 'res: res)
                                 res) ;; (car minargs))
                               (begin
                                 (if (not (impc:ti:get-generictype-candidate-types
                                           (string->symbol
                                            (car (regex:type-split (cdr x) ":")))))
                                     (impc:compiler:print-bad-type-error (string->symbol (car (regex:type-split (cdr x) ":"))) "type is undefined"))
                                 (apply string-append
                                        (car (regex:type-split (cdr x) ":"))
                                        "{"
                                        (string-join (impc:ti:minimize-generic-type
                                                      (cadr (regex:type-split (cdr x) ":"))
                                                      (if (string-contains? (car x) ":")
                                                          (cadr (regex:type-split (car x) ":"))
                                                          (symbol->string (impc:ti:get-generictype-candidate-types
                                                                           (string->symbol
                                                                            (car (regex:type-split (cdr x) ":")))))))
                                                     ",")
                                        "}"
                                        (make-list (impc:ir:get-ptr-depth (cdr x)) "*"))))
                           (if (and (regex:match? (cdr x) "^(\\[|<)") ;; closures and tuples!
                                    (regex:match? (car x) "^(\\[|<)"))
                               (let ((ptrd (impc:ir:get-ptr-depth (cdr x)))
                                     (b1 (impc:ir:get-base-type (cdr x)))
                                     (b2 (impc:ir:get-base-type (car x))))
                                 (impc:ti:minimize-generic-type
                                  (string-append "<" (substring b1 1 (- (string-length b1) 1)) ">")
                                  (string-append "<" (substring b2 1 (- (string-length b2) 1)) ">")))
                               (begin
                                 (cdr x)))))
                     typevars))
           (tv3 (map (lambda (x) (if (pair? x) (car x) x)) (cl:remove-duplicates (flatten tv2))))
           (tv4 (map (lambda (x) (if (pair? x) (car x) x)) (flatten tv2)))
           (tv5 (cl:remove #f (let ((cache '()))
                                (map (lambda (x)
                                       (if (pair? x)
                                           (if (member (cdr x) cache)
                                               #f
                                               (begin
                                                 (set! cache (cons (cdr x) cache))
                                                 (car x)))
                                           x))
                                     (flatten tv2))))))
      ;; (println 'minimout t tv2 tv3 tv4 tv5)
      tv5)))


Back to Index