impc:ti:nativef-generics-check-return-type   scheme

Defined in:


(define impc:ti:nativef-generics-check-return-type
  (lambda (ast lambda-code gpoly-type gnum vars args req?)
    ;; (println 'lambda-code: lambda-code 'gnum: gnum)
    ;; (println 'check-ret-type: gpoly-type 'request? req?)
    ;; (println 'rec: ast *impc:ti:nativef-generics-recurse-test*)
    (let ((grtype '()))
      ;; this section is here to check for a return type
      ;; for this generic function.
      ;; we do this by grabbing the gpoly's lambda code and
      ;; sending it through type checking.
      (if (< *impc:ti:nativef-generics-recurse-test* 5)
            (set! *impc:ti:nativef-generics-recurse-test*
                  (+ *impc:ti:nativef-generics-recurse-test* 1))
            ;; type inferencing for generic functions return argument!
            (let* ((symname 'placeholder)
                   (extantsyms (map (lambda (x) (car x)) vars))
                   (s1 (impc:ti:rename-all-shadow-vars symname lambda-code extantsyms))
                   (c1 (impc:ti:get-var-types s1))
                   (t1 (impc:ti:first-transform (car c1) #t))
                   (s2 (impc:ti:rename-all-shadow-vars symname t1 extantsyms))
                   (c2 (impc:ti:get-var-types s2)) ;;lambda-code))
                   (t2 (impc:ti:mark-returns (car c2) symname #f #f #f))
                   (t3 (impc:ti:closure:convert t2 (list symname)))
                   (lvars (map (lambda (x) (list x)) (impc:ti:find-all-vars t3 '())))
                   (lvarnames (map (lambda (x) (car x)) lvars))
                   (tr1 (impc:ti:type-unify gpoly-type vars))
                   (trequest (if req? req? tr1))
                   (kts (cl:remove #f (map (lambda (x y) (if (impc:ir:type? y) x #f)) (cadr s1) args)))
                   (newvars (append lvars vars))
                   (ttype '()))
              ;; this here as a check (could be removed)
              (if (not (null? (cl:intersection lvarnames extantsyms)))
                  (impc:compiler:print-compiler-error "shadow vars found when specialising generic code" (cl:intersection lvarnames extantsyms)))
              ;; this is another check (could be removed)
              (for-each (lambda (x)
                          (if (member (car x) lvarnames)
                              (println 'Type 'Collision 'On x)))

Back to Index