llvmti.xtm

;;
;; Copyright (c) 2011, Andrew Sorensen
;;
;; All rights reserved.
;;
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;;    this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution.
;;
;; Neither the name of the authors nor other contributors may be used to endorse
;; or promote products derived from this software without specific prior written
;; permission.
;;
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
;;

;; A windows allocation bug that I can't track down yet!
(define *WINDOWS_ALLOC_BUG* (if (and (string=? (sys:platform) "Windows")
                                     (not (sys:mcjit-enabled)))
                                #t #f))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; flags for printing debug info ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *impc:ti:print-sub-checks* #f)
(define *impc:ti:print-main-check* #f)
(define *impc:ti:print-unifications* #f)

(define *impc:ti:print-full-generic-types* #f)
(define *impc:ti:print-code-specialization-compiles* #f)

(define *impc:compile* #t)
(define *impc:compiler:print* #f)
(define *impc:compiler:print-ast* #f)
(define *impc:compiler:print-work-names #f) ;; this prints test__498 for example (i.e. closure bodies)
(define *impc:compiler:verbose* #f)

(define *impc:compiler:print-raw-llvm* #f)

(define *impc:compiler:allow-structural-calls #f)

(define *impc:compiler:process* (ipc:get-process-name))
;;(define *impc:compiler:process* "utility")

(define *impc:ti:bound-lambdas* '())

(define *impc:zone* (sys:default-mzone))

(define *impc:default-zone-size* 0) ;(* 8 1024))

(define *impc:compiler:message:level* 'high)
(define *impc:aot:prev-compiler-message-level* *impc:compiler:message:level*)

(define *impc:ti:implicit-adhoc-compiles* #t)

(define suppress-compiler-messages
  (lambda (bool)
    (if bool
        (set! *impc:compiler:message:level* 'low)
        (set! *impc:compiler:message:level* 'high))))

(define-macro (sys:with-quiet-compiler . form)
  `(let ((msglvl *impc:compiler:message:level*))
     (set! *impc:compiler:message:level* 'low)
     (let ((res (catch #f ,@form)))
       (set! *impc:compiler:message:level* msglvl)
       res)))

(define-macro (sys:with-noisy-compiler . form)
  `(let ((msglvl *impc:compiler:message:level*))
     (set! *impc:compiler:message:level* 'high)
     (let ((res (catch #f ,@form)))
       (set! *impc:compiler:message:level* msglvl)
       res)))

(define *impc:alphabetlist* '(a b c d e f g h i j k l m n o p q r s t u v w x y z))
(define *impc:alphabetidxlist* '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25))

;;;;;;;;;;;;;;;;
;; type enums ;;
;;;;;;;;;;;;;;;;

;; MAKE SURE SIGNED VERSIONS ARE
;; LOWER THAN UNSIGNED VERSIONS
;; i.e. si64 should be lower than ui64
;;

(define *impc:ir:notype* -3) ;; no type!
(define *impc:ir:badtype* -2)
(define *impc:ir:void* -1)
(define *impc:ir:fp64* 0)
(define *impc:ir:double* 0)
(define *impc:ir:fp32* 1)
(define *impc:ir:float* 1)
(define *impc:ir:si64* 2)
(define *impc:ir:ui64* 3)
(define *impc:ir:si32* 4)
(define *impc:ir:ui32* 5)
(define *impc:ir:si16* 6)
(define *impc:ir:ui16* 7)
(define *impc:ir:si8* 8)
(define *impc:ir:ui8* 9)
(define *impc:ir:i1* 10)
(define *impc:ir:char* 11)
(define *impc:ir:null* 12)
(define *impc:ir:closure* 13)
(define *impc:ir:tuple* 14)
(define *impc:ir:array* 15)
(define *impc:ir:vector* 16)
;; this should be incremented to represent the lowest native type
(define *impc:ir:lowest-base-type* 17)

;; and a non-type
(define *impc:ir:other* 1000)

;; pointer offset
(define *impc:ir:pointer* 100)

;;
;; global string constant cnt
;;
;; This WILL cause problems when
;; doing multi-core compilation
;;
(define *impc:ir:gstrcnt* 0)

;; local stack vars
;;
;; This is to hold local stack
;; allocations for if statements
;; These get promoted to the
;; top of the closure to avoid
;; excessive stack allocation
;; in loops etc..
;;
(define *impc:ir:ls_var* '())

;; a list of currently valid local symbols!
;; NOT including global symbols
(define *impc:ir:sym-name-stack* '())

;; type of size_t on platform
(define *impc:ir:size_t_str* (if (= 64 (sys:pointer-size)) "i64" "i32"))
;; pointer size in bytes (as a string)
(define *impc:ir:pointer_size_bytes_str* (if (= 64 (sys:pointer-size)) "8" "4"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Compiler error printing

(define *impc:compiler:pretty-print-name-color* 'green)
(define *impc:compiler:pretty-print-type-color* 'yellow)
(define *impc:compiler:pretty-print-error-color* 'red)
(define *impc:compiler:pretty-print-code-color* 'cyan)

(define impc:compiler:print-constraint-error
  (lambda (name type constraint . args)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Constraint Error"))
    (print " ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #f (print name))
    (print " failed constraint ")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print constraint))
    (print "\nwith type: ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type))           
    (if (not (null? args))
        (begin
          (print "\nast: ")
          (define ast (cons (string->symbol name) (cdar args)))
          (print (sexpr->string ast))))
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-double-colon-error
  (lambda (var)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " double colon error for ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print var "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-bad-type-error
  (lambda (type . message)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " bad type ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type))
    (if (not (null? message))
        (print " " (car message)))
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-bad-numeric-value-error
  (lambda (value expected-type)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " bad numeric value ")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print value))
    (print ", should be ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print expected-type "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-bad-type-error-with-ast
  (lambda (type message ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " bad type ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type))
    (print " " message " ")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-badly-formed-expression-error
  (lambda (expr-type ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " badly formed ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print expr-type))
    (print " expression:\n")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-index-oob-error
  (lambda (type ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print type))
    (print " index out of bounds: ")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-cannot-expand-non-generic-error
  (lambda (name)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Generics Error"))
    (print " cannot expand on non-generic ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print name "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-expansion-arity-error
  (lambda (before after)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Generics Error"))
    (print " expansion arity error ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print before))
    (print " -> ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print after "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-no-valid-forms-for-generic-error
  (lambda (name)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Generics Error"))
    (print " cannot find any valid forms for generic function ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print name "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-shadow-var-error
  (lambda (name)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Error"))
    (print " cannot define ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print name))
    (print " as a shadow variable\n")
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-already-bound-error
  (lambda (name type)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Error "))
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print name))
    (print " already bound as ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-no-redefinitions-error
  (lambda (name oldtype newtype)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Error"))
    (print " cannot redefine or overload the type signature of existing functions.  In this case, ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print name)) (print " from ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print oldtype)) (print " to ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print newtype "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-bad-arity-error
  (lambda (ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " bad arity in expression:\n")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-no-retval-error
  (lambda (ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " no return value for body: ")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-needs-zone-size-error
  (lambda (expr-name)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print expr-name))
    (print " requires a zone size as its first argument\n")
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-needs-zone-delay-error
  (lambda (expr-name)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Syntax Error"))
    (print " ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print expr-name))
    (print " requires an ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print "i64"))
    (print " delay as its second argument\n")
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-variable-not-marked-as-free-error
  (lambda (vs)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " variable " )
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print vs))
    (print " not marked as free - check the variable name in the polytype\n")
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define *impc:compiler:top-level-generic-error* #f)

(define impc:compiler:print-type-mismatch-error
  (lambda (got expected . name)
    (if *impc:compiler:top-level-generic-error*
        (begin
          (set! name (list (car *impc:compiler:top-level-generic-error*)))))
    (if (and (not (null? name))
             (list? (car name))
             (symbol? (caar name)))
        (set! name (list (car (regex:type-split (symbol->string (caar name)) "_poly_")))))

    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))

    (if (not (null? name))
        (begin (print " in ")
               (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t
                                  (print  (car name)))
               (print ",")))

    (print " got " )

    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f
                       (print (impc:ir:pretty-print-type got)))

    (print ", was expecting ")

    (if (and (list? expected)
             (= 1 (length expected)))
        (set! expected (car expected)))

    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f
                       (print (impc:ir:pretty-print-type expected)))

    (println)
    (if *impc:compiler:top-level-generic-error*
        (set! *impc:compiler:top-level-generic-error* #f))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))


(define impc:compiler:print-type-conflict-error
  (lambda (type1 type2 ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " conflicting " )
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type1))
    (print " with ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type2))
    (if *impc:compiler:top-level-generic-error*
        (begin
          (print " calling ")
          (print-with-colors *impc:compiler:pretty-print-name-color* 'default #f
                             (print (car *impc:compiler:top-level-generic-error*)))
          (print "\n")
          (set! *impc:compiler:top-level-generic-error* #f))
        (begin
          (print " in ")
          (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-if-type-conflict-error
  (lambda (then else)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " type conflict between " )
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print "then"))
    (print " (")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print then))
    (print ") and ")
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print "else"))
    (print " (")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print else))
    (print ") branch of " )
    (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print  "if"))
    (print " statement\n")
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-unsupported-conversion-error
  (lambda (from to)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " unsupported conversion from " )
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (if (number? from) (impc:ir:get-type-str from) from)))
    (print " to ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (if (number? to) (impc:ir:get-type-str to) to) "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-could-not-resolve-types_find-expr
  (lambda (name ast)
    (cond ((atom? ast) #f)
          ((and (pair? ast)
                (symbol? (car ast))
                (equal? name (car ast)))
           (vector ast))
          ((pair? ast)
           (list (impc:compiler:print-could-not-resolve-types_find-expr
                  name (car ast))
                 (impc:compiler:print-could-not-resolve-types_find-expr
                  name (cdr ast))))
          (else #f))))

(define impc:compiler:print-could-not-resolve-types
  (lambda (types ast . name)
    (if (and (not (null? types))
             (list? types)
             (= (length types) 1)
             (list? (car types)))
        (set! types (car types)))
    (if (and (not (null? types))
             (symbol? (car types)))
        (set! types (list types)))
    ;; (println 'types: types)
    ;; (println 'ast: ast)
    (print-with-colors 'black 'red #t (print "Could not resolve types!"))
    (if (not (null? name))
        (begin
          (print-with-colors 'red 'black #t (print "::"))
          (print-with-colors 'black 'red #t (print (car name)))))
    (print-with-colors 'default 'default #t (print "\n"))
    (for-each (lambda (t)
                ;; (println 't t (impc:ir:type? (cdr t)))
                (if (or (atom? t)
                        (and (not (null? (cdr t)))
                             (not (atom? (cdr t)))
                             (member (cadr t) '(213)))
                        (and (not (null? (cdr t)))
                             (impc:ir:type? (cdr t))))
                    'done
                    (let* ((ts (if (atom? (cdr t))
                                   (if (impc:ir:type? (cdr t))
                                       (list (cdr t))
                                       '())
                                   (map (lambda (x)
                                          (if (impc:ir:type? x) x
                                              #f))
                                        (cdr t))))
                           (tsr (cl:remove #f ts))
                           (expr1 (if (null? ast) '()
                                      (flatten (impc:compiler:print-could-not-resolve-types_find-expr (car t) ast))))
                           (expr2 (cl:remove #f expr1))
                           (expr1a (if (null? expr2) '() (vector-ref (car expr2) 0)))
                           (all-expr (cl:every (lambda (x) (symbol? x)) expr1a))
                           (expr (if all-expr (car expr1a) expr1a)))
                      ;; (println tsr ': expr)
                      ;; (println 'tsr tsr (car t))
                      (if (null? tsr)
                          (begin
                            (if (and (symbol? (car t))
                                     (or (regex:match? (symbol->string (car t)) "^_anon_lambda" )
                                         (regex:match? (symbol->string (car t)) "^!")))
                                'done
                                (begin
                                  (print-with-colors 'red 'black #t (print "unresolved: "))
                                  (if (null? expr)
                                      (print-with-colors 'red 'black #t (print (car t)))
                                      (print-with-colors 'red 'black #t (print expr)))
                                  (print-with-colors 'default 'default #t (print "\n")))))
                          (begin (print-with-colors 'red 'black #t (print "ambiguous: "))
                                 (if (null? expr)
                                     (print-with-colors 'red 'black #t (print (car t)))
                                     (print-with-colors 'red 'black #t (print expr)))
                                 (print-with-colors 'default 'default #t (print "\n"))
                                 (for-each (lambda (x n)
                                             (print (string-append "(" (number->string n) ") "))
                                             (print-with-colors 'default 'black #t (print (impc:ir:pretty-print-type x) "\n")))
                                           tsr
                                           (range 0 (length tsr))))))))
              types)
    (print-with-colors 'red 'default #t (print '------------------------))
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f types)
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-could-not-resolve-type-error
  (lambda (types . message)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (if (list? types)
        (print " couldn't resolve types: ")
        (print " couldn't resolve type: "))
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print types))
    (if (not (null? message))
        (print " " (car message)))
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-could-not-resolve-generic-type-error
  (lambda (types ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (if (list? types)
        (print " couldn't resolve generic types: ")
        (print " couldn't resolve generic type: "))
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print types))
    (print " ")
    (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print ast "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-missing-identifier-error
  (lambda (name type)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Error"))
    (print " cannot find" type "")
    (if (impc:ir:poly-or-adhoc? (symbol->string name))
        (let ((split-name (impc:ir:split-and-decode-poly-adhoc-name (symbol->string name))))
          (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print (car split-name)))
          (print ":")
          (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (cadr split-name) "\n")))
        (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print name "\n")))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-missing-generic-type-error
  (lambda (type-name)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Type Error"))
    (print " cannot find generic type ")
    (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print type-name "\n"))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-not-during-aot-error
  (lambda (message)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Error"))
    (print " cannot access LLVM during AOT-compilation.")
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-compiler-error
  (lambda (message . ast)
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Error"))
    (print " " message)
    (if (not (null? ast))
        (begin (print " ast: ")
               (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f
                                  (print (car ast)))))
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-compiler-warning
  (lambda (message . ast)
    (print-with-colors *impc:compiler:pretty-print-type-color*
                       'default #t (print "Compiler Warning"))
    (print " " message)
    (if (not (null? ast))
        (begin (print " ast: ")
               (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f
                                  (print (car ast)))))
    (println)
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))

(define impc:compiler:print-compiler-failed-error
  (lambda ()
    (print-with-colors *impc:compiler:pretty-print-error-color*
                       'default #t (print "Compiler Failed."))
    (if (impc:aot:currently-compiling?)
        (quit 2)
        (throw ""))))


(define impc:compiler:print-binding-details-to-log
  (lambda (lead-string symname type)
    (if (equal? *impc:compiler:message:level* 'high)
        (begin
          (print lead-string " ")
          (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print symname))
          (print " >>> ")
          (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f  (print type))
          (println)))))

(define impc:compiler:print-bind-func-details-to-log
  (lambda (lead-string symname type zone-size)
    (if (equal? *impc:compiler:message:level* 'high)
        (begin
          (print lead-string " ")
          (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print symname))
          (print " >>> ")
          (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f  (print type))
          ;; (print " zone size: ")
          ;; (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f
          ;;                    (print zone-size))
          ;; (if (= zone-size *impc:default-zone-size*)
          ;;     (print " (default)"))
          (println)))))

(define impc:compiler:print-lib-binding-details-to-log
  (lambda (libname symname type)
    ;; don't write the header stuff for other AOT-compiled xtm libs -
    ;; assume a header file already exists in that case
    (if (equal? *impc:compiler:message:level* 'high)
        (begin
          (print "LibBound:  ")
          (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print symname))
          (print " >>> ")
          (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f  (print type))
          (print  " bound from ")
          (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f  (print libname))
          (println)))))

(define impc:compiler:print-polying-details-to-log
  (lambda (lead-string poly-name native-name type)
    (if (equal? *impc:compiler:message:level* 'high)
        (begin
          (print lead-string " ")
          (print-with-colors *impc:compiler:pretty-print-name-color*
                             'default #t (print poly-name))
          (print " with ")
          (print-with-colors *impc:compiler:pretty-print-name-color*
                             'default #t (print native-name))
          (print " >>> ")
          (print-with-colors *impc:compiler:pretty-print-type-color*
                             'default #f  (print type))
          (println)))))

(define impc:compiler:print-dylib-loading-details-to-log
  (lambda (dylib-path)
    (let* ((basename (car (reverse (regex:split dylib-path "[/\\\\]"))))
           (libname (car (regex:split basename "[.]"))))
      (if (equal? *impc:compiler:message:level* 'high)
          (begin
            (print "Lib Load:  ")
            (print-with-colors *impc:compiler:pretty-print-name-color*
                               'default #t (print libname))
            (print " dynamic library loaded from ")
            (print-with-colors *impc:compiler:pretty-print-code-color*
                               'default #t (print dylib-path))
            (println))))))

(define impc:compiler:print-no-scheme-stub-notification
  (lambda (symname)
    (if #f ;;(equal? *impc:compiler:message:level* 'high)
        (begin
          (print "There is no ")
          (print-with-colors 'cyan 'default #t (print  "scheme stub"))
          (print " available for ")
          (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print symname "\n"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; GLOBAL XTLANG CACHE ;;
;;;;;;;;;;;;;;;;;;;;;;;;;

;; global lists which cache the state (especially types) of all the
;; things.

;; types should be stored in the list format, although they can be
;; printed prettily, obviously

;;;;;;;;;;;;;;;;;;;;
;; language builtins
;; -----------------
;;
(define *impc:ti:builtin-cache* '(;; math operators
                                  ("+" . #("[!v,!v,!v...]*" "addition operator: overload xtm_addition to add support for new types" (arg1 arg2...)))
                                  ("-" . #("[!v,!v,!v...]*" "subtraction operator: overload xtm_subtraction to add support for new types" (arg1 arg2...)))
                                  ("*" . #("[!v,!v,!v...]*" "multiplication operator: overload xtm_multiplication to add support for new types" (arg1 arg2...)))
                                  ("/" . #("[!v,!v,!v...]*" "division operator: overload xtm_division to add support for new types" (arg1 arg2...)))
                                  ("%" . #("[!v,!v,!v]*" "modulo operator: overload xtm_modulo to add support for new types" (arg1 arg2)))
                                  ("set!" . #("[!v,!v,!v]*" "set var to value" (var value)))
                                  ;; pointer/tuple/array/vector set/ref
                                  ("pref" . #("[!v,!v*,i64]*" "pointer-(de)reference" (ptr idx)))
                                  ("pref-ptr" . #("[!v*,!v*,i64]*" "pointer-(de)reference" (ptr idx)))
                                  ("pset!" . #("[!v,!v*,i64,!v]*" "pointer-set" (ptr idx val)))
                                  ("pfill!" . #("[!v,!v*,!v...]*" "pointer-fill fill ptr with values" (ptr v1...)))
                                  ("tref" . #("[!v,!v*,i64]*" "tuple-(de)reference" (tuple idx)))
                                  ("tref-ptr" . #("[!v*,!v*,i64]*" "tuple-(de)reference" (tuple idx)))
                                  ("tset!" . #("[!v,!v*,i64,!v]*" "tuple-set" (tuple idx val)))
                                  ("tfill!" . #("[!v,!v*,!v...]*" "tuple-fill fill tuple with values" (tuple v1...)))
                                  ("aref" . #("[!v,!v*,i64]*" "array-(de)reference" (array idx)))
                                  ("aref-ptr" . #("[!v*,!v*,i64]*" "array-(de)reference" (array idx)))
                                  ("aset!" . #("[!v,!v*,i64,!v]*" "array-set" (array idx val)))
                                  ("afill!" . #("[!v,!v*,!v...]*" "array-fill fill array with values" (array v1...)))
                                  ("vref" . #("[!v,!v*,i64]*" "vector-(de)reference" (vector idx)))
                                  ("vref-ptr" . #("[!v*,!v*,i64]*" "vector-(de)reference" (vector idx)))
                                  ("vset!" . #("[!v,!v*,i64,!v]*" "vector-set" (vector idx val)))
                                  ("vfill!" . #("[!v,!v*,!v...]*" "vector-fill fill vector with values" (vector v1...)))
                                  ;; printing
                                  ("println" . #("[void,!v...]*" "generic print function - to add support for NewType, overload print:[void,NewType]*" (val1...)))
                                  ;; memory allocation
                                  ("alloc" . #("[!v*,i64]*" "allocate memory from current zone with size (optional, default = 1)" (optional-size)))
                                  ("zalloc" . #("[!v*,i64]*" "allocate memory from current zone with size (optional, default = 1)" (optional-size)))
                                  ("halloc" . #("[!v*,i64]*" "allocate memory from the heap with size (optional, default = 1)" (optional-size)))
                                  ("salloc" . #("[!v*,i64]*" "allocate memory from the stack zone with size (optional, default = 1)" (optional-size)))
                                  ;; Extempore runtime stuff
                                  ("callback" . #("[i1,i64,sym,args...]*" "set callback for closure at time with args" (time closure args...)))
                                  ;; special scheme macros
                                  ("call-as-xtlang" . #("[String*,!v]*" "the body of this (scheme) macro will be executed as xtlang" (body)))))
;;
;; language builtins - the cache is just used for documentation at
;; this stage, the actual builtins are handled in the compiler (mostly
;; in first-transform). In the future, however, we could integrate
;; that stuff into the builtin-cache
;;
;; (name . #(type-str docstring args))
;;
;; The other differences between this and the closure-list are that
;; the type is stored as a string rather than a list (so that we can
;; handle weird/overloaded/varargs things nicely for documentation
;; purposes) and also that "body" is replaced by "args"
;;
(define impc:ti:print-builtin-cache
  (lambda ()
    (println '*impc:ti:builtin-cache*: *impc:ti:builtin-cache*)))

(define impc:ti:reset-builtin-cache
  (lambda ()
    (set! *impc:ti:builtin-cache* '())))

;; this is never called in regular compilation! the builtin cache is
;; populated by hand (see above) and is mostly here for documentation
;; (especially for language builtins)
(define impc:ti:register-new-builtin
  (lambda (builtin-name type-str docstring args)
    ;; check arg types
    (if (not (and (or (string? builtin-name) (begin (println 'bad 'builtin-name: builtin-name) #f))
                  (or (string? type-str) (begin (println 'bad 'type: type-str) #f))
                  (or (string? docstring) (begin (println 'bad 'docstring: docstring)))
                  (or (list? args) (begin (println 'bad 'args: args) #f))))
        (impc:compiler:print-compiler-error "couldn't register new builtin")
        (if (impc:ti:builtin-exists? builtin-name)
            (impc:compiler:print-already-bound-error builtin-name (impc:ti:get-builtin-type builtin-name))
            ;; create a new entry
            (begin
              (set! *impc:ti:builtin-cache*
                    (cons (cons builtin-name (vector type-str docstring args))
                          *impc:ti:builtin-cache*))
              (car *impc:ti:builtin-cache*))))))

(define impc:ti:get-builtin-type-str
  (lambda (builtin-name)
    (let ((builtin-data (assoc-strcmp builtin-name *impc:ti:builtin-cache*)))
      ;; (println 'cls-list: builtin-data)
      (if builtin-data (vector-ref (cdr builtin-data) 0) #f))))

(define impc:ti:builtin-exists?
  (lambda (builtin-name)
    (let ((res (impc:ti:get-builtin-type-str builtin-name)))
      (if (and res (not (null? res))) #t #f))))

(define impc:ti:set-builtin-type-str
  (lambda (builtin-name type-str)
    (let ((builtin-data (assoc-strcmp builtin-name *impc:ti:builtin-cache*)))
      (if builtin-data
          (if (not (null? (vector-ref (cdr builtin-data) 0)))
              (begin (print "Warning: attempting to re-type already typed builtin")
                     (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print builtin-name))
                     (print " to ")
                     (print-with-colors *impc:compiler:pretty-print-type-color* 'default #t (print (impc:ir:pretty-print-type-str type-str) "\n")))
              (vector-set! (cdr builtin-data) 0 type-str))
          (impc:compiler:print-compiler-error "tried to set type of unknown builtin" builtin-name)))))

(define impc:ti:get-builtin-docstring
  (lambda (builtin-name)
    (let ((builtin-data (assoc-strcmp builtin-name *impc:ti:builtin-cache*)))
      (if builtin-data (vector-ref (cdr builtin-data) 1) #f))))

(define impc:ti:set-builtin-docstring
  (lambda (builtin-name docstring)
    (let ((builtin-data (assoc-strcmp builtin-name *impc:ti:builtin-cache*)))
      (if builtin-data (vector-set! (cdr builtin-data) 1 docstring) #f))))

(define impc:ti:get-builtin-args
  (lambda (builtin-name)
    (let ((builtin-data (assoc-strcmp builtin-name *impc:ti:builtin-cache*)))
      (if builtin-data (vector-ref (cdr builtin-data) 2) #f))))

(define impc:ti:set-builtin-args
  (lambda (builtin-name args)
    (let ((builtin-data (assoc-strcmp builtin-name *impc:ti:builtin-cache*)))
      (if builtin-data (vector-set! (cdr builtin-data) 2 args) #f))))

;;;;;;;;;;;;;;
;; named types
;; -----------
;;
(define *impc:ti:namedtype-cache* '(("mzone" . #((14 108 2 2 2 108 "%mzone*") "Extempore memory zone"))
                                   ("clsvar" . #((14 108 4 108 2 "%clsvar*") "Extempore closure address table: <name,offset,type,TODO_whatisthis,next_table>"))))
;;
;; each element of the list is of the form
;;
;; (name . #(type docstring))

(define impc:ti:print-namedtype-cache
  (lambda ()
    (println '*impc:ti:namedtype-cache*: *impc:ti:namedtype-cache*)))

(define impc:ti:reset-namedtype-cache
  (lambda ()
    (set! *impc:ti:namedtype-cache* '())))

;; type is immutable, doesn't need a setter
(define impc:ti:get-namedtype-type
  (lambda (namedtype-name)
    (if (string? namedtype-name)
        (let ((ptr-depth (impc:ir:get-ptr-depth namedtype-name))
              (namedtype-data (assoc-strcmp (impc:ir:clean-named-type namedtype-name) *impc:ti:namedtype-cache*)))
          (if namedtype-data (impc:ir:pointer++ (vector-ref (cdr namedtype-data) 0) ptr-depth) #f))
        #f)))

(define impc:ti:namedtype-exists?
  (lambda (namedtype-name)
    (let ((res (impc:ti:get-namedtype-type namedtype-name)))
      (if (and res (not (null? res))) #t #f))))

(define impc:ti:register-new-namedtype
  (lambda (namedtype-name type docstring)
    ;; (println 'namedtype-name: namedtype-name 'type: type 'docstring: docstring)
    (if (impc:ti:namedtype-exists? namedtype-name)
        'donothing ;;(impc:compiler:print-already-bound-error namedtype-name (impc:ir:pretty-print-type type))
        ;; check arg types
        (if (not (and (or (string? namedtype-name) (begin (println 'bad 'namedtype-name: namedtype-name) #f))
                      (or (list? type) (integer? type) (begin (println 'bad 'type: type) #f))
                      (or (string? docstring) (begin (println 'bad 'docstring: docstring) #f))))
            (impc:compiler:print-compiler-error "couldn't register new named type")
            (begin
              ;; add to the AOT-header if we're precompiling
              (set! *impc:ti:namedtype-cache*
                    (cons (cons namedtype-name (vector type docstring))
                          *impc:ti:namedtype-cache*))
              (car *impc:ti:namedtype-cache*)
              (impc:aot:insert-namedtype-binding-details namedtype-name type docstring))))))

(define impc:ti:get-namedtype-docstring
  (lambda (namedtype-name)
    (let ((namedtype-data (assoc-strcmp (impc:ir:clean-named-type namedtype-name) *impc:ti:namedtype-cache*)))
      (if namedtype-data (vector-ref (cdr namedtype-data) 1) #f))))

(define impc:ti:set-namedtype-docstring
  (lambda (namedtype-name docstring)
    (let ((namedtype-data (assoc-strcmp (impc:ir:clean-named-type namedtype-name) *impc:ti:namedtype-cache*)))
      (if namedtype-data (vector-set! (cdr namedtype-data) 1 docstring) #f))))

;;;;;;;;;;;;;;;
;; type aliases
;; ------------
;;
(define *impc:ti:typealias-cache* '())
;;
;; each element of the list is of the form
;;
;; (name . #(type-alias docstring))

(define impc:ti:print-typealias-cache
  (lambda ()
    (println '*impc:ti:typealias-cache*: *impc:ti:typealias-cache*)))

(define impc:ti:reset-typealias-cache
  (lambda ()
    (set! *impc:ti:typealias-cache* '())))

(define impc:ti:get-typealias-type
  (lambda (typealias-name)
    (if (string? typealias-name)
        (let ((ptr-depth (impc:ir:get-ptr-depth typealias-name))
              (typealias-data (assoc-strcmp (impc:ir:clean-named-type typealias-name) *impc:ti:typealias-cache*)))
          (if typealias-data (impc:ir:pointer++ (vector-ref (cdr typealias-data) 0) ptr-depth) #f))
        #f)))

;; as above but returns pretty type
(define impc:ti:get-typealias-type-pretty
  (lambda (typealias-name)
    (if (string? typealias-name)
        (let ((ptr-depth (impc:ir:get-ptr-depth typealias-name))
              (typealias-data (assoc-strcmp (impc:ir:clean-named-type typealias-name) *impc:ti:typealias-cache*)))
          (if typealias-data (impc:ir:pretty-print-type (impc:ir:pointer++ (vector-ref (cdr typealias-data) 0) ptr-depth))
              #f))
        #f)))

(define impc:ti:typealias-exists?
  (lambda (typealias-name)
    (let ((res (impc:ti:get-typealias-type typealias-name)))
      (if (and res (not (null? res))) #t #f))))

;; this one will recursively keep following aliases until it reaches
;; the "ground" type
(define impc:ti:get-typealias-ground-type
  (lambda (typealias-name)
    (let loop ((lowered-alias (impc:ti:get-typealias-type typealias-name)))
      (if (and lowered-alias (string? lowered-alias))
          (loop (impc:ti:get-typealias-type lowered-alias))
          lowered-alias))))

;; as above but returns pretty print
(define impc:ti:get-typealias-ground-type-pretty
  (lambda (typealias-name)
    (let loop ((lowered-alias (impc:ti:get-typealias-type typealias-name)))
      (if (and lowered-alias (string? lowered-alias))
          (loop (impc:ti:get-typealias-type lowered-alias))
          (impc:ir:pretty-print-type lowered-alias)))))


(define impc:ti:register-new-typealias
  (lambda (typealias-name type docstring)
    ;; (println 'typealias-name: typealias-name 'type: type 'docstring: docstring)
    (if (impc:ti:typealias-exists? typealias-name)
        (impc:compiler:print-already-bound-error typealias-name (impc:ti:get-typealias-type-pretty typealias-name))
        ;; check arg types
        (if (not (and (or (string? typealias-name) (begin (println 'bad 'typealias-name: typealias-name) #f))
                      (or (list? type)
                          (integer? type)
                          (string? type)
                          ;(and (string? type)
                          ;     (impc:ti:namedtype-exists? type))
                          (begin (println 'bad 'type: type) #f))
                      (or (string? docstring) (begin (println 'bad 'docstring: docstring) #f))))
            (impc:compiler:print-compiler-error "couldn't register new type alias")
            (begin
              ;; add to the AOT-header if we're precompiling
              (set! *impc:ti:typealias-cache*
                    (cons (cons typealias-name (vector type docstring))
                          *impc:ti:typealias-cache*))
              (car *impc:ti:typealias-cache*)
              (impc:aot:insert-typealias-binding-details typealias-name type docstring))))))

(define impc:ti:get-typealias-docstring
  (lambda (typealias-name)
    (let ((typealias-data (assoc-strcmp (impc:ir:clean-named-type typealias-name) *impc:ti:typealias-cache*)))
      (if typealias-data (vector-ref (cdr typealias-data) 1) #f))))

(define impc:ti:set-typealias-docstring
  (lambda (typealias-name docstring)
    (let ((typealias-data (assoc-strcmp (impc:ir:clean-named-type typealias-name) *impc:ti:typealias-cache*)))
      (if typealias-data (vector-set! (cdr typealias-data) 1 docstring) #f))))

;;;;;;;;;;;;;;;;
;; xtlang macros
;; -------------
;;
(define *impc:ti:xtmacro-cache* '())
;;
;; each element of the list is of the form
;;
;; (name . #(docstring))
;;
;; create an xtlang macro through bind-macro. behind the scenes, these
;; are currently implemented as scheme macros (although with an
;; "xtmacro_" prefix) but this could change in future

(define impc:ti:print-xtmacro-cache
  (lambda ()
    (println '*impc:ti:xtmacro-cache*: *impc:ti:xtmacro-cache*)))

(define impc:ti:reset-xtmacro-cache
  (lambda ()
    (set! *impc:ti:xtmacro-cache* '())))

(define impc:ti:xtmacro-exists?
  (lambda (xtmacro-name)
    (if (and (string? xtmacro-name)
             (assoc-strcmp xtmacro-name *impc:ti:xtmacro-cache*))
        #t
        #f)))

(define impc:ti:register-new-xtmacro
  (lambda (macro-name docstring)
    ;; check arg types
    (if (and (or (string? macro-name) (begin (println 'bad 'macro-name: macro-name) #f))
             (or (string? docstring) (begin (println 'bad 'docstring: docstring) #f)))
        (begin
          (set! *impc:ti:xtmacro-cache*
                (cons (cons macro-name (vector docstring))
                      *impc:ti:xtmacro-cache*))
          (car *impc:ti:xtmacro-cache*)))))

(define impc:ti:get-xtmacro-docstring
  (lambda (xtmacro-name)
    (let ((xtmacro-data (assoc-strcmp xtmacro-name *impc:ti:xtmacro-cache*)))
      (if xtmacro-data (vector-ref (cdr xtmacro-data) 0) #f))))

(define impc:ti:set-xtmacro-docstring
  (lambda (xtmacro-name docstring)
    (let ((xtmacro-data (assoc-strcmp xtmacro-name *impc:ti:xtmacro-cache*)))
      (if xtmacro-data (vector-set! (cdr xtmacro-data) 0 docstring) #f))))

;; docstrings are compulsory for xtlang macros
(define-macro (bind-macro . forms)
  (let* ((string-in-first-pos? (string? (car forms)))
         (docstring (if string-in-first-pos? (car forms) ""))
         (name-and-args (if string-in-first-pos? (cadr forms) (car forms)))
         (body (if string-in-first-pos? (cddr forms) (cdr forms))))
    ;; (if (> (length body) 1)
    ;;     (set! body (cons 'begin body)))
    ;; (println 'body: body)
    `(begin
       (impc:aot:insert-xtmacro-binding-details ',name-and-args ,docstring ',@body)
       (impc:ti:register-new-xtmacro ,(symbol->string (car name-and-args)) ,docstring)
       (impc:compiler:print-binding-details-to-log
        "XtmMacro:"
        ',(car name-and-args)
        ""
        ;; now actually create the macro
        (define-macro
          ,(cons (string->symbol (string-append "xtmacro_" (symbol->string (car name-and-args))))
                 (cdr name-and-args))
          ,@body)))))

(impc:ti:register-new-builtin
 "bind-macro"
 ""
 "bind an xtlang macro"
 '([docstring] name-and-args-list macro-body))

;;;;;;;;;;;
;; closures
;; --------
;;
(define *impc:ti:closure-cache* '())
;;
;; each element of the list is of the form
;;
;; (name . #(type docstring zone-size body))
;;
;; this list replaces *impc:closuretypes*, *impc:closurebodies* and *impc:docstrings*
;;
;; TODO:
;;
;; - if we keep these lists sorted, then lookups become O(log2(N))
;;   rather than O(N) (or we could even use a hash-map one day...)

(define impc:ti:print-closure-cache
  (lambda ()
    (println '*impc:ti:closure-cache*: *impc:ti:closure-cache*)))

(define impc:ti:reset-closure-cache
  (lambda ()
    (set! *impc:ti:closure-cache* '())))

(define impc:ti:register-new-closure
  (lambda (closure-name type zone-size docstring body)
    ;; (println 'closure-name: closure-name 'type: type 'docstring: docstring 'zone-size: zone-size 'body: body 'exists? (impc:ti:closure-exists? closure-name))
    ;; check arg types
    (if (not (and (or (string? closure-name) (begin (println 'bad 'closure-name: closure-name) #f))
                  (or (list? type) (begin (println 'bad 'type: type) #f))
                  (or (number? zone-size) (begin (println 'bad 'zone-size: zone-size) #f))
                  (or (string? docstring) (begin (println 'bad 'docstring: docstring)))
                  (or (list? body) (begin (println 'bad 'body: body) #f))))
        (impc:compiler:print-compiler-error "couldn't register new closure")
        (if (impc:ti:closure-exists? closure-name)
            (let ((t (impc:ti:get-closure-type closure-name)))
              ;; (println 'double-registration: (equal? t type) 'new: type 'extant: t)
              (if (equal? t type)
                  (assoc-strcmp closure-name *impc:ti:closure-cache*)
                  (impc:compiler:print-already-bound-error closure-name (impc:ti:get-closure-type closure-name))))
            ;; create a new entry
            (begin
              (set! *impc:ti:closure-cache*
                    (cons (cons closure-name (vector type docstring zone-size body))
                          *impc:ti:closure-cache*))
              (car *impc:ti:closure-cache*))))))

(define impc:ti:get-closure-type
  (lambda (closure-name)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      ;; (println 'cls-list: closure-data)
      (if closure-data (vector-ref (cdr closure-data) 0) #f))))

(define impc:ti:get-closure-arg-types
  (lambda (name)
    (let ((type (impc:ti:get-closure-type name)))
      (if (or (not type) (null? type))
          #f
          (map impc:ir:get-type-str (cdr type))))))

;; this will return true during compilation (i.e. after the call to
;; `bind-func' but before the type of the closure is finalised)
(define impc:ti:closure-is-being-compiled?
  (lambda (closure-name)
    (let ((res (impc:ti:get-closure-type closure-name)))
      (if res #t #f))))

(define impc:ti:closure-exists?
  (lambda (closure-name)
    (let ((res (impc:ti:get-closure-type closure-name)))
      (if (and res (not (null? res))) #t #f))))

(define impc:ti:set-closure-type
  (lambda (closure-name type)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data
          (if (not (null? (vector-ref (cdr closure-data) 0)))
              (begin (print-with-colors 'yellow 'default #t (print "Warning"))
                     (print ": attempting to re-type already typed closure ")
                     (if (impc:ir:poly-or-adhoc? closure-name)
                         (let ((split-name (impc:ir:split-and-decode-poly-adhoc-name closure-name)))
                           (print-with-colors *impc:compiler:pretty-print-name-color* 'default #f (print (car split-name)))
                           (print ":")
                           (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (cadr split-name))))
                         (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print closure-name)))
                     (print " to ")
                     (print-with-colors *impc:compiler:pretty-print-type-color*
                                        'default #f (print (impc:ir:pretty-print-type type) "\n")))
              (vector-set! (cdr closure-data) 0 type))
          (impc:compiler:print-compiler-error "tried to set type of unknown closure" closure-name)))))

(define impc:ti:update-closure-name
  (lambda (closure-name new-closure-name)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data
          (begin
            (set-car! closure-data new-closure-name))
          (impc:compiler:print-compiler-error "tried to set type of unknown closure" closure-name)))))

(define impc:ti:get-closure-docstring
  (lambda (closure-name)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data (vector-ref (cdr closure-data) 1) #f))))

(define impc:ti:set-closure-docstring
  (lambda (closure-name docstring)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data (vector-set! (cdr closure-data) 1 docstring) #f))))

(define impc:ti:get-closure-zone-size
  (lambda (closure-name)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data (vector-ref (cdr closure-data) 2) #f))))

(define impc:ti:set-closure-zone-size
  (lambda (closure-name body)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data (vector-set! (cdr closure-data) 2 body) #f))))

(define impc:ti:get-closure-body
  (lambda (closure-name)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data (vector-ref (cdr closure-data) 3) #f))))

(define impc:ti:set-closure-body
  (lambda (closure-name body)
    (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
      (if closure-data (vector-set! (cdr closure-data) 3 body) #f))))

;; (define impc:ti:update-closure-body
;;   (lambda (closure-name new-closure-name body)
;;     (let ((closure-data (assoc-strcmp closure-name *impc:ti:closure-cache*)))
;;       (if closure-data
;;           (begin
;;             (set-car! closure-data new-closure-name)
;;             (vector-set! (cdr closure-data) 3 body))
;;           #f))))


;;;;;;;;;;;;;;;;;;;;;;;
;; native (C) functions
;; --------------------
;;
;; each element of the list is of the form
;;
;; (name . #(type docstring args))
;;
(define *impc:ti:nativefunc-cache*
  '(;; functions in Extempore binary (defined in {EXTLLVM,SchemeFFI}.cpp)
    ("abort" . #((213 -1) "" ())) ;; libc
    ("abs" . #((213 4 4) "" ())) ;; libc
    ("acos" . #((213 0 0) "" ())) ;; libm
    ("acosf" . #((213 1 1) "" ())) ;; libm
    ("acosh" . #((213 0 0) "" ())) ;; libm
    ("acoshf" . #((213 1 1) "" ())) ;; libm
;;    ("add_address_table" . #((213 "%clsvar*" "%mzone*" 108 4 108 4 "%clsvar*") "" ())) ;; internal
    ("ascii_text_color" . #((213 -1 4 4 4) "" ())) ;; xtlang
    ("asin" . #((213 0 0) "" ())) ;; libm
    ("asinf" . #((213 1 1) "" ())) ;; libm
    ("asinh" . #((213 0 0) "" ())) ;; libm
    ("asinhf" . #((213 1 1) "" ())) ;; libm
    ("atan" . #((213 0 0) "" ())) ;; libm
    ("atan2" . #((213 0 0 0) "" ())) ;; libm
    ("atan2f" . #((213 1 1 1) "" ())) ;; libm
    ("atanf" . #((213 1 1) "" ())) ;; libm
    ("atanh" . #((213 0 0) "" ())) ;; libm
    ("atanhf" . #((213 1 1) "" ())) ;; libm
    ("atof" . #((213 0 108) "" ())) ;; libc
    ("atoi" . #((213 4 108) "" ())) ;; libc
    ("atol" . #((213 2 108) "" ())) ;; libc
    ("audio_clock_base" . #((213 0) "" ())) ;; xtlang
    ("audio_clock_now" . #((213 0) "" ())) ;; xtlang
    ("base64_decode" . #((213 108 108 2 2) "" ())) ;; xtlang
    ("base64_encode" . #((213 108 108 2 2) "" ())) ;; xtlang
    ("calloc" . #((213 108 2 2) "" ())) ;; libc
    ("cbrt" . #((213 0 0) "" ())) ;; libm
    ("cbrtf" . #((213 1 1) "" ())) ;; libm
;;    ("check_address_exists" . #((213 10 108 "%clsvar*") "" ())) ;; internal
;;    ("check_address_type" . #((213 10 108 "%clsvar*" 108) "" ())) ;;internal
    ("clearerr" . #((213 -1 108) "" ())) ;; libc
    ("clock_clock" . #((213 0) "" ())) ;; xtlang
    ("cname_decode" . #((213 108 108 2 2) "" ())) ;; xtlang
    ("cname_encode" . #((213 108 108 2 2) "" ())) ;; xtlang
    ("copysign" . #((213 0 0 0) "" ())) ;; libm
    ("copysignf" . #((213 1 1 1) "" ())) ;; libm
    ("cosh" . #((213 0 0) "" ())) ;; libm
    ("coshf" . #((213 1 1) "" ())) ;; libm
;;    ("cptr_value" . #((213 108 108) "" ())) ;; internal
    ("ctermid" . #((213 108 108) "" ())) ;; libc
    ("dlsym" . #((213 108 108 108) "" ())) ;; libdl (!WIN32) - could be implemented on WIN32 - just used for OpenGL(?)
    ("dtof" . #((213 1 0) "" ())) ;; xtlang
    ("dtoi1" . #((213 10 0) "" ())) ;; xtlang
    ("dtoi16" . #((213 6 0) "" ())) ;; xtlang
    ("dtoi32" . #((213 4 0) "" ())) ;; xtlang
    ("dtoi64" . #((213 2 0) "" ())) ;; xtlang
    ("dtoi8" . #((213 8 0) "" ())) ;; xtlang
    ("dtoui1" . #((213 10 0) "" ())) ;; xtlang
    ("dtoui16" . #((213 6 0) "" ())) ;; xtlang
    ("dtoui32" . #((213 4 0) "" ())) ;; xtlang
    ("dtoui64" . #((213 2 0) "" ())) ;; xtlang
    ("dtoui8" . #((213 8 0) "" ())) ;; xtlang
    ("erf" . #((213 0 0) "" ())) ;; libm
    ("erfc" . #((213 0 0) "" ())) ;; libm
    ("erfcf" . #((213 1 1) "" ())) ;; libm
    ("erff" . #((213 1 1) "" ())) ;; libm
    ("exit" . #((213 -1 4) "" ())) ;; libc
    ("expm1" . #((213 0 0) "" ())) ;; libm
    ("expm1f" . #((213 1 1) "" ())) ;; libm
    ("extitoa" . #((213 108 2) "" ())) ;; xtlang (for kinect only?)
    ("fclose" . #((213 4 108) "" ())) ;; libc
    ("fdim" . #((213 0 0 0) "" ())) ;; libm
    ("fdimf" . #((213 1 1 1) "" ())) ;; libm
    ("fdopen" . #((213 108 4 108) "" ())) ;; libc
    ("feof" . #((213 4 108) "" ())) ;; libc
    ("ferror" . #((213 4 108) "" ())) ;; libc
    ("fflush" . #((213 4 108) "" ())) ;; libc
    ("fgetc" . #((213 4 108) "" ())) ;; libc
    ("fgets" . #((213 108 108 4 108) "" ())) ;; libc
    ("fileno" . #((213 4 108) "" ())) ;; libc
    ("flockfile" . #((213 -1 108) "" ())) ;; libpthread
    ("fmax" . #((213 0 0 0) "" ())) ;; libm
    ("fmaxf" . #((213 1 1 1) "" ())) ;; libm
    ("fmin" . #((213 0 0 0) "" ())) ;; libm
    ("fminf" . #((213 1 1 1) "" ())) ;; libm
    ("fmod" . #((213 0 0 0) "" ())) ;; libm
    ("fmodf" . #((213 1 1 1) "" ())) ;; libm
    ("fopen" . #((213 108 108 108) "" ())) ;; libc
    ("fputc" . #((213 4 4 108) "" ())) ;; libc
    ("fputs" . #((213 4 108 108) "" ())) ;; libc
    ("fread" . #((213 2 108 2 2 108) "" ())) ;; libc
    ("free" . #((213 -1 108) "" ())) ;; libc (via xtlang)
    ("free16" . #((213 -1 108) "" ())) ;; xtlang
    ("free_after_delay" . #((213 -1 108 0) "" ())) ;; xtlang
    ("freopen" . #((213 108 108 108 108) "" ())) ;; libc
    ("fseek" . #((213 4 108 2 4) "" ())) ;; libc
    ("ftell" . #((213 2 108) "" ())) ;; libc
    ("ftod" . #((213 0 1) "" ())) ;; xtlang
    ("ftoi1" . #((213 10 1) "" ())) ;; xtlang
    ("ftoi16" . #((213 6 1) "" ())) ;; xtlang
    ("ftoi32" . #((213 4 1) "" ())) ;; xtlang
    ("ftoi64" . #((213 2 1) "" ())) ;; xtlang
    ("ftoi8" . #((213 8 1) "" ())) ;; xtlang
    ("ftoui1" . #((213 10 1) "" ())) ;; xtlang
    ("ftoui16" . #((213 6 1) "" ())) ;; xtlang
    ("ftoui32" . #((213 4 1) "" ())) ;; xtlang
    ("ftoui64" . #((213 2 1) "" ())) ;; xtlang
    ("ftoui8" . #((213 8 1) "" ())) ;; xtlang
    ("fp80ptrtod" . #((213 0 108) "" ())) ;; xtlang
    ("ftrylockfile" . #((213 4 108) "" ())) ;; libpthread
    ("funlockfile" . #((213 -1 108) "" ())) ;; libpthread
    ("fwrite" . #((213 2 108 2 2 108) "" ())) ;; libc
;;    ("get_address_offset" . #((213 4 108 "%clsvar*") "" ())) ;; internal
;;    ("get_address_table" . #((213 "%clsvar*" 108 "%clsvar*") "" ())) ;; internal
    ("getc" . #((213 4 108) "" ())) ;; libc
    ("getc_unlocked" . #((213 4 108) "" ())) ;; libc
    ("getchar" . #((213 4) "" ())) ;; libc
    ("getchar_unlocked" . #((213 4) "" ())) ;; libc
    ("getenv" . #((213 108 108) "" ())) ;; libc
    ("gets" . #((213 108 108) "" ())) ;; libc
    ("getw" . #((213 4 108) "" ())) ;; libc
    ("hypot" . #((213 0 0 0) "" ())) ;; libm
    ("hypotf" . #((213 1 1 1) "" ())) ;; libm
    ("i16tod" . #((213 0 6) "" ())) ;; xtlang
    ("i16tof" . #((213 1 6) "" ())) ;; xtlang
    ("i16toi1" . #((213 10 6) "" ())) ;; xtlang
    ("i16toi32" . #((213 4 6) "" ())) ;; xtlang
    ("i16toi64" . #((213 2 6) "" ())) ;; xtlang
    ("i16toi8" . #((213 8 6) "" ())) ;; xtlang
    ("i16toptr" . #((213 108 6) "" ())) ;; xtlang
    ("i16toui32" . #((213 4 6) "" ())) ;; xtlang
    ("i16toui64" . #((213 2 6) "" ())) ;; xtlang
;;    ("i16value" . #((213 6 108) "" ())) ;; internal
    ("i1tod" . #((213 0 10) "" ())) ;; xtlang
    ("i1tof" . #((213 1 10) "" ())) ;; xtlang
    ("i1toi16" . #((213 6 10) "" ())) ;; xtlang
    ("i1toi32" . #((213 4 10) "" ())) ;; xtlang
    ("i1toi64" . #((213 2 10) "" ())) ;; xtlang
    ("i1toi8" . #((213 8 10) "" ())) ;; xtlang
;;    ("i1value" . #((213 10 108) "" ())) ;; internal
    ("i32tod" . #((213 0 4) "" ())) ;; xtlang
    ("i32tof" . #((213 1 4) "" ())) ;; xtlang
    ("i32toi1" . #((213 10 4) "" ())) ;; xtlang
    ("i32toi16" . #((213 6 4) "" ())) ;; xtlang
    ("i32toi64" . #((213 2 4) "" ())) ;; xtlang
    ("i32toi8" . #((213 8 4) "" ())) ;; xtlang
    ("i32toptr" . #((213 108 4) "" ())) ;; xtlang
    ("i32toui64" . #((213 2 4) "" ())) ;; xtlang
;;    ("i32value" . #((213 4 108) "" ())) ;; internal
    ("i64tod" . #((213 0 2) "" ())) ;; xtlang
    ("i64tof" . #((213 1 2) "" ())) ;; xtlang
    ("i64toi1" . #((213 10 2) "" ())) ;; xtlang
    ("i64toi16" . #((213 6 2) "" ())) ;; xtlang
    ("i64toi32" . #((213 4 2) "" ())) ;; xtlang
    ("i64toi8" . #((213 8 2) "" ())) ;; xtlang
    ("i64toptr" . #((213 108 2) "" ())) ;; xtlang
;;    ("i64value" . #((213 2 108) "" ())) ;; internal
    ("i8tod" . #((213 0 8) "" ())) ;; xtlang
    ("i8tof" . #((213 1 8) "" ())) ;; xtlang
    ("i8toi1" . #((213 10 8) "" ())) ;; xtlang
    ("i8toi16" . #((213 6 8) "" ())) ;; xtlang
    ("i8toi32" . #((213 4 8) "" ())) ;; xtlang
    ("i8toi64" . #((213 2 8) "" ())) ;; xtlang
    ("i8toui32" . #((213 4 8) "" ())) ;; xtlang
    ("i8toui64" . #((213 2 8) "" ())) ;; xtlang
;;    ("i8value" . #((213 8 108) "" ())) ;; internal
    ("ilogb" . #((213 0 0) "" ())) ;; libm
    ("ilogbf" . #((213 1 1) "" ())) ;; libm
    ("imp_rand1_d" . #((213 0 0) "" ())) ;; xtlang
    ("imp_rand1_f" . #((213 1 1) "" ())) ;; xtlang
    ("imp_rand1_i32" . #((213 4 4) "" ())) ;; xtlang
    ("imp_rand1_i64" . #((213 2 2) "" ())) ;; xtlang
    ("imp_rand2_d" . #((213 0 0 0) "" ())) ;; xtlang
    ("imp_rand2_f" . #((213 1 1 1) "" ())) ;; xtlang
    ("imp_rand2_i32" . #((213 4 4 4) "" ())) ;; xtlang
    ("imp_rand2_i64" . #((213 2 2 2) "" ())) ;; xtlang
    ("imp_randd" . #((213 0) "" ())) ;; xtlang
    ("imp_randf" . #((213 1) "" ())) ;; xtlang
    ("impc_false" . #((113 10) "" ())) ;; internal
    ("impc_null" . #((113 108) "" ())) ;; internal
    ("impc_true" . #((113 10) "" ())) ;; internal
;;    ("is_cptr" . #((213 4 108) "" ())) ;; internal
;;    ("is_cptr_or_str" . #((213 4 108) "" ())) ;; internal
;;    ("is_integer" . #((213 4 108) "" ())) ;; internal
;;    ("is_real" . #((213 4 108) "" ())) ;; internal
;;    ("is_string" . #((213 4 108) "" ())) ;; internal
    ("lgamma" . #((213 0 0) "" ())) ;; libm
    ("lgammaf" . #((213 1 1) "" ())) ;; libm
;;    ("list_ref" . #((213 108 108 4 108) "" ())) ;; internal
    ("llabs" . #((213 2 2) "" ()))
    ("llrint" . #((213 2 0) "" ()))
    ("llrintf" . #((213 2 1) "" ()))
    ("llround" . #((213 2 0) "" ()))
    ("llroundf" . #((213 2 1) "" ()))
    ;; ("llvm.ceil.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.ceil.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.ceil.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.ceil.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.ceil.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.ceil.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.cos.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.cos.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.cos.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.cos.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.cos.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.cos.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.exp.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.exp.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.exp.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.exp.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.exp.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.exp.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.exp2.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.exp2.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.exp2.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.exp2.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.exp2.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.exp2.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.fabs.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.fabs.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.fabs.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.fabs.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.fabs.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.fabs.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.floor.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.floor.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.floor.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.floor.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.floor.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.floor.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.fma.f32" . #((213 1 1 1 1) "" ())) ;; internal
    ;; ("llvm.fma.f64" . #((213 0 0 0 0) "" ())) ;; internal
    ;; ("llvm.fma.v2f64" . #((213 (16 2 0) (16 2 0) (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.fma.v4f32" . #((213 (16 4 1) (16 4 1) (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.fma.v4f64" . #((213 (16 4 0) (16 4 0) (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.fma.v8f32" . #((213 (16 8 1) (16 8 1) (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.log.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.log.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.log.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.log.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.log.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.log.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.log10.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.log10.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.log10.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.log10.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.log10.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.log10.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.log2.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.log2.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.log2.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.log2.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.log2.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.log2.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.nearbyint.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.nearbyint.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.nearbyint.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.nearbyint.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.nearbyint.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.nearbyint.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.pow.f32" . #((213 1 1 1) "" ())) ;; internal
    ;; ("llvm.pow.f64" . #((213 0 0 0) "" ())) ;; internal
    ;; ("llvm.pow.v2f64" . #((213 (16 2 0) (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.pow.v4f32" . #((213 (16 4 1) (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.pow.v4f64" . #((213 (16 4 0) (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.pow.v8f32" . #((213 (16 8 1) (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.powi.f32" . #((213 1 1 4) "" ())) ;; internal
    ;; ("llvm.powi.f64" . #((213 0 0 4) "" ())) ;; internal
    ;; ("llvm.powi.v2f64" . #((213 (16 2 0) (16 2 0) (16 2 4)) "" ())) ;; internal
    ;; ("llvm.powi.v4f32" . #((213 (16 4 1) (16 4 1) (16 4 4)) "" ())) ;; internal
    ;; ("llvm.powi.v4f64" . #((213 (16 4 0) (16 4 0) (16 4 4)) "" ())) ;; internal
    ;; ("llvm.powi.v8f32" . #((213 (16 8 1) (16 8 1) (16 8 4)) "" ())) ;; internal
    ;; ("llvm.round.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.round.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.round.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.round.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.round.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.round.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.round.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.sin.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.sin.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.sin.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.sin.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.sin.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.sin.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.sqrt.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.sqrt.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.sqrt.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.sqrt.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.sqrt.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.sqrt.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ;; ("llvm.trunc.f32" . #((213 1 1) "" ())) ;; internal
    ;; ("llvm.trunc.f64" . #((213 0 0) "" ())) ;; internal
    ;; ("llvm.trunc.v2f64" . #((213 (16 2 0) (16 2 0)) "" ())) ;; internal
    ;; ("llvm.trunc.v4f32" . #((213 (16 4 1) (16 4 1)) "" ())) ;; internal
    ;; ("llvm.trunc.v4f64" . #((213 (16 4 0) (16 4 0)) "" ())) ;; internal
    ;; ("llvm.trunc.v8f32" . #((213 (16 8 1) (16 8 1)) "" ())) ;; internal
    ("llvm_destroy_zone_after_delay" . #((213 -1 "%mzone*" 2) "" ())) ;; internal but referenced in tests
    ("fprintf" . #(varargs "" ())) ;; libc
    ("fscanf" . #(varargs "" ())) ;; libc
    ("llvm_get_function_ptr" . #((213 108 108) "" ())) ;; xtlang
    ("llvm_now" . #((213 2) "" ())) ;; xtlang (as now)
    ("llvm_peek_zone_stack" . #((213 "%mzone*") "" ())) ;; xtlang
    ("llvm_pop_zone_stack" . #((213 "%mzone*") "" ()));; xtlang
    ("llvm_print_f32" . #((213 -1 1) "" ())) ;; debug
    ("llvm_print_f64" . #((213 -1 0) "" ())) ;; debug
    ("llvm_print_i32" . #((213 -1 4) "" ())) ;; debug
    ("llvm_print_i64" . #((213 -1 2) "" ())) ;; debug
    ("llvm_print_pointer" . #((213 -1 108) "" ())) ;; debug
    ("llvm_ptr_in_current_zone" . #((213 10 108) "" ())) ;; debug (?)
    ("llvm_ptr_in_zone" . #((213 10 "%mzone*" 108) "" ())) ;; xtlang
    ;; ("llvm_push_zone_stack" . #((213 -1 "%mzone*") "" ())) ;; internal
    ("llvm_runtime_error" . #((213 -1 2 108) "" ())) ;; debug (?)
    ;; ("llvm_schedule_callback" . #((213 -1 2 108) "" ())) ;; internal
    ("llvm_send_udp" . #((213 -1 108 4 108 4) "" ())) ;; xtlang
    ("llvm_zone_copy_ptr" . #((213 10 108 108) "" ())) ;; ???
    ("llvm_zone_create" . #((213 "%mzone*" 2) "" ())) ;; internal (used for Zone)
    ("llvm_zone_destroy" . #((213 -1 "%mzone*") "" ())) ;; internal (for destroy_zone)
    ("llvm_zone_malloc" . #((213 108 "%mzone*" 2) "" ())) ;; xtlang
    ("llvm_zone_malloc_from_current_zone" . #((213 108 2) "" ())) ;; internal (?)
    ("llvm_zone_print" . #((213 -1 "%mzone*") "" ())) ;; internal (for print)
    ;; ("llvm_zone_ptr_set_size" . #((213 -1 108 2) "" ())) ;; internal
    ("llvm_zone_ptr_size" . #((213 2 108) "" ())) ;; internal (for zcopy)
    ("llvm_zone_reset" . #((213 "%mzone*" "%mzone*") "" ())) ;; internal (for reset_zone)
    ("llvm_disassemble" . #((213 i8* i8* i32) "" ())) ;; xtlang
    ("log1p" . #((213 0 0) "" ())) ;; libm
    ("log1pf" . #((213 1 1) "" ())) ;; libm
    ("log2f" . #((213 1 1) "" ())) ;; libm
    ("logb" . #((213 4 0) "" ())) ;; libm
    ("logbf" . #((213 4 1) "" ())) ;; libm
    ("longjmp" . #((213 -1 108 4) "" ())) ;;libc
    ("lrint" . #((213 2 0) "" ())) ;; libm
    ("lrintf" . #((213 2 1) "" ())) ;; libm
    ("lround" . #((213 4 0) "" ())) ;; libm
    ("lroundf" . #((213 4 1) "" ())) ;; libm
    ("malloc" . #((213 108 2) "" ())) ;; libc (via xtlang)
    ("malloc16" . #((213 108 2) "" ())) ;; xtlang
    ("memccpy" . #((213 108 108 108 4 2) "" ()))
    ("memchr" . #((213 108 108 4 2) "" ()))
    ("memcmp" . #((213 4 108 108 2) "" ()))
    ("memcpy" . #((213 -1 108 108 2) "" ()))
    ("memmove" . #((213 108 108 108 2) "" ()))
    ("memset" . #((213 108 108 4 2) "" ()))
    ("mk_cptr" . #((213 108 108 108) "" ()))
    ("mk_double" . #((213 108 108 0) "" ()))
    ("mk_float" . #((213 108 108 1) "" ()))
    ("mk_i1" . #((213 108 108 10) "" ()))
    ("mk_i16" . #((213 108 108 6) "" ()))
    ("mk_i32" . #((213 108 108 4) "" ()))
    ("mk_i64" . #((213 108 108 2) "" ()))
    ("mk_i8" . #((213 108 108 8) "" ()))
    ("mk_string" . #((213 108 108 108) "" ()))
    ("mutex_create" . #((213 108) "" ()))
    ("mutex_destroy" . #((213 4 108) "" ()))
    ("mutex_lock" . #((213 4 108) "" ()))
    ("mutex_trylock" . #((213 4 108) "" ()))
    ("mutex_unlock" . #((213 4 108) "" ()))
    ("nan" . #((213 0 108) "" ()))
    ("nanf" . #((213 1 108) "" ()))
    ("new_address_table" . #((213 "%clsvar*") "" ()))
    ("next_prime" . #((213 2 2) "" ()))
    ("nextafter" . #((213 0 0 0) "" ()))
    ("nextafterf" . #((213 1 1 1) "" ()))
    ("nexttoward" . #((213 0 0 0) "" ()))
    ("nexttowardf" . #((213 1 1 1) "" ()))
    ("pclose" . #((213 4 108) "" ()))
    ("perror" . #((213 -1 108) "" ()))
    ("popen" . #((213 108 108 108) "" ()))
    ("printf" . #(varargs "" ())) ;; libc
    ("ptrtoi16" . #((213 6 108) "" ()))
    ("ptrtoi32" . #((213 4 108) "" ()))
    ("ptrtoi64" . #((213 2 108) "" ()))
    ("putc" . #((213 4 4 108) "" ()))
    ("putc_unlocked" . #((213 4 4 108) "" ()))
    ("putchar" . #((213 4 4) "" ()))
    ("putchar_unlocked" . #((213 4 4) "" ()))
    ("puts" . #((213 4 108) "" ()))
    ("putw" . #((213 4 4 108) "" ()))
    ("r32value" . #((213 1 108) "" ()))
    ("r64value" . #((213 0 108) "" ()))
    ("raise" . #((213 4 4) "" ()))
    ("rand" . #((213 4) "" ()))
    ("realloc" . #((213 108 108 2) "" ()))
    ("register_for_window_events" . #((213 4) "" ()))
    ("xtm_set_main_callback" . #((213 -1 108) "" ()))
    ("remainder" . #((213 0 0 0) "" ()))
    ("remainderf" . #((213 1 1 1) "" ()))
    ("remove" . #((213 4 108) "" ()))
    ("remquo" . #((213 0 0 0 108) "" ()))
    ("remquof" . #((213 1 1 1 108) "" ()))
    ("rename" . #((213 4 108 108) "" ()))
    ("rewind" . #((213 -1 108) "" ()))
    ("rint" . #((213 4 0) "" ()))
    ("rintf" . #((213 4 1) "" ()))
    ("rmatch" . #((213 10 108 108) "" ()))
    ("rmatches" . #((213 2 108 108 208 2) "" ()))
    ("rreplace" . #((213 108 108 108 108 108) "" ()))
    ("rsplit" . #((213 10 108 108 108 108) "" ()))
    ("scalbn" . #((213 0 0 4) "" ()))
    ("scalbnf" . #((213 1 1 4) "" ()))
    ("sscanf" . #(varargs "" ())) ;; libc
    ("setbuf" . #((213 -1 108 108) "" ()))
    ("setenv" . #((213 4 108 108 4) "" ()))
    ("setjmp" . #((213 4 108) "" ()))
    ("setvbuf" . #((213 4 108 108 4 2) "" ()))
    ("sinh" . #((213 0 0) "" ())) ;; libm
    ("sinhf" . #((213 1 1) "" ())) ;; libm
    ("sprintf" . #(varargs "" ())) ;; libc
    ("strcat" . #((213 108 108 108) "" ()))
    ("strchr" . #((213 108 108 4) "" ()))
    ("strcmp" . #((213 4 108 108) "" ()))
    ("strcoll" . #((213 4 108 108) "" ()))
    ("strcpy" . #((213 108 108 108) "" ()))
    ("strcspn" . #((213 2 108 108) "" ()))
    ("strdup" . #((213 108 108) "" ()))
    ("strerror" . #((213 108 4) "" ()))
    ("string_hash" . #((213 2 108) "" ()))
    ("string_value" . #((213 108 108) "" ()))
    ("strlen" . #((213 2 108) "" ()))
    ("strncat" . #((213 108 108 108 2) "" ()))
    ("strncmp" . #((213 4 108 108 2) "" ()))
    ("strncpy" . #((213 108 108 108 2) "" ()))
    ("strpbrk" . #((213 108 108 108) "" ()))
    ("strrchr" . #((213 108 108 4) "" ()))
    ("strspn" . #((213 2 108 108) "" ()))
    ("strstr" . #((213 108 108 108) "" ()))
    ("strtok" . #((213 108 108 108) "" ()))
    ("strtok_r" . #((213 108 108 108 208) "" ()))
    ("strxfrm" . #((213 2 108 108 2) "" ()))
    ("swap32f" . #((213 4 1) "" ()))
    ("swap32i" . #((213 4 4) "" ()))
    ("swap64f" . #((213 2 0) "" ()))
    ("swap64i" . #((213 2 2) "" ()))
    ("sys_sharedir" . #((213 108) "" ()))
    ("sys_slurp_file" . #((213 108 108) "" ()))
    ("system" . #((213 4 108) "" ()))
    ("tan" . #((213 0 0) "" ())) ;; libm
    ("tanf" . #((213 1 1) "" ())) ;; libm
    ("tanh" . #((213 0 0) "" ())) ;; libm
    ("tanhf" . #((213 1 1) "" ())) ;; libm
    ("tempnam" . #((213 108 108 108) "" ()))
    ("tgamma" . #((213 0 0) "" ()))
    ("tgammaf" . #((213 1 1) "" ()))
    ("thread_fork" . #((213 108 108 108) "" ()))
    ("thread_destroy" . #((213 -1 108) "" ()))
    ("thread_join" . #((213 4 108) "" ()))
    ("thread_kill" . #((213 4 108) "" ()))
    ("thread_self" . #((213 108) "" ()))
    ("thread_sleep" . #((213 2 2 2) "" ()))
    ("thread_equal" . #((213 4 108 108) "" ()))
    ("thread_equal_self" . #((213 4 108) "" ()))
    ("tmpfile" . #((213 108) "" ()))
    ("tmpnam" . #((213 108 108) "" ()))
    ("trunc" . #((213 0 0) "" ()))
    ("ui16tod" . #((213 0 6) "" ()))
    ("ui16tof" . #((213 1 6) "" ()))
    ("ui1tod" . #((213 0 10) "" ()))
    ("ui1tof" . #((213 1 10) "" ()))
    ("ui32tod" . #((213 0 4) "" ()))
    ("ui32tof" . #((213 1 4) "" ()))
    ("ui64tod" . #((213 0 2) "" ()))
    ("ui64tof" . #((213 1 2) "" ()))
    ("ui8tod" . #((213 0 8) "" ()))
    ("ui8tof" . #((213 1 8) "" ()))
    ("ungetc" . #((213 4 4 108) "" ()))
    ("unsetenv" . #((213 4 108) "" ()))
    ("unswap32f" . #((213 1 4) "" ()))
    ("unswap32i" . #((213 4 4) "" ()))
    ("unswap64f" . #((213 0 2) "" ()))
    ("unswap64i" . #((213 2 2) "" ()))
    ))

(define impc:ti:print-nativefunc-cache
  (lambda ()
    (println '*impc:ti:nativefunc-cache*: *impc:ti:nativefunc-cache*)))

(define impc:ti:reset-nativefunc-cache
  (lambda ()
    (set! *impc:ti:nativefunc-cache* '())))

(define impc:ti:register-new-nativefunc
  (lambda (nativefunc-name type docstring arg-list)
    ;; check arg types
    (if (not (and (or (string? nativefunc-name) (begin (println 'bad 'nativefunc-name: nativefunc-name) #f))
                  (or (list? type) (begin (println 'bad 'type: type) #f))
                  (or (string? docstring) (begin (println 'bad 'docstring: docstring)))
                  (or (list? arg-list) (begin (println 'bad 'arg-list: arg-list)))))
        (impc:compiler:print-compiler-error "couldn't register new nativefunc")
        (let ((existing (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
          (if existing
              ;; update details if it already exists
              (set-cdr! existing (vector type docstring arg-list))
              ;; or create a new entry
              (begin
                (set! *impc:ti:nativefunc-cache*
                      (cons (cons nativefunc-name (vector type docstring arg-list))
                            *impc:ti:nativefunc-cache*))
                (car *impc:ti:nativefunc-cache*)))))))

(define impc:ti:get-nativefunc-type
  (lambda (nativefunc-name)
    (let ((nfunc-data (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
      (if nfunc-data (vector-ref (cdr nfunc-data) 0) #f))))

(define impc:ti:get-nativefunc-arg-types
  (lambda (name)
    (let ((type (impc:ti:get-nativefunc-type name)))
      (if (or (not type) (null? type))
          #f
          (map impc:ir:get-type-str (cdr type))))))

(define impc:ti:nativefunc-exists?
  (lambda (nativefunc-name)
    (if (impc:ti:get-nativefunc-type nativefunc-name) #t #f)))

(define impc:ti:set-nativefunc-type
  (lambda (nativefunc-name type)
    (let ((nfunc-data (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
      (if nfunc-data (vector-set! (cdr nfunc-data) 0 type) #f))))

(define impc:ti:get-nativefunc-docstring
  (lambda (nativefunc-name)
    (let ((nfunc-data (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
      (if nfunc-data (vector-ref (cdr nfunc-data) 1) #f))))

(define impc:ti:set-nativefunc-docstring
  (lambda (nativefunc-name docstring)
    (let ((nfunc-data (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
      (if nfunc-data (vector-set! (cdr nfunc-data) 1 docstring) #f))))

(define impc:ti:get-nativefunc-arg-names
  (lambda (nativefunc-name)
    (let ((nativefunc-data (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
      (if nativefunc-data (vector-ref (cdr nativefunc-data) 2) #f))))

(define impc:ti:set-nativefunc-arg-names
  (lambda (nativefunc-name arg-list)
    (let ((nativefunc-data (assoc-strcmp nativefunc-name *impc:ti:nativefunc-cache*)))
      (if nativefunc-data (vector-set! (cdr nativefunc-data) 2 arg-list) #f))))

;; helpers for dealing with either closures or nativefuncs

(define impc:ti:get-closure-or-nativefunc-type
  (lambda (closure-or-nativefunc-name)
    (or (impc:ti:get-closure-type closure-or-nativefunc-name)
        (impc:ti:get-nativefunc-type closure-or-nativefunc-name))))

(define impc:ti:closure-or-nativefunc-exists?
  (lambda (closure-or-nativefunc-name)
    (or (impc:ti:closure-exists? closure-or-nativefunc-name)
        (impc:ti:nativefunc-exists? closure-or-nativefunc-name))))

(define impc:ti:get-closure-or-nativefunc-arg-types
  (lambda (closure-or-nativefunc-name)
    (or (impc:ti:get-closure-arg-types closure-or-nativefunc-name)
        (impc:ti:get-nativefunc-arg-types closure-or-nativefunc-name))))

(define impc:ti:get-closure-or-nativefunc-docstring
  (lambda (closure-or-nativefunc-name)
    (or (impc:ti:get-closure-docstring closure-or-nativefunc-name)
        (impc:ti:get-nativefunc-docstring closure-or-nativefunc-name))))

;;;;;;;;;;;;;;;;;;;;;;;;
;; polymorphic functions
;; ---------------------
;;
;; for poly funcs, `type' is a list of vectors
;;
;; (polyfunc-name . #((list #(func1 func1type) #(func2 func2type)) docstring))
;;
(define *impc:ti:polyfunc-cache*
  '())

(define impc:ti:print-polyfunc-cache
  (lambda ()
    (println '*impc:ti:polyfunc-cache*: *impc:ti:polyfunc-cache*)))

(define impc:ti:reset-polyfunc-cache
  (lambda ()
    (set! *impc:ti:polyfunc-cache* '())))

(define impc:ti:polyfunc-exists?
  (lambda (polyfunc-name)
    (if (assoc-strcmp polyfunc-name *impc:ti:polyfunc-cache*) #t #f)))

(define impc:ti:get-polyfunc-candidate-list
  (lambda (polyfunc-name)
    (let ((pfunc-data (assoc-strcmp polyfunc-name *impc:ti:polyfunc-cache*)))
      (if pfunc-data
          (vector-ref (cdr pfunc-data) 0)
          #f))))

;; only add the docstring first time around
;; remap impc:ir:add-poly
(define impc:ti:register-new-polyfunc
  (lambda (polyfunc-name func-name func-type docstring)
    ;; check arg types
    (if (not (and (or (string? polyfunc-name) (begin (println 'bad 'polyfunc-name: polyfunc-name) #f))
                  (or (string? func-name) (begin (println 'bad 'polyfunc-name: func-name) #f))
                  (or (list? func-type) (begin (println 'bad 'type: func-type) #f))
                  (or (string? docstring) (begin (println 'bad 'docstring: docstring)))))
        (impc:compiler:print-compiler-error "couldn't register new polymorphic function")
        (let ((candidates (assoc-strcmp polyfunc-name *impc:ti:polyfunc-cache*)))
          ;; add the bind-poly form to the AOT-header if we're precompiling
          (if candidates
              (let ((res (cl:find-if (lambda (x) (string=? (vector-ref x 0) func-name))
                                     (vector-ref (cdr candidates) 0))))
                ;; update the docstring
                (if (not (string=? docstring ""))
                    (begin
                      (vector-set! (cdr candidates) 1 docstring)
                      (print-with-colors 'yellow 'default #t (print "Warning:"))
                      (print " the docstring for the polymorphic function ")
                      (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print func-name))
                      (print " has been updated.\n")))
                (if res
                    ;; if we're overriding an already poly'd function
                    (vector-set! res 1 func-type)
                    ;; if we're adding a new poly'd function
                    (vector-set! (cdr candidates) 0
                                 (cons (vector func-name func-type)
                                       (vector-ref (cdr candidates) 0)))))
              ;; or create a new entry
              (set! *impc:ti:polyfunc-cache*
                    (cons (cons polyfunc-name (vector (list (vector func-name func-type)) docstring))
                          *impc:ti:polyfunc-cache*)))
          (impc:aot:insert-polyfunc-binding-details polyfunc-name func-name docstring)))))

(define impc:ti:get-polyfunc-docstring
  (lambda (polyfunc-name)
    (let ((polyfunc-data (assoc-strcmp polyfunc-name *impc:ti:polyfunc-cache*)))
      (if polyfunc-data (vector-ref (cdr polyfunc-data) 1) #f))))

(define impc:ti:get-polyfunc-candidate-names
  (lambda (polyfunc-name)
    (let ((candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name)))
      (and candidates
           (map (lambda (func-vector) (vector-ref func-vector 0)) candidates)))))

;; remap impc:ir:poly-types - should return list types for all options
(define impc:ti:get-polyfunc-candidate-types
  (lambda (polyfunc-name)
    (let ((candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name)))
      (and candidates
           (map (lambda (func-vector) (vector-ref func-vector 1)) candidates)))))

(define impc:ti:get-polyfunc-candidate-pretty-types
  (lambda (polyfunc-name)
    (let ((types (impc:ti:get-polyfunc-candidate-types polyfunc-name)))
      (and types (map impc:ir:pretty-print-type types)))))

;; remap impc:ir:poly-print-all
(define impc:ti:polyfunc-pretty-print
  (lambda (polyfunc-name)
    (let ((candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name)))
      (and candidates
           (begin
             (print "Polymorphic options for ")
             (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print polyfunc-name))
             (println)
             (for-each (lambda (func-vector)
                         ;; perhaps this should (regex:split (vector-ref func-vector 0) "_poly_") to clean the generic ones up a bit?
                         (print "  ")
                         (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print (vector-ref func-vector 0)))
                         (print ":")
                         (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (impc:ir:pretty-print-type (vector-ref func-vector 1))))
                         (println))
                       candidates))))))

;; takes a polyname and a type, and returns the (first)
;; poly'd over function with that type
;; remap impc:ir:check-poly
(define impc:ti:get-polyfunc-candidate
  (lambda (polyfunc-name func-type)
    (let loop ((candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name)))
      (if (or (not candidates) (null? candidates))
          #f
          (if (equal? (vector-ref (car candidates) 1) func-type)
              (string->symbol (vector-ref (car candidates) 0))
              (loop (cdr candidates)))))))


(define impc:ti:remove-polyfunc-candidate
  (lambda (polyfunc-name func-type)
    (let* ((candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name))
          (n (assoc-strcmp polyfunc-name *impc:ti:polyfunc-cache*))
          (v (cdr n)))
      (vector-set! v 0 (cl:delete-if (lambda (x) (equal? (vector-ref x 1) func-type)) candidates))
      (set! candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name))
      (println 'Removed (string->symbol polyfunc-name))
      (if (= (length candidates) 1)
          (impc:ti:create-scheme-wrapper (vector-ref (car candidates) 0))))))

(define impc:ti:unique-polyfunc-candidate
  (lambda (polyfunc-name func-type)
    (let* ((candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name))
          (n (assoc-strcmp polyfunc-name *impc:ti:polyfunc-cache*))
          (v (cdr n)))
      (vector-set! v 0 (cl:delete-if-not (lambda (x) (equal? (vector-ref x 1) func-type)) candidates))
      (set! candidates (impc:ti:get-polyfunc-candidate-list polyfunc-name))
      (if (= (length candidates) 1)
          (begin (impc:ti:create-scheme-wrapper (vector-ref (car candidates) 0))
                 (println 'Success! (string->symbol polyfunc-name) 'is 'now 'monomorphic!))
          (impc:compiler:print-compiler-error (string-append "Could not make " polyfunc-name " monomorphic"))))))

(define-macro (remove-func name type)
  `(impc:ti:remove-polyfunc-candidate
    ,(symbol->string name)
    ',(impc:ir:pointer++ (impc:ir:get-type-from-pretty-str (impc:ir:get-base-type (symbol->string type))))))

(define-macro (unique-func name type)
  `(impc:ti:unique-polyfunc-candidate
    ,(symbol->string name)
    ',(impc:ir:pointer++ (impc:ir:get-type-from-pretty-str (impc:ir:get-base-type (symbol->string type))))))

(define-macro clear-session
  (lambda ()
    (set! *impc:ti:polyfunc-cache* '())))


;;;;;;;;;;;;;;;;;;;;
;; generic functions
;; -----------------
;;
;; most of this is either copy-pasted from the polyfunc cache, or just
;; copied from the old ad-hoc cache (with a few "API" functions
;; renamed)
;;
(define *impc:ti:genericfunc-cache* '())

(define *impc:ti:genericfunc-needs-update* '())

(define impc:ti:print-genericfunc-cache
  (lambda ()
    (println '----------------------)
    (map (lambda (x)
           (println ':> x))
         *impc:ti:genericfunc-cache*)))

(define impc:ti:reset-genericfunc-cache
  (lambda ()
    (set! *impc:ti:genericfunc-cache* '())))

(define impc:ti:genericfunc-src-changed
  (lambda (name arity)
    (if (string? name) (set! name (string->symbol name)))
    (let ((res (member (cons name arity) *impc:ti:genericfunc-needs-update*)))
      ;; (println 'name: name 'res: res)
      (if res #t #f))))

(define impc:ti:genericfunc-src-compiled
  (lambda (name arity)
    (if (string? name) (set! name (string->symbol name)))
    (set! *impc:ti:genericfunc-needs-update*
          (cl:remove-if (lambda (x) (equal? x (cons name arity))) *impc:ti:genericfunc-needs-update*))))

(define impc:ti:genericfunc-apply-macros
  (lambda (ast)
    (cond ((atom? ast) ast)
          ((and (list? ast)
                (symbol? (car ast))
                (impc:ti:xtmacro-exists? (symbol->string (car ast))))
           (macro-expand (cons (string->symbol
                                (string-append "xtmacro_"
                                               (symbol->string (car ast))))
                               (cdr ast))))
          ((pair? ast)
           (cons (impc:ti:genericfunc-apply-macros (car ast))
                 (impc:ti:genericfunc-apply-macros (cdr ast))))
          (else ast))))

(define *impc:ti:genericfunc-num-list* '())

(define impc:ti:register-new-genericfunc
  (lambda (code)
    (let ((type-constraint #f))
      ;; (println 'adding: code)
      (set! *impc:ti:generic-count* (+ *impc:ti:generic-count* 1))
      ;; (println 'addgpoly: code 'at: *impc:ti:generic-count*)
      ;; (println 'code-pre-macro: code)
      ;; apply any macros to generic code!
      (if (and (symbol? (caddr code))
               (equal? '-> (caddr code)))
          (set! type-constraint (cadddr code)))
      (set! code (cons (car code)
                       (list (cadr code)
                             (impc:ti:genericfunc-apply-macros (if type-constraint
                                                                   (car (cddddr code))
                                                                   (caddr code))))))
      (if (not (regex:match? (symbol->string (cadr code)) "(:|{)"))
          (impc:compiler:print-compiler-error "generic functions must supply type"))
      (let* ((res (impc:ti:split-namedfunc (cadr code))) ;;(regex:type-split (symbol->string (cadr code)) ":"))
             (name (string->symbol (car res)))
             (numl (assoc-strcmp (car res) *impc:ti:genericfunc-num-list*))
             ;; (num (if numl (cdr numl) *impc:ti:generic-count*))
             (num *impc:ti:generic-count*)
             ;; (ftype (string->symbol (cadr res))))
             (type (cadr res))
             (syms (cl:remove-duplicates (regex:match-all type "![a-zA-Z0-9_]*")))
             (newsyms (map (lambda (s)
                             ;; (println 's: s)
                             (if (regex:match? s "^!g")
                                 (let ((r (regex:split s "_")))
                                   (string-append (car r) "___" (number->string num)))
                                 (let ((r (string-append "!gx"
                                                         (substring s 1 (string-length s))
                                                         "_"
                                                         (number->string num))))
                                   r)))
                           ;; (string-append "!g"
                           ;;                (substring s 1 (string-length s))
                           ;;                "_"
                           ;;                (number->string num)))
                           syms))
             (newtype1 (regex:replace-everything type syms newsyms))
             (newtype (string->symbol (regex:replace-all newtype1 "___" "_")))
             (newtypematch (map (lambda (k) (if (regex:match? k "(:|{)")
                                           ;; (car (regex:type-split k ":"))
                                           (apply string-append (car (impc:ti:split-namedtype k))
                                                  (make-list (impc:ir:get-ptr-depth k) "*"))
                                           (if (regex:match? k "^\\!g")
                                               "_"
                                               (regex:replace-all k "\\!g[^,\\]\\>]*" "_"))))
                                (impc:ir:get-pretty-closure-arg-strings (symbol->string newtype))))
             (arity (- (length (impc:ir:get-pretty-closure-arg-strings (symbol->string newtype))) 1))
             (newcode (list 'bind-func
                            (string->symbol (string-append (symbol->string name)
                                                           ":"
                                                           (symbol->string newtype)))
                            (caddr code))))
        ;; (println 'newtype newtype 'newsyms newsyms 'newcode newcode 'newtypem newtypematch 'constraint type-constraint)
        (let ((v (cl:remove-if (lambda (x)
                                 (or
                                  (<> arity (cadr x))
                                  (not (string=? (symbol->string name) (symbol->string (car x))))
                                  (not (equal? type-constraint (car (cdr (cddddr x)))))
                                  (member #f
                                          (map (lambda (xx yy)
                                                 ;; (println 'for x 'xx: xx 'yy: yy (car (cddddr x)))
                                                 (let ((res (if (regex:match? xx "^\\!g")
                                                                (string=?
                                                                 (car (regex:type-split yy "_"))
                                                                 (car (regex:type-split xx "_")))
                                                                (string=?
                                                                 ;; (car (regex:type-split yy ":"))
                                                                 ;; (car (regex:type-split xx ":"))))))
                                                                 (car (impc:ti:split-namedtype yy))
                                                                 (car (impc:ti:split-namedtype xx))))))
                                                   ;; (println 'res: res)
                                                   res))
                                               (impc:ir:get-pretty-closure-arg-strings (symbol->string newtype))
                                               (impc:ir:get-pretty-closure-arg-strings (symbol->string (caddr x)))))))
                 *impc:ti:genericfunc-cache*)))
        (if (= num *impc:ti:generic-count*)
              (set! *impc:ti:genericfunc-num-list* (cons (cons (symbol->string name) *impc:ti:generic-count*) *impc:ti:genericfunc-num-list*)))
        ;; (set! *impc:ti:generic-count* (- *impc:ti:generic-count* 1)))
          ;; (if (not (null? v))
          ;;     (println 'updating: name 'with newtype 'and type-constraint 'for v)
          ;;     (println 'adding: name 'with newtype 'and type-constraint))
          (if (not (null? v))
              (set-cdr! (car v) (list arity newtype newcode newtypematch type-constraint))
              (set! *impc:ti:genericfunc-cache* (cons (list name arity newtype newcode newtypematch type-constraint) *impc:ti:genericfunc-cache*)))
          (set! *impc:ti:genericfunc-needs-update* (cons (cons name arity) *impc:ti:genericfunc-needs-update*))
          #t)))))

;; with an optional arity check
(define impc:ti:genericfunc-exists?
  (lambda (name . arity)
    (if (string? name) (set! name (string->symbol name)))
    (if (null? arity)
        (let ((res (assoc-strcmp name *impc:ti:genericfunc-cache*)))
          (if res #t #f))
        (let* ((res (assoc-strcmp-all name *impc:ti:genericfunc-cache*))
               (results (map (lambda (r) (cadr r)) res)))
          (if (and (not (null? results)) (member (car arity) results)) #t #f)))))

;; (define impc:ti:genericfunc-type-constraint
;;   (lambda (name . arity)
;;     (if (string? name) (set! name (string->symbol name)))
;;     (if (null? arity)
;;         (let ((res (assoc-strcmp name *impc:ti:genericfunc-cache*)))
;;           (if res (list-ref (cdr res) 4)  #f))
;;         (let* ((res (assoc-strcmp-all name *impc:ti:genericfunc-cache*))
;;                (results (map (lambda (r) (cadr r)) res)))
;;           (if (and (not (null? results)) (member (car arity) results))
;;               (list-ref (cdr (cl:find-if (lambda (x) (= (cadr x) (car arity))) res)) 4)
;;               #f)))))

(define impc:ir:genericfunc-stringify-generic-arg-strings
  (lambda (args)
    (string-join (map (lambda (a)
                        (if (null? a)
                            "_"
                            (let ((r (impc:ir:pptype a)))
                              (if (null? r)
                                  "_"
                                  r))))
                      args) ",")))

(define impc:ir:genericfunc-type-setup
  (lambda (type)
    ;; (println 'type: type)
    (if (null? type)
        '()
        (map (lambda (x)
               ;; (println 'x x)
               (cond ((string? x)
                      (let ((depth (impc:ir:get-ptr-depth x)))
                        ;; (println 'depth_a: x depth)
                        (if (string-contains? x "_poly_")
                            (apply string-append (cadr (regex:matched x "%(.*)_poly_.*")) (make-list depth "*"))
                            (apply string-append (cadr (regex:matched x "%([^-*]*)")) (make-list depth "*")))))
                     ((and (symbol? x)
                           (regex:match? (symbol->string x) "(:|{)")) ;; this is my last change here!!
                      (let ((depth (impc:ir:get-ptr-depth x)))
                        ;; (println 'depth_b: x depth)
                        (apply string-append (car (impc:ti:split-namedtype x)) (make-list depth "*"))))
                     ((impc:ir:closure? x)
                      (let* ((depth (+ -1 (impc:ir:get-ptr-depth x)))
                             (res (apply
                                   string-append "[" (impc:ir:genericfunc-stringify-generic-arg-strings (cdr x)) "]"
                                   (make-list depth "*"))))
                        res))
                     ((impc:ir:tuple? x)
                      (let* ((depth (+ 0 (impc:ir:get-ptr-depth x)))
                             (res (apply
                                   string-append "<" (impc:ir:genericfunc-stringify-generic-arg-strings (cdr x)) ">"
                                   (make-list depth "*"))))
                        res))
                     ((impc:ir:array? x)
                      (if (impc:ir:type? x)
                          (impc:ir:pretty-print-type x)
                          (if (and (list? (caddr x))
                                   (impc:ir:type? (car (caddr x))))
                              (impc:ir:pretty-print-type (list (car x) (cadr x) (car (caddr x))))
                              (impc:compiler:print-compiler-error "Bad array for gen type" x))))
                     ((impc:ir:vector? x)
                      (if (impc:ir:type? x)
                          (impc:ir:pretty-print-type x)
                          (if (and (list? (caddr x))
                                   (impc:ir:type? (car (caddr x))))
                              (impc:ir:pretty-print-type (list (car x) (cadr x) (car (caddr x))))
                              (impc:compiler:print-compiler-error "Bad vector for gen type" x))))
                     ((and (number? x)
                           (= x *impc:ir:notype*))
                      "notype")
                     ((impc:ir:type? x)
                      (impc:ir:pretty-print-type x))
                     ((and (list? x) ;; if we have mulitple VALID type
                           ;; options then just choose the first valid
                           ;; type 
                           (member #t (map (lambda (xx) (impc:ir:type? xx)) x)))
                      (impc:ir:pretty-print-type (car (cl:remove-if-not (lambda (xx) (impc:ir:type? xx)) x))))
                     (else "_")))
             (if (and (number? (car type))
                      (impc:ir:closure? type))
                 (cddr type)
                 type)))))

(define impc:ir:genericfunc-match-closure-types
  (lambda (a b)
    (let* ((t1 (if (or (string=? a "_")
                       (not (char=? (string-ref a 0) #\[)))
                   '()
                   (impc:ir:get-pretty-closure-arg-strings a)))
           (t2 (if (or (string=? b "_")
                       (not (char=? (string-ref b 0) #\[)))
                   '()
                   (impc:ir:get-pretty-closure-arg-strings b))))
      (if (<> (length t1) (length t2))
          -1
          (let ((weight (apply +
                               (map (lambda (x y)
                                      (cond ((string=? x "_") 0)
                                            ((string=? x y) 1)
                                            ((string=? y "_") 0)
                                            (else -1)))
                                    t1 t2))))
            ;;(println 'a a 'b b 'weight (/ weight (length t1)))
            (if (> weight 0) weight ;;(/ weight (length t1))
                (if (< weight 0) -1
                    1/4))))))) ;; give some slight weighting (more than 0) just for being a valid closure

(define impc:ir:genericfunc-match-tuple-types
  (lambda (a b)
    (let ((t1 (impc:ir:get-pretty-tuple-arg-strings a))
          (t2 (impc:ir:get-pretty-tuple-arg-strings b)))
      (if (<> (length t1) (length t2))
          -1
          (let ((weight (apply +
                               (map (lambda (x y)
                                      (cond ((string=? x "_") 0)
                                            ((string=? x y) 1)
                                            ((string=? y "_") 0)
                                            (else -1)))
                                    t1 t2))))
            (if (> weight 0) weight ;;(/ weight (length t1))
                (if (< weight 0) -1
                    1/4))))))) ;; give some slight weighting (more than 0) just for being a valid tuple

(define impc:ti:genericfunc-types
  (lambda (name arity type)
    ;; (println 'name name 'arity arity 'type type)
    (let ((arity_check_only (if (equal? type #f) #t #f))
          (failed_constraint_check #f))
      ;; (println 'poly: name 'a: arity 't: type)
      (if (symbol? name) (set! name (symbol->string name)))
      ;; (println 'type_a: type)
      (cond ((and type (list? type))
             (set! type (impc:ir:genericfunc-type-setup type))
             ;; if lgth(type) = arity then we only have args
             ;; and we should add a "_" return type
             (if (= (length type) arity)
                 (set! type (cons "_" type))))
            ((and type (string? type))
             (let ((ags (impc:ir:get-pretty-closure-arg-strings type)))
               (set! type (map (lambda (x)
                                 ;; (println 'x: x)
                                 (if (or (char=? (string-ref x 0) (integer->char 91))
                                         (char=? (string-ref x 0) (integer->char 60)))
                                     x
                                     (if (regex:match? x "(:|{)")
                                         (apply string-append (car (impc:ti:split-namedtype x))
                                                (make-list (impc:ir:get-ptr-depth x) "*"))
                                         (if (regex:match? x "^\\!")
                                             "_"
                                             x))))
                               ags))))
            (else (set! type (make-list (+ 1 arity) "_"))))
      ;; (println 'type_b: type)
      (let* ((tmp (assoc-strcmp-all (string->symbol name) *impc:ti:genericfunc-cache*))
             (res (cl:remove-if (lambda (x)
                                  (or
                                   (not (if (list-ref x 5)
                                            (apply (eval (list-ref x 5))
                                                   (map (lambda (x)
                                                          (if (string? x)
                                                              (if (string=? x "_")
                                                                  *impc:ir:notype*
                                                                  (impc:ir:get-type-from-pretty-str x))
                                                              *impc:ir:notype*
                                                              x))
                                                        type))
                                            #t))
                                   (<> arity (cadr x))))
                                tmp)))
        ;; (println 'res res 'tmp tmp)
        ;; if we are searching for 'notype' (i.e. haven't really
        ;; started looking yet) then we will just return the first
        ;; thing with the correct arity.
        (if (and (null? res)
                 (member #t (map (lambda (x) (and (string? x) (string=? x "_"))) type)))
            (let ((t2 (cl:remove-if (lambda (x) (<> arity (cadr x))) tmp)))
              (if (not (null? t2))
                  (set! res (list (car t2))))))

        ;; if the initial type request was #f (i.e. arity only check) then...
        ;; (if (and (null? res) arity_check_only) (set! res tmp))
        ;; (println 'res: (map (lambda (gp) (car (cddddr gp))) res))
        (if (null? res)
            #f
            (let* ((weights (map (lambda (gp)
                                   ;; (println 'gp: (car (cddddr gp)) 'type type)
                                   (cons (apply + (map (lambda (x y)
                                                         ;; (println x '=? y)
                                                         (cond ((string=? y "notype") 0)
                                                               ((string=? x "_") 0)
                                                               ((char=? (string-ref x 0) (integer->char 91))
                                                                (if (string=? y "_") 0
                                                                    (impc:ir:genericfunc-match-closure-types x y)))
                                                               ((char=? (string-ref x 0) (integer->char 60))
                                                                (if (string=? y "_") 0
                                                                    (impc:ir:genericfunc-match-tuple-types x y)))
                                                               ((string=? x y) 1)
                                                               ;; ((string=? y "_") 0)
                                                               (else -1)))
                                                       (car (cddddr gp))
                                                       type))
                                         gp))
                                 res))
                   (constraint_chks (map (lambda (gp)
                                           (let ((chk (cadr (cddddr gp))))
                                             (if (not (list? chk))
                                                 #t
                                                 (apply (eval chk)
                                                        (map (lambda (x)
                                                               (if (and (string? x)
                                                                        (string=? "_" x))
                                                                   *impc:ir:notype*
                                                                   x))
                                                             type)))))
                                         res))
                   (filtered_weights (foldl (lambda (lst x)
                                              (if (car x) (cons (cdr x) lst) lst))
                                            '()
                                            (map cons constraint_chks weights)))
                   (w (apply max (map (lambda (x) (car x)) (if (null? filtered_weights) weights filtered_weights)))))
              ;; (println '++++++++++++++ (length weights))
              ;; (println (for-each (lambda (k)
              ;;                      (println k))
              ;;                    weights))
              ;; (println 'best: w ': (length weights) '-> (assoc w weights))
              (if (> (length (assoc-strcmp-all w weights)) 1)
                  (impc:compiler:print-compiler-error (string-append "ambiguous generic overload " (symbol->string name) " -> " (symbol->string type))))
              (cdddr (assoc w weights))))))))

(define impc:ti:genericfunc-pretty-print
  (lambda (name)
    (if (string? name) (set! name (string->symbol name)))
    (let ((candidates (assoc-strcmp-all name *impc:ti:genericfunc-cache*)))
      (if (null? candidates)
          (begin
            (print "No generic specialisations found for ")
            (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print name))
            (println))
          (begin
            (print "Generic specialisations for ")
            (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print name))
            (println)
            (for-each (lambda (gf-list)
                        ;; perhaps this should (regex:split (vector-ref gf-list 0) "_poly_") to clean the generic ones up a bit?
                        (print "  ")
                        (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print (car gf-list)))
                        (print ":")
                        (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (caddr gf-list)))
                        (println))
                      candidates))))
    #t))

;;;;;;;;;;;;;;;;;;;;
;; polymorphic types
;; -----------------
;;
;; you don't create polymorphic types directly - you do it through
;; generic types
;;
;; (polytype-name . #((list #(func1 func1type) #(func2 func2type)) docstring))
;;
(define *impc:ti:polytype-cache*
  '())

(define impc:ti:print-polytype-cache
  (lambda ()
    (println '*impc:ti:polytype-cache*: *impc:ti:polytype-cache*)))

(define impc:ti:reset-polytype-cache
  (lambda ()
    (set! *impc:ti:polytype-cache* '())))

(define impc:ti:polytype-exists?
  (lambda (polytype-name)
    (if (assoc-strcmp polytype-name *impc:ti:polytype-cache*) #t #f)))

(define impc:ti:get-polytype-candidate-list
  (lambda (polytype-name)
    (let ((pfunc-data (assoc-strcmp polytype-name *impc:ti:polytype-cache*)))
      (if pfunc-data
          (vector-ref (cdr pfunc-data) 0)
          #f))))

;; only add the docstring first time around
;; remap impc:ir:add-polytype
(define impc:ti:register-new-polytype
  (lambda (polytype-name type-name type docstring)
    ;; (println 'newpolytype: polytype-name type-name type)
    ;; check arg types
    (if (not (and (or (string? polytype-name) (begin (println 'bad 'polytype-name: polytype-name) #f))
                  (or (string? type-name) (begin (println 'bad 'polytype-name: type-name) #f))
                  (or (list? type) (begin (println 'bad 'type: type) #f))
                  (or (string? docstring) (begin (println 'bad 'docstring: docstring)))))
        (impc:compiler:print-compiler-error "couldn't register new polymorphic type")
        (let ((candidates (assoc-strcmp polytype-name *impc:ti:polytype-cache*)))
          (if candidates
              (let ((res (cl:find-if (lambda (x) (string=? (vector-ref x 0) type-name))
                                     (vector-ref (cdr candidates) 0))))
                (if res
                    ;; if we're overriding an already poly'd type
                    (vector-set! res 1 type)
                    ;; if we're adding a new poly'd type
                    (vector-set! (cdr candidates) 0
                                 (cons (vector type-name type)
                                       (vector-ref (cdr candidates) 0)))))
              ;; or create a new entry
              (set! *impc:ti:polytype-cache*
                    (cons (cons polytype-name (vector (list (vector type-name type)) docstring))
                          *impc:ti:polytype-cache*)))
          (if (not (impc:ti:namedtype-exists? type-name))
              (impc:ti:register-new-namedtype type-name type docstring))))))

(define impc:ti:get-polytype-candidate-names
  (lambda (polytype-name)
    (let ((candidates (impc:ti:get-polytype-candidate-list polytype-name)))
      (and candidates
           (map (lambda (func-vector) (vector-ref func-vector 0)) candidates)))))

;; remap impc:ir:polytype-types - should return list types for all
;; options
(define impc:ti:get-polytype-candidate-types
  (lambda (polytype-name)
    (let ((candidates (impc:ti:get-polytype-candidate-list polytype-name)))
      (and candidates
           (map (lambda (func-vector) (vector-ref func-vector 1)) candidates)))))

(define impc:ti:get-polytype-candidate-pretty-types
  (lambda (polytype-name)
    (let ((types (impc:ti:get-polytype-candidate-types polytype-name)))
      (and types (map impc:ir:pretty-print-type types)))))

;; remap impc:ir:poly-print-all
(define impc:ti:polytype-pretty-print
  (lambda (polytype-name)
    (let ((candidates (impc:ti:get-polytype-candidate-list polytype-name)))
      (and candidates
           (begin
             (print "Polymorphic types for ")
             (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print polytype-name))
             (println)
             (for-each (lambda (func-vector)
                         ;; perhaps this should (regex:split (vector-ref func-vector 0) "_poly_") to clean the generic ones up a bit?
                         (print "  ")
                         (print-with-colors *impc:compiler:pretty-print-code-color* 'default #f (print (vector-ref func-vector 0)))
                         (print ": ")
                         (print-with-colors *impc:compiler:pretty-print-type-color* 'default #f (print (impc:ir:pretty-print-type (vector-ref func-vector 1))))
                         (println))
                       candidates))))))

;; takes a polyname and a type, and returns the name of the first
;; (first) namedtype with that type
;; remap impc:ir:check-polytype
(define impc:ti:get-polytype-candidate
  (lambda (polytype-name func-type)
    (let loop ((candidates (impc:ti:get-polytype-candidate-list polytype-name)))
      (if (or (not candidates) (null? candidates))
          #f
          (if (equal? (vector-ref (car candidates) 1) func-type)
              (string->symbol (vector-ref (car candidates) 0))
              (loop (cdr candidates)))))))

(define impc:ti:polytype-match?
  (lambda (t1 t2)
    (if (<> (length t1)
            (length t2))
        #f
        (if (member #f (map (lambda (t1 t2)
                              (if (atom? t1)
                                  (set! t1 (list t1)))
                              (if (atom? t2)
                                  (set! t2 (list t2)))
                              (if (null? (impc:ti:intersection* t1 t2))
                                  #f
                                  #t))
                            t1
                            t2))
            #f
            #t))))

;;;;;;;;;;;;;;;;
;; generic types
;; -------------
;;
;; most of this is either copy-pasted from the polytype cache, or just
;; copied from the old ad-hoc cache (with a few "API" functions
;; renamed)
;;
(define *impc:ti:generictype-cache* '())

(define *impc:ti:generictype-needs-update* '())

(define impc:ti:print-generictype-cache
  (lambda ()
    (println '*impc:ti:generictype-cache*: *impc:ti:generictype-cache*)))

(define impc:ti:reset-generictype-cache
  (lambda ()
    (set! *impc:ti:generictype-cache* '())))

(define impc:ti:generictype-exists?
  (lambda (name)
    (if (string? name) (set! name (string->symbol name)))
    (let ((res (assoc-strcmp name *impc:ti:generictype-cache*)))
      (if res #t #f))))

(define *impc:ti:generic-count* 0)

(define impc:ti:register-new-generictype
  (let ((cnt 0))
    (lambda (name type)
      (set! cnt 0)
      (set! *impc:ti:generic-count* (+ *impc:ti:generic-count* 1))
      ;; (println 'add-gpolytype: name 'at: *impc:ti:generic-count*)
      (if (symbol? type) (set! type (symbol->string type)))
      (let* ((syms (cl:remove-duplicates (regex:match-all type "![a-zA-Z0-9_]*")))
             (newsyms (map (lambda (s)
                             (if (regex:match? s "^!g")
                                 (let ((r (regex:split s "_")))
                                   (set! cnt (+ cnt 1))
                                   (string-append (car r) "x" (number->string cnt) "_" (number->string *impc:ti:generic-count*)))
                                 (let ((r (string-append "!g"
                                                         (substring s 1 (string-length s))
                                                         "_"
                                                         (number->string *impc:ti:generic-count*))))
                                   r)))
                           syms))
             (newtype (string->symbol (regex:replace-everything type syms newsyms)))
             (v (assoc-strcmp name *impc:ti:generictype-cache*)))
        ;; (println 'gtype-name: name 'type: type 'newtype: newtype 'v: v)
        (if v
            (set-cdr! v newtype)
            (set! *impc:ti:generictype-cache* (cons (cons name newtype) *impc:ti:generictype-cache*)))
        #t))))

(define impc:ti:get-generictype-candidate-types
  (lambda (name)
    (if (string? name) (set! name (string->symbol name)))
    (let ((res (assoc-strcmp name *impc:ti:generictype-cache*)))
      (if res
          (cdr res)
          #f))))

;; checks both named types and poly types
(define impc:ti:get-named-type
  (lambda (name)
    (or (impc:ti:get-generictype-candidate-types name)
        (impc:ti:get-polytype-candidate-types name)
        (let ((from-cache (impc:ti:get-namedtype-type name)))
          (and from-cache
               ;; because the old (pre-mcjit) version used
               ;; llvm:get-named-type, which returned the type in
               ;; LLVM IR format, we convert to this format
               (impc:ir:get-type-str from-cache))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; global variables (i.e. 'bind-val's)
;; -----------------------------------
;;
;; each element of the list is of the form
;;
;; (name . #(type docstring))
;;
(define *impc:ti:globalvar-cache*
  '())

(define impc:ti:print-globalvar-cache
  (lambda ()
    (println '*impc:ti:globalvar-cache*: *impc:ti:globalvar-cache*)))

(define impc:ti:reset-globalvar-cache
  (lambda ()
    (set! *impc:ti:globalvar-cache* '())))

;; type is immutable, doesn't need a setter
(define impc:ti:get-globalvar-type
  (lambda (globalvar-name)
    (let ((globalvar-data (assoc-strcmp globalvar-name *impc:ti:globalvar-cache*)))
      (if globalvar-data
          (vector-ref (cdr globalvar-data) 0)
          #f))))

(define impc:ti:globalvar-exists?
  (lambda (globalvar-name)
    (if (impc:ti:get-globalvar-type globalvar-name) #t #f)))

(define impc:ti:register-new-globalvar
  (lambda (globalvar-name type docstring)
    (if (impc:ti:globalvar-exists? globalvar-name)
        (impc:compiler:print-already-bound-error (string->symbol globalvar-name) (impc:ir:pretty-print-type (impc:ir:pointer-- (impc:ti:get-globalvar-type globalvar-name))))
        ;; check arg types
        (if (not (and (or (string? globalvar-name) (begin (println 'bad 'globalvar-name: globalvar-name) #f))
                      (or (list? type)
                          (integer? type)
                          (impc:ti:namedtype-exists? type)
                          (begin (println 'bad 'type: type) #f))
                      (or (string? docstring) (begin (println 'bad 'docstring: docstring) #f))))
            (impc:compiler:print-compiler-error "couldn't register new globalvar")
            (begin
              ;; add the bind-poly form to the AOT-header if we're precompiling
              (set! *impc:ti:globalvar-cache*
                    ;; the old llvm:get-global-variable-type returned
                    ;; an extra level of pointerness from the bind-val
                    ;; declaration (e.g. (bind-val mytype i64) would
                    ;; return type "i64*"), so we increment the
                    ;; "pointerlyness" by one level here to mimic this
                    ;; behaviour
                    (cons (cons globalvar-name (vector (impc:ir:pointer++ type) docstring))
                          *impc:ti:globalvar-cache*))
              (car *impc:ti:globalvar-cache*))))))

(define impc:ti:get-globalvar-docstring
  (lambda (globalvar-name)
    (let ((globalvar-data (assoc-strcmp globalvar-name *impc:ti:globalvar-cache*)))
      (if globalvar-data (vector-ref (cdr globalvar-data) 1) #f))))

(define impc:ti:set-globalvar-docstring
  (lambda (globalvar-name docstring)
    (let ((globalvar-data (assoc-strcmp globalvar-name *impc:ti:globalvar-cache*)))
      (if globalvar-data (vector-set! (cdr globalvar-data) 1 docstring) #f))))

;;;;;;;;;;;;;;;;;;;;;
;; AOT-compilation ;;
;;;;;;;;;;;;;;;;;;;;;

(define *impc:aot:current-output-port* #f)
(define *impc:aot:current-lib-name* "xtmdylib")
(define *impc:aot:win-link-libraries* '(".\\libs\\platform-shlibs\\extempore.lib"))
(define *impc:aot:func-defs-in-mod* '())
;; should be a cons pair e.g. '(libGLU .
;; "/System/Library/Frameworks/OpenGL.framework/OpenGL")
(define *impc:aot:current-load-dylib-info* #f)

(define impc:aot:add-win-link-library
  (lambda (libname)
    (if (not (string-contains? libname "opengl32"))
        (set! *impc:aot:win-link-libraries*
              (cons (regex:replace (sanitize-platform-path libname) "dll$" "lib")
                    *impc:aot:win-link-libraries*)))))

(define impc:aot:currently-compiling?
  (lambda ()
    (or (output-port? *impc:aot:current-output-port*)
        ;; this will be #t in a suppress-aot-do form
        *impc:aot:current-output-port*)))

;; helpers for putting the correct info into the aot-header file

(define impc:aot:insert-typealias-binding-details
  (lambda (name type docstring)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list
            'bind-alias
            (string->symbol name)
            (string->symbol (impc:ir:pretty-print-type type))
            docstring)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-xtmacro-binding-details
  (lambda (name-and-args docstring body)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list
            'bind-macro
            name-and-args
            docstring
            body)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-generic-func
  (lambda (expr)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          ;; (println 'inserting 'generic 'func: expr)
          (write expr *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-generic-type
  (lambda (expr)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          ;; (println 'inserting 'generic 'type: expr)
          (write expr *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-namedtype-binding-details
  (lambda (name type docstring)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list
            'bind-lib-type
            (string->symbol *impc:aot:current-lib-name*)
            (string->symbol name)
            (string->symbol (impc:ir:pretty-print-type type))
            docstring)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-closure-binding-details
  (lambda (name type zone-size docstring body)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list
            'bind-lib-func
            (string->symbol *impc:aot:current-lib-name*)
            (string->symbol name)
            (string->symbol (impc:ir:pretty-print-type type))
            zone-size
            docstring
            (list 'quote body))
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-nativefunc-binding-details
  (lambda (lib-name func-name type docstring)
    (if (and (output-port? *impc:aot:current-output-port*)
             ;; ignore the binding if we're just binding something
             ;; from an Extempore AOT-compiled library
             (not (and (>= (string-length (atom->string lib-name)) 3)
                       (string=? "xtm" (substring (atom->string lib-name) 0 3)))))
        (begin
          (write
           (list 'bind-lib lib-name func-name type)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-polyfunc-binding-details
  (lambda (poly-name func-name docstring)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list
            'bind-poly
            (string->symbol poly-name)
            (string->symbol func-name)
            docstring)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-globalvar-binding-details
  (lambda (library name type docstring)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list 'bind-lib-val
                 (string->symbol library)
                 (string->symbol name)
                 (string->symbol (impc:ir:pretty-print-type type))
                 docstring)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-ext-globalvar-binding-details
  (lambda (name type docstring)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list 'bind-ext-val
                 (string->symbol name)
                 (string->symbol (impc:ir:pretty-print-type type))
                 docstring)
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

(define impc:aot:insert-load-dylib-details
  (lambda (library lib-path)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (write
           (list 'bind-dylib library `(list ,@lib-path))
           *impc:aot:current-output-port*)
          (write
           `(if (not ',library)
                (begin
                  (print-with-colors '*impc:compiler:pretty-print-error-color* 'default #t (print "Error"))
                  (print ": could not load the " ',library
                         " dynamic library - perhaps you can install it through your package manager?\n")
                  (error "")))
           *impc:aot:current-output-port*)
          (newline *impc:aot:current-output-port*)))))

;; don't need specialised ones for these:

;; genericfunc
;; polytype
;; generictype

(define get-llvm-path
  (lambda ()
    (let ((path_from_env (sys:command-output (unix-or-Windows "echo $EXT_LLVM_DIR" "echo %EXT_LLVM_DIR%"))))
      (cond
       ((not (or (string=? path_from_env "") (string=? path_from_env "%EXT_LLVM_DIR%")))
        (sanitize-platform-path path_from_env))
       ((not (null? (sys:directory-list (string-append (sys:share-dir) "/llvm"))))
        (sanitize-platform-path (string-append (sys:share-dir) "/llvm")))
       (else
        (print-with-colors 'yellow 'default #t (print "Warning"))
        (print " could not find llvm path\n")
        #f)))))

;; insert arbitrary sexp into the AOT-compilation
;; file, otherwise do nothing
(define-macro (impc:aot:insert-forms . forms)
  (if (output-port? *impc:aot:current-output-port*)
      `(begin
         ,@(map (lambda (sexp)
                  `(begin (write ',sexp *impc:aot:current-output-port*)
                          (newline *impc:aot:current-output-port*)))
                forms))))

;; insert arbitrary sexp into the AOT-compilation
(define impc:aot:insert-sexpr
  (lambda (sexpr)
    (if (output-port? *impc:aot:current-output-port*)
        (begin (write sexpr *impc:aot:current-output-port*)
               (newline *impc:aot:current-output-port*)))))

(define-macro (impc:aot:do-and-emit . forms)
  `(begin
     ,@forms
     (impc:aot:insert-forms ,@forms)))

(define-macro (impc:aot:do-or-emit . forms)
  (if (not (output-port? *impc:aot:current-output-port*))
      `(begin ,@forms)
      `(impc:aot:insert-forms ,@forms)))

(define-macro (impc:aot:do-at-runtime . forms)
  `(impc:aot:do-or-emit
    (if (not (output-port? *impc:aot:current-output-port*))
        (begin ,@forms))))

(define-macro (impc:aot:suppress-aot-do . forms)
  `(if ,*impc:aot:current-output-port*
       (let ((aot-compilation-port *impc:aot:current-output-port*))
         (set! *impc:aot:current-output-port* #t)
         (begin ,@forms)
         ;; whatever happens, set the port back to the original value
         (set! *impc:aot:current-output-port* aot-compilation-port))
       (begin ,@forms)))

(define impc:aot:compile-module
  (lambda (module-name module)
    (let* ((llc-path (sanitize-platform-path (string-append (get-llvm-path) "/bin/llc"))))
      (let* ((platform (sys:platform))
             (tmp-dir (unix-or-Windows "/tmp/extempore/" (string-append (sys:command-output "echo %TEMP%") "\\extempore\\")))
             (bc-path (string-append tmp-dir module-name (unix-or-Windows ".bc" ".ll")))
             (asm-path (string-append tmp-dir module-name (unix-or-Windows ".o" ".obj"))) ; could skip .o (straight to .so)
             (output-dir (sanitize-platform-path (string-append (sys:share-dir) "/libs/aot-cache/")))
             (output-shlib-path (string-append output-dir module-name
                                               (cond ((string=? platform "Linux") ".so")
                                                     ((string=? platform "OSX") ".dylib")
                                                     ((string=? platform "Windows") ".dll"))))
             (link-libs (if (string=? platform "Windows")
                            *impc:aot:win-link-libraries*
                            '()))
             (optimize-compiles? #t)
             (llc-command
              (unix-or-Windows (string-append
                                llc-path
                                (if optimize-compiles? " -O3 -tailcallopt" "-O0")
                                " -relocation-model=pic "
                                " -filetype=obj "
                                (if (and (string=? (sys:platform) "OSX")
                                         (sys:cmdarg "mcpu")
                                         (not (string=? (sys:cmdarg "mcpu") "")))
                                    (string-append "-mcpu="
                                                   (sys:cmdarg "mcpu")
                                                   " ")
                                    "")
                                bc-path " -o " asm-path)
                               (string-append
                                llc-path
                                (if optimize-compiles? " -O3 -tailcallopt" "-O0")
                                " -filetype=obj -mtriple=x86_64-pc-win32 "
                                bc-path)))
             (link-command
              (unix-or-Windows (string-append
                                (cond ((string=? platform "Linux")
                                       (string-append "gcc "
                                                      (if optimize-compiles? "-O3 -g" "-g -O0")
                                                      " --shared -fPIC "))
                                      ((string=? platform "OSX")
                                       (string-append "clang "
                                                      (if optimize-compiles? "-O3" "-g -O0")
                                                      " -dynamiclib -undefined dynamic_lookup ")))
                                asm-path
                                " -o " output-shlib-path)
                               (string-append
                                "call link"
                                ;; (sanitize-platform-path (sys:share-dir))
                                ;; " /FORCE:UNRESOLVED "
                                " /MACHINE:x64 /DLL"
                                " /OUT:" output-shlib-path
                                " " (string-join link-libs " ")
                                ;; (string-append tmp-dir module-name ".lib ")
                                " msvcrt.lib legacy_stdio_definitions.lib "
                                asm-path))))
        (print "Using llc " llc-path "...\n\n")
        (begin
          (print-with-colors 'black 'yellow #t (print " Exporting module "))
          (print "\n  " bc-path "\n\n"))
        ;; make sure tmp-dir exists
        (sys:command (string-append (unix-or-Windows "mkdir " "md ") tmp-dir))
        ;; (sys:command (string-append "rm " bc-path " " asm-path " " output-shlib-path))
        (llvm:export-module module bc-path)
        (let ((llc-res 0)
              (linker-res 0))
          (begin
            (print-with-colors 'black 'yellow #t (print " Generating assembly from LLVM bitcode "))
            (print "\n  " llc-command "\n\n"))
          (set! llc-res (sys:command llc-command))
          (if (<> llc-res 0)
              (begin (print-with-colors 'red 'default #t
                                        (print "llc command failed with exit code " llc-res "\n"))
                     (quit 1)))
          (begin
            (print-with-colors 'black 'yellow #t (print " Compiling native shared library "))
            (print "\n  " link-command "\n\n"))
          (set! linker-res (sys:command link-command))
          (if (<> linker-res 0)
              (begin (print-with-colors 'red 'default #t
                                        (print "linking failed with exit code " linker-res "\n"))
                     (quit 1))
              (begin
                (print-with-colors 'black 'green #t (print " Succesfully compiled "))
                (print "\n  " output-shlib-path "\n\n"))))))))

(define impc:aot:insert-header
  (lambda (libname)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (display (string-append "(sys:load-preload-check '" (substring libname 3) ")\n")
                   *impc:aot:current-output-port*)
          (display (string-append "(define *xtmlib-" (substring libname 3) "-loaded* (now))\n")
                   *impc:aot:current-output-port*)
          (display "(set! *impc:aot:prev-compiler-message-level* *impc:compiler:message:level*)\n(set! *impc:compiler:message:level* 'low)\n"
                   *impc:aot:current-output-port*)
          (display (string-append "(bind-dylib " libname " \"" libname
                                  (cond ((string=? (sys:platform) "Linux") ".so\")\n")
                                        ((string=? (sys:platform) "Windows") ".dll\")\n")
                                        ((string=? (sys:platform) "OSX") ".dylib\")\n")))
                   *impc:aot:current-output-port*)
          (write
           `(if (not ,(string->symbol libname))
                (begin
                  (print-with-colors '*impc:compiler:pretty-print-error-color* 'default #t (print "Error"))
                  (print ": could not load the AOT-compilied " ,libname
                         " dynamic library\n")
                  (error "")))
           *impc:aot:current-output-port*)
          (display (string-append "(print \"Loading \")\n(print-with-colors 'blue 'default #t (print '"
                                  libname "))\n(print \" library... \")\n")
                   *impc:aot:current-output-port*)
          (display (string-append ";; flush the JIT-compilation queue, so we only get this file's code in the module\n"
                                  "(impc:compiler:flush-jit-compilation-queue)\n")
                   *impc:aot:current-output-port*)))))

(define impc:aot:insert-footer
  (lambda (libname)
    (if (output-port? *impc:aot:current-output-port*)
        (begin
          (display (string-append "(print-with-colors 'green 'default #t (print \"done\"))")
                   *impc:aot:current-output-port*)
          (display (string-append "(print \" in\" (* 1.0 (/ (- (now) *xtmlib-" (substring libname 3) "-loaded*) *second*)) \"seconds\\n\")\n")
                   *impc:aot:current-output-port*)
          (display (string-append "(define *xtmlib-" (substring libname 3) "-loaded* (now))\n")
                   *impc:aot:current-output-port*)
          (display "(set! *impc:compiler:message:level* *impc:aot:prev-compiler-message-level*)\n"
                   *impc:aot:current-output-port*)))))

(define impc:aot:print-compilation-details
  (lambda (start-time)
    (print-with-colors 'yellow 'default #t
                       (print "Total compile time: "))
    (print (* 1.0 (/ (- (now) start-time) *minute*)) "minutes\n\n")
    (print-with-colors 'black 'blue #t (print " Types "))
    (print "\n  " (length *impc:ti:typealias-cache*))
    (print-with-colors 'cyan 'default #f (print " type aliases\n"))
    (print "  " (length *impc:ti:generictype-cache*))
    (print-with-colors 'cyan 'default #f (print " named types\n"))
    (print "  " (length *impc:ti:namedtype-cache*))
    (print-with-colors 'cyan 'default #f (print " generic\n"))
    (print "  " (length *impc:ti:polytype-cache*))
    (print-with-colors 'cyan 'default #f (print " specializations\n\n"))

    (print-with-colors 'black 'blue #t (print " Closures "))
    (print "\n  " (length *impc:ti:closure-cache*))
    (print-with-colors 'cyan 'default #f (print " top-level closures\n"))
    (print "  " (length *impc:ti:genericfunc-cache*))
    (print-with-colors 'cyan 'default #f (print " generics\n"))
    (print "  " (length *impc:ti:polyfunc-cache*))
    (print-with-colors 'cyan 'default #f (print " specializations\n\n"))))

(define-macro (unix-or-Windows unix-expr win-expr)
  (if (string=? (sys:platform) "Windows")
      win-expr unix-expr))

(define Windows-convert-unix-path
  (lambda (unix-path)
    (regex:replace-all unix-path  "/" "\\")))

(define sanitize-platform-path
  (lambda (path)
    (if (string=? (sys:platform) "Windows")
        (Windows-convert-unix-path path)
        path)))

(define Windows-add-libdir-to-PATH
  (lambda ()
    (let ((path (sys:command-output "echo %PATH%")))
      (if (not (string-contains? path "libs/platform-shlibs"))
          (sys:set-env "PATH" (string-append path ";" (sys:share-dir) "/libs/platform-shlibs"))))))

;; do it!
(if (string=? (sys:platform) "Windows")
    (Windows-add-libdir-to-PATH))

(define impc:aot:compile-xtm-file
  (lambda (lib-path)
    (let ((start-time (now))
          (in-file-port (or
                         (open-input-file (sanitize-platform-path lib-path))
                         (open-input-file (sanitize-platform-path (string-append (sys:share-dir) "/" lib-path))))))
      (if (not in-file-port)
          (begin (print-with-colors 'black 'red #t
                                    (print "Error:"))
                 (print " no .xtm file at" (sanitize-platform-path lib-path) "\n"))
          (let* ((res (close-port in-file-port))
                 (libname (sanitize-platform-path (filename-from-path lib-path)))
                 (libname-no-extension (string-append "xtm" (filename-strip-extension libname)))
                 (output-dir (sanitize-platform-path (string-append (sys:share-dir) "/libs/aot-cache")))
                 (aot-compilation-file-path (sanitize-platform-path (string-append output-dir "/" libname))))
            (if (not (sys:load-preload-check (string->symbol libname-no-extension)))
                (begin (print "AOT-compilation file not written ")
                       (close-port *impc:aot:current-output-port*)
                       (set! *impc:aot:current-output-port* #f))
                (begin
                  ;; if the preload check passes, create aot-cache dir
                  ;; if it doesn't exist
                  (sys:command (string-append (unix-or-Windows "mkdir " "md ") output-dir))
                  ;; remove old AOT file if present
                  (if (file-exists? aot-compilation-file-path)
                      (sys:command (string-append (unix-or-Windows "rm " "DEL ") aot-compilation-file-path)))
                  ;; open output file, ready for writing
                  (set! *impc:aot:current-output-port* (open-output-file aot-compilation-file-path))
                  (set! *impc:aot:func-defs-in-mod* '())
                  (if (impc:aot:currently-compiling?)
                      (begin
                        (llvm:optimize #t); // should this be restored later?
                        ;; this is the 'success' branch
                        (set! *impc:aot:current-lib-name* libname-no-extension)
                        ;; (impc:aot:insert-header libname-no-extension)
                        (print-with-colors 'cyan 'black #t (print "Started compiling: "))
                        (println lib-path)
                        (println)
                        (sys:load lib-path)
                        (println)
                        (print-with-colors 'cyan 'black #t (print "Finished compiling: "))
                        (println lib-path)
                        (println)
                        (begin
                          (println)
                          (print-with-colors 'black 'yellow #t (print " JIT-compiling IR "))
                          (print "\n"))
                        (let ((module (impc:compiler:flush-jit-compilation-queue)))
                          (if (not module)
                              (impc:compiler:print-compiler-error "Failed compiling LLVM IR"))
                          (impc:aot:compile-module libname-no-extension module))
                        ;; (impc:aot:insert-footer libname-no-extension)
                        (close-port *impc:aot:current-output-port*)
                        (set! *impc:aot:current-lib-name* "xtmdylib")
                        (if  *impc:aot:current-output-port*
                             (begin (set! *impc:aot:current-output-port* #f)
                                    (print "Successfully wrote AOT-compilation file to ")
                                    (print-with-colors 'green 'default #f (print aot-compilation-file-path "\n\n"))
                                    (impc:aot:print-compilation-details start-time)
                                    (quit 0))
                             (begin (print-with-colors 'black 'red #t (print " Error "))
                                    (print "\n\nsomething went wrong in writing the output file ")
                                    (print-with-colors 'red 'faultde #t (print aot-compilation-file-path "\n"))
                                    (quit 1))))
                      (begin (print-with-colors 'black 'red #t
                                                (print " Error "))
                             (print "\n\ncannot write AOT-compilation file at " aot-compilation-file-path "\n")
                             (quit 2))))))))))


(define icr:new-zone
  (lambda args
    (if (null? args)
        (sys:create-mzone *impc:default-zone-size*)
        (sys:create-mzone (car args)))))

(define icr:destroy-zone
  (lambda (zone)
    (if (equal? *impc:zone* zone)
        (set! *impc:zone* (sys:default-mzone)))
    (if (equal? zone (sys:default-mzone))
        (print-notification "You are not allowed to destroy the default zone")
        (sys:destrop-mzone zone))))

(define icr:set-zone
  (lambda (zone)
    (set! *impc:zone* zone)))

(define icr:set-zone-default
  (lambda ()
    (set! *impc:zone* (sys:default-mzone))))

;; regex:type-split pair is like regex split
;; but only splits on 'first' occurence
(define regex:type-split
  (lambda (str char)
    (let ((p (regex:split str char)))
      (if (and (> (length p) 1)
               (> (length (cdr p)) 1))
          (list (car p) (apply string-append (cadr p)
                               (map (lambda (k) (string-append char k)) (cddr p))))
          p))))

(define impc:ti:split-namedfunc
  (lambda (str)
    (if (symbol? str) (set! str (symbol->string str)))
    (regex:type-split str ":")))

(define impc:ti:split-namedtype
  (lambda (str)
    (if (symbol? str) (set! str (symbol->string str)))
    (if (regex:match? str "^[A-Za-z0-9_]*{")
        (let* ((p (regex:type-split str "{"))
               (ptrd (impc:ir:get-ptr-depth (cadr p)))
               (base (impc:ir:get-base-type (cadr p))))
          (list (car p) (apply string-append "<" (substring base 0 (- (string-length base) 1)) ">"
                               (make-list ptrd "*"))))
        (if (regex:match? str "^[A-Za-z0-9_]*:")
            (regex:type-split str ":")
            (regex:type-split str "\\*")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strips pretty-types from source code
;; returns a cons of (the-new-ast any-explicit-types)
;;
(define impc:ti:get-var-types
  (lambda (ast)
    (let* ((types '())
           (f (lambda (ast)
                ;;(print 'ast: ast 'types: types)
                (cond ((null? ast) '())
                      ((atom? ast) ast)
                      ((member (car ast) *impc:lambdaslist*)
                       (list* (car ast) ;; 'lambda
                              (map (lambda (a)
                                     (if (and (list? a)
                                              (eq? (car a) '*colon-hook*))
                                         (impc:compiler:print-double-colon-error (caddr a)))
                                     (if (string-contains? (symbol->string a) ":")
                                         (let ((t (regex:type-split (symbol->string a) ":")))
                                           (if (regex:match? (cadr t) "^\\<|\\[")
                                               (if (not (regex:match? (cadr t) "\\>|\\]"))
                                                   (impc:compiler:print-bad-type-error (cadr t))))
                                           (set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
                                           (string->symbol (car t)))
                                         a))
                                   (cadr ast))
                              (f (cddr ast))))
                      ((member (car ast) *impc:letslist*)
                       (list* (car ast)
                              (map (lambda (a)
                                     (if (or (atom? a)
                                             (null? (cdr a))
                                             (list? (car a))
                                             (> (length (cdr a)) 1))
                                         (impc:compiler:print-badly-formed-expression-error 'let a))
                                     (if (and (list? (car a))
                                              (eq? (car (car a)) '*colon-hook*))
                                         (impc:compiler:print-double-colon-error (caddr (car a))))
                                     (if (string-contains? (symbol->string (car a)) ":")
                                         (let ((t (regex:type-split (symbol->string (car a)) ":")))
                                           (if (regex:match? (cadr t) "^\\<|\\[")
                                               (if (not (regex:match? (cadr t) "\\>|\\]"))
                                                   (impc:compiler:print-bad-type-error (cadr t))))
                                           (set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
                                           (list (string->symbol (car t)) (car (f (cdr a)))))
                                         (list (car a) (car (f (cdr a))))))
                                   (cadr ast))
                              (f (cddr ast))))
                      ((pair? ast)
                       (cons (f (car ast))
                             (f (cdr ast))))))))
      (cons (f ast) types))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; expand types
;;
;; takes and {...} types and should fully expand
;; types must be generic
;;

(define impc:ti:expand-generic-type-func-gpoly-arity
  (lambda (name xvararity)
    (let* ((all-gpolys (cl:remove-if-not (lambda (x) (equal? (car x) name)) *impc:ti:genericfunc-cache*))
           (all-gtypes (map (lambda (x) (caddr x)) all-gpolys))
           (all-type-arity (map (lambda (x) (length
                                             (cl:remove-duplicates
                                              (regex:match-all (symbol->string x)
                                                               "(![A-Za-z0-9_]*)"))))
                                all-gtypes))
           (res (cl:remove #f (map (lambda (x y) (if (= x xvararity) y #f)) all-type-arity all-gtypes))))
      (if (<> (length res) 1)
          (impc:compiler:print-expansion-arity-error name (string->symbol (string-append "no_valid_arity_for_" (atom->string xvararity) "_gvar")))
          res))))


(define impc:ti:expand-generic-type
  (lambda (t)
    (let* ((t2 (symbol->string t))
           (p (regex:type-split t2 ":"))
           (name (car p)))
      (if (or (null? (cdr p))
              (not (char=? #\$ (string-ref (cadr p) 0))))
          t
          (let* ((func? (char=? #\[ (string-ref (cadr p) 1)))
                 (xtype (substring (cadr p) 1 (string-length (cadr p))))
                 (ptrdepth (impc:ir:get-ptr-depth xtype))
                 (base (impc:ir:get-base-type xtype))
                 (xvars (if func?
                            (impc:ir:get-pretty-closure-arg-strings base)
                            (impc:ir:get-pretty-tuple-arg-strings base)))
                 (gtt (if func?
                          (impc:ti:expand-generic-type-func-gpoly-arity (string->symbol name) (length xvars))
                          (assoc-strcmp (string->symbol name) *impc:ti:generictype-cache*)))
                 (gtype (if gtt
                            (symbol->string (if func? (car gtt) (cdr gtt)))
                            (impc:compiler:print-cannot-expand-non-generic-error name)))
                 (_gvars (regex:match-all gtype "(![A-Za-z0-9_]*)"))
                 (gvars (cl:remove-duplicates _gvars)))
            (if (<> (length gvars) (length xvars))
                (impc:compiler:print-expansion-arity-error (cdr t) (string->symbol (string-append (car p) ":" gtype))))
            (for-each (lambda (x y)
                        (set! gtype (regex:replace-all gtype x y)))
                      gvars xvars)
            (if func?
                (string->symbol (impc:ir:pointer++ (string-append (car p) "_poly_" (cname-encode gtype)) (- ptrdepth 1)))
                (string->symbol (impc:ir:pointer++ (string-append (car p) ":" gtype) ptrdepth))))))))


(define impc:ti:expand-generic-types
  (lambda (types)
    (map (lambda (t)
           (cons (car t) (impc:ti:expand-generic-type (cdr t)))) types)))

(define impc:ti:simplify-genericfunc-pretty-type
  (lambda (pretty-type)
    (string-append
     "["
     (string-join
      (map (lambda (x)
             (if (string-contains? x ":")
                 (impc:ir:pointer++ (car (regex:type-split x ":"))
                                    (impc:ir:get-ptr-depth x))
                 x))
           (impc:ir:get-pretty-closure-arg-strings pretty-type))
      ",")
     "]*")))

(define impc:ti:simplify-generictype-pretty-type
  (lambda (pretty-type)
    (string-append
     "<"
     (string-join
      (map (lambda (x)
             (if (string-contains? x ":")
                 (impc:ir:pointer++ (car (regex:type-split x ":"))
                                    (impc:ir:get-ptr-depth x))
                 x))
           (impc:ir:get-pretty-tuple-arg-strings pretty-type))
      ",")
     ">")))

;; this currently doesn't work for multiple "replace" instances
;; (define impc:ti:get-initial-generic-pretty-type
;;   (lambda (pretty-type)
;;     (regex:replace-all pretty-type "!g([a-zA-Z_]+)_[0-9]+" "!$1")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Rename any shadow variables in code
;;
;; return new 'renamed' ast
;;

(define impc:ti:gen-shadow
  (let ((n 0))
    (lambda (x)
      (set! n (+ n 1))
      (string->symbol (string-append (symbol->string x) "_s_" (number->string n))))))

(define *impc:letslist* '(let let* letrec))

;; this code expects that all pretty types
;; have already been removed from the ast!
(define impc:ti:rename-all-shadow-vars
  (lambda (symname full-ast syms)
    (letrec ((f (lambda (ast fname)
                  (cond ((atom? ast) ast)
                        ((null? ast) ast)
                        ((list? ast)
                         (cond ((member (car ast) *impc:letslist*)
                                ;; first find and replace all shadow vars
                                (let* ((replace-pairs
                                        (cl:remove
                                         #f
                                         (flatten
                                          (map (lambda (x)
                                                 (let* ((pair (regex:type-split (symbol->string (car x)) ":"))
                                                        (sym (string->symbol (car pair))))
                                                   (if (and (not (equal? sym symname))
                                                            (or (member sym syms)
                                                                (impc:ti:namedtype-exists? (symbol->string sym))
                                                                (impc:ti:genericfunc-exists? sym)
                                                                (impc:ti:xtmacro-exists? (symbol->string sym))
                                                                (impc:ti:polyfunc-exists? (symbol->string sym))
                                                                (and (not (equal? sym fname))
                                                                     (impc:ti:closure-exists? (symbol->string sym)))
                                                                (impc:ti:globalvar-exists? (symbol->string sym))))
                                                       (let ((shadow (impc:ti:gen-shadow sym)))
                                                         (set! syms (cons shadow syms))
                                                         (if (null? (cdr pair))
                                                             (cons sym shadow)
                                                             (list (cons sym shadow)
                                                                   (cons (car x)
                                                                         (string->symbol
                                                                          (string-append
                                                                           (symbol->string shadow) ":" (cadr pair)))))))
                                                       (begin
                                                         (set! syms (cons sym syms))
                                                         #f))))
                                               (cadr ast)))))
                                       (newast (replace-all ast replace-pairs)))
                                  ;; now make sure we have code coverage!
                                  (cons (car newast)
                                        (cons (map (lambda (x) (cons (car x) (f (cdr x) fname))) (cadr newast))
                                              (f (cddr newast) fname)))))
                               ((member (car ast) *impc:lambdaslist*)
                                (let* ((replace-pairs
                                        (cl:remove
                                         #f
                                         (flatten
                                          (map (lambda (x)
                                                 (let* ((pair (regex:type-split (symbol->string x) ":"))
                                                        (sym (string->symbol (car pair))))
                                                   (if (or (member sym syms)
                                                           (impc:ti:namedtype-exists? (symbol->string sym))
                                                           (impc:ti:genericfunc-exists? sym)
                                                           (impc:ti:xtmacro-exists? (symbol->string sym))
                                                           (impc:ti:polyfunc-exists? (symbol->string sym))
                                                           (and (not (equal? sym fname))
                                                                (impc:ti:closure-exists? (symbol->string sym)))
                                                           (impc:ti:globalvar-exists? (symbol->string sym)))
                                                       (let ((shadow (impc:ti:gen-shadow sym)))
                                                         (set! syms (cons shadow syms))
                                                         (if (null? (cdr pair))
                                                             (cons x shadow)
                                                             (list (cons sym shadow)
                                                                   (cons x
                                                                         (string->symbol
                                                                          (string-append
                                                                           (symbol->string shadow) ":" (cadr pair)))))))
                                                       (begin
                                                         (set! syms (cons sym syms))
                                                         #f))))
                                               (cadr ast)))))
                                       (newast (replace-all ast replace-pairs)))
                                  (cons (car ast)
                                        (cons (cadr newast)
                                              (f (cddr newast) fname)))))
                               ((pair? ast)
                                (cons (f (car ast) fname)
                                      (f (cdr ast) fname)))
                               (else ast)))))))
      (if (equal? (car full-ast) 'let)
          (f full-ast (caaadr full-ast))
          (f full-ast '___no_sym___)))))



;;
;; TRANSFORM CODE
;;
;; Transform straight R5RS code into
;; a simpler but still valid R5RS scheme code
;;

(define impc:ti:and
  (lambda (ast)
    (if (pair? ast)
        (list 'if (car ast)
              (if (null? (cdr ast))
                  (car ast)
                  (impc:ti:and (cdr ast)))
              #f))))

(define impc:ti:or
  (lambda (ast)
    (if (pair? ast)
        (list 'if (car ast)
              (car ast)
              (if (null? (cdr ast))
                  #f
                  (impc:ti:or (cdr ast)))))))

(define impc:ti:cond
  (lambda (ast)
    (if (null? ast) '()
	      (list 'if (caar ast)
              (if (null? (cdar ast))
                  '()
                  (apply list 'begin (cdar ast)))
              (impc:ti:cond (cdr ast))))))

(define impc:ti:cond
  (lambda (ast)
    (cl:remove '()
               (if (null? ast) '()
                   (list 'if (caar ast)
                         (if (null? (cdar ast))
                             (impc:compiler:print-badly-formed-expression-error 'cond ast)
                             (apply list 'begin (cdar ast)))
                         (if (and
                              (not (null? (cdr ast)))
                              (eq? (caadr ast) 'else))
                             (apply list 'begin (cdadr ast))
                             (if (not (null? (cdr ast)))
                                 (impc:ti:cond (cdr ast)))))))))


(define impc:ti:list
  (lambda (ast)
    (if (null? ast) 'null
        (list 'cons
              (car ast)
              (impc:ti:list (cdr ast))))))


(define impc:ti:println
  (lambda (ast)
    (if (null? ast)
        `(print_return)
        `(begin
           ,(if (string? (car ast))
                (list 'printf "%s" (car ast))
                (list 'print (car ast)))
           ,@(flatten-1 (map (lambda (x)
                               (if (string? x)
                                   (list
                                    (list 'print_space)
                                    (list 'printf "%s" x))
                                   (list
                                    (list 'print_space)
                                    (list 'print x))))
                             (cdr ast)))
           (print_return)))))

(define impc:ti:println2
  (lambda (ast)
    (if (null? ast)
        `(print_return)
        `(begin
           ,(if (string? (car ast))
                (list 'printf "%s" (car ast))
                (list 'print (car ast)))
           ,@(flatten-1 (map (lambda (x)
                               (if (string? x)
                                   (list
                                    ;; (list 'print_space)
                                    (list 'printf "%s" x))
                                   (list
                                    ;; (list 'print_space)
                                    (list 'print x))))
                             (cdr ast)))
           void))))

(define impc:ti:sprintln
  (lambda (ast)
    (if (null? ast)
        (String "")
        `(memzone 1024
           (cat
            ,(if (string? (car ast))
                 `(let ((x_t_mst:i8* (salloc 1024)))
                    (sprintf x_t_mst "%s" ,(car ast))
                    (String x_t_mst))
                 (list 'toString (car ast)))
            ,@(flatten-1 (map (lambda (x)
                                (if (string? x)
                                    (list `(let ((x_t_mst:i8* (salloc 1024)))
                                             (sprintf x_t_mst " %s" ,x)
                                             (String x_t_mst)))
                                    (list
                                     (list 'toString_space)
                                     (list 'toString x))))
                              (cdr ast))))))))


(define impc:ti:sprintln2
  (lambda (ast)
    (if (null? ast)
        (String "")
        `(memzone 1024
           (cat
            ,@(map (lambda (x)
                     (if (string? x)
                         `(let ((xx_t_mst:i8* (salloc 1024)))
                            (sprintf xx_t_mst "%s" ,x)
                            (String xx_t_mst))
                         (list 'toString x)))
                   ast))))))


(define impc:ti:format
  (lambda (ast)
    (if (null? ast) 'null
        (list 'cat
              (if (string? (car ast))
                  (list 'Str (car ast))
                  (list 'format (car ast)))
              (impc:ti:format (cdr ast))))))


(define impc:ti:not
  (lambda (ast)
    (list 'if ast #f #t)))

(define impc:ti:quote
  (lambda (ast)
    (cond ((null? ast) '(impc_null)) ;(list))
          ((symbol? ast)
           (let ((str (symbol->string ast)))
             (if (char=? #\' (car (reverse (string->list str))))
                 `(String ,(substring str 0 (- (string-length str) 1)))
                 `(Symbol ,str))))
          ((list? ast)
           (cons 'list (map (lambda (a)
                              (if (or (eq? 'NIL a)
                                      (null? a))
                                  '(list)
                                  a))
                            ast)))
          (else ast))))


(define *anonlambdanum* 0)

;; no anonymous lambdas !!!
(define impc:ti:lambda
  (lambda (ast)
    (set! *anonlambdanum* (+ 1 *anonlambdanum*))
    (let* ((fname (string->symbol (string-append "_anon_lambda_" (number->string *anonlambdanum*))))
           (rest (cons (impc:ti:first-transform (cadr ast) #t)
                       (list (cons 'begin (impc:ti:first-transform (cddr ast) #t)))))
           ;;(expr (cons 'lambda rest)))
           (expr (cons (car ast) rest)))
      `(let ((,fname ,expr))
         (begin ,fname)))))


;; replace (* 2 3 4 5) or (+ 2 3 4 5)
;; with (* 2 (* 3 (* 4 5))) etc..
(define impc:ti:binary-arity
  (lambda (ast inbody?)
    (let ((op (car ast))
          (inlst (reverse (cdr ast))))
      (let loop ((rest (cdr inlst))
                 (lst (car inlst)))
        (if (null? rest) lst
            (loop (cdr rest) (cons op (cons (impc:ti:first-transform (car rest) inbody?) (list lst)))))))))


(define impc:ti:binary-arity
  (lambda (ast inbody?)
    (let ((op (car ast))
          (inlst (cdr ast)))
      (if (< (length inlst) 2)
          (impc:compiler:print-bad-arity-error ast))
      (let loop ((rest (cddr inlst))
                 (lst (list op
                            (impc:ti:first-transform (car inlst) inbody?)
                            (impc:ti:first-transform (cadr inlst) inbody?))))
        (if (null? rest) lst
            (loop (cdr rest) (list op lst (impc:ti:first-transform (car rest) inbody?))))))))


(define impc:ti:bitwise-not-to-eor
  (lambda (ast inbody?)
    (list 'bitwise-eor (cadr ast) -1)))


(define impc:ti:afill!
  (lambda (ast)
    (append '(begin)
            (map (lambda (arg idx)
                   (list 'aset! (car ast) idx arg))
                 (cdr ast)
                 (make-list-with-proc (length ast) (lambda (i) i))))))


(define impc:ti:pfill!
  (lambda (ast)
    (append '(begin)
            (map (lambda (arg idx)
                   (list 'pset! (car ast) idx arg))
                 (cdr ast)
                 (make-list-with-proc (length ast) (lambda (i) i))))))


(define impc:ti:tfill!
  (lambda (ast)
    (append '(begin)
            (map (lambda (arg idx)
                   (list 'tset! (car ast) idx arg))
                 (cdr ast)
                 (make-list-with-proc (length ast) (lambda (i) i))))))

(define impc:ti:vfill!
  (lambda (ast)
    (append '(begin)
            (map (lambda (arg idx)
                   (list 'vset! (car ast) idx arg))
                 (cdr ast)
                 (make-list-with-proc (length ast) (lambda (i) i))))))

(define *xtm_mz_num* 0)

(define impc:ti:check-memzone-void?
  (lambda (ast)
    (if (atom? ast)
        (if (equal? ast 'void) #t #f)
        (if (list? ast)
            (if (null? ast)
                #f
                (impc:ti:check-memzone-void? (car (reverse ast))))
            #f))))

(define impc:ti:memzone
  (lambda (ast)
    (define zone_returns_void? (impc:ti:check-memzone-void? ast))
    (if zone_returns_void?
        `(begin (push_new_zone ,(cadr ast))
                ,(if (= (length ast) 3) (caddr ast) (cadddr ast))
                (pop_zone)
                void)
        (begin
          (define resname (string->symbol (string-append "res" (number->string (modulo *xtm_mz_num* 100)))))
          (define zonename (string->symbol (string-append "zone" (number->string (modulo *xtm_mz_num* 100)))))
          (define newzname (string->symbol (string-append "newz" (number->string (modulo *xtm_mz_num* 100)))))
          (define rescopyname (string->symbol (string-append "rescopy" (number->string (modulo *xtm_mz_num* 100)))))
          (set! *xtm_mz_num* (+ *xtm_mz_num* 1))
          (if (or (> (length ast) 4)
                  (< (length ast) 3))
              (impc:compiler:print-bad-arity-error ast))
          `(begin (push_new_zone ,(cadr ast))
                  (let ((,resname ,(if (= (length ast) 3) (caddr ast) (cadddr ast)))
                        (,zonename (pop_zone))
                        (,newzname (llvm_peek_zone_stack)))
                    ;; this extra let seems reduentant! BUT is needed
                    ;; because rescopyname should go in newzone not zonename
                    ;; i.e. needs to go into a *new* let after pop_zone is called
                    (let ((,rescopyname (zcopy ,resname ,zonename ,newzname)))
                      ,(if (= (length ast) 3)
                           `(llvm_zone_destroy ,zonename)
                           `(llvm_destroy_zone_after_delay ,zonename ,(caddr ast)))
                      ,rescopyname)))))))

(define impc:ti:memzone
  (lambda (ast)
    (define zone_returns_void? (impc:ti:check-memzone-void? ast))
    (if zone_returns_void?
        `(begin (push_new_zone ,(cadr ast))
                ,(if (= (length ast) 3) (caddr ast) (cadddr ast))
                (let ((zonename (pop_zone))
                      (hook:<i64,i8*,i8*>* (cast (tref zonename 4)))
                      (f:[void]* null))
                  (while (not (null? hook))
                    (set! f (cast (tref hook 1) [void]*))
                    (f)
                    (set! hook (cast (tref hook 2) <i64,i8*,i8*>*)))
                  (llvm_zone_destroy zonename)
                  )
                void)
        (begin
          (define resname (string->symbol (string-append "res" (number->string (modulo *xtm_mz_num* 100)))))
          (define zonename (string->symbol (string-append "zone" (number->string (modulo *xtm_mz_num* 100)))))
          (define newzname (string->symbol (string-append "newz" (number->string (modulo *xtm_mz_num* 100)))))
          (define rescopyname (string->symbol (string-append "rescopy" (number->string (modulo *xtm_mz_num* 100)))))
          (set! *xtm_mz_num* (+ *xtm_mz_num* 1))
          (if (or (> (length ast) 4)
                  (< (length ast) 3))
              (impc:compiler:print-bad-arity-error ast))
          `(begin (push_new_zone ,(cadr ast))
                  (let ((,resname ,(if (= (length ast) 3) (caddr ast) (cadddr ast)))
                        (,zonename (pop_zone))
                        (,newzname (llvm_peek_zone_stack)))
                    ;; this extra let seems reduentant! BUT is needed
                    ;; because rescopyname should go in newzone not zonename
                    ;; i.e. needs to go into a *new* let after pop_zone is called
                    (let ((,rescopyname (zcopy ,resname ,zonename ,newzname))
                          (hook:<i64,i8*,i8*>* (cast (tref ,zonename 4)))
                          (f:[void]* null))
                      ,(if (= (length ast) 3)
                           `(begin
                              (while (not (null? hook))
                                (set! f (cast (tref hook 1) [void]*))
                                (f)
                                (set! hook (cast (tref hook 2) <i64,i8*,i8*>*))
                                1)
                              (llvm_zone_destroy ,zonename)
                              )
                           `(llvm_destroy_zone_after_delay ,zonename ,(caddr ast)))
                      ,rescopyname)))))))

(define impc:ti:beginz
  (lambda (ast)
    (impc:ti:memzone `(memzone ,(* 1024 4) (begin ,@(cdr ast))))))

(define impc:ti:letz
  (lambda (ast)
    ;; (if (not (number? (eval (cadr ast))))
    ;;     (impc:compiler:print-needs-zone-size-error 'letz)
    (if (and (list? (cadr ast))
             (list? (caadr ast)))
        (impc:ti:memzone `(memzone ,(* 1024 4)
                                   (let ,(cadr ast) ,@(cddr ast))))
        (impc:ti:memzone `(memzone ,(cadr ast)
                                   (let ,(caddr ast) ,@(cdddr ast)))))))

(impc:ti:register-new-builtin
 "letz"
 ""
 "let-bind temporary variables

Create a new memzone (with optional zone-size), execute `body' with
temporary variables bound as described in `bindings', copy the final
body form up out of the new zone into the surrounding zone, and free the
newly-created zone.

This is handy for computations which will generate a lot of
short-lived allocations - by performing them inside a new zone then
any `zalloc' calls will allocate from within this \"temporary\" zone,
which is much cheaper than heap allocations and can be easily freed at
the end.

e.g.

(letz 100000 ((a 3)                  ;; 3 is bound to a
              (b 42)                 ;; 42 is bound to b
              (c:float* (alloc 10))) ;; a pointer to enough memory for 10 floats is bound to c
  (+ a b (ftoi64 (pref c 0))))

`letz' is the same as `let', with the addition of the new memzone"
 '(bindings [zone-size] body))

(define impc:ti:zone_cleanup
  (lambda (ast)
    `(let ((zone (llvm_peek_zone_stack))
           (hooks:<i64,i8*,i8*>* (cast (tref zone 4)))
           (hook:<i64,i8*,i8*>* (alloc))
           (f (lambda () ,@(cdr ast) void)))
       (tfill! hook 0 (cast f i8*) (cast hooks i8*))
       (tset! zone 4 (cast hook i8*))
       void)))

(define impc:ti:callback
  (lambda (ast)
    `(let ((zold (llvm_peek_zone_stack))
           (znew (push_new_zone (* 1024 4))))
       (llvm_callback ,(car ast)
                      ,(cadr ast)
                      ,@(map (lambda (x)
                               (impc:ti:first-transform `(zcopy ,x zold znew) #t))
                             (cddr ast)))
       (pop_zone)
       (llvm_destroy_zone_after_delay znew
                                      (+ (- ,(car ast) (llvm_now))
                                         (* ,*au:samplerate* 10)))
       void)))

(define (impc:ti:multicref args)
  `(let ,(append (map (lambda (a b n)
                        (list (string->symbol (string-append "f" (number->string n) ":[void]*"))
                              (list (string->symbol
                                     (string-append
                                      (if (= n 0)
                                          (symbol->string a)
                                          (string-append "f" (number->string (- n 1))))
                                      "." (symbol->string b))))))
                      (reverse (cdddr (reverse args)))
                      (cdr (reverse (cdr (reverse args))))
                      (range (length (cddr args))))
                 (list (list (string->symbol (string-append "v:" (symbol->string (car (reverse args)))))
                             (list (string->symbol (string-append "f" (number->string (length (cddddr args))) "."
                                                                  (symbol->string (cadr (reverse args)))))))))
         v))

(define (impc:ti:multicset args)
  `(let ,(map (lambda (a b n)
                (list (string->symbol (string-append "f" (number->string n) ":[void]*"))
                      (list (string->symbol
                             (string-append
                              (if (= n 0)
                                  (symbol->string a)
                                  (string-append "f" (number->string (- n 1))))
                              "." (symbol->string b))))))
              (reverse (cddddr (reverse args)))
              (cdr (reverse (cdr (reverse args))))
              (range (length (cdddr args))))
        (,(string->symbol (string-append "f" (number->string (- (length (cddddr args)) 1)) "."
                                         (symbol->string (caddr (reverse args)))
                                         ":" (symbol->string (cadr (reverse args)))))
          ,(car (reverse args)))))


(define impc:ti:gteq
  (lambda (ast)
    `(or (> ,(cadr ast) ,(caddr ast))
         (= ,(cadr ast) ,(caddr ast)))))

(define impc:ti:lteq
  (lambda (ast)
    `(or (< ,(cadr ast) ,(caddr ast))
         (= ,(cadr ast) ,(caddr ast)))))


;; This to auto surround dotimes with a let
(define impc:ti:doloop
  (lambda (ast inbody?)
    ;; (println 'doloop 'ast: ast)
    (let* ((pair (regex:type-split (symbol->string (caadr ast)) ":"))
           (sym (string->symbol (car pair))))
      `(let ((,(caadr ast) (bitconvert 0)))
         (begin
           (dotimes
               ,(if (null? (cddr (cadr ast)))
                    `(,sym ,(impc:ti:first-transform (cadr (cadr ast)) inbody?))
                    `(,sym ,(impc:ti:first-transform (cadr (cadr ast)) inbody?)
                           ,(impc:ti:first-transform (caddr (cadr ast)) inbody?)))
             (begin ,@(impc:ti:first-transform (cddr ast) inbody?))))))))

(impc:ti:register-new-builtin
 "doloop"
 ""
 "doloop

Execute `body' forms `count' times, with `index-variable' bound to
successive numerical values (incrementing by 1 each loop). If `start'
is given, start from there, otherwise start from 0.

`index-variable' will be automatically bound as a temporary variable
of type i32, i64, float or double - the type will be inferred from the
types of `start' and `count'"
 '(index-variable [start] count body))

(define impc:ti:dotimes
  (lambda (ast inbody?)
    (list 'dotimes
          (impc:ti:first-transform (cadr ast) inbody?)
          (cons 'begin (impc:ti:first-transform (cddr ast) inbody?)))))


(impc:ti:register-new-builtin
 "dotimes"
 ""
 "dotimes loop

Execute `body' forms `count' times, with `index-variable' bound to
successive numerical values (incrementing by 1 each loop). If `start'
is given, start from there, otherwise start from 0.

`index-variable' can be either i32, i64, float or double, and must be
defined outside the loop. For a loop where the index variable is
automatically bound as a temporary variable, see `doloop'."
 '(index-variable [start] count body))

(define impc:ti:while
  (lambda (ast inbody?)
    (list 'while
          (impc:ti:first-transform (cadr ast) inbody?)
          (cons 'begin (impc:ti:first-transform (cddr ast) inbody?)))))

(impc:ti:register-new-builtin
 "while"
 ""
 "while loop

Continue executing `body' forms until `test-expression' returns #f"
 '(test-expression body))

(define *unique-polynum* 0)

(define *impc:mathintrinsicslist* '(sin cos ceil floor exp pow log log2 log10 sqrt fabs round trunc nearbyint fma exp2 powi))
(define *impc:mathbinaryaritylist* '(* - / + % modulo bitwise-and bitwise-or bitwise-eor bitwise-shift-left bitwise-shift-right))
(define *impc:lambdaslist* '(lambda lambdas lambdaz lambdah))

(define impc:ti:first-transform
  (lambda (ast inbody?)
    ;; (println 'ast: ast)
    (if (null? ast) '()
        (cond ((list? ast)
               (cond ((or (and (symbol? (car ast))
                               (impc:ti:get-polyfunc-candidate-types (symbol->string (car ast))))
                          (impc:ti:genericfunc-exists? (car ast)))
                      (set! *unique-polynum* (+ 1 *unique-polynum*))
                      (cons (string->symbol (string-append (symbol->string (car ast))
                                                           "##" ;"$$$"
                                                           (number->string *unique-polynum*)))
                            (impc:ti:first-transform (cdr ast) inbody?)))
                     ((and ;; exact poly match (with type)
                       (symbol? (car ast))
                       (regex:match? (symbol->string (car ast)) ":\\[")
                       ;;(impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string (car ast)) ":"))
                       (impc:ti:get-polyfunc-candidate (car (regex:type-split (symbol->string (car ast)) ":"))
                                                       (impc:ir:get-type-from-pretty-str
                                                        (cadr (regex:type-split (symbol->string (car ast)) ":")))))
                      (let ((p (regex:type-split (symbol->string (car ast)) ":")))
                        (cons
                         (impc:ti:get-polyfunc-candidate (car p)
                                                         (impc:ir:get-type-from-pretty-str (cadr p)))
                         (impc:ti:first-transform (cdr ast) inbody?))))
                     ((and ;; generic match (with type)
                       (symbol? (car ast))
                       (regex:match? (symbol->string (car ast)) ":\\[")
                       (impc:ti:genericfunc-exists? (car (regex:type-split (symbol->string (car ast)) ":"))))
                      (let* ((p (regex:type-split (symbol->string (car ast)) ":"))
                             (ptrdepth (impc:ir:get-ptr-depth (cadr p))))
                        (impc:ti:specialize-genericfunc (car p) (cadr p))
                        (cons
                         (string->symbol (impc:ir:pointer++ (string-append (car p) "_poly_" (cname-encode (cadr p))) (- ptrdepth 1)))
                         (impc:ti:first-transform (cdr ast) inbody?))))
                     ((and ;; non exact poly match with (with type)
                       (symbol? (car ast))
                       (regex:match? (symbol->string (car ast)) ":\\[")
                       (impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string (car ast)) ":"))))
                      (let* ((p (regex:type-split (symbol->string (car ast)) ":"))
                             (t (if (impc:ti:typealias-exists? (cadr p))
                                    (impc:ti:get-typealias-type (cadr p))
                                    (cadr p)))
                             (cname (cname-encode (impc:ir:get-base-type t)))
                             (ptrdepth (impc:ir:get-ptr-depth t)))
                        (cons
                         (string->symbol (string-append (car p) "_adhoc_" cname))
                         (impc:ti:first-transform (cdr ast) inbody?))))
                     ((eq? (car ast) 'letz)
                      (impc:ti:first-transform (impc:ti:letz ast) inbody?))
                     ((eq? (car ast) 'memzone)
                      (impc:ti:first-transform (impc:ti:memzone ast) inbody?))
                     ((eq? (car ast) 'beginz)
                      (impc:ti:first-transform (impc:ti:beginz ast) inbody?))
                     ((eq? (car ast) 'zone_cleanup)
                      (impc:ti:first-transform (impc:ti:zone_cleanup ast) inbody?))
                     ((eq? (car ast) '>=)
                      (impc:ti:first-transform (impc:ti:gteq ast) inbody?))
                     ((eq? (car ast) '<=)
                      (impc:ti:first-transform (impc:ti:lteq ast) inbody?))
                     ((eq? (car ast) 'and)
                      (impc:ti:first-transform (impc:ti:and (cdr ast)) inbody?))
                     ;; ((eq? (car ast) 'random)
                     ;;  (impc:ti:first-transform (impc:ti:random (cdr ast)) inbody?))
                     ((eq? (car ast) 'quote)
                      (impc:ti:first-transform (impc:ti:quote (cadr ast)) inbody?))
                     ((eq? (car ast) 'list)
                      (impc:ti:first-transform (impc:ti:list (cdr ast)) inbody?))
                     ((or (eq? (car ast) 'strln)
                          (eq? (car ast) 'strj))
                      (impc:ti:first-transform (impc:ti:format (cdr ast)) inbody?))
                     ((eq? (car ast) 'sprintln)
                      (impc:ti:first-transform (impc:ti:sprintln (cdr ast)) inbody?))
                     ((eq? (car ast) 'sprintout)
                      (impc:ti:first-transform (impc:ti:sprintln2 (cdr ast)) inbody?))
                     ((eq? (car ast) 'println)
                      (impc:ti:first-transform (impc:ti:println (cdr ast)) inbody?))
                     ((eq? (car ast) 'printout)
                      (impc:ti:first-transform (impc:ti:println2 (cdr ast)) inbody?))
                     ((eq? (car ast) 'afill!)
                      (impc:ti:first-transform (impc:ti:afill! (cdr ast)) inbody?))
                     ((eq? (car ast) 'pfill!)
                      (impc:ti:first-transform (impc:ti:pfill! (cdr ast)) inbody?))
                     ((eq? (car ast) 'tfill!)
                      (impc:ti:first-transform (impc:ti:tfill! (cdr ast)) inbody?))
                     ((eq? (car ast) 'vfill!)
                      (impc:ti:first-transform (impc:ti:vfill! (cdr ast)) inbody?))
                     ((eq? (car ast) 'or)
                      (impc:ti:first-transform (impc:ti:or (cdr ast)) inbody?))
                     ((eq? (car ast) 'free)
                      (list 'free (list 'bitcast (impc:ti:first-transform (cadr ast) inbody?)
                                        'i8*)))
                     ((member (car ast) '(vector_ref))
                      (impc:ti:first-transform `(let ((v1 (alloc)) (v2 (vector ,@(cdr ast)))) (pset! v1 0 v2) v1) inbody?))
                     ((member (car ast) '(array_ref))
                      (impc:ti:first-transform `(let ((a1 (alloc)) (a2 (array ,@(cdr ast)))) (pset! a1 0 a2) a1) inbody?))
                     ((member (car ast) '(tuple_ref))
                      (impc:ti:first-transform `(let ((t1 (alloc)) (t2 (tuple ,@(cdr ast)))) (pset! t1 0 t2) t1) inbody?))
                     ((member (car ast) '(vector))
                      `(make-vector ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast))))
                     ((member (car ast) '(array))
                      `(make-array ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast))))
                     ((member (car ast) '(tuple))
                      `(make-tuple ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast))))
                     ((eq? (car ast) 'not)
                      (impc:ti:first-transform (impc:ti:not (cadr ast)) inbody?))
                     ((member (car ast) '(callback schedule))
                      (impc:ti:first-transform (impc:ti:callback (impc:ti:first-transform (cdr ast) inbody?)) inbody?))
                     ((and (member (car ast) *impc:mathbinaryaritylist*)
                           (<> (length ast) 3))
                      (impc:ti:first-transform (impc:ti:binary-arity ast inbody?) inbody?))
                     ((member (car ast) '(bitwise-not ~))
                      (impc:ti:bitwise-not-to-eor ast inbody?))
                     ((member (car ast) *impc:lambdaslist*)
                      (if inbody?
                          (impc:ti:lambda ast)
                          (cons (impc:ti:first-transform (car ast) inbody?)
                                (cons (impc:ti:first-transform (cadr ast) #t)
                                      (list (cons 'begin (impc:ti:first-transform (cddr ast) #t)))))))
                     ((eq? (car ast) 'cond)
                      (impc:ti:first-transform (impc:ti:cond (cdr ast)) inbody?))
                     ((eq? (car ast) 'cset!)
                      (list 'closure-set!
                            (impc:ti:first-transform (cadr ast) inbody?)
                            (symbol->string (caddr ast))
                            (impc:ti:first-transform (cadddr ast) inbody?)
                            (if (not (null? (cddddr ast)))
                                (impc:ir:get-type-str (impc:ir:convert-from-pretty-types (car (cddddr ast)))))))
                     ((eq? (car ast) 'cref)
                      (list 'closure-ref
                            (impc:ti:first-transform (cadr ast) inbody?)
                            (symbol->string (caddr ast))
                            (if (not (null? (cdddr ast)))
                                (impc:ir:get-type-str (impc:ir:convert-from-pretty-types (cadddr ast))))))
                     ((eq? (car ast) 'refcheck)
                      (list 'closure-refcheck
                            (impc:ti:first-transform (cadr ast) inbody?)
                            (symbol->string (caddr ast))))
                     ((member (car ast) '(cast convert))
                      (if (= (length ast) 2)
                          (impc:ti:first-transform (list (if (eq? (car ast) 'cast)
                                                             'bitcast
                                                             'bitconvert)
                                                         (cadr ast)) inbody?)
                          (let* ((p (regex:type-split (symbol->string (caddr ast)) ":"))
                                 (ptrdepth (impc:ir:get-ptr-depth (caddr ast)))
                                 (basetype (if (null? (cdr p)) #f (impc:ir:get-base-type (cadr p))))
                                 (etype (if (null? (cdr p)) #f (cname-encode basetype))))
                            (impc:ti:first-transform
                             (list (if (eq? (car ast) 'cast)
                                       'bitcast
                                       'bitconvert)
                                   (cadr ast)
                                   (if etype
                                       (string->symbol
                                        (impc:ir:pointer++ (string-append "%" (car p) "_poly_" etype)
                                                           ptrdepth))
                                       (string->symbol (car p))))
                             inbody?))))
                     ((eq? (car ast) 'doloop) (impc:ti:doloop ast inbody?))
                     ((eq? (car ast) 'dotimes) (impc:ti:dotimes ast inbody?))
                     ((eq? (car ast) 'while) (impc:ti:while ast inbody?))
                     ((member (car ast) *impc:letslist*)
                      (cons (impc:ti:first-transform (car ast) inbody?)
                            (cons (map (lambda (p)
                                         (list (impc:ti:first-transform (car p) #f)
                                               (impc:ti:first-transform (cadr p) #f))
                                         )
                                       (cadr ast))
                                  (list (cons 'begin (impc:ti:first-transform (cddr ast) #t))))))
                     ((and (symbol? (car ast))
                           (regex:match? (symbol->string (car ast)) ".*\\..*")
                           (not (regex:match? (symbol->string (car ast)) "\\.[0-9]*i$"))
                           ;; this last case here to catch of '.' in
                           ;; floating point numbers of type 1.000:float etc..
                           (not (number? (string->atom (car (regex:type-split (symbol->string (car ast)) ":"))))))
                      (if (regex:match? (symbol->string (car ast)) ".*\\..*:.*")
                          (let* ((subs (regex:split (symbol->string (car ast)) "\\."))
                                 (a (string->symbol (car subs)))
                                 (subs2 (regex:type-split (car (reverse subs)) ":"))
                                 (b (string->symbol (car subs2)))
                                 (c (string->symbol (cadr subs2))))
                            (cond ((and (= (length ast) 1) (= (length subs) 2)) ;; cref
                                   (impc:ti:first-transform (list 'cref a b c) inbody?))
                                  ((= (length subs) 2) ;; cset
                                   (impc:ti:first-transform (list 'cset! a b (cadr ast) c) inbody?))
                                  ((and (> (length subs) 2) (= (length ast) 2)) ;; multipart cset
                                   (impc:ti:first-transform
                                    (impc:ti:multicset
                                     (append (map (lambda (x) (string->symbol x))
                                                  (append (reverse (cdr (reverse subs))) subs2))
                                             (cdr ast)))
                                    inbody?))
                                  ((and (> (length subs) 2) (= (length ast) 1)) ;; multipart cref
                                   (impc:ti:first-transform
                                    (impc:ti:multicref
                                     (map (lambda (x) (string->symbol x))
                                          (append (reverse (cdr (reverse subs))) subs2)))
                                    inbody?))
                                  (else ;; error!
                                   (impc:compiler:print-compiler-error "Bad form!" ast))))
                          (let* ((subs (regex:split (symbol->string (car ast)) "\\."))
                                 (a (string->symbol (car subs)))
                                 (b (string->symbol (cadr subs))))
                            (if (= (length ast) 1)
                                (impc:ti:first-transform (list 'cref a b) inbody?)
                                (impc:ti:first-transform (list 'cset! a b (cadr ast)) inbody?)))))
                     ((and (atom? (car ast))
                           (symbol? (car ast))
                           (impc:ti:xtmacro-exists? (symbol->string (car ast))))
                      (impc:ti:first-transform
                       (macro-expand (cons (string->symbol
                                            (string-append "xtmacro_"
                                                           (symbol->string (car ast))))
                                           (cdr ast)))
                       'inbody?))
                     (else
                      (cons ;(impc:ti:first-transform (car ast) inbody?)
                       (impc:ti:first-transform (car ast) #t)
                                        ;(impc:ti:first-transform (cdr ast) inbody?)))))
                       (impc:ti:first-transform (cdr ast) #t)))))
              (else
               ;; (println 'atom: ast)
               (cond ((rational? ast)
                      (impc:ti:first-transform `(Rat ,(rational->n ast) ,(rational->d ast)) inbody?))
                     ((eq? ast #f) '(impc_false))
                     ((eq? ast #t) '(impc_true))
                     ((eq? ast '&) 'bitwise-and)
                     ((eq? ast 'bor) 'bitwise-or) ; can't use a pipe
                     ((eq? ast '^) 'bitwise-eor)
                     ((eq? ast '<<) 'bitwise-shift-left)
                     ((eq? ast '>>) 'bitwise-shift-right)
                     ((eq? ast '~) 'bitwise-not)
                     ((eq? ast 'else) '(impc_true))
                     ((eq? ast 'null) '(impc_null))
                     ((eq? ast 'now) 'llvm_now)
                     ((eq? ast 'pset!) 'pointer-set!)
                     ((eq? ast 'pref) 'pointer-ref)
                     ((eq? ast 'pref-ptr) 'pointer-ref-ptr)
                     ((eq? ast 'vset!) 'vector-set!)
                     ((eq? ast 'vref) 'vector-ref)
                     ((eq? ast 'vshuffle) 'vector-shuffle)
                     ((eq? ast 'aset!) 'array-set!)
                     ((eq? ast 'aref) 'array-ref)
                     ((eq? ast 'aref-ptr) 'array-ref-ptr)
                     ((eq? ast 'tset!) 'tuple-set!)
                     ((eq? ast 'tref) 'tuple-ref)
                     ((eq? ast 'tref-ptr) 'tuple-ref-ptr)
                     ((eq? ast 'salloc) 'stack-alloc)
                     ((eq? ast 'halloc) 'heap-alloc)
                     ((eq? ast 'zalloc) 'zone-alloc)
                     ((eq? ast 'alloc) 'zone-alloc)
                     ;; ((eq? ast 'schedule) 'callback)
                     ((eq? ast 'randomf) 'imp_randf)
                     ((eq? ast 'void) '(void))
                     ((and (symbol? ast)
                           (regex:match? (symbol->string ast) "^[+-]?[0-9]*\\.?[0-9]*[+-][0-9]*\\.?[0-9]*i$"))
                      (let ((p (regex:matched (symbol->string ast) "^([+-]?[0-9]*\\.?[0-9]*)([+-][0-9]*\\.?[0-9]*)i$")))
                        ;;`(Cpxd ,(* 1.0 (string->number (cadr p))) ,(* 1.0 (string->number (caddr p))))))
                        (impc:ti:first-transform `(Cpxd ,(* 1.0 (string->number (cadr p))) ,(* 1.0 (string->number (caddr p)))) inbody?)))
                     ((and (symbol? ast)
                           (regex:match? (symbol->string ast) ":\\$(\\[|<)"))
                      (let ((t (impc:ti:expand-generic-type ast)))
                        (if (impc:ti:closure-exists? (symbol->string t))
                            t
                            (let ((p (regex:type-split (symbol->string t) "_poly_")))
                              (impc:ti:specialize-genericfunc (car p) (cname-decode (cadr p)))
                              t))))
                     ((and (symbol? ast)
                           (regex:match? (symbol->string ast) ":(f)|(i)|(f32)|(f64)|(float)|(double)|(i1)|(i8)|(i64)|(i32)|(i64)"))
                      (let ((p (regex:type-split (symbol->string ast) ":")))
                        (if (not (number? (string->atom (car p))))
                            ast
                            ;; otherwise do a convert
                            (cond ((string=? (cadr p) "f")
                                   (list 'bitconvert (string->atom (car p)) 'float))
                                  ((string=? (cadr p) "i")
                                   (list 'bitconvert (string->atom (car p)) 'i32))
                                  ((string=? (cadr p) "f32")
                                   (list 'bitconvert (string->atom (car p)) 'float))
                                  ((string=? (cadr p) "f64")
                                   (list 'bitconvert (string->atom (car p)) 'double))
                                  (else
                                   (list 'bitconvert (string->atom (car p)) (string->symbol (cadr p))))))))
                     (else ast)))))))


;;
;; TYPE INFERENCE CODE
;;
;; request? can be a type - or a symbol if it's a symbol it must be a free variable available in vars
;;
;;

;; is 't' a complex type?
(define impc:ti:complex-type?
  (lambda (t)
    (if (and (atom? t)
             (not (string? t)))
        #f
        (if (string? t) #t
            (if (and (number? (car t))           ;; if list starts with a number (i.e. not a symbol)
                     (<> (car t) *impc:ir:void*) ;; if not void
                     ;; if proper complex type (tuple,array,closure)
                     (member (modulo (car t) *impc:ir:pointer*)
                             (list *impc:ir:tuple* *impc:ir:array* *impc:ir:vector* *impc:ir:closure*)))
                #t
                #f)))))

;; should this be called impc:ti:generic-type? is the presence of a
;; bang (!) the only thing to check?
(define impc:ti:bang-type?
  (lambda (type)
    (string-contains? (atom->string type) "!")))

;; newname mappings is an assoc list
;; containing xlist*##105 -> "xlist--3823948324392" mappings
;; it is reset by llvm:ti:run
(define *impc:ti:generic-type-mappings* '())


(define regex:replace-all
  (lambda (str replace with)
    (if (regex:match? str replace)
        (regex:replace-all (regex:replace str replace with) replace with)
        str)))

;; where finds and replaces
;; are equal length lists
(define regex:replace-everything
  (lambda (str finds replaces)
    (if (<> (length finds) (length replaces))
        (impc:compiler:print-compiler-error "regex:replace-everything expects an equal number of finds and replaces"))
    (for-each (lambda (find replace)
                (if (not (string=? find replace))
                    (let ((s (regex:replace-all str find replace)))
                      (set! str s))))
              finds replaces)
    str))

;; takes a gpolytype (i.e. <!head,xlist*> )
;; and tries to expand on all !bang types ...
;; in other words try to change
;; this <!head,xlist*> into <i64,xlist*>
;; return #f or an expanded
(define impc:ti:reify-generic-type-expand
  (lambda (type gnum spec vars)
    ;; (println 'reifyin: type 'gnum: gnum 'spec: spec) ; 'vars: vars)
    (for-each (lambda (v)
                ;; (println 'v: v)
                (if (and (impc:ti:bang-type? (car v))
                         (if (not gnum) #t
                             (regex:match? (symbol->string (car v)) (string-append "##" gnum)))
                         (regex:match? type (car (regex:split (symbol->string (car v)) "(##)|(%)")))
                         (not (null? (cdr v))))
                    (let* ((t (impc:ti:type-normalize (impc:ti:type-unify (cdr v) vars)))
                           ;; (llllll (println 't: t))
                           (tl (if (impc:ir:type? t)
                                   (impc:ir:pretty-print-type t)
                                   '())))
                      ;; (println 'v: v 't: t 'tl: tl)
                      (if (not (null? tl))
                          (let* ((xx (car (regex:type-split (symbol->string (car v)) "##")))
                                 (base (impc:ir:get-base-type xx))
                                 (xxx (string-append base "[*]*")))
                            (set! type (regex:replace-all type xxx tl)))))
                    #f))
              vars)
    ;; (println 'reifyout: type 'gnum: gnum)
    type))


(define impc:ti:maximize-generic-type
  (lambda (string-type)
    ;; (println 'maxtypein: string-type)
    (let* ((ptr-depth (impc:ir:get-ptr-depth string-type))
           (p (impc:ti:split-namedtype string-type)))
      ;; first check of we are asking for a fully generic type definition (i.e. List*)
      (if (and (null? (cdr p))
               (impc:ti:get-generictype-candidate-types (car p))) ;; not generic!
          (apply string-append (car p) ":" (symbol->string (impc:ti:get-generictype-candidate-types (car p)))
                 (make-list (impc:ir:get-ptr-depth string-type) "*"))
          ;; next check if type is already maximized!
          (if (or (not (impc:ti:get-generictype-candidate-types (car p)))  ;; not generic!
                  (and (not (regex:match? (cadr p) "({|!)"))
                       (not (string-contains? string-type "{"))))
              string-type
              ;; otherwise we really do need to max type!
              (let* ((name (car p))
                     (argstr (cadr p))
                     (ags
                      (cl:remove #f
                                 (map (lambda (x)
                                        (if (regex:match? x "^[A-Za-z0-9_]*{")
                                            (impc:ti:maximize-generic-type x)
                                            (if (regex:match? x (string-append "^" name "[^A-Za-z0-9_]"))
                                                #f
                                                x)))
                                      (impc:ir:get-pretty-tuple-arg-strings argstr)))) ;)
                     (named_ags (cl:remove
                                 #f
                                 (map (lambda (x)
                                        (if (regex:match? x "^[A-Za-z0-9_]*{")
                                            (impc:ti:maximize-generic-type x)
                                            #f))
                                      (impc:ir:get-pretty-tuple-arg-strings argstr))))
                     (ags_a (cl:remove-duplicates (regex:match-all argstr "![A-Za-z_0-9]*")))
                     (gtype (symbol->string (impc:ti:get-generictype-candidate-types (car p))))
                     ;; (plst (impc:ir:get-pretty-tuple-arg-strings gtype))
                     ;; (plst (map (lambda (x)
                     ;;              (if (regex:match? x "^[A-Za-z0-9_]*{")
                     ;;                  (impc:ti:maximize-generic-type x)
                     ;;                  x))
                     ;;            (impc:ir:get-pretty-tuple-arg-strings gtype)))
                     (named_gags (cl:remove
                                  #f
                                  (map (lambda (x)
                                         (if (regex:match? x "^[A-Za-z0-9_]*({|:<)")
                                             (string-append "\\Q" x "\\E")
                                             #f))
                                       (impc:ir:get-pretty-tuple-arg-strings gtype))))
                     (gags (cl:remove-duplicates (regex:match-all gtype "![A-Za-z_0-9]*"))))
                ;; (println 'maximize: string-type 'gtype gtype 'ags ags 'gags gags 'named: named_ags named_gags)
                (let* ((gt2 (if (<> (length named_gags)
                                    (length named_ags))
                                gtype
                                (regex:replace-everything gtype named_gags named_ags)))
                       ;; (lll (println 'gt2 gt2))
                       (newt (if (<> (length ags) (length gags))
                                 gt2
                                 (regex:replace-everything gt2 gags ags)))
                       ;; (lllll (println 'newt newt))
                       (newt2 (map (lambda (x)
                                     ;; (println 'string-type string-type 'x x)
                                     (if (regex:match? x "^[A-Za-z0-9_]*{")
                                         (if (regex:match? x (string-append string-type "\\**"))
                                             (regex:replace x "^([^{]*).+(\\*+)$" "$1$2")
                                             (impc:ti:maximize-generic-type x))
                                         x))
                                   (impc:ir:get-pretty-tuple-arg-strings newt)))
                       ;; (lllllllll (println 'newt2 newt2))
                       (newtype_c (apply string-append (car p) ":<" (string-join newt2 ",") ">"
                                         (make-list ptr-depth "*"))))
                  ;; (println 'maxtypeout: string-type newtype_c)
                  newtype_c)))))))


(define impc:ti:get-generic-type-as-tuple
  (lambda (string-type)
    (set! string-type (impc:ir:pretty-print-type string-type))
    (let* ((a (impc:ti:maximize-generic-type string-type))
           (b (impc:ti:split-namedtype a))
           (t (impc:ir:get-type-from-pretty-str (cadr b))))
      t)))


(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)))


(define impc:ti:minimize-gen-type-finalize-x
  (lambda (typevars lst)
    ;; (println 'finalize: lst)
    (let* ((newl1 (car lst))
           (newl2 (cdr lst))
           (mem '())
           (res (map (lambda (x y)
                       ;; (println 'x x 'y y)
                       (if (member x mem)
                           #f
                           (if (equal? x y)
                               #f
                               (begin                             
                                 (set! mem (cons x mem))
                                 y))))
                     newl1
                     newl2))
           (ret (cl:remove-if (lambda (x) (not x)) res))
           (chk1 (if (> (length typevars) (length ret))
                     (begin (set! typevars (cl:remove-duplicates typevars))
                            #f)
                     #t))                            
           (errchk (if (<> (length ret) (length typevars))
                       (begin (impc:compiler:print-compiler-error "Type Vars and Ret should be same length in Minimize Finalize X"
                                                                  (list ret typevars))
                              #f)
                       #t))
           (pairs (map (lambda (x y) (cons x y)) ret typevars))
           (ps (cl:remove-duplicates pairs))
           (result (map (lambda (p) (car p)) ps)))
      ;; (println '>> 'new1 newl1 'new2 newl2 'res res 'mem mem 'ret ret 'typevars typevars 'result result)
      (if (null? result)
          result
          (map (lambda (x) (impc:ir:pretty-print-type x)) result)))))
    

(define impc:ti:minimize-gen-type-x
  (lambda (l1 newl1 l2 newl2)
;    (println 'l1 l1 'nl1 newl1 'l2 l2 'nlw newl2)
    (if (string? l2) (set! l2 (impc:ti:get-generic-type-as-tuple l2)))
    (if (null? l1)
        (cons (reverse newl1) (reverse newl2))
        (if (list? (car l1))
            (let ((res (impc:ti:minimize-gen-type-x (car l1) '() (car l2) '())))
              (impc:ti:minimize-gen-type-x
               (cdr l1) (append (car res) newl1)
               (cdr l2) (append (cdr res) newl2)))
            (if (and (symbol? (car l1))
                     (regex:match? (symbol->string (car l1)) "^!"))
                (impc:ti:minimize-gen-type-x (cdr l1) (cons (car l1) newl1)
                        (cdr l2) (cons (car l2) newl2))
                (impc:ti:minimize-gen-type-x (cdr l1) newl1
                                             (cdr l2) newl2))))))


(define impc:ti:minimized-gen-type
  (lambda (type gtype)
    (impc:ti:minimize-gen-type-finalize-x
     (map (lambda (x) (string->symbol x)) (regex:match-all gtype "\\![a-zA-Z0-9_]*"))
     (impc:ti:minimize-gen-type-x (impc:ir:get-type-from-pretty-str gtype) '()
                                  (impc:ir:get-type-from-pretty-str type) '()))))



(define impc:ti:tuple-list-from-pretty-tuple-str
  (lambda (str)
    (impc:ir:get-pretty-tuple-arg-strings str)))

(define impc:ti:generate-generic-type-cname
  (lambda (t gtype)
    ;; (println 'gentypecname: t gtype)
    (let (;(mint (impc:ti:minimize-generic-type t gtype)))
          (mint (impc:ti:minimized-gen-type t gtype)))
      ;; (println 'generatecname: t 'gtype gtype 'min mint)
      (for-each (lambda (x)
                  (if (string-contains? x "!")
                      (impc:compiler:print-bad-type-error t
                                                          (string-append "Could not generate type cname:" (sexpr->string mint)))))
                mint)
      ;; (println 'new_cname_for: 't: t 'is (string-append "<" (string-join mint ",") ">"))
      (cname-encode (string-append "<" (string-join mint ",") ">")))))


;; (define impc:ir:split-squig
;;   (lambda (x)
;;     (let* ((base (impc:ir:get-base-type x))
;;            (ptrs (impc:ir:get-ptr-depth x))
;;            (p (regex:type-split base "{"))
;;            (argstr (substring (cadr p) 0 (- (string-length (cadr p)) 1))))
;;       (list (car p)
;;             (apply string-append "<" argstr ">" (make-list ptrs "*"))))))

;; this will basically try to turn xlist*##664 into "%xlist--adoOmdroIRU*"
;;
;; 1. try to reify the generic type (vs) using (vars)
;; 2. check against specifications of the polytype that may already exist
;; 3. if 2. exists then return the typename of the specification of the generic type
;; 4. if 2. does not exist then create specific type, add it to type polys and return it
;; 5. if type cannot be unified throw compiler error.
(define impc:ti:reify-generic-type
  (lambda (vs vars all-vs)
    ;; (println 'reify-generic-type: vs) ;; (symbol? vs)
    ;; (println 'vars: vars)
    ;; (println 'all-vs: all-vs)
    ;; (println 'gtype: vs 'vars: vars 'allvs: all-vs)
    ;; (println '-> (assoc-strcmp vs vars))
    (if (and (assoc-strcmp vs vars)
             (not (null? (cdr (assoc-strcmp vs vars))))
             (impc:ir:type? (cadr (assoc-strcmp vs vars))))
        (cadr (assoc-strcmp vs vars))
        (if (and (symbol? vs)
                 (string-contains? (symbol->string vs) "##")
                 (not (regex:match? (symbol->string vs) "^!")))
            (let* ((rsplit1a (regex:split (symbol->string vs) "##")) ;\\$\\$\\$"))
                   (rsplit1 (if (string-contains? (car rsplit1a) "{")
                                (cons (impc:ti:maximize-generic-type (car rsplit1a)) (cdr rsplit1a))
                                rsplit1a))
                   (gnum (if (> (length rsplit1) 1) (cadr rsplit1) #f))
                   (rsplit2 (impc:ti:split-namedtype (car rsplit1)))
                   (gpolyname (car rsplit2))
                   (gtype-explicit (if (null? (cdr rsplit2)) '()
                                       (impc:ir:get-base-type (cadr rsplit2))))
                   ;; (llllll (println 'gpolyname: gpolyname 'gtype: gtype-explicit))
                   (spec (if (> (length rsplit2) 1) (cadr rsplit2) #f))
                   (ptrdepth (impc:ir:get-ptr-depth (car rsplit1)))
                   (elements '())
                   (validelements? #f)
                   (t1 (symbol->string (impc:ti:get-generictype-candidate-types (string->symbol (impc:ir:get-base-type gpolyname)))))
                   (gtype t1))
              ;; (println 'reifyts gtype 'vs gtype-explicit)
              (if (and (not (null? gtype-explicit))
                       (impc:ti:bang-type? gtype-explicit))
                  (set! t1 gtype-explicit))
              ;; go through and check that there are NO non-explicit gpoly's at top level of type
              ;; (println '%%%%%%%%%%%%%%%%%%%%%%%% gnum)
              ;; (println '->A: t1 'gtype: gtype 'explict: gtype-explicit 'ptrdepth: ptrdepth 'gpoly: gpolyname 'gnum: gnum)
              ;; (println '->VARS: vars 'all-vs all-vs)
              ;; attempt to expand any <!head,xlist*> into <i64,xlist*>
              (set! t1 (impc:ti:reify-generic-type-expand t1 gnum spec vars))
              ;; (println '->B: t1 'ptrdepth: ptrdepth 'gpoly: gpolyname)
              (let* ((s1 (regex:replace t1 "\\<(.*)\\>?.*" "$1"))
                     (es2 (impc:ir:get-type-joiner
                           (cl:remove-if (lambda (x) (string=? x ""))
                                         ;;  (regex:match? x gpolyname)))
                                         (regex:match-all s1 impc:ir:regex-tc-or-a))))
                     (es (map (lambda (x) (if (string? (impc:ir:get-type-from-pretty-str x))
                                         (impc:ir:get-type-from-pretty-str x) x))
                              es2))
                     (tr (cl:remove-if (lambda (x)
                                         ;; (println 'x: x 'gpolyname: gpolyname)
                                         (if (and (not (regex:match? x "^(<|\\[)"))
                                                  (string-contains? x ":"))
                                             (let ((p (regex:type-split x ":")))
                                               (or (string=? (car p) gpolyname)
                                                   (impc:ir:type? (impc:ir:get-type-from-pretty-str (cadr p)))))
                                             (if (regex:match? x "^!")
                                                 #f
                                                 (or (regex:match? x (string-append gpolyname "([{},:*#]|$)"))
                                                     (impc:ir:type? (impc:ir:get-type-from-pretty-str x))))))
                                       ;; (impc:ir:type? x)))))
                                       es)))
                (if (null? tr) (set! validelements? #t))
                (set! elements es))
              ;; (println '->C: t1 (impc:ti:type-normalize t1))
              ;; (println 'elements: elements 'tr: validelements? 't1: t1 'vs: vs (regex:match? t1 "!"))
              (if (and validelements?
                       (not (string-contains? t1 "!")))
                  (let* ((base (impc:ir:get-base-type gpolyname)) ;(symbol->string vs)))
                         ;; (newname (string-append base "_poly_" (cname-encode t1)))
                         (newname (string-append base "_poly_" (impc:ti:generate-generic-type-cname t1 gtype)))
                         (max (impc:ti:maximize-generic-type (impc:ir:pretty-print-type (string-append "%" newname))))
                         (newtype1 t1) ;;(regex:replace t2 (string-append base "([^-][^-])") (string-append newname "$1")))
                         (newtype2 (cons 14 (map (lambda (x)
                                                   (if (string? (impc:ir:get-type-from-pretty-str x))
                                                       (impc:ir:get-type-from-pretty-str x)
                                                       (if (regex:match? x (string-append gpolyname "([{},:*#]|$)"))
                                                           (impc:ir:pointer++ (string-append "%" newname) (impc:ir:get-ptr-depth x))
                                                           (impc:ir:get-type-from-pretty-str x))))
                                                 elements)))
                         (newtype3 (impc:ir:get-type-str newtype2)))
                    ;; (println 'base: base 't1: t1 'gt: gtype 'nt1 newtype1 'nt2 newtype2 'nt3 newtype3 'nn: newname)
                    ;; ok now we have a type we need to add it to llvm and
                    ;; polytype
                    ;; (println 'newtype! newname 'totype: newtype3)
                    (if (not (impc:ti:namedtype-exists? newname))
                        (begin ;; if this is a new reification of a generic type then ...
                          ;; (println 'compile-type! newname 'totype: newtype3 'type: t1 'gt: gtype )
                          (if (llvm:compile-ir (string-append "%" newname " = type " newtype3))
                              (begin
                                (impc:ti:register-new-polytype base
                                                               newname
                                                               newtype2
                                                               "")
                                ;; we should probably also build dataconstructors for the new
                                ;; concrete type?? (at least for printing reasons)
                                ;; because impc:ti:compile-type-dataconstructors needs to be called from
                                ;; the top level, we should call use callback to add to queue
                                (callback (now) 'impc:ti:compile-type-dataconstructors (string->symbol newname) newtype1 #f #t #t)
                                'done)
                              (impc:compiler:print-compiler-failed-error))))
                    (let ((rettype (impc:ir:pointer++ (string-append "%" newname) ptrdepth)))
                      ;; (println 'oldvs: vs)
                      ;; (set! vs (string->symbol
                      ;;           (string-append base ":" gtype
                      ;;                          (apply string-append (make-list ptrdepth "*"))
                      ;;                          "##" gnum)))
                      ;; (println 'updatevar: vs 'with rettype)
                      (impc:ti:update-var vs vars '() rettype)
                      rettype))
                  vs))
            vs))))



;; trys to type unify vs against any other
;; choices available in all-vs
;; (define impc:ti:symbol-expand-reverse-check
;;   (lambda (vs vars all-vs)
;;     ;; (println 'vs vs 'all-vs all-vs 'vars vars)
;;     (impc:ti:type-unify all-vs vars)
;;     ;; (println 'vs: vs 'vars: vars)
;;     (if (not (null? (cdr (assoc-strcmp vs vars))))
;;         (cdr (assoc-strcmp vs vars))
;;         vs)))


;; takes types with symbols and expands them
;; using types associated with symbols in vars
;; if a particular var doesn't have a type yet
;; then we try to reverse expand
;; (i.e. look at other closure options that may include type values
;; and assign those values into vars)
;; (define impc:ti:symbol-expand
;;   (lambda (vs vars all-vs)
;;     ;; (println 'symbol-expand: vs 'allvs: all-vs) ; 'vars: vars)
;;     ;; (println 'vars: vars)
;;     ;; (println 'all-vs: all-vs)
;;     (if (atom? vs)
;;         (if (symbol? vs)
;;             (if (or (impc:ti:get-generictype-candidate-types (string->symbol (impc:ir:get-base-type (car (regex:split (car (regex:split (symbol->string vs) "##")) "%"))))) ;"\\$\\$\\$")) "%")))))
;;                     (if (and (regex:match? (symbol->string vs) ":")
;;                              (impc:ti:get-generictype-candidate-types
;;                               (string->symbol (car (regex:type-split (symbol->string vs) ":")))))
;;                         #t #f))
;;                 (impc:ti:reify-generic-type vs vars all-vs)
;;                 (if (not (assoc-strcmp vs vars)) ;; if not in vars
;;                     (if (regex:match? (symbol->string vs) "^![^#]*$") ;; then check to see if symbol is a !gvar
;;                         vs
;;                         ;; (impc:compiler:print-variable-not-marked-as-free-error vs))
;;                         vs)
;;                     ;; check to see a type has been defined
;;                     ;; otherwise return null
;;                     (let ((t (cdr (assoc-strcmp vs vars))))
;;                       ;; first check to see if the symbol vs has a value
;;                       (if (null? t) ;; if it doesn't we might need to reverse match!
;;                           (impc:ti:symbol-expand-reverse-check vs vars all-vs)
;;                           t))))
;;             (begin ;(println 'ccc: vs)
;;               vs))
;;         (cons (impc:ti:symbol-expand (car vs) vars all-vs)
;;               (impc:ti:symbol-expand (cdr vs) vars all-vs)))))


;; impc:ti:intersection* is cl:intersection for
;; an arbirary number of sets (i.e. args)
;; also handles *impc:ir:other* which we want
;; to match against anything.
(define impc:ti:intersection*
  (lambda args
    (let loop ((a args)
               (res '()))
      (if (null? a)
          res
          (loop (cdr a)
                (if (null? res)
                    (car a)
                    (if (null? (car a))
                        res
                        (cl:intersection (car a) res))))))))




(define impc:ti:complex-unify
  (lambda (sym types vars)
    ;; (println 1 'sym: sym 'types: types)

    (set! types (cl:remove-duplicates types))

    ;; (println 2 'sym: sym 'types: types)

    ;; this is here to catch any trailing complex types
    ;; i.e. ((211 2 106) (211 2 106) 211 2 106)
    ;; we turn them into
    ;; ((211 2 106) (211 2 106) (211 2 106))
    (set! types
          (let loop ((lst types))
            (if (null? lst) '()
                (if (or (list? (car lst))
                        (string? (car lst)))
                    (cons (car lst) (loop (cdr lst)))
                    (list lst)))))

    ;; (println 3 'sym: sym 'types: types)

    (set! types (impc:ti:type-unify types vars))

    ;; (println 4 'sym: sym 'types: types)

    types))


;; this goes through IN ORDER and returns either:
;; NULL if the lists don't match
;; or
(define impc:ti:unify-lists
  (lambda args
                                        ;(println 'unify: args 'norm: (impc:ti:type-normalize args))
    (if (null? args)
        args
        (let ((lgths (map (lambda (k) (length k)) args)))
          (if (not (null? (cl:remove (car lgths) lgths)))
              '()
              (let ((result
                     (apply map (lambda args
                                  (let ((l1 (cl:remove '() args)))
                                    (if (null? l1) l1
                                        (let ((l2 (cl:remove-duplicates l1)))
                                          (if (null? l2)
                                              l2
                                              ;;(car l2))))))
                                              (if (= 1 (length l2))
                                                  (car l2)
                                                  '()))))))
                            args)))
                                        ;(println 'result: result)
                (if (member '() result)
                    '()
                    result)))))))



;; this is here to normalize any recursive tuples
;; i.e. put them in their simplist "named" form
;; you can pass in a a complete list of types
;; at the end and have this normalize them
(define impc:ti:type-normalize
  (lambda (t)
    (cond ((atom? t) t)
          ((and (list? t)
                (not (null? t))
                (not (impc:ir:type? (car t)))
                (number? (car t))
                ;;(= *impc:ir:tuple* (modulo (car t) *impc:ir:pointer*)))
                (impc:ir:tuple? (car t)))
           ;; first check all sub tuples for possible normalization!
           (set! t (map (lambda (a) (impc:ti:type-normalize a)) t))
           (let ((named-types (cl:remove-if-not string? t)))
             (if (null? named-types)
                 t
                 (let ((res (map (lambda (k)
                                   ;; (println 'k: k)
                                   (let* ((split (regex:split k "%|(_poly_)"))
                                          (gen-type (if (impc:ti:get-generictype-candidate-types (cadr split))
                                                        (symbol->string (impc:ti:get-generictype-candidate-types (cadr split)))
                                                        ""))
                                          ;; (gen-type (symbol->string (impc:ti:get-generictype-candidate-types (cadr split))))
                                          (named-type (impc:ti:get-namedtype-type k))
                                          (domatch? (if (and (list? named-type)
                                                             (= (length named-type) (length t)))
                                                        #t #f))
                                          (match (if domatch?
                                                     (map (lambda (a b)
                                                            ;; (println 'aa a 'bb b)
                                                            (if (equal? a b) #t
                                                                (if (and (symbol? a)
                                                                         (regex:match? gen-type (symbol->string a)))
                                                                    #t
                                                                    #f)))
                                                          t ;; type coming in
                                                          named-type)
                                                     (list k))))
                                     (if (member #f match) #f k)))
                                 named-types)))
                   (set! res (cl:remove-if-not string? res))
                   (if (null? res)
                       (impc:ti:type-normalize (cdr t))
                       (if (car res)
                           (car res)
                           t))))))
          ((pair? t)
           (cons (impc:ti:type-normalize (car t))
                 (impc:ti:type-normalize (cdr t)))))))


;; this function is here to support type-unify
;; in the following way:
;;
;; when going through type-unify it is possible
;; for a situation to arrise where a unification
;; over something like this may occur:
;; (("%list--3834748* (112 !head##829 list*##829"))
;;
;; the result for the unification will be "%list-3834748*"
;; check-to-update-generic-vars is here to do a quick
;; check of the (112 !head##829 list*##829) to update
;; any possible vars (such as !head##829) which could get
;; useful information from the "%list--3834748*" before
;; they get thrown away.
(define impc:ti:check-to-update-generic-vars
  (lambda (atom lists vars)
    ;; (println 'checktoupdategenericvars: atom 'lists lists 'vars: vars)
    (let ((atom-type (if (string? atom)
                         (impc:ti:get-namedtype-type atom)
                         atom)))
      ;; (println 'atom: atom 'atom-type atom-type 'lists lists)
      (if (list? atom-type)
          (map (lambda (e)
                 ;; (println 'type-match: atom-type 'against e)
                 (if (and (list? e)
                          (= (length e) (length atom-type)))
                     (if (and (number? (car e))
                              (number? (car atom-type))
                              (= (car e) (car atom-type)))
                         (map (lambda (a b)
                                (if (and (symbol? a)
                                         (assoc-strcmp a vars))
                                    (begin
                                      (impc:ti:update-var a vars '() b))))
                              (cdr e)
                              (cdr atom-type)))))
               lists))
      #t)))

(define impc:ti:type-unify-closure
  (lambda (t vars)
    ;; (println 'cls: t (flatten-1 t))
    (if (or (null? t)
            (not (list? (car t))))
        t
        (let* ((t1 (flatten-1 t))
               (lgth (length (car t1)))
               (t2 (cl:remove-if (lambda (x) (or (atom? x)
                                            (<> (length x) lgth)))
                                    t1))
               (p2 (map (lambda (i)
                          ;; (println 'i i)
                          (map (lambda (x)
                                 ;; (println 'x x)
                                 (list-ref x i))
                               t2))
                        (range 1 lgth)))
               (p3 (map (lambda (x) (impc:ti:type-unify (cl:remove-duplicates x) vars)) p2))
               (p4 (cons 213 p3)))
          ;; (println 'p2 p2 'p3 p3 'p4 p4 't t)
          (set! p4 '())
          (if (null? p4) t2 p4)))))

;;
;; IF TYPE CANNOT BE UNIFIED SUCCESSFULLY THEN WE SHOULD RETURN NULL '()
;; i.e. if we have ((114 0 0) (14 0 0)) don't return this -> return '()
;;
(define impc:ti:type-unify
  (lambda (t vars)
    ;; (println 't: t 'vars: vars)
    (cond ((atom? t)
           (if (and (symbol? t)
                    #t
                    (or (impc:ti:get-generictype-candidate-types
                         (string->symbol
                          (impc:ir:get-base-type
                           (car (regex:split (car (regex:split (symbol->string t) "##")) "%")))))
                        (if (and (regex:match? (symbol->string t) "(:|{)")
                                 (impc:ti:get-generictype-candidate-types
                                  (string->symbol (car (impc:ti:split-namedtype t)))))
                            #t
                            #f)))
               (impc:ti:reify-generic-type t vars '())
               (if (and (symbol? t) (assoc-strcmp t vars))
                   (let ((r (impc:ti:type-unify (cdr (assoc-strcmp t vars)) vars)))
                     (if (null? r) t r)) ;; if r is NULL or false return t
                   t)))
          ((list? t)
           (cond ((impc:ti:complex-type? t)
                  (map (lambda (v) (impc:ti:type-unify v vars)) t))
                 ((= (length t) 1)
                  (impc:ti:type-unify (car t) vars))
                 (else
                  (let* ((ts (impc:ti:type-normalize
                              (map (lambda (v)
                                     (let ((vvv (impc:ti:type-unify v vars)))
                                       ;; (println 'vvv: vvv)
                                       (impc:ti:type-clean vvv)))
                                   t)))
                         (ts1 (cl:remove #f ts))
                         (ts2 (cl:remove-duplicates ts1))
                         (result ts2))
                    ;; (println 1 t 'unified: result)
                    (if (and (= (length result) 1)
                             (impc:ir:type? (car result)))
                        (car result) ;; return immediately if we have a result
                        (begin
                          ;; first check result to see if we have a valid named-type (i.e. "%string")
                          (if (and #f
                                   (= (length result) 2) ;; find all occurences of ((112 0 1) "%string--38293482")
                                   (cl:find-if string? result)
                                   (cl:find-if (lambda (k) (not (string? k))) result))
                              (set! result (list (cl:find-if string? result))))

                          ;; (println 2 t 'unified: result)
                          ;; this is here for cases like
                          ;; (!head%a##287 0 1) ;; which should resolve to (0 1) if !head%a##287 has no type
                          (if (and (not (cl:find-if impc:ti:complex-type? result))
                                   (not (cl:find-if string? result))
                                   (cl:find-if symbol? result))
                              (set! result (cl:remove-if symbol? result)))

                          ;; (println 3 t 'unified: result)
                          ;; next check to see if we need to do some number crunching
                          ;; basically checking to solve things like
                          ;; ((0 1) 1) which should resolve to 1
                          ;; (0 (0 1) (0 1 2)) which should resolve to 0
                          ;; ((0 1) (0 1 2)) sould resolve to (0 1 2)
                          (if (and (cl:find-if list? result)
                                   (not (cl:find-if impc:ti:complex-type? result)))
                              (let ((non-choices (cl:remove-duplicates (cl:remove-if list? result)))
                                    (choices (cl:remove-duplicates (flatten (cl:remove-if atom? ts2)))))
                                (if (and (= (length non-choices) 1)
                                         (member (car non-choices) choices))
                                    (set! result (car non-choices))
                                    (set! result (cl:remove-duplicates (flatten result))))))

                          ;; (println 4 t 'unified: result)
                          ;; if there is a choice between resolved types and unresolved types
                          ;; then obviously we should choose resolved types!
                          (if (list? result)
                              (let ((resolved (cl:remove-duplicates
                                               (cl:remove-if-not (lambda (k)
                                                                   (if (and (impc:ir:type? k)
                                                                            (impc:ti:complex-type? k))
                                                                       #t #f))
                                                                 result))))
                                (if (not (null? resolved))
                                    ;; (set! result (car resolved)))))
                                    (set! result resolved))))

                          ;; (println 5 t 'unified: result)
                          ;; finally return type (and do generic update check)
                          (if (null? result)
                              result
                              (if (and (not (number? result))
                                       (not (impc:ir:type? result))
                                       (list? result)
                                       (impc:ir:tuple? (car result)))
                                  (let* ((r1 (cl:remove-if (lambda (x) (not (impc:ir:type? x))) result))
                                         (res (cl:remove-duplicates r1))
                                         (resl (length res)))
                                    ;; (println 'res: res)
                                    (if (= resl 1)
                                        (begin
                                          (impc:ti:check-to-update-generic-vars (car res) t vars)
                                          (car res))
                                        r1))
                                    ;; (if res res
                                    ;;     (car result))) ;; result is a proper tuple
                                  (if (and (list? result)
                                           (= (length result) 1))
                                      (begin
                                        (impc:ti:check-to-update-generic-vars (car result) t vars)
                                        (car result)) ;; if result only has 1 element then return that
                                      ;; result)))))))))
                                      (if (and (list? result)
                                               (impc:ir:closure? (car result)))
                                          (impc:ti:type-unify-closure result vars)
                                          (if (or (impc:ir:type? result) ;; either result is a propert type
                                                  (not (cl:find-if (lambda (k) (not (number? k))) result))) ;; or list of number '(0 1 2 3) for example
                                              result ;; if list is either a propert type OR a list of numeric types (i.e. '(0 1 2))
                                              '()))))))))))) ;; if we still have mixed choice of complex types then return NULL
          ((pair? t)
           (impc:ti:type-unify (cdr t) vars))
          (else (impc:compiler:print-bad-type-error t)))))


(define impc:ti:generic-type-details
  (lambda (a)
    (if (and (symbol? a)
             (string-contains? (symbol->string a) "##"))
        (let* ((gname (car (regex:split (symbol->string a) "##")))
               (gnum (string->number (cadr (regex:split (symbol->string a) "##"))))
               (_basename (impc:ir:get-base-type gname))
               (name_and_type (impc:ti:split-namedtype _basename))
               (basename (car name_and_type))
               (gtype (if (null? (cdr name_and_type)) #f (cadr name_and_type)))
               (gchar (cdr (regex:split basename "%")))
               (gname2 (car (regex:split basename "%")))
               (gpt (impc:ti:get-generictype-candidate-types gname2)))
          (if gpt
              (list (string->symbol gname2) gnum (if (null? gchar) "" (car gchar)) (impc:ir:get-type-from-pretty-str (symbol->string gpt)) gtype)
              (list (string->symbol gname2) gnum (if (null? gchar) "" (car gchar)) '() gtype)))
        #f)))

;; try to find a type for a !bang from a reified type
;;
;; example use is in impc:ti:sym-unify
(define impc:ti:check-bang-against-reified
  (lambda (bang-sym reified-sym vars)
    (let ((r (assoc-strcmp reified-sym vars)))
      (if (null? r)
          #f
          (let* ((gtd (impc:ti:generic-type-details reified-sym))
                 (gtd2 (impc:ti:generic-type-details bang-sym))
                 (type (cdr r))
                 (gtype (cadddr gtd))
                 (pos (cl:position (car gtd2) gtype)))
            (if (and type pos (list? (car type)) (> (length (car type)) pos))
                (let ((val (list-ref (car type) pos)))
                  val)
                (if (regex:match? (symbol->string (car r)) "^!g(.*)_.*##([0-9]*)$")
                    (let ((l1 (regex:matched (symbol->string bang-sym) "^!g(.*)_.*##([0-9]*)$"))
                          (l2 (regex:matched (symbol->string reified-sym) "^!g(.*)_.*##([0-9]*)$")))
                      (if (and (= (length l1) (length l2))
                               (> (length l1) 2)
                               (and (string=? (cadr l1) (cadr l2))
                                    (string=? (caddr l1) (caddr l2))))
                          type
                          #f))
                    #f)))))))



(define impc:ti:sym-unify
  (lambda (sym types vars)
    ;; if sym is a !bang symbol and has no type set
    ;; then we trawl through vars looking for reified
    ;; types which we might be able to match it against.
    (if (and (null? types)
             (regex:match? (symbol->string sym) "^!"))
        (let ((gtd (impc:ti:generic-type-details sym)))
          (map (lambda (k)
                 (if (and (not (null? (cdr k)))
                          (impc:ir:type? (cadr k)))
                     (let ((gtd2 (impc:ti:generic-type-details (car k))))
                       (if (and gtd2 (= (cadr gtd) (cadr gtd2)))
                           (let ((val (impc:ti:check-bang-against-reified sym (car k) vars)))
                             (if val
                                 (begin
                                   (impc:ti:update-var sym vars '() val))))))))
               vars)))

    ;; (if (not (cl:find-if list? types))
    ;; 	  (begin (set! types (cl:remove-duplicates types)) ;; first normalize and check for duplicates
    ;; 		 (if (= (length types) 1)
    ;; 		     (car types) ;; if only 1 element in list return as atom
    ;; 		     (impc:ti:complex-unify types types vars)))
    ;; 	  (impc:ti:complex-unify sym types vars))))

    (let ((result (impc:ti:complex-unify sym types vars)))
      ;; (println 'sym: sym 't: types 'result result 'vars: vars)
      (if (and (list? result)
               (= (length result) 1))
          (car result)
          (impc:ti:type-clean result)))))



;; unify is a little bit ugly
;; 1st it expands all symbols - during this process vars can be modified (force-var, update-var)
;; 2nd because var can change we check result against var to see if any change to var has improved things
;; 3rd because step 2 may have made changes for the better we should do a final symbol check
;; basically means going through the final result list to see if any symbols left in complex
;; types can be given types.
(define impc:ti:unify
  (lambda (vars)
    ;; (println 'unifyvars: vars)
    (let ((result (map (lambda (v)
                         ;;(println 'unify-v: v)
                         (let* ((sym (car v))
                                ;;(kkkkkk (println 'sym sym))
                                ;; expand any symbols and do reverse symbol checks
                                ;; (types-expanded (map (lambda (t)
                                ;;                        ;; first CLEAN the type (remove extraneous lists)
                                ;;                        (set! t (impc:ti:type-clean t))
                                ;;                        (if (or (symbol? t)
                                ;;                                (list? t))
                                ;;                            (let ((res (impc:ti:symbol-expand t vars (cdr v))))
                                ;;                              (set! res (impc:ti:type-clean res))
                                ;;                              res)
                                ;;                            t))
                                ;;                      (cdr v)))
                                ;; (kkkkkkkk (println 'unify-v-expanded: v 'expanded: types-expanded))
                                ;; (types-unified types-expanded)) ;(impc:ti:sym-unify sym types-expanded vars)))
                                (types-unified (impc:ti:sym-unify sym (cdr v) vars)))
;                                (types-unified (impc:ti:sym-unify sym types-expanded vars)))

                           ;; (println 'sym_____: v)
                           ;; (println 'expanded: types-expanded)
                           ;; (println 'unified_: types-unified)
                           ;; (println 'vars____: vars)

                           ;; (println 'types-unified: types-unified)
                           ;; (println 'un-expanded (cdr v))
                           ;; (println 'un-unified types-expanded)
                           ;; (println 'unified types-unified)
                           ;; (println 'vdone: v)
                           (cons sym types-unified)))
                       vars)))
      ;; a final comparison between vars and result
      ;; this is because things in VAR may well have changed
      ;;
      ;; anything in result that is NULL will hopefully
      ;; have a value in vars that we can use
      (let ((result2 (map (lambda (a b)
                            (if (null? (cdr a))
                                (if (not (null? (cdr b)))
                                    (if (= (length (cdr b)) 1)
                                        (cons (car a) (cadr b))
                                        (cons (car a) (cdr b)))
                                    a)
                                a))
                          result
                          vars)))
        ;; (println 'result: result)
        ;; (println 'vars: vars)
        ;; (println 'result2: result2)

        ;; and return result
        result2))))


;; checks to see if a type system is completely unified
(define impc:ti:unity?
  (lambda (vars)
    (map (lambda (x)
           (if (impc:ir:type? (cdr x)) #t #f))
         vars)))


;; join elements into a list (without including nulls)
(define impc:ti:join
  (lambda args
    (cl:remove-if null? args)))


;; this function removes any uneccessary lists
;; it just checks for lists of 1 element and
;; extracts the atom from the list
;;
;; i.e. (211 (2) (211 3 3) (xlist*##123)) should be
;; (211 2 (211 3 3) xlist*##123)
;; (define impc:ti:type-clean
;;   (lambda (type)
;;     (if (or (null? type)
;;             (atom? type)
;;             (impc:ir:type? type)) ;; (note to andrew) remove this line for GC crash!
;; 	type
;;         (map (lambda (k)
;;                (if (list? k)
;;                    (if (= (length k) 1)
;;                        (car k)
;;                        k)
;;                    k))
;;              type))))

(define impc:ti:type-clean
  (lambda (type)
    (if (or (null? type)
            (atom? type)
            (impc:ir:type? type)) ;; (note to andrew) remove this line for GC crash!
        type
        (map (lambda (k)
               (if (list? k)
                   (if (= (length k) 1)
                       (impc:ti:type-clean (car k))
                       (impc:ti:type-clean k))
                   k))
             type))))

;; this is here for whenever we get
;; new 'argument' information about
;; a locally bound lambda which might help
;; us to derive new return type information
(define impc:ti:type-check-bound-lambda
  (lambda (sym vars kts t)
    (if (not (assoc-strcmp sym *impc:ti:bound-lambdas*))
        #f
        (let* ((f (cadr (assoc-strcmp sym *impc:ti:bound-lambdas*)))
               (args (cadr f))
               (body (caddr f))
               (estr (sexpr->string body))
               (recursive? (regex:match? estr (string-append "(" "\\(\\s*" (symbol->string sym) "\\s" ")|(\\(\\s*callback)")))
               (rettype '()))
          (if (not recursive?)
              (begin
                (if (not (null? t))
                    (for-each (lambda (x y)
                                ;; (println 'lambda 'x: x 'y: y)
                                (impc:ti:update-var x vars kts y))
                              args (cddr t)))
                (set! rettype (impc:ti:type-check (caddr (cadr (assoc-strcmp sym *impc:ti:bound-lambdas*)))
                                                  vars kts #f))
                (if (null? t)
                    (let ((argtypes (map (lambda (x)
                                           (cadr (assoc-strcmp x vars)))
                                         args)))
                      ;; (println 'update: sym 'with (cons 213 (cons (car rettype) argtypes)))
                      (impc:ti:update-var sym vars kts (cons 213 (cons(car rettype) argtypes)))))
                (if (impc:ir:type? rettype)
                    rettype
                    #f)))))))

;; 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)))
            (equal? sym t))
        'exit
        (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))
                    'exit)
                  (let ((pair (assoc-strcmp sym vars)))
                    (if pair
                        (let ((pair-rest (cdr pair)))
                          (if (or (impc:ir:type? t)
                                  (impc:ti:complex-type? t))
                              (begin
                                ;; 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)))
                                    (begin
                                      (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
                                     #f
                                     (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))))))
                    '())))))))


;; force a var to a particular type
;; (i.e. wipe out other choices)
;;
;; do allow force-var to overwrite kts values
(define impc:ti:force-var
  (lambda (sym vars kts t)

    (if (and (list? t)
             (= (length t) 1)
             (string? (car t)))
        (set! t (car t)))

    (set! t (impc:ti:type-clean t))
    ;; (println 't1: t)
    (set! t (impc:ti:type-normalize t vars))
    ;; (println 't2: t)
    ;;(if (equal? sym 'length) (begin (println '-> 'forcing 'length t))) ; (error)))
    ;;(if (equal? sym 'l) (println '-> 'forcing 'l t))
    ;;(println 'force-var:> sym 'in: vars 'with: t 'kts: kts)
    (if (and (not (assoc-strcmp sym vars))
             (not (impc:ti:closure-exists? (symbol->string sym)))
             (not (impc:ti:globalvar-exists? (symbol->string sym))))
        (impc:compiler:print-missing-identifier-error sym 'variable)
        (let ((pair (assoc-strcmp sym vars)))
          (if pair
              (if (impc:ir:type? t)
                  (begin
                    ;; 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)))
                    (set-cdr! pair (list t)))
                  (set-cdr! pair t))
              '())))))


(define impc:ti:get-var
  (lambda (sym vars)
    (if (not (symbol? sym))
        (impc:compiler:print-missing-identifier-error sym 'variable)
        (if (not (assoc-strcmp sym vars))
            (if (impc:ti:globalvar-exists? (symbol->string sym))
                (cons sym (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string sym))))
                (impc:compiler:print-missing-identifier-error sym 'variable))
            (assoc-strcmp sym vars)))))


;; clear all vars
(define impc:ti:clear-all-vars
  (lambda (vars)
    (map (lambda (x)
           (set-cdr! x '()))
         vars)))



;; resolve "string" types by looking up get-named-type
;; resolve 'symbol types by looking in vars
;; otherwise just return t
(define impc:ti:try-to-resolve-named-types
  (lambda (t vars)
    ;; check for named types
    (if (string? t)
        (let ((t (impc:ti:get-namedtype-type t))
              (ptr-level (impc:ir:get-ptr-depth t)))
          (dotimes (i ptr-level) (set! t (impc:ir:pointer++ t)))
          (list t))
        (if (symbol? t)
            (if (null? (assoc-strcmp t vars))
                '()
                (cdr (assoc-strcmp t vars)))
            t))))



(define impc:ti:numeric-check
  (lambda (ast vars kts request?)
    ;; (println 'numeric-check 'ast: ast (integer? ast) 'request? request?)
    (if *impc:ti:print-sub-checks* (println 'num:> 'ast: ast 'request? request?))
    (if (and request?
             (not (null? request?)))
        (cond ((symbol? request?)
               (let* ((t1 (impc:ti:symbol-check request? vars kts #f))
                      (t2 (impc:ti:numeric-check ast vars kts #f))
                      (t3 (cl:intersection t1 t2)))
                 (if (null? t1) t2 t3)))
              ((list? request?)
               (let* ((t1 (impc:ti:numeric-check ast vars kts #f))
                      (t2 (cl:intersection request? t1)))
                 t2))
              ((number? request?)
               (let* ((t1 (impc:ti:numeric-check ast vars kts #f))
                      (t2 (cl:intersection (list request?) t1)))
                 t2))
              ((string? request?)
               (let* ((t1 (impc:ti:numeric-check ast vars kts #f))
                      (t2 (cl:intersection (list request?) t1)))
                 t2))
              (else
               (print-with-colors 'red 'default #t (print "Compiler Error:"))
               (print "shouldn't reach here in numeric check il- request?: ")
               (print-with-colors 'blue 'default #f (print request?))
               (print "\nYou might be using a ")
               (print-with-colors 'blue 'default #t (print "pref"))
               (print " where you should be using a ")
               (print-with-colors 'blue 'default #t (print "tref"))
               (println)
               (throw "")))
        (if (integer? ast)  ;; preference goes to start of list
            (if (or (= 1 ast) (= 0 ast))
                (list *impc:ir:si64* *impc:ir:si32* *impc:ir:si16* *impc:ir:ui8* *impc:ir:i1*)
                (if (< ast 256)
                    (list *impc:ir:si64* *impc:ir:si32* *impc:ir:si16* *impc:ir:ui8*)
                    (list *impc:ir:si64* *impc:ir:si32* *impc:ir:si16*)))  ;*impc:ir:fp64* *impc:ir:fp32*))
            (list *impc:ir:fp64* *impc:ir:fp32*)))))


;; IS NEW
;; (define impc:ti:symbol-check
;;   (lambda (ast vars kts request?)
;;     ;; (println 'symchk ast 'vars: vars 'req: request?)
;;     (if (not (symbol? ast))
;;         (impc:compiler:print-compiler-error "Trying to symbol check a non-symbol" ast))
;;     ;; (println 'symcheck 'ast: ast 'request? request? (impc:ir:get-base-type (symbol->string ast)))
;;     (if (assoc-strcmp ast kts)
;;         (list (cdr (assoc-strcmp ast vars)))
;;         (if (and
;;              (assoc-strcmp ast vars)
;;              (impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars))
;;              (if request?
;;                  (equal? request? (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars))
;;                  #t))
;;             (begin ;;(println '.................really-saving-time! 'ast ast 'res: (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars) 'r request?)
;;               (list (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars)))
;;             (begin
;;               (if (and (symbol? ast)
;;                        (impc:ti:genericfunc-exists? (string->symbol (impc:ir:get-base-type (symbol->string ast)))))
;;                   (begin
;;                     (impc:compiler:print-compiler-error "Try forcing a type? Ambiguous generic function as value" ast)))
;;               (if (and (symbol? ast)
;;                        (impc:ti:polyfunc-exists? (impc:ir:get-base-type (symbol->string ast))))
;;                   (let ((pt (impc:ti:get-polyfunc-candidate-types (impc:ir:get-base-type (symbol->string ast)))))
;;                     (cond ((and (> (length pt) 1)
;;                                 (assoc request? pt))
;;                            (if (assoc-strcmp ast vars) (impc:ti:update-var ast vars kts (list request?)))
;;                            (set! ast (string->symbol (string-append (impc:ir:get-base-type (symbol->string ast))
;;                                                                     ":" (impc:ir:pretty-print-type request?)))))
;;                           ((= (length pt) 1)
;;                            (if (assoc-strcmp ast vars) (impc:ti:update-var ast vars kts pt))
;;                            (set! ast (string->symbol (string-append (impc:ir:get-base-type (symbol->string ast))
;;                                                                     ":" (impc:ir:pretty-print-type (car pt))))))
;;                           (else
;;                            (impc:compiler:print-compiler-error
;;                             "Try forcing a type? Ambiguous polymorphic function as a value" ast)))))
;;               (if *impc:ti:print-sub-checks* (println 'sym:> 'ast: ast 'request? request?))
;;               ;; if a request is made - assume it's forced
;;               ;; find the intersection between the request
;;               ;; and the current values and force that intersection
;;               (let ((polytype #f))
;;                 (if (and (not (assoc-strcmp ast vars))
;;                          (not (impc:ti:closure-exists? (symbol->string ast)))
;;                          (not (impc:ti:globalvar-exists? (symbol->string ast))))
;;                     (if (and (regex:match? (symbol->string ast) ":")
;;                              (or (impc:ti:genericfunc-exists?
;;                                   (string->symbol (car (regex:type-split (symbol->string ast) ":"))))
;;                                  (impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string ast) ":")))))
;;                         (let* ((p (regex:type-split (symbol->string ast) ":"))
;;                                (t (if (impc:ti:typealias-exists? (cadr p))
;;                                       (impc:ir:pretty-print-type (impc:ti:get-typealias-type (cadr p)))
;;                                       (cadr p)))
;;                                (etype (cname-encode (impc:ir:get-base-type t))))
;;                           ;; (println 'ast: ast 'etype: etype)
;;                           (begin
;;                             (set! request? #f)
;;                             (if (impc:ti:polyfunc-exists? (car p))
;;                                 (set! ast (string->symbol (string-append (car p) "_adhoc_" etype)))
;;                                 (set! ast (string->symbol (string-append (car p) "_poly_" etype))))
;;                             (set! polytype (impc:ir:get-type-from-pretty-str t))))
;;                         (begin (impc:compiler:print-missing-identifier-error ast 'symbol))))
;;                 (let ((type (if polytype polytype
;;                                 (if (assoc-strcmp ast vars)
;;                                     (cdr (assoc-strcmp ast vars))
;;                                     (if (impc:ti:closure-exists? (symbol->string ast))
;;                                         (list (cons (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (map impc:ir:get-type-from-str (impc:ti:get-closure-arg-types (symbol->string ast)))))
;;                                         (list (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string ast)))))))))
;;                   ;; (println '---------- (member ast kts) 'type: type (impc:ir:type? type))
;;                   (if (and request?
;;                            (not (member ast kts)) ;; if we're in KTS then we should ignore requests!
;;                            (not (null? request?)))
;;                       (if (null? type)
;;                           (begin
;;                             (impc:ti:update-var ast vars kts (list request?))
;;                             request?)
;;                           (let ((intersection (impc:ti:type-unify (list request? type) vars)))
;;                             ;; (println 'intersection intersection 'request? request? 'type: type 'ast: ast)
;;                             (if (not (null? intersection))
;;                                 (begin
;;                                   ;; andrew change
;;                                   (impc:ti:force-var ast vars kts (list intersection))
;;                                   ;;(impc:ti:force-var ast vars kts (list request?)) ;(list intersection))
;;                                   ;;(impc:ti:update-var ast vars kts (list intersection))
;;                                   (list intersection))
;;                                 type)))
;;                       type))))))))



(define impc:ti:symbol-check
  (lambda (ast vars kts request?)
    ;; (println 'symchk ast 'vars: vars 'req: request?)
    ;; (println 'symcheck 'ast: ast 'request? request? (impc:ir:get-base-type (symbol->string ast)))
    (cond ((not (symbol? ast))
           (impc:compiler:print-compiler-error "Trying to symbol check a non-symbol" ast))
          ((assoc-strcmp ast kts)
           (list (cdr (assoc-strcmp ast vars))))
          ((and
            (assoc-strcmp ast vars)
            (impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars))
            (if request?
                (equal? request? (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars))
                #t))
           (begin
             ;; (println '.................saving-time!)
             (list (impc:ti:type-unify (cdr (assoc-strcmp ast vars)) vars))))
          ((impc:ti:globalvar-exists? (symbol->string ast))
           (list (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string ast)))))
          (else
           (if (and (symbol? ast)
                    (impc:ti:genericfunc-exists? (string->symbol (impc:ir:get-base-type (symbol->string ast)))))
               (begin
                 (impc:compiler:print-compiler-error "Try forcing a type? Ambiguous generic function as value" ast)))
           (if (and (symbol? ast)
                    (impc:ti:polyfunc-exists? (impc:ir:get-base-type (symbol->string ast))))
               (let ((pt (impc:ti:get-polyfunc-candidate-types (impc:ir:get-base-type (symbol->string ast)))))
                 (cond ((and (> (length pt) 1)
                             (assoc request? pt))
                        (if (assoc-strcmp ast vars) (impc:ti:update-var ast vars kts (list request?)))
                        (set! ast (string->symbol (string-append (impc:ir:get-base-type (symbol->string ast))
                                                                 ":" (impc:ir:pretty-print-type request?)))))
                       ((= (length pt) 1)
                        (if (assoc-strcmp ast vars) (impc:ti:update-var ast vars kts pt))
                        (set! ast (string->symbol (string-append (impc:ir:get-base-type (symbol->string ast))
                                                                 ":" (impc:ir:pretty-print-type (car pt))))))
                       (else
                        (impc:compiler:print-compiler-error
                         "Try forcing a type? Ambiguous polymorphic function as a value" ast)))))
           (if *impc:ti:print-sub-checks* (println 'sym:> 'ast: ast 'request? request?))
           ;; if a request is made - assume it's forced
           ;; find the intersection between the request
           ;; and the current values and force that intersection
           (let ((polytype #f))
             (if (and (not (assoc-strcmp ast vars))
                      (not (impc:ti:closure-exists? (symbol->string ast)))
                      (not (impc:ti:globalvar-exists? (symbol->string ast))))
                 (if (and (string-contains? (symbol->string ast) ":")
                          (or (impc:ti:genericfunc-exists?
                               (string->symbol (car (regex:type-split (symbol->string ast) ":"))))
                              (impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string ast) ":")))))
                     (let* ((p (regex:type-split (symbol->string ast) ":"))
                            (t (if (impc:ti:typealias-exists? (cadr p))
                                   (impc:ir:pretty-print-type (impc:ti:get-typealias-type (cadr p)))
                                   (cadr p)))
                            (etype (cname-encode (impc:ir:get-base-type t))))
                       ;; (println 'ast: ast 'etype: etype)
                       (begin
                         (set! request? #f)
                         (if (impc:ti:polyfunc-exists? (car p))
                             (set! ast (string->symbol (string-append (car p) "_adhoc_" etype)))
                             (set! ast (string->symbol (string-append (car p) "_poly_" etype))))
                         (set! polytype (impc:ir:get-type-from-pretty-str t))))
                     (begin (impc:compiler:print-missing-identifier-error ast 'symbol))))
             (let ((type (if polytype polytype
                             (if (assoc-strcmp ast vars)
                                 (cdr (assoc-strcmp ast vars))
                                 (if (impc:ti:closure-exists? (symbol->string ast))
                                     (list (cons (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (map impc:ir:get-type-from-str (impc:ti:get-closure-arg-types (symbol->string ast)))))
                                     (list (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string ast)))))))))
               ;; (println '---------- (member ast kts) 'type: type (impc:ir:type? type))
               (if (and request?
                        (not (member ast kts)) ;; if we're in KTS then we should ignore requests!
                        (not (null? request?)))
                   (if (null? type)
                       (begin
                         (impc:ti:update-var ast vars kts (list request?))
                         request?)
                       (let ((intersection (impc:ti:type-unify (list request? type) vars)))
                         ;; (println 'intersection intersection 'request? request? 'type: type 'ast: ast)
                         (if (not (null? intersection))
                             (begin
                               ;; andrew change
                               (impc:ti:force-var ast vars kts (list intersection))
                               ;;(impc:ti:force-var ast vars kts (list request?)) ;(list intersection))
                               ;;(impc:ti:update-var ast vars kts (list intersection))
                               (list intersection))
                             type)))
                   type)))))))


(define *math-recursion-check-depth* 0)

(define impc:ti:math-check
  (lambda (ast vars kts request?)
    ;; cleanup request!
    (if (and (list? request?) (= 1 (length request?))) (set! request? (car request?)))
    ;; if request? is notype - make false
    (if (equal? request? *impc:ir:notype*) (set! request? #f))
    ;; if request is false
    (if (not request?)
        (begin (if (member (cadr ast) kts) (set! request? (cdr (assoc-strcmp (cadr ast) vars))))
               (if (member (caddr ast) kts) (set! request? (cdr (assoc-strcmp (caddr ast) vars))))))
    ;; now start type checking
    (let* ((n1 (cadr ast))
           (n2 (caddr ast))
           (a (impc:ti:type-unify (impc:ti:type-check n1 vars kts request?) vars))
           (b (impc:ti:type-unify (impc:ti:type-check n2 vars kts request?) vars))
           (t (impc:ti:type-unify (cl:remove #f (list (if (null? a) #f a) (if (null? b) #f b))) vars)))
      (if (equal? a #f) (set! a '()))
      (if (equal? b #f) (set! b '()))
      ;; (println 'math: 'a a 'b b 't t 'r request? 'ast: ast *math-recursion-check-depth*)

      (set! *math-recursion-check-depth* (+ *math-recursion-check-depth* 1))
      ;; if we can fully 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)))))
      ;; one more try for equality!
      (if (and
           (not (equal? a b))
           (impc:ir:type? t)
           (< *math-recursion-check-depth* 6))
          (begin
            (set! a (impc:ti:type-check n1 vars kts t))
            (set! b (impc:ti:type-check n2 vars kts t))))
      ;; and one more try
      (if (and
           (not (equal? a b))
           (< *math-recursion-check-depth* 6))
          (let* ((a2 (impc:ti:type-check n1 vars kts b))
                 (b2 (impc:ti:type-check n2 vars kts a))
                 (t2 (impc:ti:type-unify (list a2 b2) vars)))
            ;; (println 't2 t2 'a a 'b b 'a2 a2 'b2 b2 'ast ast)
            (if (impc:ir:type? t2)
                (begin (set! a t2)
                       (set! b t2)))))

      (set! *math-recursion-check-depth* 0)

      (if (and (not (equal? a b))
               (impc:ir:type? b)
               (impc:ir:type? a)
               (not (or (impc:ir:tuple? a)
                        (impc:ir:tuple? b)))
               (not (and (impc:ir:vector? a)   ;; we are allowed to multiply
                         (impc:ir:vector? b)))) ;; a Vector by a Vector*
          (impc:compiler:print-type-conflict-error (impc:ir:pretty-print-type a)
                                                   (impc:ir:pretty-print-type b)
                                                   ast))
      (if (and (impc:ir:type? t)
               (impc:ir:pointer? t)
               (not (impc:ir:tuple? t))
               (not (impc:ir:vector? t)))
          (impc:compiler:print-type-mismatch-error (impc:ir:pretty-print-type t) "number" (symbol->string (car ast))))
      (if *impc:ti:print-sub-checks* (println 'math:> 'ast: ast 'a: a 'b: b 't: t 'request? request?))
      (if (not (null? t))
          (begin (if (and (symbol? (cadr ast)) (not (impc:ir:tuple? t))) (impc:ti:force-var (cadr ast) vars kts t))
                 (if (and (symbol? (caddr ast)) (not (impc:ir:tuple? t))) (impc:ti:force-var (caddr ast) vars kts t))
                 (if (and (not (null? t)) ;; this here because math functions always return non-pointer vectors
                          (impc:ir:type? t)
                          (impc:ir:vector? t) ;; we want to do this because these vectors are always stack allocated
                          (impc:ir:pointer? t)) ;; also these vectors are immutable (i.e. cannot use vector-set!)
                     (impc:ir:pointer-- t)
                     t))
          (cond ((impc:ir:vector? a)
                 (if (symbol? (cadr ast)) (impc:ti:update-var (cadr ast) vars kts a))
                 (if (impc:ir:pointer? a) (impc:ir:pointer-- a) a))
                ((impc:ir:vector? b)
                 (if (symbol? (caddr ast)) (impc:ti:update-var (cadr ast) vars kts b))
                 (if (impc:ir:pointer? b) (impc:ir:pointer-- b) b))
                ((not (cl:find-if symbol? (cdr ast))) t) ;; return t
                ((and (symbol? (cadr ast))
                      (symbol? (caddr ast))
                      (not (null? (cdr (impc:ti:get-var (cadr ast) vars))))
                      (not (null? (cdr (impc:ti:get-var (caddr ast) 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 (cadr ast) vars kts '())
                 (impc:ti:force-var (caddr ast) vars kts '())
                 t) ;; and return t (which should be NULL)
                ((and (symbol? (cadr ast)) (not (null? b)))
                 (impc:ti:update-var (cadr ast) vars kts b) b) ;; return b
                ((and (symbol? (caddr ast)) (not (null? a)))
                 (impc:ti:update-var (caddr ast) vars kts a) a) ;; return a
                (else t))))))

(define impc:ti:math-intrinsic-check
  (lambda (ast vars kts request?)
    (if (equal? request? *impc:ir:notype*) (set! request? #f))
    (if (equal? request? (list *impc:ir:notype*)) (set! request? #f))
    ;; (println 'intrinsic: ast 'r: request?)
    (let* ((args (- (length ast) 1))
           (a (impc:ti:type-unify (impc:ti:type-check (cadr ast) vars kts request?) vars))
           (b (if (> args 1)
                  (impc:ti:type-unify (impc:ti:type-check (caddr ast) vars kts request?) vars)
                  #f))
           (c (if (> args 2)
                  (impc:ti:type-unify (impc:ti:type-check (cadddr ast) vars kts request?) vars)
                  #f)))
      (if (null? a) (set! a b))
      (if (null? b) (set! b a))
      ;; (println 'a a 'b b 'c c 'r: request? 'ast ast)
      ;; if (cadr ast) is a symbol update it
      (if (and (symbol? (cadr ast))
               (impc:ir:type? a))
          (impc:ti:update-var (cadr ast) vars kts a))
      (if (and (not (list? a))
               (impc:ir:fixed-point? a))
          (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type a)
                                              (string-append "Only real numbers are supported for math intrinsics: "
                                                             (symbol->string (car ast)))))
      (if (and (impc:ir:type? a)
               (impc:ir:vector? a)
               (impc:ir:pointer? a))
          (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type a)
                                              (string-append "\nVector math intrinsics do not support pointers\nTry dereferencing your vector: " (sexpr->string ast))))
      (if (and (impc:ir:type? a)
               (impc:ir:vector? a))
          (if (or (and (= (caddr a) 1)
                       (not (member (cadr a) '(4 8))))
                  (and (= (caddr a) 0)
                       (not (member (cadr a) '(2 4)))))
              (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type a)
                                                  (string-append "\nVector size not supported by math intrinsics\nFor floats try 4 or 8 - for doubles try 2 or 4\n" (sexpr->string ast)))))
      (if (and b
               (not (equal? a b))
               (not (number? (cadr ast)))
               (not (number? (caddr ast))))
          (impc:compiler:print-type-conflict-error (impc:ir:pretty-print-type a)
                                                   (impc:ir:pretty-print-type b)
                                                   ast)
          (if (and b
                   (not (equal? a b))
                   (number? (cadr ast)))
              (list b)
              (list a))))))

(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*)))))))


;; with _native functions
(define impc:ti:nativef-check
  (lambda (ast vars kts request?)
    ;; (println 'type-checking: (car ast))
    ;; (println 'native-check 'ast: ast 'vars: vars 'request: request?)
    (let* ((name (symbol->string (car ast)))
           (ftype (map impc:ir:get-type-from-str
                       (or (impc:ti:get-nativefunc-arg-types name)
                           (impc:ti:get-closure-arg-types name)))))
      (if *impc:ti:print-sub-checks* (println 'ftype:> 'ast: ast 'type: ftype))

      (if (<> (length ftype)
              (length ast))
          (impc:compiler:print-compiler-error "bad arity in call" ast))

      ;; we don't care what we get back because we already know the return type
      (for-each (lambda (a t)
                  ;; if a is a symbol then add type t to a
                  ;; we also know that for native functions there
                  ;; is no choice about the type so we should
                  ;; force it to the type not update it
                                        ;(if (symbol? a) (impc:ti:force-var a vars kts t))
                  (if (and t (symbol? a)) (impc:ti:update-var a vars kts t))
                  (impc:ti:type-check a vars kts t))
                (cdr ast)
                (cdr ftype))
      (list (car ftype)))))


;; this takes a type like
;; "%List--PFBhaXI6PGk2NCxpNjQ_KixMaXN0Kj4*"
;; which decodes to: "<Pair:<i64,i64>*,List*>"
;; and unwraps it into (114 (114 2 2) (114 !a List*))
;; it must be recursive because a naive unwrap gives
;; (114 "%Pair--..." "%List--...")
(define impc:ti:completely-unwrap-named-type
  (lambda (x)
    (if (and (string? x)
             (regex:match? x "^%")
             (string-contains? x "_poly_")
             (if (null? (impc:ti:get-named-type x))
                 (impc:compiler:print-missing-identifier-error x 'type)
                 #t))
        (let* ((gpolyname (regex:replace-all x "^%(.*)_poly_.*$" "$1"))
               (ptrdepth (impc:ir:get-ptr-depth x))
               (gpoly (cons (+ *impc:ir:tuple* (* *impc:ir:pointer* ptrdepth))
                            (map (lambda (x)
                                   (string->symbol x))
                                 (impc:ir:get-pretty-tuple-arg-strings
                                  (symbol->string (impc:ti:get-generictype-candidate-types gpolyname)))))))
          (impc:ti:completely-unwrap-named-type
           (replace-all (impc:ir:get-type-from-str (impc:ti:get-named-type x)) (list (cons x gpoly)))))
        (if (list? x)
            (map (lambda (y)
                   (impc:ti:completely-unwrap-named-type y))
                 x)
            x))))

(define impc:ti:descending-generic-type-match
  (lambda (a b)
    (cond ((equal? a b) #t)
          ((atom? a)
           (if (and (symbol? a)
                    (regex:match? (symbol->string a) "^!"))
               #t
               #f))
          ((atom? b)
           (if (and (symbol? b)
                    (regex:match? (symbol->string b) "^!"))
               #t
               #f))
          (else
           (if (member #f
                       (map (lambda (x y)
                              (impc:ti:descending-generic-type-match x y))
                            a b))
               #f #t)))))


;; match two explicit generic types!
;; returns true for a match of false for a fail
(define impc:ti:generic-types-matchup?
  (lambda (aa bb vars)
    ;; (println 'trying 'to 'match 'generic 'type aa 'against 'generic 'type bb)
    (if (or (not (symbol? aa))
            (not (or (string? bb) (symbol? bb)))
            (not (string-contains? (symbol->string aa) ":")))
        #f
        (let* ((a (symbol->string aa))
               (b (if (symbol? bb) (symbol->string bb) bb))
               (p1a (regex:type-split a "##"))
               (p1b (regex:type-split b "##"))
               (p2a (regex:type-split (car p1a) ":"))
               (p2b (regex:type-split (car p1b) ":"))
               (t1a (if (not (null? (cdr p2a)))
                        (impc:ir:get-type-from-pretty-str (cadr p2a)) '()))
               (t1b (if (not (null? (cdr p2b)))
                        (impc:ir:get-type-from-pretty-str (cadr p2b)) '()))
               (au (if (and (assoc-strcmp aa vars)
                            (= (length (cdr (assoc-strcmp aa vars))) 1))
                       (car (cdr (assoc-strcmp aa vars)))))
               (bu (if (and (assoc-strcmp bb vars)
                            (= (length (cdr (assoc-strcmp bb vars))) 1))
                       (car (cdr (assoc-strcmp bb vars))))))
          (if (and (null? bu) (regex:match? (car p2b) "^%"))
              (set! bu (car p2b)))
          (if (string? au)
              (set! t1a (impc:ti:completely-unwrap-named-type au)))
          (if (string? bu)
              (set! t1b (impc:ti:completely-unwrap-named-type bu)))
          ;; (println 'which 'is 'to 'match:)
          ;; (println t1a)
          ;; (println 'against:)
          ;; (println t1b)
          ;; now try to match on t1a and t1b
          (let* ((res (impc:ti:descending-generic-type-match t1a t1b)))
            ;; this for printing only
            ;; (if (not res)
            ;;     (begin
            ;;       (println 'match-failed: t1a 'vs t1b)
            ;;       (println 'A: aa)
            ;;       (println 'B: bb)))
            res)))))


;; type inferencing for generic functions arguments
(define impc:ti:nativef-generics-check-args
  (lambda (ast gpoly-type vars kts request?)
    ;; (println 'generic-check-args 'ast: ast 'vars: vars)
    ;; (println '____ast: ast)
    ;; (println 'generic-type: gpoly-type)

    ;; type inferencing for generic functions arguments
    (map (lambda (a gt)
           ;; (println 'arg-in: a 'gt: gt)
           ;; gt for generics type
           (let ((tt (impc:ti:type-check a vars kts gt))
                 (subcheck #t))
             ;; (println 'arg-in: a 'gt: gt 'tt: tt)
             ;; (println 'vars: vars)

             ;; generics are unforgiving to choice
             ;; so if we have number choice then
             ;; let's always force i64 or double
             (if (or (equal? tt (list *impc:ir:si64* *impc:ir:si32*))
                     (equal? tt (list *impc:ir:si64* *impc:ir:si32* *impc:ir:si16*))
                     (equal? tt (list *impc:ir:si64* *impc:ir:si32* *impc:ir:si16* *impc:ir:ui8*))
                     (equal? tt (list *impc:ir:si64* *impc:ir:si32* *impc:ir:si16* *impc:ir:ui8* *impc:ir:i1*)))
                 (set! tt (list *impc:ir:si64*)))
             (if (equal? tt (list *impc:ir:fp64* *impc:ir:fp32*))
                 (set! tt (list *impc:ir:fp64*)))

             ;; (println 1 'a: a 'tt: tt 'gt: gt)
             (if (and (list? tt) (= (length tt) 1)) (set! tt (car tt)))

             (if (and (atom? gt)
                      (symbol? gt)
                      (assoc-strcmp gt vars)
                      (if (string-contains? (symbol->string gt) ":")
                          (impc:ti:generic-types-matchup? gt tt vars)
                          #t))
	     	 (begin ;; (println '----matched-polytype-1: gt '-> tt)
	     	   (if (symbol? tt)
               (begin
                 (if (not (assoc-strcmp tt vars))
                     (set! vars (cons (list tt) vars)))
                 (if (null? (cdr (assoc-strcmp tt vars)))
                     (impc:ti:update-var gt vars kts (list tt))
                     (begin
                       (impc:ti:update-var gt vars kts (impc:ti:type-unify (cdr (assoc-strcmp tt vars)) vars)))))
                 (impc:ti:update-var gt vars kts (impc:ti:type-unify tt vars)))))

	     (if (atom? tt)
		 (set! tt (list tt)))
	     (if (and (list? tt)
		      (list? (car tt))
		      (not (atom? gt)))
		 (set! tt (car tt)))
	     (if (atom? gt)
		 (set! gt (list gt)))
	     ;(println 2 'a: a 'tt: tt 'gt: gt)
	     ;; if gt and tt still not equal tt maybe a named-type
	     (if (<> (length gt) (length tt))
           (if (and
                (not (null? tt))
                (string? (car tt)) ;; named type?
                (not (null? (llvm:get-named-type (car tt))))
			  (= (length gt) (length (impc:ir:get-type-from-str (llvm:get-named-type (car tt))))))
		     (set! tt (impc:ir:get-type-from-str (llvm:get-named-type (car tt))))
		     (set! subcheck #f)))
		     ;;(print-error 'Compiler 'Error: 'type 'mismatch 'in 'generics gt '- tt)))

	     ;; GCHANGE
	     ;; we might be able to update-vars based by matching our request 'gt vs our result 'tt
	     (if subcheck
		 (for-each
		  (lambda (aa bb)
		    ;; (println 'matched-polytype-2: aa '-> bb)
                    ;; (println 'vars: vars)
                    (if (and (atom? aa)
                             (symbol? aa)
                             (assoc-strcmp aa vars)
                             (if (string-contains? (symbol->string aa) ":")
                                 (impc:ti:generic-types-matchup? aa bb vars)
                                 #t))
                        (if (and (symbol? bb) (assoc-strcmp bb vars))
                            (begin
                                        ;(set! tt (impc:ti:type-unify (cdr (assoc-strcmp bb vars)) vars))
                                        ;(impc:ti:update-var aa vars kts tt))
                              (impc:ti:update-var aa vars kts (cdr (assoc-strcmp bb vars))))
                            (if (string? bb)
                                (impc:ti:update-var aa vars kts bb)
                                (impc:ti:update-var aa vars kts (list bb))))))
                  gt tt))
             tt))
         (cdr ast)
         (cddr gpoly-type))))


;; adds ##gnum's to all poly types
(define impc:ti:nativef-generics-make-gtypes-unique
  (lambda (pt gnum)
    (cond ((null? pt) '())
          ((symbol? pt)
           ;; (println 'bingo pt)
           (cond ((regex:match? (symbol->string pt) "^!") ;; check for !head and !head%b
                  (let ((kk (string->symbol (string-append (symbol->string pt) "##" (number->string gnum)))))
                    ;; (println 'pt1: pt 'kk: kk)
                    kk))
                 ;; check for xlist*
                 ((or (if (and (regex:match? (symbol->string pt) "(:|{)")
                               (assoc-strcmp (string->symbol (car (impc:ti:split-namedtype pt)))
                                             *impc:ti:generictype-cache*))
                          #t #f)
                      (assoc-strcmp (string->symbol (impc:ir:get-base-type (symbol->string pt)))
                                    *impc:ti:generictype-cache*))
                  (let ((kk (string->symbol (string-append (symbol->string pt) "##" (number->string gnum)))))
                    ;; (println 'pt2: pt 'kk: kk)
                    kk))
                 ;; check for xlist%b*
                 ((and (string-contains? (symbol->string pt) "%") ;; check for
                       (assoc-strcmp (string->symbol (impc:ir:get-base-type (car (regex:split (symbol->string pt) "%")))) *impc:ti:generictype-cache*))
                  (let ((kk (string->symbol (string-append (symbol->string pt) "##" (number->string gnum)))))
                    ;; (println 'pt3: pt 'kk: kk)
                    kk))
                 (else
                  ;; (println 'pt: pt 'kk: pt)
                  pt)))
          ((pair? pt)
           (cons (impc:ti:nativef-generics-make-gtypes-unique (car pt) gnum)
                 (impc:ti:nativef-generics-make-gtypes-unique (cdr pt) gnum)))
          (else pt))))


;; this attempts to update-var !bangs from reified types and also GTypes
;; i.e. if we have allready resolved xlist*##289 to %xlist--2812497382948
;; but we have failed to resolve !head##289
;; then we try to get back from %xlist--2812497382948 to set !head##289
(define impc:ti:reverse-set-bangs-from-reified
  (lambda (poly reified gnum vars)
    ;; (println 'reverse-bangs: poly 'gnum: gnum)
    ;; (println 'vars vars)    
    ;; (println 'reified: reified)
    ;; (println 'pretty: (impc:ir:pretty-print-type reified))
    ;; (println 'okpretty)
    (if (and (not (list? poly))
             (or (not (symbol? poly))
                 (not (regex:match? (symbol->string poly) "(:|{)"))))
        'done ;; we can only check reified if poly IS a list (not a reference to a list!)
        (let* ((prettyreified (impc:ir:pretty-print-type reified))
               (sss (if (list? poly) "" (car (regex:type-split (symbol->string poly) "##"))))
               ;; (gpolytype (if (list? poly) poly (impc:ir:get-type-from-pretty-str sss)))
               (namedtype (impc:ir:get-type-from-str (impc:ti:get-named-type reified)))
               (gpolytype (if (list? poly) poly
                              (cons (car namedtype) (impc:ir:get-type-from-pretty-tuple
                                        (cadr (impc:ti:split-namedtype (impc:ti:maximize-generic-type sss))))))))
          ;; (println 'poly: poly 'gnum gnum)
          ;; (println 'reified: (impc:ti:get-named-type reified))
          ;; (println 'polyt: gpolytype)
          ;; (println 'named: namedtype)
          (if (<> (length gpolytype)
                  (length namedtype))
              ;; (impc:compiler:print-type-mismatch-error (list poly
              ;; gpolytype) (list reified namedtype)))
              '()
              (for-each (lambda (a b)
                          ;; (println 'a: a 'b: b)
                          (if (symbol? b)
                              (if (regex:match? (symbol->string b) "^!")
                                  (impc:ti:update-var
                                   (string->symbol (string-append (symbol->string b) "##" (number->string gnum)))
                                   vars '() a)))
                          (if (and (string? a)
                                   (not (string=? a reified)) ;; watch out for recursive!
                                   (string-contains? a "_poly_"))
                              (impc:ti:reverse-set-bangs-from-reified b a gnum vars)))
                        namedtype gpolytype))))))

;;
;; first for generic functions we do a gnum test
;;
;; basically the gnum test looks to see if all of the types
;; in the gftype are of the same gnum as the generic function
;; if they aren't of the same gnum (i.e. if they are NEW links)
;; then we might be able to do additonal reverse lookups on the
;; OLD gnum vars by looking into NEW gnum vars
;;
;; for example:
;; if ORIGINAL type (gpoly-type) = (211 !head##110 xlist*##110)
;; and NEW type         (gftype) = (211 !head##110 xlist*##109)
;; then we might be able to match !head##110 against !head##109
;;
(define impc:ti:nativef-generics-final-tests
  (lambda (ast gpoly-type gftype gnum vars kts)
    ;; (println 'nativef-generics-final-tests)
    ;; do a final check of all !bang types in original gpoly-type to see
    ;; if we can improve them with any reified types we may have
    (for-each (lambda (k)
                (if (symbol? k)
                    (if (assoc-strcmp k vars) ;;(not (null? (assoc-strcmp k vars)))
                        (let ((v (cdr (assoc-strcmp k vars))))
                          (if (string? v)
                              (impc:ti:reverse-set-bangs-from-reified k v gnum vars)
                              (if (and (list? v)
                                       (= (length v) 1)
                                       (string? (car v)))
                                  (impc:ti:reverse-set-bangs-from-reified k (car v) gnum vars)))))))
              (cdr gpoly-type))
    ;; attempt to reify any gtype symbols that don't currenty have type values (i.e. not var entry)
    (for-each (lambda (a)
                (if (and (symbol? a)
                         (string-contains? (symbol->string a) "##")
                         (not (assoc-strcmp a vars)))
                    ;; (null? (cdr (assoc-strcmp a vars))))
                    ;; should call this impc:ti:symbol-tryto-reify-generic-type
                    (let ((res (impc:ti:reify-generic-type a vars '())))
                      (if (not (equal? res a))
                          (begin ;; (println 'genupdate: a '-> res)
                            (impc:ti:update-var a vars kts res))))))
              (cdr gftype))

    #t))


;; recursion test
(define *impc:ti:nativef-generics-recurse-test* 0)

(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)
          (begin
            (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)))
                        vars)

              ;; update newvars to include incoming argument types
              (for-each (lambda (s t a)
                          ;; (println 's: s 't: t 'a: a)
                          (if (and (impc:ir:closure? t) (assoc-strcmp a *impc:ti:bound-lambdas*))
                              (set! *impc:ti:bound-lambdas*
                                    (cons (cons s (replace-all (cdr (assoc-strcmp a *impc:ti:bound-lambdas*))
                                                               (list (cons a s))))
                                          *impc:ti:bound-lambdas*)))
                          (impc:ti:update-var s newvars '() (impc:ti:type-unify t vars))
                          )
                        (if (eq? (car s1) 'lambda)
                            (cadr s1) ;; lambda arguments
                            (cadr (cl:find-if (lambda (x) (if (and (list? x) (eq? (car x) 'lambda)) #t #f))
                                              s1))) ;; this case here for generic starting with let not a lambda!
                        args
                        (cdr ast))
              ;; NOW DO ACTUAL TYPE CHECK!
              (let ((toplvl? (if *impc:compiler:top-level-generic-error* #f #t)))
                (if toplvl? (set! *impc:compiler:top-level-generic-error*
                                  (cons (car (regex:type-split (symbol->string (car ast)) "##"))
                                        (map (lambda (t a)
                                               ;; (println 't: t 'a: a)
                                               (if (null? t)
                                                   (if (atom? a)
                                                       (cons "?" (atom->string a))
                                                       (sexpr->string a))
                                                   (cons (impc:ir:pretty-print-type t)
                                                         (if (atom? a)
                                                             (atom->string a)
                                                             (sexpr->string a)))))
                                             args
                                             (cdr ast)))))
                (set! ttype (impc:ti:type-check t1 newvars kts trequest))
                (if toplvl? (set! *impc:compiler:top-level-generic-error* #f)))
              ;; don't let any local vars (lvars) escape back up to a
              ;; level where they will not mean anything!!!!
              (set! ttype (replace-all ttype (map (lambda (x) (cons x '())) lvarnames)))
              (set! *impc:ti:nativef-generics-recurse-test* (- *impc:ti:nativef-generics-recurse-test* 1))
              (if (< *impc:ti:nativef-generics-recurse-test* 0)
                  (set! *impc:ti:nativef-generics-recurse-test* 0))
              (if (and (not (null? ttype))
                       (impc:ir:closure? (car ttype)))
                  ;; (impc:ir:type? (cadar ttype)))
                  (begin
                    ;; (println 'done ttype)
                    (set! grtype ttype)))))
          (if (= *impc:ti:nativef-generics-recurse-test* 5)
              (begin
                (set! *impc:ti:nativef-generics-recurse-test*
                      (+ *impc:ti:nativef-generics-recurse-test* 1))
                #f)
              (begin ;; (println 'hit-recursion-limit)
                ;; (println 'vars vars)
                (print-error 'Compiler 'Error: 'hit 'generics 'recursion 'limit 'request req?)
                #f)))
      ;; (if (not (equal? gpoly-type (car grtype)))
      ;;     (begin (println 'RET: gpoly-type '-> grtype)
      ;;            (println '-----------------)))
      grtype)))


(define impc:ti:strip-named-type
  (lambda (t)
    (if (symbol? t) (set! t (symbol->string t)))
    (if (not (string? t))
        (impc:compiler:print-bad-type-error t "Should be named type!")
        (let ((ptrdepth (impc:ir:get-ptr-depth t)))
          (if (regex:match? t "^[A-Za-z0-9]*:")
              (apply string-append (car (regex:type-split t ":")) (make-list ptrdepth "*"))
              (if (regex:match? t "^[A-Za-z0-9]*{")
                  (apply string-append (car (regex:type-split t "{")) (make-list ptrdepth "*")))
              t)))))


(define impc:ti:variable-substitution-pairs
  (lambda (t1 t2)
    (if (or (not (list? t1))
            (not (list? t2))
            (<> (length t1) (length t2)))
        '()
        (let ((pairs
               (flatten (map (lambda (a b)
                               (cond ((list? a)
                                      (impc:ti:variable-substitution-pairs a b))
                                     ((atom? a)
                                      (if (and (impc:ir:type? a)
                                               (symbol? b)
                                               (regex:match? (symbol->string b) "^!"))
                                          (cons (symbol->string b) (impc:ir:pretty-print-type a))))
                                     (else '())))
                             t1 t2))))
          pairs))))

(define impc:ti:variable-substitution
  (lambda (type t1 t2 gnum vars kts)
    ;; (println 'variable-sub-in type)
    (let ((pairs (impc:ti:variable-substitution-pairs t1 t2))
          (newtype (sexpr->string type)))
      (for-each (lambda (x)
                  ;; (println 'updatevar:
                  ;;          (string->symbol (string-append (car x) "##" (number->string gnum)))
                  ;;          'with:
                  ;;          (impc:ir:get-type-from-pretty-str (cdr x)))
                  (impc:ti:update-var (string->symbol (string-append (car x) "##" (number->string gnum)))
                                      vars kts (list (impc:ir:get-type-from-pretty-str (cdr x))))
                  ;; (println 'x x (impc:ir:get-type-from-pretty-str (cdr x)))
                  (if (impc:ir:type? (impc:ir:get-type-from-pretty-str (cdr x)))
                      (set! newtype (regex:replace-all newtype
                                                       (string-append (car x) "##" (number->string gnum))
                                                       (if (string? (impc:ir:get-type-from-pretty-str (cdr x)))
                                                           (string-append "\""
                                                                          (impc:ir:get-type-from-pretty-str (cdr x))
                                                                          "\"")                       
                                                           (sexpr->string (impc:ir:get-type-from-pretty-str (cdr x))))))
                      (set! newtype (regex:replace-all newtype (car x) (cdr x)))))
                pairs)
      ;; (if (not (null? pairs)) (println 'newt: newtype (impc:ir:type? newtype)))
      ;; (println 'variable-sub-out (string->sexpr newtype))  
      (string->sexpr newtype))))

(define impc:ti:get-type-for-gpoly
  (lambda (t)
    (cons (real->integer (+ *impc:ir:closure* (* (+ (impc:ir:get-ptr-depth t) 1) *impc:ir:pointer*)))
          (map (lambda (k)
                 ;; (println 'kk k)
                 (if (regex:match? k "^\\[")
                     (impc:ti:get-type-for-gpoly k)
                     (if (string-contains? k ":") ;; if generic either gvar of named type
                         (string->symbol k)
                         (if (regex:match? k "^[A-Za-z0-9]*{")
                             (string->symbol k)
                             (impc:ir:get-type-from-pretty-str k)))))
               (impc:ir:get-pretty-closure-arg-strings t)))))


(define *impc:ti:nativef-generics:calls* 0)

;; generics check
(define impc:ti:nativef-generics
  (lambda (ast vars kts request?)
    (set! *impc:ti:nativef-generics:calls* (+ *impc:ti:nativef-generics:calls* 1))
    ;; (println 'native: *impc:ti:nativef-generics:calls* ast 'request: request?)
    ;; (println 'vars: vars)
    ;; (println 'genericf-in: (assoc-strcmp (car ast) vars))
    (set! impc:ir:get-type-expand-poly #f)
    (if (or (null? request?)
            (and (list? request?)
                 (equal? (car request?) *impc:ir:notype*)))
        (set! request? #f))
     ;; flatten request
    (if (and request? 
             (list? request?)
             ;; (not (impc:ir:complex-type? request?))
             (not (impc:ir:type? request?)) ;
             (impc:ir:type? (car request?)))
        (set! request? (car request?)))    
    (if (not (impc:ir:type? request?))
        (set! request? #f))
    ;; 
    ;; (println 'generics-check (car ast) 'request: request?)    
    ;; only check if not already fully formed!
    (cond ((assoc-strcmp (car ast) kts)
           ;; (println 'leave-early1: ast ': (assoc-strcmp (car ast) kts))
           (begin
             (for-each (lambda (x r)
                         (impc:ti:type-check x vars kts r))
                       (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)))))
          ((impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars))
           ;; (println 'leave-early2: ast ': (assoc-strcmp (car ast) vars)) ;;(assoc-strcmp (car ast) vars))
           (begin
             (for-each (lambda (x r)
                         (impc:ti:type-check x vars kts r))
                       (cdr ast)
                       (cddr (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars)))
             ;; (println 'hit: (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* ((args (map (lambda (x)
                               ;; (println ast 'check x)
                               (impc:ti:type-unify (impc:ti:type-check x vars kts #f) vars))
                             (cdr ast)))
                  (gname (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))
                  (gnum (string->number (cadr (regex:split (symbol->string (car ast)) "##"))))
                  (arity (- (length ast) 1))
                  ;; (lll (println 'gname gname arity (if request? (cons request? args) args)))
                  (gpt (impc:ti:genericfunc-types gname arity (if request? (cons request? args) args)))
                  ;; request? request? args)))
                  (gpoly-code (cadr gpt))
                  (constraint (cadddr gpt))
                  (constraint-code (if (not constraint) #f (if (symbol? constraint) (get-closure-code (eval constraint)) constraint)))
                  (lambda-code (caddr gpoly-code))
                  (gtype (impc:ir:get-type-from-pretty-str (symbol->string (car gpt))))
                  (gpoly-type (impc:ti:get-type-for-gpoly
                               (cadr (regex:type-split (symbol->string (cadr gpoly-code)) ":"))))
                  (gpoly-type-orig (impc:ti:nativef-generics-make-gtypes-unique gpoly-type gnum)))
             ;; (println "gpt:" gpt)
             ;; (println "gtype:" gtype)
             ;; (println "args:" args)
             ;; (println "args2:" args2)
             ;; (println "constraint:" constraint)
             ;; (println "constraint-code:" constraint-code)

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             ;; it is possible for some generic types to be missed from 'vars'
             ;; due to the fact that a different gpoly (overridden generic) choice
             ;; was made when initially seeding 'vars'
             ;; so ... at this point we check and inject missing arg types into vars
             ;;
             (for-each (lambda (a)
                         (if (regex:match? a "^([a-zA-Z]|!)")
                             (if (and (not (assoc-strcmp (string->symbol (string-append a "##" (number->string gnum))) vars))
                                      (regex:match? a "(:|!|{)"))
                                 (let ((newsymm (string->symbol (string-append a "##" (number->string gnum))))
                                       (all-syms (cl:remove-duplicates (map (lambda (aa)
                                                                              (string->symbol (string-append aa "##" (number->string gnum))))
                                                                            (regex:match-all a "![^,}>\\]]*")))))
                                   ;; (println 'all all-syms 'new newsymm)
                                   (set! all-syms (remove (symbol->string newsymm) all-syms))
                                   ;; (println 'adding_p newsymm 'gnum gnum) ;newsym newsymm)
                                   ;; add newsym
                                   (set-cdr! vars (cons (list newsymm) (cdr vars)))
                                   ;; add all-syms
                                   (for-each (lambda (x)
                                               (if (and (not (assoc-strcmp x vars))
                                                        (regex:match? (symbol->string x) "^([a-zA-Z]|!)"))
                                                   (begin
                                                     ;; (println 'adding_sub x 'gnum gnum)
                                                     (set-cdr! vars (cons (list x) (cdr vars)))
                                                     ;;(set! vars (cons (list (string->symbol x)) vars))
                                                     )))
                                             all-syms)))))
                       (impc:ir:get-pretty-closure-arg-strings (cadr (regex:type-split (symbol->string (cadr gpoly-code)) ":"))))

             (if (<> (length (cdr gpoly-type))
                     (length ast))
                 (impc:compiler:print-compiler-error "bad arity in generics call" ast))

             ;; add ##gnum's to all gpoly types (both !bangs like !head and gpoly types like xlist*)
             (set! gpoly-type
                   (impc:ti:type-unify
                    (impc:ti:nativef-generics-make-gtypes-unique gpoly-type gnum)
                    vars))

             ;; if there is a valid request (return type) add it to gpoly-type!
             ;; (println '--> request? request? 'gpolyt gpoly-type)
             (if (and request? (impc:ir:type? request?))
                 ;; (set! gpoly-type (cons (car gpoly-type) (cons request? (cddr gpoly-type)))))
                 (begin
                   (if (symbol? (cadr gpoly-type))
                       (begin
                         ;; (println 'g-return-update: (cadr gpoly-type) 'with request?)
                         (if (not (member (cadr gpoly-type) vars))
                             (set-cdr! vars (cons (list (cadr gpoly-type)) (cdr vars))))
                         (impc:ti:update-var (cadr gpoly-type) vars kts (list request?))))
                 (set! gpoly-type (cons (car gpoly-type) (cons request? (cddr gpoly-type))))))
             (let* ((a gpoly-type)
                    (b (map (lambda (x)
                              (if (and (string? x)
                                       (regex:match? x "^[A-Za-z0-9]*{"))
                                  (impc:ti:get-generic-type-as-tuple x)
                                  x))
                            gpoly-type))
                    (c gtype))
               ;; (println 'a a)
               ;; (println 'b b)
               ;; (println 'c c)
               (set! gpoly-type (impc:ti:variable-substitution a b c gnum vars kts))
               ;; (println 'd gpoly-type)
               (set! gpoly-type (map (lambda (x)
                                       (if (symbol? x)
                                           (let ((p (regex:split (symbol->string x) "##")))
                                             (if (and (string-contains? (car p) "{")
                                                      (impc:ir:type? (impc:ir:get-type-from-pretty-str (car p))))
                                                 (impc:ir:get-type-from-pretty-str (car p))
                                                 x))
                                           x))
                                     gpoly-type))
               ;; (println 'e2 gpoly-type)
               gpoly-type)
             (if (impc:ir:type? gpoly-type)
                 (begin
                   ;; (println 'update-a: (car ast) 'with: gpoly-type)
                   (impc:ti:update-var (car ast) vars kts gpoly-type)
                   (cadr gpoly-type))
                 (begin
                   ;; excercise the actual generic code! (if we don't have a type yet!)
                   (let* ((req? (impc:ti:type-unify gpoly-type vars))
                          (res (impc:ti:nativef-generics-check-args ast gpoly-type vars kts request?))
                          (resb (map (lambda (x) (impc:ti:type-unify x vars)) res))
                          (newgtype (cons (car req?)
                                          (cons (if (impc:ir:type? request?)
                                                    request?
                                                    (cadr req?))
                                                (map (lambda (a b c)
                                                       (if (impc:ir:type? a) a
                                                           (if (impc:ir:type? b) b
                                                               c)))
                                                     resb args (cddr req?)))))
                          ;; (lll (println 'resb: resb 'req? req? 'requst request? 'args args))
                          (nvars '()) ;; don't do copy unless we need it ;(cl:tree-copy vars))
                          (rtype (cond ((impc:ir:type? newgtype)
                                        newgtype)
                                        ((impc:ir:type? req?)
                                         newgtype)
                                        ((equal? gpoly-type gpoly-type-orig) ;; no new information!
                                         newgtype)
                                        ((and (equal? gname *impc:ti:type-check-function-symbol-short*) ;; this for recursive generic
                                              (impc:ir:type? (cadr (assoc-strcmp *impc:ti:type-check-function-symbol* vars))))
                                         (cadr (assoc-strcmp *impc:ti:type-check-function-symbol* vars)))
                                        (else
                                         (set! nvars (cl:tree-copy vars))
                                         (impc:ti:nativef-generics-check-return-type
                                          ast lambda-code gpoly-type gnum nvars (cddr newgtype)
                                          (if (impc:ir:type? request?) request? #f)))))
                          (grtype (impc:ti:type-unify rtype vars)))
                     ;; we might have gained something useful in nvars!
                     ;; that we can use for vars!
                     ;; have to be careful that it is a fully valid type though!
                     ;; otherwise we might introduce dependencies from inside
                     ;; a generic call that we should not have access to
                     (for-each (lambda (n v)
                                 (if (and (null? (cdr v))
                                          (= (length n) 2)
                                          (impc:ir:type? (cadr n)))
                                     (begin
                                       ;; (println 'update-b: (car v) 'with: (cdr n))
                                       (impc:ti:update-var (car v) vars kts (cdr n)))))
                               nvars vars)
                     ;; check to see if for-each is possible (i.e. request and (cadr gpoly-type)) are same length
                     ;; (if (list? request?)
                     ;;     (if (and (list? (cadr gpoly-type))
                     ;;              (<> (length request?) (length (cadr gpoly-type))))
                     ;;         (set! request? #f))
                     ;;     (if (list? (cadr gpoly-type))
                     ;;         (if (and (string? request?) ;; named type?
                     ;;                  (= (length (cadr gpoly-type)) (length (impc:ti:get-namedtype-type request?))))
                     ;;             (set! request? (impc:ti:get-namedtype-type request?))
                     ;;             (set! request? #f))
                     ;;         (if (<> (length (list request?)) (length (list (cadr gpoly-type))))
                     ;;             (set! request? #f))))

                     ;; (if (and request?
                     ;;          (not (string? (cadr gpoly-type))))
                     ;;     (if (and (list? request?)
                     ;;              (atom? (cadr gpoly-type))
                     ;;              (symbol? (cadr gpoly-type)))
                     ;;         (begin
                     ;;           ;; (println 'update-c: (cadr gpoly-type) 'with: request?)
                     ;;           (impc:ti:update-var (cadr gpoly-type) vars kts request?))
                     ;;         (if (and (list? request?)
                     ;;                  (number? (cadr gpoly-type))
                     ;;                  (member (cadr gpoly-type) request?))
                     ;;             (set! request? (cadr gpoly-type))
                     ;;             (for-each
                     ;;              (lambda (aa bb)
                     ;;                (if (and (atom? aa)
                     ;;                         (symbol? aa)
                     ;;                         (assoc-strcmp aa vars))
                     ;;                    (begin
                     ;;                      ;; (println 'update-d: aa 'with: bb)
                     ;;                      (impc:ti:update-var aa vars kts bb))))
                     ;;              (if (atom? request?)
                     ;;                  (list (cadr gpoly-type))
                     ;;                  (cadr gpoly-type))
                     ;;              (if (atom? request?)
                     ;;                  (list request?)
                     ;;                  request?)))))

                     ;; if request? is not a fully formed type
                     ;; then we will stick to the the current poly type
                     (if (not (impc:ir:type? request?))
                         (set! request? #f))

                     ;; (println 'ast: 'preset: vars)
                     ;; set generic functions type ( (cadr gpoly-type)|request? + res)
                     (let ((gftype (if request?
                                       (list (cons (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))
                                                   (cons (list request?) resb)))
                                       (list (cons (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))
                                                   (cons (list (cadr gpoly-type)) resb))))))

                       ;; (println 'gftype1: gftype 'gpoly-type gpoly-type)
                       (set! gftype (impc:ti:type-clean (car gftype)))
                       ;; (println 'gftype2: gftype)

                       ;; don't seem to need this anymore :(  ???
                       ;; (impc:ti:nativef-generics-final-tests ast gpoly-type gftype gnum vars kts)

                       ;; (println 'pre ast 'grtype grtype 'gftype gftype 'constraint constraint)
                       (if (null? grtype) (set! grtype gftype))
                       
                       ;; apply any type constraints check!
                       (if (and (not (null? grtype)) 
                                constraint)
                           (let* ((lgrtype (if (= (length grtype) (+ 2 arity)) ;; in case grtype is a list of multiple closure options rather than 1 specific closure type
                                               grtype
                                               (car (cl:remove-if-not (lambda (x)
                                                                        (impc:ir:closure? x))
                                                                      grtype))))
                                  (chk (if (and (list? (cadr constraint-code))
                                                (<> (length (cdr lgrtype))
                                                    (length (cadr constraint-code))))
                                          'false
                                          (apply (eval constraint)
                                                 (map (lambda (x)
                                                        (if (string? x)
                                                            (apply string-append
                                                                   (car (regex:split (impc:ir:pretty-print-type x) "{"))
                                                                   (make-list (impc:ir:get-ptr-depth x) "*"))
                                                            x))
                                                      (cdr lgrtype)))
                                          #t)))
                             (if (boolean? chk)
                                 (if chk
                                     'great
                                     (impc:compiler:print-constraint-error
                                      (car (regex:split (atom->string (car ast)) "##"))
                                      (impc:ir:pretty-print-type grtype)
                                      constraint
                                      ast))
                                 (if (impc:ir:type? chk)
                                     (set! grtype chk)
                                     (impc:compiler:print-compiler-error
                                      (string-append "Poorly defined constraint check: "
                                                     (sexpr->string constraint)
                                                     " for generic call "
                                                     (sexpr->string ast)
                                                     " for type "
                                                     (if (impc:ir:type? grtype)
                                                         (impc:ir:pretty-print-type grtype)
                                                         "<uknown>")))))))
                                 
                       ;; (println 'post ast 'constraint 'grtype grtype 'gftype gftype)                           
                       ;; if grtype is VALID
                       ;; and if the return type of gftype is a symbol
                       ;; THEN update the return type of gftype (symbol)
                       ;; with the reified return type of grtype
                       (if (and (impc:ir:type? grtype)
                                (symbol? (cadr gftype))
                                (assoc-strcmp (cadr gftype) vars))
                           (begin
                             ;; (println 'update-e: (cadr gftype) 'with: (cadr grtype))
                             (impc:ti:update-var (cadr gftype) vars kts (cadr grtype))))

                       ;; update arguments?!
                       (map (lambda (x y)
                              (if (symbol? x)
                                  (begin ;; (println 'update-f: x 'with: (list y))
                                         (impc:ti:update-var x vars kts (list y)))))
                            (cdr ast)
                            (cddr gftype))

                       (if (impc:ir:type? grtype)
                           (begin
                             ;(println 'udpate-g: (car ast) 'with: (list grtype))
                             (impc:ti:update-var (car ast) vars kts (list grtype)))
                           (begin
                             ;(println 'update-h: (car ast) 'with: (list gftype) 'r: request? 'gp: gpoly-type)
                             (impc:ti:update-var (car ast) vars kts (list gftype))))))))
             ;; (println 'done-continue ast)
             ;; (println 'gret: request? gpoly-type)
             (if request?
                 (list request?)
                 (list (cadr gpoly-type))))))))



;; generics check
;; (define impc:ti:nativef-generics
;;   (lambda (ast vars kts request?)
;;     (set! *impc:ti:nativef-generics:calls* (+ *impc:ti:nativef-generics:calls* 1))
;;     ;; (println 'native: *impc:ti:nativef-generics:calls* ast 'request: request?)
;;     ;; (println 'generics-check (car ast) 'request: request?)
;;     ;; (println 'vars: vars)
;;     ;; (println 'genericf-in: (assoc-strcmp (car ast) vars) 'request?)
;;     (set! impc:ir:get-type-expand-poly #f)
;;     (if (or (null? request?)
;;             (and (list? request?)
;;                  (equal? (car request?) *impc:ir:notype*)))
;;         (set! request? #f))
;;     ;; only check if not already fully formed!
;;     (if (impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp (car ast) vars)) vars))
;;         (begin
;;           (for-each (lambda (x r)
;;                       (impc:ti:type-unify (impc:ti:type-check x 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))))
;;         (let* ((args (map (lambda (x)
;;                             (impc:ti:type-unify (impc:ti:type-check x vars kts #f) vars))
;;                           (cdr ast)))
;;                ;; (llllll (println 'nargs: (car ast) ': args))
;;                (gname (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))
;;                (gnum (string->number (cadr (regex:split (symbol->string (car ast)) "##"))))
;;                (arity (- (length ast) 1))
;;                (gpt (impc:ti:genericfunc-types gname arity (if request? (cons request? args) args)))
;;                ;; request? request? args)))
;;                (gpoly-code (cadr gpt))
;;                (lambda-code (caddr gpoly-code))
;;                (gtype (impc:ir:get-type-from-pretty-str (symbol->string (car gpt))))
;;                (gpoly-type (impc:ti:get-type-for-gpoly
;;                             (cadr (regex:type-split (symbol->string (cadr gpoly-code)) ":"))))
;;                (gpoly-type-orig (impc:ti:nativef-generics-make-gtypes-unique gpoly-type gnum)))

;;           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;           ;; it is possible for some generic types to be missed from 'vars'
;;           ;; due to the fact that a different gpoly (overridden generic) choice
;;           ;; was made when initially seeding 'vars'
;;           ;; so ... at this point we check and inject missing arg types into vars
;;           ;;
;;           (for-each (lambda (a)
;;                       (if (regex:match? a "^([a-zA-Z]|!)")
;;                           (if (and (not (assoc-strcmp (string->symbol (string-append a "##" (number->string gnum))) vars))
;;                                    (regex:match? a "(:|!|{)"))
;;                               (let ((newsymm (string->symbol (string-append a "##" (number->string gnum))))
;;                                     (all-syms (cl:remove-duplicates (map (lambda (aa)
;;                                                                            (string->symbol (string-append aa "##" (number->string gnum))))
;;                                                                          (regex:match-all a "![^,}>\\]]*")))))
;;                                 ;; (println 'all all-syms 'new newsymm)
;;                                 (set! all-syms (remove (symbol->string newsymm) all-syms))
;;                                 ;; (println 'adding_p newsymm 'gnum gnum) ;newsym newsymm)
;;                                 ;; add newsym
;;                                 (set-cdr! vars (cons (list newsymm) (cdr vars)))
;;                                 ;; add all-syms
;;                                 (for-each (lambda (x)
;;                                             (if (and (not (assoc-strcmp x vars))
;;                                                      (regex:match? (symbol->string x) "^([a-zA-Z]|!)"))
;;                                                 (begin ;; (println 'adding_sub x 'gnum gnum)
;;                                                        (set-cdr! vars (cons (list x) (cdr vars)))
;;                                                        ;;(set! vars (cons (list (string->symbol x)) vars))
;;                                                        )))
;;                                           all-syms)))))
;;                     (impc:ir:get-pretty-closure-arg-strings (cadr (regex:type-split (symbol->string (cadr gpoly-code)) ":"))))

;;           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;           ;; this is all here purely for generating nicer compiler errors!
;;           ;; and can be removed safely without effecting any functionality
;;           (for-each (lambda (a b)
;;                       ;; (println 'a: a 'b: b)
;;                       (if (symbol? a)
;;                           (begin (set! a (assoc-strcmp a vars))
;;                                  (if (and (symbol? b)
;;                                           (list? a)
;;                                           (> (length a) 1)
;;                                           (atom? (cadr a))
;;                                           (regex:match? (symbol->string b) "(:|{)")) ;; generic!
;;                                      (let* ((bb (car (impc:ti:split-namedtype b)))
;;                                             (ptrdepth (impc:ir:get-ptr-depth (symbol->string b)))
;;                                             (aa (cond ((string? (cadr a))
;;                                                        (cadr (regex:matched (cadr a) "%(.*)_poly_.*")))
;;                                                       ((symbol? (cadr a))
;;                                                        (car (impc:ti:split-namedtype (cadr a))))
;;                                                       (else (cadr a))))
;;                                             (aptrdepth (impc:ir:get-ptr-depth (cadr a))))
;;                                        ;; (println 'aa: aa 'bb: bb)
;;                                        (if (or (not (string? aa))
;;                                                (and (not (equal? aa bb))
;;                                                     (not (regex:match? aa "^!"))))
;;                                            (impc:compiler:print-type-mismatch-error
;;                                             (if (and (list? aa)
;;                                                      (not (impc:ir:type? aa)))
;;                                                 aa
;;                                                 (if (string? aa)
;;                                                     (impc:ir:pointer++ aa aptrdepth)
;;                                                     (impc:ir:pretty-print-type aa)))
;;                                             (impc:ir:pointer++ bb ptrdepth)
;;                                             (car (regex:type-split (symbol->string (car ast)) "##")))))))))
;;                     (cdr ast)
;;                     (cddr gpoly-type))
;;           ;;
;;           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;           (if (<> (length (cdr gpoly-type))
;;                   (length ast))
;;               (impc:compiler:print-compiler-error "bad arity in generics call" ast))

;;           ;; add ##gnum's to all gpoly types (both !bangs like !head and gpoly types like xlist*)
;;           (set! gpoly-type
;;                 (impc:ti:type-unify
;;                  (impc:ti:nativef-generics-make-gtypes-unique gpoly-type gnum)
;;                  vars))

;;           ;; (if (and request?
;;           ;;          (impc:ir:type? request?))
;;           ;;     (begin
;;           ;;       (if (symbol? (cadr gpoly-type))
;;           ;;           (impc:ti:update-var (cadr gpoly-type) vars kts (list request?)))
;;           ;;       (set! gpoly-type (cons (car gpoly-type) (cons request? (cddr gpoly-type))))))

;;           (let* ((a gpoly-type)
;;                  (b (map (lambda (x)
;;                            (if (and (string? x)
;;                                     (regex:match? x "^[A-Za-z0-9]*{"))
;;                                (impc:ti:get-generic-type-as-tuple x)
;;                                x))
;;                          gpoly-type))
;;                  (c gtype))
;;             ;; (println 'a a)
;;             ;; (println 'b b)
;;             ;; (println 'c c)
;;             (set! gpoly-type (impc:ti:variable-substitution a b c gnum vars kts))
;;             ;; (println 'd gpoly-type)
;;             (set! gpoly-type (map (lambda (x)
;;                                     (if (symbol? x)
;;                                         (let ((p (regex:split (symbol->string x) "##")))
;;                                           (if (and (regex:match? (car p) "{")
;;                                                    (impc:ir:type? (impc:ir:get-type-from-pretty-str (car p))))
;;                                               (impc:ir:get-type-from-pretty-str (car p))
;;                                               x))
;;                                         x))
;;                                   gpoly-type))
;;             ;; (println 'e2 gpoly-type)
;;             gpoly-type)
;;           ;; (println 'ast: ast gpoly-type)
;;           (if (impc:ir:type? gpoly-type)
;;               (begin (impc:ti:update-var (car ast) vars kts gpoly-type)
;;                      (cadr gpoly-type))
;;               (begin
;;                 ;; type inferencing for generic functions arguments and return type
;;                 (let* ((res (impc:ti:nativef-generics-check-args ast gpoly-type vars kts request?))
;;                        (resb (map (lambda (x) (impc:ti:type-normalize (impc:ti:type-unify x vars))) res))
;;                        (ttt (map (lambda (x) (impc:ir:type? x)) resb))
;;                        ;; (lllll (println 'ttt: ttt))
;;                        (req? (impc:ti:type-unify gpoly-type vars))
;;                        (nvars (cl:tree-copy vars))
;;                        ;; (ll (println '--->
;;                        ;;              gpoly-type
;;                        ;;              (equal? gpoly-type gpoly-type-orig)
;;                        ;;              (println ttt)))
;;                        ;; (lll (println gpoly-type-orig))
;;                        ;;(rtype (if (impc:ir:type? req?) req? '()))
;;                        (rtype (if (impc:ir:type? req?)
;;                                   req?
;;                                   (if (equal? gpoly-type gpoly-type-orig) ;; no new information!
;;                                       ;;(and (not (null? ttt))
;;                                       ;;     (not (member #t ttt))) ; at least 1 true! ;;(cdr ttt))))
;;                                       '()
;;                                       (impc:ti:nativef-generics-check-return-type
;;                                        ast lambda-code gpoly-type gnum nvars resb
;;                                        (if (impc:ir:type? req?) req? #f)))))
;;                        (grtype (impc:ti:type-unify rtype vars)))
;;                   ;; we might have gained something useful in nvars!
;;                   ;; that we can use for vars!
;;                   ;; have to be careful that it is a fully valid type though!
;;                   ;; otherwise we might introduce dependencies from inside
;;                   ;; a generic call that we should not have access to

;;                   (for-each (lambda (n v)
;;                               (if (and (null? (cdr v))
;;                                        (= (length n) 2)
;;                                        (impc:ir:type? (cadr n)))
;;                                   (begin ;;(println 'bingo 'update (car v) 'with (cdr n))
;;                                     (impc:ti:update-var (car v) vars kts (cdr n)))))
;;                             nvars vars)

;;                   ;; check to see if for-each is possible (i.e. request and (cadr gpoly-type)) are same length
;;                   (if (list? request?)
;;                       (if (and (list? (cadr gpoly-type))
;;                                (<> (length request?) (length (cadr gpoly-type))))
;;                           (set! request? #f))
;;                       (if (list? (cadr gpoly-type))
;;                           (if (and (string? request?) ;; named type?
;;                                    (= (length (cadr gpoly-type)) (length (impc:ti:get-namedtype-type request?))))
;;                               (set! request? (impc:ti:get-namedtype-type request?))
;;                               (set! request? #f))
;;                           (if (<> (length (list request?)) (length (list (cadr gpoly-type))))
;;                               (set! request? #f))))

;;                   (if (and request?
;;                            (not (string? (cadr gpoly-type))))
;;                       (if (and (list? request?)
;;                                (atom? (cadr gpoly-type))
;;                                (symbol? (cadr gpoly-type)))
;;                           (impc:ti:update-var (cadr gpoly-type) vars kts request?)
;;                           (if (and (list? request?)
;;                                    (number? (cadr gpoly-type))
;;                                    (member (cadr gpoly-type) request?))
;;                               (set! request? (cadr gpoly-type))
;;                               (for-each
;;                                (lambda (aa bb)
;;                                  (if (and (atom? aa)
;;                                           (symbol? aa)
;;                                           (assoc-strcmp aa vars))
;;                                      (impc:ti:update-var aa vars kts bb)))
;;                                (if (atom? request?)
;;                                    (list (cadr gpoly-type))
;;                                    (cadr gpoly-type))
;;                                (if (atom? request?)
;;                                    (list request?)
;;                                    request?)))))

;;                   ;; if request? is not a fully formed type
;;                   ;; then we will stick to the the current poly type
;;                   (if (not (impc:ir:type? request?))
;;                       (set! request? #f))

;;                   ;; (println 'ast: 'preset: vars)
;;                   ;; set generic functions type ( (cadr gpoly-type)|request? + res)
;;                   (let ((gftype (if request?
;;                                     (list (cons (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))
;;                                                 (cons (list request?) res)))
;;                                     (list (cons (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))
;;                                                 (cons (list (cadr gpoly-type)) res))))))
;;                     ;; (println 'gftype gftype)
;;                     ;; (println 'gftype: gftype 'gpoly-type gpoly-type)
;;                     (set! gftype (impc:ti:type-clean (car gftype)))
;;                     (impc:ti:nativef-generics-final-tests ast gpoly-type gftype gnum vars kts)
;;                     ;; if grtype is VALID
;;                     ;; and if the return type of gftype is a symbol
;;                     ;; THEN update the return type of gftype (symbol)
;;                     ;; with the reified return type of grtype
;;                     (if (and (impc:ir:type? grtype)
;;                              (symbol? (cadr gftype))
;;                              (assoc-strcmp (cadr gftype) vars))
;;                         (impc:ti:update-var (cadr gftype) vars kts (cadr grtype)))

;;                     ;; update arguments?!
;;                     (map (lambda (x y)
;;                            (if (symbol? x)
;;                                (impc:ti:update-var x vars kts (list y))))
;;                          (cdr ast)
;;                          (cddr gftype))

;;                     (if (impc:ir:type? grtype)
;;                         (impc:ti:update-var (car ast) vars kts (list grtype))
;;                         (impc:ti:update-var (car ast) vars kts (list gftype)))))))
;;           (if request?
;;               (list request?)
;;               (list (cadr gpoly-type)))))))


(define impc:ti:nativef-poly-exact-check
  (lambda (ast vars kts request?)
    ;; (println 'nateivef-poly-exact: ast 'req: request?)
    (if (or (null? request?)
            (regex:match? (sexpr->string request?) "(!|(##))"))  ;; must be generic - exit!
        #f
        (let* ((polyf (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
               (ftypes (impc:ti:get-polyfunc-candidate-types (symbol->string polyf)))
               (asttype (cons 213 (cons request? (map (lambda (a)
                                                        (impc:ti:type-unify (impc:ti:type-check a vars kts #f) vars))
                                                      (cdr ast))))))
          (if (not ftypes)
              #f
              (begin
                ;; if no return type is ever required
                ;; then we can ignore it for our checks
                (if (and (list? request?)
                         (equal? *impc:ir:notype* (car request?)))
                    (for-each (lambda (ft)
                                (if (equal? (cddr asttype) (cddr ft))
                                    (set! asttype ft)))
                              ftypes))
                (if (and (list? ftypes)
                         (member asttype ftypes))
                    (begin
                      ;; (println 'force-poly (car ast) 'to (list asttype))
                      ;; if exact poly should we force var??
                      (impc:ti:force-var (car ast) vars kts (list asttype))
                      #t)
                    #f)))))))



;; (define impc:ti:nativef-poly-check-valid-args
;;   (lambda (ast vars kts request? ftypes valid-lgth)
;;     (map (lambda (type valid)
;;            ;; (println 'type: type 'valid: valid)
;;            (if valid
;;                (let* ((checked-types
;;                        (map (lambda (a t)
;;                               ;; (println 'a a 't t)
;;                               ;; andrew's change here!
;;                               (let ((t2 (impc:ti:type-unify
;;                                          (impc:ti:type-check a vars kts
;;                                                              (if (impc:ir:type? t)
;;                                                                  t
;;                                                                  #f))
;;                                          vars)))
;;                                 ;; (println 'a: a 't: t 't2: t2)
;;                                 t2))
;;                             (cdr ast)
;;                             (cddr type)))
;;                       (ct2 (map (lambda (ct ft) ;; checked type against poly type
;;                                   ;; (println 'ct: ct 'ft: ft)
;;                                   (if (and (number? ct) (number? ft))
;;                                       (if (= ct ft) #t #f)
;;                                       (if (and (string? ct) (string? ft))
;;                                           (if (string=? ct ft) #t #f)
;;                                           (if (list? ct)
;;                                               (if (member ft ct) #t #f) ;; #f
;;                                               #f))))
;;                                 (if request?
;;                                     (cons request? checked-types)
;;                                     checked-types)
;;                                 (if request?
;;                                     (cdr type)
;;                                     (cddr type)))))
;;                  ct2)
;;                (list #f)))
;;          ftypes
;;          valid-lgth)))

(define impc:ti:nativef-poly-check-match-ftypes
  (lambda (args ftypes request?)
    (let* ((ftypes2 (cl:remove-if (lambda (x) (<> (length (cddr x)) (length args))) ftypes))
           (results (map (lambda (type)
                           (map (lambda (ct ft) ;; check args aginst ftype
                                  (if (and (number? ct) (number? ft))
                                      (if (= ct ft) #t #f)
                                      (if (and (string? ct) (string? ft))
                                          (if (string=? ct ft) #t #f)
                                          (if (list? ct)
                                              (if (member ft ct) #t #f) ;; #f
                                              #f))))
                                (if request?
                                    (cons request? args)
                                    args)
                                (if request?
                                    (cdr type)
                                    (cddr type))))
                         ftypes2))
           (hits (map (lambda (r) (length (cl:remove #f r))) results))
           (best (if (null? hits) 0 (apply max hits)))
           (res-types (map (lambda (x y) (cons x y)) (if (null? hits) (make-list (length ftypes2) 0) hits) ftypes2))
           (short-list (cl:remove-if (lambda (x) (<> (car x) best)) res-types))
           (valid (map (lambda (x) (cdr x)) short-list)))
      valid)))


(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))))))


;; polymorphic version
;; (define impc:ti:nativef-poly-check
;;   (lambda (ast vars kts request?)
;;     ;; (println 'poly-checking: ast 'req? request? 'kts kts) ;; 'v: vars)
;;     (if (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)))))
;;         (if (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
;;               ;; (println 'bingo: 'saving 'time!)
;;               (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))))
;;             (let* ((polyf (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
;;                    (ftypes (impc:ti:get-polyfunc-candidate-types (symbol->string polyf)))
;;                    (valid-lgth (map (lambda (type)
;;                                       (if (<> (length (cdr type))
;;                                               (length ast)) #f #t))
;;                                     ftypes))
;;                    ;;(tmpvars (cl:tree-copy vars))
;;                    (valid-args (map (lambda (type valid)
;;                                       ;; (println 'type: type 'valid: valid)
;;                                       (if valid
;;                                           (let* ((checked-types
;;                                                   (map (lambda (a t)
;;                                                          ;; (println 'a a 't t)
;;                                                          ;; andrew's change here!
;;                                                          (let ((t2 (impc:ti:type-unify
;;                                                                     (impc:ti:type-check a vars kts
;;                                                                                         (if (impc:ir:type? t)
;;                                                                                             t
;;                                                                                             #f))
;;                                                                     vars)))
;;                                                            ;; (println 'a: a 't: t 't2: t2)
;;                                                            t2))
;;                                                        (cdr ast)
;;                                                        (cddr type)))
;;                                                  (ct2 (map (lambda (ct ft) ;; checked type against poly type
;;                                                              ;; (println 'ct: ct 'ft: ft)
;;                                                              (if (and (number? ct) (number? ft))
;;                                                                  (if (= ct ft) #t #f)
;;                                                                  (if (and (string? ct) (string? ft))
;;                                                                      (if (string=? ct ft) #t #f)
;;                                                                      (if (list? ct)
;;                                                                          (if (member ft ct) #t #f) ;; #f
;;                                                                          #f))))
;;                                                            (if request?
;;                                                                (cons request? checked-types)
;;                                                                checked-types)
;;                                                            (if request?
;;                                                                (cdr type)
;;                                                                (cddr type)))))
;;                                             ct2)
;;                                           (list #f)))
;;                                     ftypes
;;                                     valid-lgth))
;;                    (weighted-choices (map (lambda (l) (length (cl:remove #f l))) valid-args))
;;                    (best-result (apply max weighted-choices))
;;                    (valid-polys
;;                     (cl:remove #f (map (lambda (type weight)
;;                                          (if (or
;;                                               (= weight 0)
;;                                               (< weight best-result)) #f
;;                                               type))
;;                                        ftypes
;;                                        weighted-choices))))
;;               ;;(println 'ftypes: ftypes)
;;               ;; (println 'weighted-choices: weighted-choices 'request? request?)
;;               ;; (println 'va valid-args)
;;               ;; (println '-> ast 'valid-polys: valid-polys 'request: request?)

;;               (if (null? valid-polys)
;;                   (set! valid-polys
;;                         (cl:remove #f (map (lambda (a b) (if a b #f)) valid-lgth ftypes))))
;;               (if (null? valid-polys)
;;                   (impc:compiler:print-compiler-error "no valid polymorphic options" ast))

;;                                         ;(println 'valid-polysa: valid-polys 'request? request? 'ast: ast)
;;               (let ((returns (map (lambda (t)
;;                                     (cadr t))
;;                                   valid-polys)))
;;                 ;; (println 'returns returns 'request? request?)
;;                 ;; (println 'vars: vars)
;;                 ;; (if request?
;;                 ;;     (if (list? request?)
;;                 ;;         (set! returns (impc:ti:intersection* returns request?))
;;                 ;;        (set! returns (impc:ti:intersection* returns (list request?)))))
;;                 ;; (println 'returns2 returns)
;;                 ;; (set! valid-polys (cl:remove #f
;;                 ;;                              (map (lambda (v)
;;                 ;;                                     (if (member (cadr v) returns)
;;                 ;;                                         v
;;                 ;;                                         #f))
;;                 ;;                                   valid-polys)))

;;                 ;; (println 'valid-polys ast 'ps: valid-polys)
;;                 ;; (println 'ft ast 'fts: ftypes)
;;                 ;; (println 'kts: kts)

;;                 ;; 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: valid-polys 'ast: ast)
;;                 ;; update valid-polys to reflect return types (from request?)
;;                 (impc:ti:update-var (car ast) vars kts valid-polys)
;;                                         ;(println 'returns: returns)
;;                 returns))))))


(define impc:ti:callback-check
  (lambda (ast vars kts request?)
    ;; (println 'callback-check 'ast: ast 'vars: vars 'request: request?)
    (let ((ftype (map impc:ir:get-type-from-str
                      (let ((ags (impc:ti:get-closure-arg-types (symbol->string (caddr ast)))))
                        (if ags ags '())))))
      (if *impc:ti:print-sub-checks* (println 'ftype:> 'ast: ast 'type: ftype))
      (impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
      (if (null? ftype)
          (begin (let ((fargs (cons 213
                                    (cons -1
                                          (map (lambda (a)
                                                 (impc:ti:type-check a vars kts '()))
                                               (cdddr ast))))))
                   (if (and (impc:ir:type? fargs)
                            (assoc (caddr ast) vars)
                            (null? (cdr (assoc (caddr ast) vars))))
                       (impc:ti:update-var  (caddr ast) vars kts fargs)))
                 (list *impc:ir:void*))
          (begin (if (<> (+ 2 (length ftype))
                         (length ast))
                     (impc:compiler:print-compiler-error "bad arity in call" ast))
                 (if (and (assoc (caddr ast) vars)
                          (null? (cdr (assoc (caddr ast) vars))))
                     (impc:ti:update-var (caddr ast) vars kts (cons 213 ftype)))
                 ;; we don't care what we get back
                 (for-each (lambda (a t)
                             (if (symbol? a) (impc:ti:update-var a vars kts t))
                             (impc:ti:type-check a vars kts t))
                           (cdddr ast)
                           (cdr ftype))
                 ;; callback returns void
                 (list *impc:ir:void*))))))


(define impc:ti:push_new_zone-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 2)
        (impc:compiler:print-compiler-error "bad arity in call" ast))
    (impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
    (list "%mzone*")))

(define impc:ti:push_zone-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 2)
        (impc:compiler:print-compiler-error "bad arity in call" ast))
    (impc:ti:type-check (cadr ast) vars kts "%mzone*")
    (list "%mzone*")))

(define impc:ti:create_zone-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 2)
        (impc:compiler:print-compiler-error "bad arity in call" ast))
    (impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
    (list "%mzone*")))

(define impc:ti:pop_zone-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 1)
        (impc:compiler:print-compiler-error "bad arity in call" ast))
                                        ;(println 'memzonecheck ast (list? (cadr ast)))
    (list "%mzone*")))


(define impc:ti:let-check
  (lambda (ast vars kts request?)
    ;; (println 'letchk: ast 'req request?) ; 'vars vars)
    ;; (println 'vars: vars '(cadr ast) (cadr ast))
    ;; for the symbols we want to set each return type
    (let ((internalreq? (cond ((equal? `(begin ,(caar (cadr ast)))
                                       (caddr ast))                               
                               request?)
                              (else #f))))
      (for-each (lambda (e)
                  ;; (println 'e e)
                  (if (and (list? (cadr e))
                           (equal? (caadr e) 'lambda))
                      (set! *impc:ti:bound-lambdas* (cons e *impc:ti:bound-lambdas*)))
                  (if (and #f
                           (assoc-strcmp (car e) vars)
                           (impc:ir:type? (impc:ti:type-unify (cdr (assoc-strcmp (car e) vars)) vars)))
                      (list (impc:ti:type-unify (cdr (assoc-strcmp (car e) vars)) vars))
                      (let ((a (impc:ti:type-check (cadr e) vars kts
                                                   (cond ((assoc-strcmp (car e) kts)
                                                          ;; (println 'retfor (car e) (cadr (assoc-strcmp (car e) kts)))
                                                          (cadr (assoc-strcmp (car e) kts)))
                                                         ((and (not (null? (cdr (assoc-strcmp (car e) vars))))
                                                               (impc:ir:type? (cadr (assoc-strcmp (car e) vars))))
                                                          ;; (println 'retfor (car e) (cadr (assoc-strcmp (car e) vars)))
                                                          (cadr (assoc-strcmp (car e) vars)))
                                                         (else
                                                          ;; (println 'retfor (car e) internalreq?)
                                                          internalreq?)))))
                        ;; (println '---update: (car e) 'with: a)
                        (impc:ti:update-var (car e) vars kts a)
                        ;; (println '---vars: vars)
                        )))
                (cadr ast))
      ;; then return the return type for the whole let
      ;; which should have a begin body! so caddr should work
      (let ((ret (impc:ti:type-check (caddr ast) vars kts request?)))
        ret))))

(impc:ti:register-new-builtin
 "let"
 ""
 "let-bind temporary variables

Execute `body' with temporary variables bound as described in `bindings'.

e.g.

(let ((a 3)                  ;; 3 is bound to a
      (b 42)                 ;; 42 is bound to b
      (c:float* (alloc 10))) ;; a pointer to enough memory for 10 floats is bound to c
  (+ a b (ftoi64 (pref c 0))))

xtlang's `let' syntax is the same as Scheme"
 '(bindings body))

(define impc:ti:null?-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (cadr ast) vars kts request?)))
      (if (or (null? a) ;; couldn't resolve yet!
              (and (pair? a)
                   (null? (car a))))
          (list *impc:ir:i1*)
          (if (if (not (impc:ir:type? a))
                  (impc:ir:pointer? (car a))
                  (impc:ir:pointer? a))
              (list *impc:ir:i1*)
              (impc:compiler:print-compiler-error "null must take a pointer type" ast))))))


(define impc:ti:null-check
  (lambda (ast vars kts request?)
    ;; (println 'null-check 'ast: ast 'request? request?)
    (let ((res (if (and (symbol? request?)
                        (string-contains? (symbol->string request?) "##"))
                   (if (assoc-strcmp request? vars)
                       (if (null? (cdr (assoc-strcmp request? vars)))
                           request?
                           (cdr (assoc-strcmp request? vars))))
                   (if (and request?
                            (impc:ir:pointer? request?))
                       (list request?)
                       '())))) ;; forcing to i8* causes problems for generics
                                        ;(list (+ *impc:ir:pointer* *impc:ir:si8*))))))
      res)))



(define impc:ti:ret-check
  (lambda (ast vars kts request?)
    ;; (println 'retcheck: request? 'a: ast)
    ;; (println 'vars: vars)
    ;; grab function name from ret->
    (let* ((sym (if (equal? (caddr ast) (cadr ast))
                    '()
                    (impc:ti:get-var (cadr ast) vars)))
           (t (if (null? sym) #f
                  (if (null? (cdr sym))
                      #f
                      (if (impc:ir:type? (cdr sym))
                          (cdr sym)
                          (car (cdr sym))))))
           ;;(car (cdr sym)))))
           ;; if closure has a return type set
           ;; pass it as a request
           (a (impc:ti:type-unify
               (impc:ti:type-check (caddr ast) vars kts
                                   (if (and t
                                            (impc:ir:type? t)
                                            (impc:ir:closure? t))
                                       (if (list? t) (cadr t) request?)
                                        ;#f)))) ;; or else pass #f
                                       request?))
               vars))) ;; or pass on request
      ;; (println 'retchecked-> a 'request? request? 'ast: ast 't: t)
      ;; if t is not a closure type we have a problem!
      (if (and t
               (or (not (list? t));(not (impc:ir:type? t))
                   (not (impc:ir:closure? t))))
          (impc:compiler:print-compiler-error "type error calculating return type - have you specified an incorrect closure type?" ast))
      (if *impc:ti:print-sub-checks* (println 'ret:> 'ast: ast 'a: a 'sym: sym))
      (if (and (impc:ir:type? t)
               (impc:ir:closure? t))
          (if (symbol? (caddr ast))
              (impc:ti:update-var (caddr ast) vars kts (list (cadr t)))
              ;; else the return value is not a symbol
              ;; and we should use it's value to update the lambda's type
              (impc:ti:update-var (car sym) vars kts
                                  (list (impc:ir:pointer++ (impc:ir:pointer++ (list* *impc:ir:closure* a (cddr t))))))))
      ;; (println 'ret: a)
      a)))


(define impc:ti:begin-check
  (lambda (ast vars kts request?)
    ;;(println 'request: request?)
    ;; we should ONLY use request? on the LAST sexpr in the begin
    ;; i.e. we should only use the LAST begin sexpr for a return type
    (let ((sexplst (reverse (cdr ast))))
      (if (and (list? (car sexplst))
               (member (caar sexplst) '(ifret)))
          (if (<> (length (car sexplst)) 4)
              (impc:compiler:print-compiler-error "Conditional statements in a return position must provide two branches!" (car sexplst))))
      ;; we need type check coverage for ALL sexpr's
      ;; by only the last one counts towards the returned type

      ;; so we start with type coverage
      ;; reverse order shouldn't matter because there
      ;; should be no type dependencies between these sexpressions
      ;; also we pass *impc:ir:notype* as a request
      ;; because no return type is required from this expression
      ;; not just that we don't know it, but that none is actually required
      (map (lambda (e) (impc:ti:type-check e vars kts (list *impc:ir:notype*))) (cdr sexplst))
      ;; now we do the last sexpr in the begin for a return type
      ;; it SHOULD get passed the request?
      (let ((res (impc:ti:type-check (car sexplst) vars kts request?)))
        ;; and return res
        res))))


(define impc:ti:bitcast-check
  (lambda (ast vars kts request?)
    ;; (println 'bitcastcheck'req: request?)
    (if (null? (cddr ast))
        (if request? (list request?) (list))
        ;; for the symbols we want to set each return type
        ;;(impc:ti:update-var (cadr ast) vars kts (impc:ir:convert-from-pretty-types (caddr ast)))
        (list (impc:ir:convert-from-pretty-types (caddr ast))))))


(define impc:ti:bitconvert-check
  (lambda (ast vars kts request?)
    ;; don't pass on request because convert
    ;; is by definition expecting a different arg to its return!
    (impc:ti:type-check (cadr ast) vars kts #f)
    (if (null? (cddr ast))
        (if request? (list request?) (list))
        ;; for the symbols we want to set each return type
        ;;(impc:ti:update-var (cadr ast) vars kts (impc:ir:convert-from-pretty-types (caddr ast)))
        (list (impc:ir:convert-from-pretty-types (caddr ast))))))


(define impc:ti:if-check
  (lambda (ast vars kts request?)
                                        ;(println 'if: ast 'request? request?)
    (let* ((a (impc:ti:type-check (cadr ast) vars kts #f)) ;request?))
           (b (impc:ti:type-check (caddr ast) vars kts request?))
           (c (if (null? (cdddr ast))
                  '()
                  (impc:ti:type-check (cadddr ast) vars kts request?)))
           (t (impc:ti:type-unify (list b c) vars)))
                                        ;(t (cl:intersection (if (atom? b) (list b) b) (if (atom? c) (list c) c))))
      (if *impc:ti:print-sub-checks* (println 'if:> 'a: a 'b: b 'c: c 't: t))
      ;; (println 'a: a 'b: b 'c: c 't: t)
      (if (null? b)
          (set! t c))
      (if (null? c)
          (set! t b))
      ;; return intersection of b and c
      (if (null? t)
          t ;;(print-error 'Compiler 'Error: 'cannot 'unify 'then b 'and 'else c 'in ast) ;(map (lambda (v) (impc:ir:get-type-str v)) b) 'and 'else (map (lambda (v) (impc:ir:get-type-str v)) c) 'clauses 'in ast)
          t))))



(define impc:ti:void-check
  (lambda (ast vars kts request?)
    (if (> (length ast) 1)
        (impc:compiler:print-compiler-error "void does not take any arguments")
        (list *impc:ir:void*))))


(define impc:ti:make-array-check
  (lambda (ast vars kts request?)
    ;; (println 'make-array request?)
    (let* ((a (impc:ti:type-check (cadr ast) vars kts #f))
           (b (map (lambda (x) (set! a (impc:ti:type-check x vars kts a))) (cddr ast))))
      (list *impc:ir:array* (length (cdr ast)) a))))

(define impc:ti:array-set-check  
  (lambda (ast vars kts request?)
    (if (<> (length ast) 4)
        (impc:compiler:print-bad-arity-error (car ast)))
    (let* ((a (impc:ti:type-check (cadr ast) vars kts #f))
           ;; b should be fixed point types
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*)))
           ;; c should be of type a*
           (c (impc:ti:type-check (cadddr ast) vars kts (if (or (null? a)
                                                                (not (impc:ir:type? (car a))))
                                                            #f
                                                            (list (caddr (car a)))))))
      (if (or (and (not (null? a))
                   (impc:ir:type? (car a))
                   (not (impc:ir:array? (car a))))
              (and (not (null? a))
                   (impc:ir:type? (car a))
                   (> (impc:ir:get-ptr-depth (car a)) 1)))
          (impc:compiler:print-bad-type-error (impc:ir:get-type-str (car a) c)))
      ;; array set check will return the value set
      c)))


(define impc:ti:array-ref-ptr-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 3)
        (impc:compiler:print-bad-arity-error ast))
    (let ((a (impc:ti:type-check (cadr ast) vars kts '())) ;request?))
          ;; b should be fixed point
          (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
      (if (impc:ir:type? a) (set! a (list a)))
      (if (null? a)
          a
          (if (or (not (impc:ir:array? (car a)))
                  (> (impc:ir:get-ptr-depth (car a)) 1))
              (impc:compiler:print-bad-type-error (impc:ir:get-type-str (car a)))
              (list (impc:ir:pointer++ (caddr (car a)))))))))


(define impc:ti:array-ref-check
  (lambda (ast vars kts request?)
    ;;(println 'request? request?)
    ;;(println 'array-ref-check: 'ast: ast 'vars: vars 'kts: kts)
    (if (<> (length ast) 3)
        (impc:compiler:print-bad-arity-error ast))
    (let ((a (impc:ti:type-check (cadr ast) vars kts '()))
          ;; b should be fixed point
          (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
      (if (impc:ir:type? a) (set! a (list a)))
      (if (null? a)
          a
          (if (or (not (impc:ir:array? (car a)))
                  (> (impc:ir:get-ptr-depth (car a)) 1))
              (impc:compiler:print-bad-type-error (impc:ir:get-type-str (car a)))
              (list (caddr (car a))))))))

(define impc:ti:make-vector-check
  (lambda (ast vars kts request?)
    ;; (println 'make-vector request?)
    (let* ((a (impc:ti:type-check (cadr ast) vars kts #f))
           (b (map (lambda (x) (set! a (impc:ti:type-check x vars kts a))) (cddr ast))))
      (list *impc:ir:vector* (length (cdr ast)) a))))

(define impc:ti:vector-set-check
  (lambda (ast vars kts request?)
                                        ;(println 'ast: ast 'vars: vars)
    (if (<> (length ast) 4)
        (impc:compiler:print-bad-arity-error ast))
    (let* ((a (impc:ti:type-check (cadr ast) vars kts #f))
           ;; b should be i32
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*)))
           ;; c should be of type a*
           (c (impc:ti:type-check (cadddr ast) vars kts (if (null? a) #f (list (caddr (car a)))))))
      (if (or (and (not (null? a))
                   (impc:ir:type? (car a))
                   (not (impc:ir:vector? (car a))))
              (and (not (null? a))
                   (impc:ir:type? (car a))
                   (> (impc:ir:get-ptr-depth (car a)) 1)))
          (impc:compiler:print-bad-type-error (impc:ir:get-type-str (car a))))
      ;; vector set returns a whole new vector!  check llvm ir doc
      a)))

(define impc:ti:vector-ref-check
  (lambda (ast vars kts request?)
                                        ;(println 'request? request?)
                                        ;(println 'vector-ref-check: 'ast: ast 'vars: vars 'kts: kts)
    (if (<> (length ast) 3)
        (impc:compiler:print-bad-arity-error ast))
    (let ((a (impc:ti:type-check (cadr ast) vars kts '()))
          ;; b should be i32
          (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*))))
      (if (impc:ir:type? a) (set! a (list a)))
      (if (null? a)
          a
          (if (or (not (impc:ir:vector? (car a)))
                  (> (impc:ir:get-ptr-depth (car a)) 1))
              (impc:compiler:print-bad-type-error (impc:ir:get-type-str (car a)))
              (list (caddr (car a))))))))


(define impc:ti:vector-shuffle-check
  (lambda (ast vars kts request?)
    ;;(println 'vector-ref-check: 'ast: ast 'vars: vars 'kts: kts)
    (let ((a (impc:ti:type-check (cadr ast) vars kts request?))
          (b (impc:ti:type-check (caddr ast) vars kts request?)))
      (if (impc:ir:type? a) (set! a (list a)))
      (if (impc:ir:pointer? (car a))
          (impc:ir:pointer-- (car a))
          (car a)))))


(define impc:ti:pointer-set-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 4)
        (impc:compiler:print-bad-arity-error ast))
    (let* ((aa (impc:ti:type-check (cadr ast) vars kts #f))
           (a (if (and (list? aa) (= (length aa) 1) (symbol? (car aa))) '() aa))
           ;; b should be fixed point types
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*)))
           ;; c should be of type *a
           (c (impc:ti:type-check (cadddr ast) vars kts (if (null? a) #f
                                                            (if (atom? a)
                                                                (list (impc:ir:pointer-- a))
                                                                (list (impc:ir:pointer-- (car a))))))))
      ;; try running type check on a if C exists! but a does not
      (if (and (null? a)
               (not (null? c)))
           (begin ;; (println 'bingo c)
             (if (atom? c) (set! c (list c)))
            (set! a (impc:ti:type-check (cadr ast) vars kts
                                        (map (lambda (k) (impc:ir:pointer++ k))
                                             (cl:remove-if-not impc:ir:type? c))))))

      (if (not (null? a))
          (if (and (not (impc:ir:pointer? (if (impc:ir:type? a) a
                                             (if (list? a) (car a) a))))
                   (not (symbol? (if (impc:ir:type? a) a
                                     (if (list? a) (car a) a)))))
              (impc:compiler:print-bad-type-error a "trying to pset! into a value")))

      (if (and (list? c) (= 1 (length c))) (set! c (car c)))

      (if (and (symbol? (cadr ast))
               (impc:ir:type? c))
          (if (string? c)
              (impc:ti:update-var (cadr ast) vars kts (string-append c "*"))
              (impc:ti:update-var (cadr ast) vars kts (impc:ir:pointer++ c))))
      ;; array set check will return the type of the value set
      c)))


(define impc:ti:pointer-ref-ptr-check
  (lambda (ast vars kts request?)
    (if (<> (length ast) 3)
        (impc:compiler:print-bad-arity-error ast))
    (let ((a (impc:ti:type-check (cadr ast) vars kts request?))
          ;; b should be fixed point
          (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
      (if (impc:ir:type? a) (set! a (list a)))
      (if (and (not (null? a))
               (< (impc:ir:get-ptr-depth (car a)) 1))
          (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type (car a))
                                              "Cannot de-reference non-pointer type"))
      (if (null? a)
          a
          (list (car a))))))


(define impc:ti:pointer-ref-check
  (lambda (ast vars kts request?)
    ;; (println 'pointer-ref-check: 'ast: ast 'request? request?) ;'vars: vars 'kts: kts)
    (if (<> (length ast) 3)
        (impc:compiler:print-bad-arity-error ast))
    (if (or (impc:ir:type? request?) (atom? request?)) (set! request? (list request?)))
    (let ((a (impc:ti:type-check (cadr ast) vars kts ;; '())) ;request?))
                                 (map (lambda (k) (impc:ir:pointer++ k))
                                      (cl:remove-if-not impc:ir:type? request?))))
          ;; b should be fixed point
          (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
      (if (impc:ir:type? a) (set! a (list a)))
      (if (and (not (null? a))
               (< (impc:ir:get-ptr-depth (car a)) 1))
          (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type (car a))
                                              "Cannot de-reference non-pointer type"))
      (if (null? a)
          a
          (list (impc:ir:pointer-- (car a)))))))


;; make should be of the form
;; (halloc type)
;; where type is a valid type
;; (nalloc i64)
;; memory is allocated on the head
(define impc:ti:heap-alloc-check
  (lambda (ast vars kts request?)
    (if (and request?
             (not (impc:ir:pointer? request?))
             (not (symbol? request?)))
        (impc:compiler:print-compiler-error "Allocation must return pointer type" ast))
    (if (= (length ast) 2)
        (let ((a (impc:ti:type-check (cadr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
          request?)
        request?)))


;; make should be of the form
;; (alloc type)
;; where type is a valid type
;; (alloc i64)
;; memory is allocated on the head
(define impc:ti:zone-alloc-check
  (lambda (ast vars kts request?)
    (if (and request?
             (not (impc:ir:pointer? request?))
             (not (symbol? request?)))
        (impc:compiler:print-compiler-error "Allocation must return pointer type" ast))
    (if (= (length ast) 2)
        (let ((a (impc:ti:type-check (cadr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
          request?)
        request?)))



;; make should be of the form
;; (salloc type)
;; where type is a valid type
;; (salloc i64)
;; memory is allocated on the head
(define impc:ti:stack-alloc-check
  (lambda (ast vars kts request?)
    (if (and request?
             (not (impc:ir:pointer? request?))
             (not (symbol? request?)))
        (impc:compiler:print-compiler-error "Allocation must return pointer type" ast))
    (if (= (length ast) 2)
        (let ((a (impc:ti:type-check (cadr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
          request?)
        request?)))

(define impc:ti:num-of-elts-check
  (lambda (ast vars kts request?)
    *impc:ir:si64*))

(define impc:ti:ref-check
  (lambda (ast vars kts request?)
    (if (not (assoc-strcmp (cadr ast) vars))
        (impc:compiler:print-compiler-error "no valid local variable found in call to ref" ast))
    (impc:ir:pointer++ (cadr (assoc-strcmp (cadr ast) vars)))))

(define impc:ti:make-tuple-check
  (lambda (ast vars kts request?)
    (let* ((a (map (lambda (x t)
                     (impc:ti:type-check x vars kts t))
                   (cdr ast)
                   (if (and (list? request?)
                            (equal? 14 (car request?)))
                       (cdr request?)
                       (make-list (length (cdr ast)) #f)))))
      (cons *impc:ir:tuple* a))))


(define impc:ti:tuple-set-check
  (lambda (ast vars kts request?)
    ;;(println 'tsetcheck ast vars kts request?)
    (if (<> (length ast) 4)
        (impc:compiler:print-bad-arity-error ast))
    ;; (caddr ast) must be an integer
    (if (not (integer? (caddr ast)))
        (impc:compiler:print-bad-type-error (caddr ast) "tuple-set! must use a literal integer index"))
    (let* (;; a should be a tuple of some kind
           (a (let ((res (impc:ti:type-check (cadr ast) vars kts #f)))
                (if (null? res) res
                    (if (and (string? (car res))
                             (char=? (string-ref (car res) 0) #\%))
                        (let ((t (impc:ti:get-namedtype-type (impc:ir:get-base-type (car res)))))
                          (dotimes (i (impc:ir:get-ptr-depth (car res))) (set! t (impc:ir:pointer++ t)))
                          (list t))
                        res))))
           ;; b should be 32bit fixed point type -- llvm structs only support 32bit indexes
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*)))
           (req? (if (and (not (null? a))
                          (list? a))
                     (if (impc:ir:tuple? (car a))
                         (if (> (+ 2 (caddr ast)) (length (car a)))
                             (impc:compiler:print-index-oob-error 'tuple ast)
                             (list-ref (car a) (+ 1 (caddr ast))))
                         #f)
                     #f))
                                        ;(llllll (println 'req: req?  'cara: (car a) 'z: (caddr ast) 'list-ref: (+ 1 (caddr ast))))
           ;; c should be an element of a tuple
           (c (impc:ti:type-check (cadddr ast) vars kts req?)))
      ;; (if (and (not (null? a))
      ;;          (list? a))
      ;;     (if (impc:ir:tuple? (car a))
      ;;         (list-ref (car a) (+ 1 (caddr ast)))
      ;;         #f)
      ;;     #f))))
      (if (and (not (null? a))
               (not (null? (car a)))
               (not (symbol? (car a))) ;; symbol may not have yet been defined!!
               (not (impc:ir:tuple? (car a))))
          (impc:compiler:print-bad-type-error (caddr ast) (string-append "invalid tuple-set-check type " (impc:ir:get-type-str (car a)))))
      ;; if (cadddr ast) is a symbol we should update
      ;; it's type with c but for polymorphic cases
      ;; we should ensure that we also do a type-unification
      (if (symbol? (cadddr ast))
          (let* ((types (if (assoc-strcmp (cadddr ast) vars)
                            (cdr (assoc-strcmp (cadddr ast) vars))
                            (impc:ti:type-check (cadddr ast) vars kts req?)))
                 (utype (impc:ti:type-unify (list c types) vars)))
                                        ;(println 'types: types 'utype: utype 'c: (list c types))
            (if (null? utype)
                (impc:ti:force-var (cadddr ast) vars kts (list c))
                (impc:ti:force-var (cadddr ast) vars kts (list utype)))))

      ;; tuple set check will return the type of the value set
      c)))


(define impc:ti:tuple-ref-ptr-check
  (lambda (ast vars kts request?)
    ;; (caddr ast) must be an integer
    (if (not (integer? (caddr ast)))
        (impc:compiler:print-bad-type-error (caddr ast) "tuple-ref must use a literal integer index"))
    (let* (; a should be a tuple of some kind!
           (a (impc:ti:type-check (cadr ast) vars kts #f)) ;;(if (impc:ir:type? request?)
           ;;(impc:ir:tuple? request?)
           ;;request?
           ;;#f))) ;request?))
           ;; b should be fixed point -- llvm structs only support 32bit indexes
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*))))
      (if (and (not (null? a)) (or (atom? a) (impc:ir:type? a)))  (set! a (list a)))

      ;; check for named types
      (if (not (null? a)) (set! a (impc:ti:try-to-resolve-named-types (car a) vars)))


      ;;(println 'tupref-check 'a: a 'ast: ast (list-ref (car a) (+ 1 (caddr ast))))
      (if (and (not (null? a))
               (list? a)
               (impc:ir:tuple? (car a)))
          (list (impc:ir:pointer++ (list-ref (car a) (+ 1 (caddr ast)))))
          ;;'()))))
          (if (null? a)
              '()
              ;; (impc:compiler:print-bad-type-error (caddr ast) (string-append "invalid tuple-ref-ptr type " (impc:ir:get-type-str (car a)))))))))
              a)))))



(define impc:ti:tuple-ref-check
  (lambda (ast vars kts request?)
    ;; (println 'ref-check ast request?) ;kts vars)
    ;; (caddr ast) must be an integer
    (if (not (integer? (caddr ast)))
        (impc:compiler:print-bad-type-error (caddr ast) "tuple-ref must use a literal integer index"))
    (let* (; a should be a tuple of some kind!
           (a (impc:ti:type-check (cadr ast) vars kts #f)) ;(if (and (impc:ir:type? request?)
                                        ;	(impc:ir:tuple? request?))
                                        ;  request?
                                        ; #f))) ;request?))
           ;; b should be fixed point -- llvm structs only support 32bit indexes
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*)))
           (idx (eval (caddr ast))))
      (if (and (not (null? a)) (or (atom? a) (impc:ir:type? a))) (set! a (list a)))
      ;; unify a?
      (if (not (null? a)) (set! a (impc:ti:type-unify (car a) vars)))
      (if (and (not (null? a)) (or (atom? a) (impc:ir:type? a))) (set! a (list a)))
      ;; is 'a' still generic? (i.e. not resolved to a named type yet?)
      (if (and (not (null? a))
               (symbol? (car a)))
          (let* ((p1 (regex:split (symbol->string (car a)) "##"))
                 ;; (lllll (println 'ppp1: p1))
                 (p2 (regex:type-split (car p1) ":"))
                 ;; (llllllll (println 'ppp2: p2))
                 (args (map (lambda (x)
                              (if (regex:match? x "^\\!")
                                  (string->symbol (string-append x "##" (cadr p1)))
                                  (impc:ir:get-type-from-pretty-str x)))
                            (if (null? (cdr p2))
                                '()
                                (impc:ir:get-pretty-tuple-arg-strings (cadr p2))))))
            (set! a (list (list (cons 114 args))))))
      ;; we MUST expand named types!
      (if (and (not (null? a))
               (not (number? (car a))))
          (set! a (impc:ti:try-to-resolve-named-types (car a) vars)))
      (if (and (not (null? a))
               (or (atom? a)
                   (number? (car a))
                   (impc:ir:type? a)))
          (set! a (list a)))
      (if (and (not (null? a))
               (list? a)
               (impc:ir:tuple? (car a)))
          (begin (if (>= (caddr ast)
                         (- (length (car a)) 1))
                     (impc:compiler:print-index-oob-error 'tuple ast))
                 (let ((res (list-ref (car a) (+ 1 idx))))
                   (if (not (impc:ir:type? res))
                       (if (and (assoc-strcmp res vars) request?)
                           (if (null? (cdr (assoc-strcmp res vars)))
                               (begin
                                 ;; (println 'updateres: res '-> request?)
                                 (impc:ti:update-var res vars kts request?)
                                 (set! res request?))
                               (set! res '()))
                           (set! res '())))
                   ;; (println 'trefres: res)
                   res))
          '()))))


;;(closure-set! closure a i32 5)
(define impc:ti:closure-set-check
  (lambda (ast vars kts request?)
    ;;(println 'cset 'ast: ast 'request? request?)
    (if (<> (length ast) 5)
        (impc:compiler:print-bad-arity-error ast))
    (let* (;; a should be a closure of some kind
           (a (if (and (symbol? (cadr ast))
                       (impc:ti:closure-exists? (symbol->string (cadr ast))))
                  #t ; // yes (cadr ast) is a globally defined closure
                  (impc:ti:type-check (cadr ast) vars kts #f)))
           ;; b should be a string (the var's name)
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si8*)))
           ;; c should be a value for var's name
           (c (impc:ti:type-check (cadddr ast) vars kts
                                  (if (null? (car (cddddr ast)))
                                      request?
                                      (impc:ir:get-type-from-str (car (cddddr ast)))))))
      c)))

;;(closure-ref closure a i32)
(define impc:ti:closure-ref-check
  (lambda (ast vars kts request?)
    ;; (println 'cls 'ref 'check: ast 'request? request?)
    (if (<> (length ast) 4)
        (impc:compiler:print-bad-arity-error ast))
    (let* (;; a should be a closure of some kind
           (a (if (and (symbol? (cadr ast))
                       (impc:ti:closure-exists? (symbol->string (cadr ast))))
                  #t ; // yes (cadr ast) is a globally defined closure
                  (impc:ti:type-check (cadr ast) vars kts #f))) ;; do NOT check against request!
           ;; b should be a string (the var's name)
           (b (impc:ti:type-check (caddr ast) vars kts (impc:ir:pointer++ (list *impc:ir:si8*)))))
      (if (null? (cadddr ast))
          (if request?
              request?
              '())
          (impc:ir:get-type-from-str (cadddr ast))))))

;; (closure-ref closure a i32)
(define impc:ti:closure-refcheck-check
  (lambda (ast vars kts request?)
    ;; (println 'cls2 'ref 'check: ast 'request? request?)
    (if (<> (length ast) 3)
        (impc:compiler:print-bad-arity-error ast))
    (let* (;; a should be a closure of some kind
           (a (if (and (symbol? (cadr ast))
                       (impc:ti:closure-exists? (symbol->string (cadr ast))))
                  #t ; // yes (cadr ast) is a globally defined closure
                  (impc:ti:type-check (cadr ast) vars kts #f))) ;; request?)))
           ;; b should be a string (the var's name)
           (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si8*))))
      (list *impc:ir:i1*))))


(define impc:ti:set-check
  (lambda (ast vars kts request?)
    ;; (println 'ast: ast 'vars: vars 'kts: kts 'request?: request?)
    (let* ((sym (impc:ti:get-var (cadr ast) vars))
           (a (impc:ti:type-check (caddr ast) vars kts (cdr sym))))
      (if *impc:ti:print-sub-checks* (println 'set!:> 'ast: ast 'a: a))
      ;; (println 'a: a 'sym: sym)
      (if (and (list? a)
               (= (length a) 1)
               (impc:ir:type? (car a)))
          (set! a (car a)))
      ;; if sym is not a global var then add return type to sym
      (if (and (assoc-strcmp (car sym) vars)
               (member a (cdr (assoc-strcmp (car sym) vars))))
          (impc:ti:force-var (car sym) vars '() a)
          (if (assoc-strcmp (car sym) vars)
              (impc:ti:update-var (car sym) vars kts a)))
      a)))

(define impc:ti:pdref-check
  (lambda (ast vars kts request?)
    (let* ((a (impc:ti:type-check (cadr ast) vars kts request?)))
      (if *impc:ti:print-sub-checks* (println 'ptrref:> 'ast: ast 'a: a))
      ;; return type of ptrref is 'a' dereferenced'
      (if (list? a)
          (set! a (car a)))
      (if (and (impc:ir:type? a)
               (impc:ir:pointer? a))
          (impc:ir:pointer-- a)
          (impc:compiler:print-bad-type-error a "pref needs a pointer argument")))))


(define impc:ti:pref-check
  (lambda (ast vars kts request?)
    (let* ((a (impc:ti:type-check (cadr ast) vars kts request?)))
      (if *impc:ti:print-sub-checks* (println 'ptrref:> 'ast: ast 'a: a))
      ;; return type of ptrref is 'a' referenced
      (if (list? a)
          (set! a (car a)))
      (if (and (impc:ir:type? a)
               (impc:ir:pointer? a))
          (impc:ir:pointer++ a)
          (impc:compiler:print-bad-type-error a "pref needs a pointer argument")))))


(define impc:ti:lambda-check
  (lambda (ast vars kts request?)
    ;; (println 'lcheck: ast 'request? request?)
    ;; first we check if a type request has been made
    (if (and request? (impc:ir:closure? request?))
        ;; if there is a request then cycle through
        ;; and set lambda arg symbols
        (begin
          (if (<> (length (cadr ast))
                  (length (cddr request?)))
              (begin
                (impc:compiler:print-compiler-error "Bad request to lambda chk:" ast)))
          (map (lambda (sym req)
                 (if (symbol? sym)
                     (if (atom? req)
                         (impc:ti:update-var sym vars kts (list req))
                         (impc:ti:update-var sym vars kts req))))
               (cadr ast)
               (cddr request?))
          ;; finally set request? to the return type
          (set! request? (cadr request?))))
    ;; run body for type coverage
    ;; grab the last result as return type
    (let ((res (impc:ti:type-unify (impc:ti:type-check (caddr ast) vars kts request?) vars)))
      ;; if no valid return type rerun type-check for a second time
      (if (not (or (impc:ir:type? res)
                   (and (list? res)
                        (= (length res) 1)
                        (impc:ir:type? (car res)))))
          (set! res (impc:ti:type-unify (impc:ti:type-check (caddr ast) vars kts request?) vars)))
      ;; (println 'bbbb: res '-> request? request?) ;  '-> (caddr ast))
      ;; if we have a choice between numeric options we force one!
      (if (and (not (impc:ti:complex-type? res))
               (list? res)
               (> (length res) 1)
               (not (member #f (map (lambda (t) (impc:ir:floating-point? t)) res))))
          (set! res (list (apply min res)))) ;;(list *impc:ir:fp64*))) ;; force doubles
      (if (and (not (impc:ti:complex-type? res))
               (list? res)
               (> (length res) 1)
               (not (member #f (map (lambda (t) (impc:ir:fixed-point? t)) res))))
          (set! res (list (apply min res)))) ;; (list *impc:ir:si64*))) ;; force i64
      ;; if we now have a valid type - then sending type to body!
      (if (and (list? res)
               (= (length res) 1)
               (impc:ir:type? (car res)))
          (begin (impc:ti:type-check (caddr ast) vars kts (car res))
                 (set! res (car res))))
      ;; return lambda type which is made up of
      ;; argument symbols plus return type from last body expression
      (let* ((ret (list (impc:ir:pointer++ (list* *impc:ir:closure* res (cadr ast)) 2)))
             (uret (impc:ti:type-unify ret vars)))
        (if (not (null? uret))
            (map (lambda (sym req)
                   ;; (println 'larg: sym 'req: req)
                   (if (symbol? sym)
                       (impc:ti:update-var sym vars kts (impc:ti:type-unify req vars))))
                 (cadr ast)
                 (cddr uret)))
        ;; (println 'vars3 vars)
        (if (null? uret) ret uret)))))


;; whenever a closure is called we calculate a type for it
;; at the end these possibly multiple views should unify!
(define impc:ti:closure-call-check
  (lambda (ast vars kts request?)
    ;; (println 'cchint 'ast: ast 'vars: vars 'request: request?)
    ;; otherwise we need to try to find a type definition for the closure
    (let* ((ctype (if (assoc-strcmp (car ast) vars)
                      (cdr (assoc-strcmp (car ast) vars))
                      (if (impc:ti:closure-exists? (symbol->string (car ast)))
                          (list (impc:ti:get-closure-type (symbol->string (car ast))))
                          ;; check for globalvar closures
                          (if (and (impc:ti:globalvar-exists? (symbol->string (car ast)))
                                   (impc:ir:closure? (impc:ti:get-globalvar-type (symbol->string (car ast)))))
                              (list (impc:ti:get-globalvar-type (symbol->string (car ast))))
                              (impc:compiler:print-missing-identifier-error (car ast) 'closure)))))
           ;; (llllllll (println 'ctype: ctype))
           ;; get argument expression types
           (res (map (lambda (e t)
                       ;; (println 'e: e 't: t)
                       (let ((res (impc:ti:type-check e vars kts
                                                      (if (symbol? t)
                                                          (impc:ti:symbol-check t vars kts #f)
                                                          t))))
                         ;; if t is a symbol then add res to t
                         (if (and (not (null? res))
                                  (symbol? t))
                             (if (or (and (list? res)
                                          (impc:ir:type? (car res)))
                                     (impc:ir:type? res))
                                 (impc:ti:force-var t vars kts res)
                                        ;(impc:ti:update-var t vars kts res)
                                 (impc:ti:update-var t vars kts res)))
                                        ;(if (symbol? t) (impc:ti:update-var t vars kts res))

                         res))
                     (cdr ast)
                     (if (or (null? ctype)
                             (and (number? (car ctype))
                                  (= (car ctype) (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))))
                             (not (impc:ir:closure? (car ctype))))
                         (make-list (length (cdr ast)) #f)
                         ;; if we are using an existing definition then check arity
                         (if (<> (length (cddr (car ctype)))
                                 (length (cdr ast)))
                             (impc:compiler:print-bad-arity-error ast)
                             (cddr (car ctype))))))
           ;; if we already have a type defined we can use it's return type
           ;; otherwise
           ;; if there was a request that will be the return type
           ;; otherwise we cannot know it
           (ret (if (and (not (null? ctype))
                         (not (atom? (car ctype)))
                         (impc:ir:closure? (car ctype)))
                    (cadr (car ctype))
                    (if (and request?
                             (not (and (list? request?)
                                       (equal? (car request?) *impc:ir:notype*)))
                             (not (null? request?)))
                        request?
                        '()))))

      (if *impc:ti:print-sub-checks* (println 'closure:> 'ast: ast 'res: res 'ret: ret))
      (if (assoc-strcmp (car ast) vars)
          (impc:ti:update-var (car ast) vars kts
                              (list (impc:ir:pointer++ (list* *impc:ir:closure* ret res) 2))))
      (if (list? ret) ret
          (list ret)))))


;; for fptrcall
;; which has the form
;; (fptrcall fptr ... args)
(define impc:ti:fptrcall-check
  (lambda (ast vars kts request?)
    ;; (println 'ast: ast)
    (let* ((fptr (impc:ti:type-check (cadr ast) vars kts #f))
           ;; (lllll (println 'fptr fptr))
           (ctype (if (impc:ir:closure? (car fptr))
                      (car fptr)
                      (impc:compiler:print-bad-type-error (car fptr) "bad fptr type in fptrcall")))
           ;; (lllllll (println 'ctype ctype))
           ;; get argument expression types
           (res (map (lambda (e t)
                       ;;(println 'e: e 't: t)
                       (let ((res (impc:ti:type-check e vars kts
                                                      (if (symbol? t)
                                                          (impc:ti:symbol-check t vars kts #f)
                                                          t))))
                         ;; if t is a symbol then add res to t
                         (if (symbol? t)
                             (if (or (and (list? res)
                                          (impc:ir:type? (car res)))
                                     (impc:ir:type? res))
                                 (impc:ti:force-var t vars kts res)
                                 (impc:ti:update-var t vars kts res)))
                         res))
                     (cddr ast)
                     (if (<> (length (cddr ctype))
                             (length (cddr ast)))
                         (impc:compiler:print-bad-arity-error ast)
                         (cddr ctype)))))
      (cadr ctype))))



;; for fptrcall
;; which has the form
;; (fptrcall fptr ... args)
(define impc:ti:fptrcall-check
  (lambda (ast vars kts request?)
    (let* ((fptr (impc:ti:type-check (cadr ast) vars kts #f)))
      (if (null? fptr)
          (list)
          (let* ((ctype (if (impc:ir:closure? (car fptr))
                            (car fptr)
                            (impc:compiler:print-bad-type-error (car fptr) "bad fptr type in fptrcall")))
                 (res (map (lambda (e t)
                             ;;(println 'e: e 't: t)
                             (let ((res (impc:ti:type-check e vars kts
                                                            (if (symbol? t)
                                                                (impc:ti:symbol-check t vars kts #f)
                                                                t))))
                               ;; if t is a symbol then add res to t
                               (if (symbol? t)
                                   (if (or (and (list? res)
                                                (impc:ir:type? (car res)))
                                           (impc:ir:type? res))
                                       (impc:ti:force-var t vars kts res)
                                       (impc:ti:update-var t vars kts res)))
                               res))
                           (cddr ast)
                           (if (<> (length (cddr ctype))
                                   (length (cddr ast)))
                               (impc:compiler:print-bad-arity-error ast)
                               (cddr ctype)))))
            (cadr ctype))))))




(define impc:ti:dotimes-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (car (cadr ast)) vars kts #f))
          (b (impc:ti:type-check (cadr (cadr ast)) vars kts #f)))
      (if (and (not (impc:ir:type? b))
               (= (length b) 1))
          (set! b (car b)))
      (if (and (not (impc:ir:type? a))
               (= (length a) 1))
          (set! a (car a)))
      (if (and (impc:ir:type? a)
               (list? b)
               (member a b))
          (set! b a))
      ;; (car (cadr ast)) should be a symbol that we want to update with a
      (if (not (symbol? (car (cadr ast))))
          (impc:compiler:print-badly-formed-expression-error 'dotimes ast))
      (impc:ti:update-var (car (cadr ast)) vars kts b)
      (if (and (symbol? (cadr (cadr ast)))
               (impc:ir:type? a))
          (impc:ti:update-var (cadr (cadr ast)) vars kts a))
      ;; check over body code but don't worry about return types
      (impc:ti:type-check (caddr ast) vars kts #f)
      ;; dotimes returns void
      (list *impc:ir:void*))))

(define impc:ti:while-check
  (lambda (ast vars kts request?)
    (if (tree-member 'let (cadr ast))
        (impc:compiler:print-compiler-error "You cannot bind variables within a while condition check!" (cadr ast)))
    (let ((type (impc:ti:type-check (cadr ast) vars kts (list *impc:ir:i1*)))
          (body (impc:ti:type-check (caddr ast) vars kts #f)))
      (if (not (or (and (number? type) (= type *impc:ir:i1*))
                   (= (car type) *impc:ir:i1*)
                   (null? type)))
          (impc:compiler:print-bad-type-error (car type) "test expression in while loop must return a boolean"))
      (list *impc:ir:void*))))

(define impc:ti:printf-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
      ;; run through everything else for completeness but don't care about the results
      (for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cddr ast))
      ;; printf returns i32
      (list *impc:ir:si32*))))

(define impc:ti:fprintf-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*))))
          (b (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
      ;; run through everything else for completeness but don't care about the results
      (for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cdddr ast))
      ;; printf returns i32
      (list *impc:ir:si32*))))

(define impc:ti:sprintf-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*))))
          (b (impc:ti:type-check (caddr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
      ;; run through everything else for completeness but don't care about the results
      (for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cdddr ast))
      ;; printf returns i32
      (list *impc:ir:si32*))))

(define impc:ti:sscanf-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*))))
          (b (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
      ;; run through everything else for completeness but don't care about the results
      (for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cdddr ast))
      ;; printf returns i32
      (list *impc:ir:si32*))))

(define impc:ti:fscanf-check
  (lambda (ast vars kts request?)
    (let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*))))
          (b (impc:ti:type-check (caddr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
      ;; run through everything else for completeness but don't care about the results
      (for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cdddr ast))
      ;; printf returns i32
      (list *impc:ir:si32*))))

(define impc:ti:string-check
  (lambda (ast vars kts request?)
    (if (string? ast)
        (list (+ *impc:ir:si8* *impc:ir:pointer*))
        '())))

(define impc:ti:carcdr-check
  (lambda (ast vars kts request?)
    ;; check that we are getter a pair as an argument
    (impc:ti:type-check (cadr ast) vars kts (list (impc:ir:pointer++ *impc:ir:pair*)))
    ;; don't do anything about return type yet
    '()))

(define impc:ti:coerce-check
  (lambda (ast vars kts request?)
    (impc:ti:type-check (cadr ast) vars kts #f)
    (list (caddr ast))))

(define impc:ti:closure-in-first-position
  (lambda (ast vars kts request?)
    ;; first check return type of car ast (which will be a closure)
    ;; then check against it's arg types
    (let ((type (impc:ti:type-check (car ast) vars kts request?)))
      (if (null? type)
          (impc:compiler:print-bad-type-error "unknown-type" ast))
      (if (not (impc:ir:type? type))
          (set! type (car type)))
      (if (not (list? type))
          (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type type) ast))
      (if (<> (length (cddr type)) (length (cdr ast)))
          (impc:compiler:print-bad-arity-error ast))
      (if (<> (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (car type))
          (impc:compiler:print-bad-type-error (impc:ir:pretty-print-type (car type)) ast)
          (begin (map (lambda (a b)
                        (impc:ti:type-check b vars kts a))
                      (cddr type)
                      (cdr ast))
                 (cadr type))))))


(define *impc:ti:type-check:calls* 0)

;; vars is statefull and will be modified in place
(define impc:ti:type-check
  (lambda (ast vars kts request?)
    (set! *impc:ti:type-check:calls* (+ *impc:ti:type-check:calls* 1))
    ;; (println 'tc: ast); 'vars: vars)
    ;; (println 'type-check: ast  'vars: vars  'kts: kts 'request? request?)
    (if *impc:ti:print-main-check* (println 'type-check: ast 'kts: kts 'request? request?))
    (if *impc:ti:print-main-check* (println 'vars------: vars))
    (cond ((null? ast) '())
          ((and (atom? ast) (number? ast)) (impc:ti:numeric-check ast vars kts request?))
          ((and (atom? ast) (symbol? ast)) (impc:ti:symbol-check ast vars kts request?))
          ((and (atom? ast) (string? ast)) (impc:ti:string-check ast vars kts request?))
          ((atom? ast) (impc:compiler:print-compiler-error "internal error unhandled atom" ast))
          ((and (list? ast) (member (car ast) *impc:letslist*)) (impc:ti:let-check ast vars kts request?))
          ((and (list? ast) (member (car ast) *impc:lambdaslist*)) (impc:ti:lambda-check ast vars kts request?))
          ((and (list? ast) (equal? (car ast) 't:))
           (impc:ti:type-check (cadr ast) vars kts
                               (impc:ir:get-type-from-pretty-str
                                (symbol->string (caddr ast)))))
          ((and (list? ast) (member (car ast) *impc:mathbinaryaritylist*))
           ;; '(* / + - % modulo bitwise-and bitwise-or bitwise-eor bitwise-shift-left bitwise-shift-right bitwise-not)))
           (let ((r (impc:ti:math-check ast vars kts request?)))
             (if (impc:ir:tuple? r)
                 (begin ;; this is very dodgy!
                   (set! *unique-polynum* (+ 1 *unique-polynum*))
                   (let ((m (string->symbol (string-append (cond ((eq? (car ast) '*) "xtm_multiplication##")
                                                                 ((eq? (car ast) '+) "xtm_addition##")
                                                                 ((eq? (car ast) '/) "xtm_division##")
                                                                 ((eq? (car ast) '-) "xtm_subtraction##")
                                                                 ((eq? (car ast) '%) "xtm_modulo##")
                                                                 (else (print-error "Error in math overloading")))
                                                           (number->string *unique-polynum*)))))
                     (insert-at-index 1 vars (list m))
                     (set-car! ast m)
                     (set! r (impc:ti:type-check ast vars kts request?)))))
             r))
          ((and (list? ast) (member (car ast) '(< > = <>)))
           (let ((r (impc:ti:compare-check ast vars kts request?)))
             (if (impc:ir:tuple? r)
                 (begin ;; this is very dodgy!
                   (set! *unique-polynum* (+ 1 *unique-polynum*))
                   (let ((m (string->symbol (string-append (cond ((eq? (car ast) '<) "xtm_lessthan##")
                                                                 ((eq? (car ast) '>) "xtm_greaterthan##")
                                                                 ((eq? (car ast) '=) "xtm_equal##")
                                                                 ((eq? (car ast) '<>) "xtm_notequal##")
                                                                 (else (print-error "Error in math overloading")))
                                                           (number->string *unique-polynum*)))))
                     (insert-at-index 1 vars (list m))
                     (set-car! ast m)
                     (set! r (impc:ti:type-check ast vars kts request?)))))
             *impc:ir:i1*))
          ((and (list? ast) (member (car ast) *impc:mathintrinsicslist*)) (impc:ti:math-intrinsic-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(dotimes))) (impc:ti:dotimes-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(while))) (impc:ti:while-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(printf))) (impc:ti:printf-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(sprintf))) (impc:ti:sprintf-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(fprintf))) (impc:ti:fprintf-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(sscanf))) (impc:ti:sscanf-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(fscanf))) (impc:ti:fscanf-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(push_zone))) (impc:ti:push_zone-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(pop_zone))) (impc:ti:pop_zone-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(push_new_zone))) (impc:ti:push_new_zone-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(create_zone))) (impc:ti:create_zone-check ast vars kts request?))
          ;;((and (list? ast) (member (car ast) '(memzone))) (impc:ti:memzone-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(llvm_callback))) (impc:ti:callback-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(make-vector))) (impc:ti:make-vector-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(vector-set!))) (impc:ti:vector-set-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(vector-ref))) (impc:ti:vector-ref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(vector-shuffle))) (impc:ti:vector-shuffle-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(make-array))) (impc:ti:make-array-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(array-set!))) (impc:ti:array-set-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(array-ref))) (impc:ti:array-ref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(array-ref-ptr))) (impc:ti:array-ref-ptr-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(pointer-set!))) (impc:ti:pointer-set-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(pointer-ref))) (impc:ti:pointer-ref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(pointer-ref-ptr))) (impc:ti:pointer-ref-ptr-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(stack-alloc))) (impc:ti:stack-alloc-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(heap-alloc))) (impc:ti:heap-alloc-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(zone-alloc))) (impc:ti:zone-alloc-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(make-tuple))) (impc:ti:make-tuple-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(num-of-elts))) (impc:ti:num-of-elts-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(ref))) (impc:ti:ref-check ast vars kts request?))                    
          ((and (list? ast) (member (car ast) '(tuple-set!))) (impc:ti:tuple-set-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(tuple-ref))) (impc:ti:tuple-ref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(tuple-ref-ptr))) (impc:ti:tuple-ref-ptr-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(closure-set!))) (impc:ti:closure-set-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(closure-ref))) (impc:ti:closure-ref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(closure-refcheck))) (impc:ti:closure-refcheck-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(pref))) (impc:ti:pref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(pdref))) (impc:ti:pdref-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(null?))) (impc:ti:null?-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(impc_null))) (impc:ti:null-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(bitcast))) (impc:ti:bitcast-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(bitconvert))) (impc:ti:bitconvert-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(void))) (impc:ti:void-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(fptrcall))) (impc:ti:fptrcall-check ast vars kts request?))
          ((and (list? ast) ;; poly func (specific match)
                (symbol? (car ast))
                request?
                (string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
                (impc:ti:nativef-poly-exact-check ast vars kts request?))
           ;; (println 'poly-exact: ast 'r: request?)
           request?)
          ((and (list? ast) ;; generic function
                (symbol? (car ast))
                (string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
                (impc:ti:genericfunc-exists? (string->symbol (car (regex:split (symbol->string (car ast)) "##")))
                                             (length (cdr ast))))
           ;; (println 'generic: ast 'r: request?)
           (impc:ti:nativef-generics ast vars kts request?))
          ((and (list? ast) ;; poly func (closest match)
                (symbol? (car ast))
                (string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
                (impc:ti:get-polyfunc-candidate-types (car (regex:split (symbol->string (car ast)) "##"))))
           ;; (println 'poly: ast 'r: request?)
           (let ((reses (impc:ti:nativef-poly-check ast vars kts request?)))
             ;; (println 'polyclosest 'ast: ast reses 'r: request?)
             reses))
          ((and (list? ast) ;; native function
                (symbol? (car ast))
                (or (impc:ti:nativefunc-exists? (symbol->string (car ast)))
                    (impc:ti:closure-exists? (symbol->string (car ast)))))
           ;; (println 'native: ast 'r: request?)
           (impc:ti:nativef-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(begin))) (impc:ti:begin-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(if ifret))) (impc:ti:if-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(set!))) (impc:ti:set-check ast vars kts request?))
          ((and (list? ast) (member (car ast) '(ret->))) (impc:ti:ret-check ast vars kts request?))
          ((and (list? ast) (assoc-strcmp (car ast) vars)) (impc:ti:closure-call-check ast vars kts request?))
          ((and (list? ast) (list? (car ast))) (impc:ti:closure-in-first-position ast vars kts request?))
          ((and (list? ast) ;; this is here to check against closures as global vars (i.e. not in local environment)
                (symbol? (car ast))
                (or (impc:ti:closure-exists? (symbol->string (car ast)))
                    (let ((gvar-type (impc:ti:get-globalvar-type (symbol->string (car ast)))))
                      (and gvar-type (impc:ir:closure? gvar-type)))))
           (impc:ti:closure-call-check ast vars kts request?))
          (else
           (impc:ti:join (impc:ti:type-check (car ast) vars kts request?)
                         (impc:ti:type-check (cdr ast) vars kts request?))))))


(define impc:ti:find-unresolved-simple-types
  (lambda (union)
    (let ((unresolved (cl:remove #f (map (lambda (x) ;; return the first bad variable that is not a closure
                                           (if (null? (cdr x)) #f
                                               (if (and (list? (cdr x)) ;; check there are multiple choices
                                                        (number? (cadr x))
                                                        (not (member (modulo (cadr x) *impc:ir:pointer*)
                                                                     (list *impc:ir:tuple* *impc:ir:closure* *impc:ir:array* *impc:ir:vector*))) ;; make sure it's a base type (not closure or tuple)
                                                        (cl:every impc:ir:type? (cdr x))) ;; check that it's choices are valid (not null)
                                                   x #f)))
                                         union))))
      (if (null? unresolved) #f
          unresolved))))


(define impc:ti:remove-single-element-lists
  (lambda (l)
    (map (lambda (k)
           ;; (println 'k k)
           (if (list? k)
               (if (= (length k) 1)
                   (car k)
                   (impc:ti:remove-single-element-lists k))
               k))
         l)))


(define impc:ti:clean-fvars
  (lambda (vars)
    ;; (println 'cleaning: vars)
    ;; first remove all single element lists
    (map (lambda (v)
           (set-cdr! v (impc:ti:remove-single-element-lists (cdr v))))
         vars)
    ;; (println 'vars2: vars)
    vars))





(define *type-check-continuation* '())

(define impc:ti:run-type-check
  (lambda (vars forced-types ast)
    ;; (println '====================================)
    ;; (println 'run-type-check 'ast: ast)    
    ;; (println 'forced-types forced-types)
    ;; (println 'vars: vars)
    (let ((typelist (call/cc (lambda (k) (set! *type-check-continuation* k) '()))))
      (if (null? typelist)
          (set! typelist (impc:ti:run-type-check* vars forced-types ast)))
      ;; (println 'unified 'types: typelist)
      typelist)))

(define *impc:ti:type-check-function-symbol* #f)
(define *impc:ti:type-check-function-symbol-short* #f)

;; run the type checker
;; if we fail to unify completely the first time
;; try some possible substitutions!
(define impc:ti:run-type-check*
  (lambda (vars forced-types ast . cnt)
    (set! *impc:ti:nativef-generics:calls* 0)
    (set! *impc:ti:type-check:calls* 0)
    ;; (println '------------------------------------)
    ;; (println 'run-type-check*: (caaadr ast))
    ;; (println 'forced-types* forced-types)
    ;; (println 'ast: ast)
    ;; (println 'vars*: vars)
    (define *impc:ti:nativef-generics-recurse-test* 0)    
    (set! *impc:ti:type-check-function-symbol* (caaadr ast))
    (set! *impc:ti:type-check-function-symbol-short*
          (string->symbol
           (car (regex:split (symbol->string *impc:ti:type-check-function-symbol*) "(_poly_)|(_adhoc_)"))))
    ;; (if (null? cnt) (sys:clear-log-view))
    (let* ((fvars (map (lambda (t) ;; add any forced-type values to vars
                         (if (assoc-strcmp (car t) forced-types)
                             (let ((tt (cdr (assoc-strcmp (car t) forced-types))))
                               (cons (car t) (list tt)))
                             t))
                       vars))
           ;; (lll (println 'vars1: vars))
           (kts (map (lambda (x) (car x)) forced-types)) ;; just need symbols from forced-types
           ;; fvars gets modified 'in place' during this next
           ;; operation
           (t1 (clock:clock))
           (ret (impc:ti:type-check ast fvars kts #f))
           ;; (llllllll (println 'pre-unified-vars: fvars))
           (t2 (clock:clock))
           (u1 (impc:ti:unify fvars))
           (u (cl:remove-if (lambda (x)
                              (and (not (impc:ir:type? (cdr x)))
                                   (regex:match? (symbol->string (car x)) "(^!|[A-Za-z]\\:\\<|[A-Za-z]{)")))
                            u1))
           (t3 (clock:clock))
           ;; (lllll (println 'post-unified-vars: u))
           (t (impc:ti:unity? u))
           (t4 (clock:clock))
           ;; (lllllll (println (println 'cccccc)))
           (tt (cl:every (lambda (x) x) t))
           (a (if tt #t
                  (impc:ti:find-unresolved-simple-types u))))
                                        ;(println 'fvars: fvars)
                                        ;(println 'types: u)
      (if *impc:ti:print-unifications* (println 'tirun:> a '-> u))

      ;; (println (caaadr ast) 'type-check: (- t2 t1) 'unify: (- t3 t2) 'unity: (- t4 t3))
      ;; (println (caaadr ast)
      ;;          'num-vars: (length vars)
      ;;          'num-kvar: (length forced-types)
      ;;          'tc-calls: *impc:ti:type-check:calls*
      ;;          'gencalls: *impc:ti:nativef-generics:calls*)

      ;; (println 'tt tt)
      ;; (println 'u u)
      ;; (println '-------------------------------------)

      ;; if we have unified types then return them through continuation
      (if (or tt
              (and (not (null? cnt))
                   (list? (car cnt))
                   (member u (car cnt))))
          (*type-check-continuation* u))

      (cond ((and (not (null? cnt))
                  (eq? #f (car cnt)))
             u)
            ((not a) ;; this run is for generics
             (impc:ti:clear-all-vars fvars)
             (let* ((ret (impc:ti:run-type-check* fvars
                                                  ;; kts for all solved types
                                                  (cl:remove #f (map (lambda (k)
                                                                       (if (impc:ir:type? (cdr k)) k #f))
                                                                     u))
                                                  ast (cons u (if (null? cnt) cnt (car cnt))))))
               ret))
            (else ;; I think this whole section might be a waste of time!
             (let ((res (map (lambda (x) ;; call run-type-check for each version of a simple type
                               ;; first clear vars
                               (impc:ti:clear-all-vars fvars)
                               (let* ((newforced (append (cl:remove-if-not (lambda (z) (and (not (list? z)) (pair? z))) u)
                                                         ;; and any simple types that unify on x
                                                         (cl:remove 'failed
                                                                    (map (lambda (k)
                                                                           (if (null? (cl:intersection (list x) (cdr k)))
                                                                               'failed
                                                                               (cons (car k) x)))
                                                                         (impc:ti:find-unresolved-simple-types u)))
                                                         forced-types))
                                      (newkts (cl:remove-if (lambda (x) (and (assoc-strcmp (car x) forced-types)
                                                                     (not (equal? (assoc-strcmp (car x) forced-types) x))))
                                                         newforced)))
                                 (impc:ti:run-type-check* fvars newkts ast #f)))
                             ;; ast (cons u (if (null? cnt) cnt (car cnt)))))
                             (cdr (car a)))))
               ;; then see what versions might be OK?
               (let* ((rr (map (lambda (y)
                                 (cl:remove-if (lambda (x)
                                                 (regex:match? (symbol->string (car x)) "(^!|[A-Za-z]\\:\\<|[A-Za-z]{)"))
                                                 ;; (regex:match? (symbol->string (car x)) "^!" ))
                                               y))
                               res))
                      (r (cl:find-if (lambda (x)
                                       (cl:every (lambda (x) x) (impc:ti:unity? x)))
                                     rr)))
                 (if (not r) ;; if no options are any good then :(
                     u
                     r))))))))
                     ;; (impc:compiler:print-could-not-resolve-types
                     ;;  u
                     ;;  ast))
                 ;; (begin r))))))))


;;
;;
;; Other utility code
;;
;;
(define impc:ti:add-types-to-source-atom
  (lambda (symname ast types envvars . prev)
    ;; (println 'symname: symname 'ast: ast)
    (cond ((and (symbol? ast)
                (not (string-contains? (symbol->string ast) ":"))
                (impc:ti:polyfunc-exists? (symbol->string ast)))
           (let* ((pname (symbol->string ast))
                  (ts (impc:ti:get-polyfunc-candidate-types pname)))
             (if (= (length ts) 1)
                 (string->symbol (string-append pname "_adhoc_" (cname-encode (impc:ir:get-base-type (impc:ir:pretty-print-type (car ts))))))
                 (impc:compiler:print-compiler-error "Try forcing a type. Ambiguous polymorphic function" ast))))
          ((and (symbol? ast)
                (string-contains? (symbol->string ast) ":")
                (impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string ast) ":"))))
           (let* ((res (regex:type-split (symbol->string ast) ":"))
                  (pname (car res))
                  (ptype (if (impc:ti:typealias-exists? (cadr res))
                             (impc:ir:get-base-type (impc:ir:pretty-print-type (impc:ti:get-typealias-type (cadr res))))
                             (impc:ir:get-base-type (cadr res)))))
             (string->symbol (string-append pname "_adhoc_" (cname-encode ptype)))))
          ((and (symbol? ast)
                (string-contains? (symbol->string ast) ":"))
           (let* ((p (regex:type-split (symbol->string ast) ":"))
                  (ptrs (impc:ir:get-ptr-depth ast))
                  (gpoly? (impc:ti:genericfunc-exists? (string->symbol (car p))))
                  (apoly? (impc:ti:polyfunc-exists? (car p)))
                  (etype (cname-encode (impc:ir:get-base-type (cadr p)))))
             (if gpoly?
                 (begin
                   (if (not (impc:ti:closure-exists? (string-append (car p) "_poly_" etype)))
                       (let* ((arity (impc:ir:get-arity-from-pretty-closure (cadr p)))
                              (ptypes (impc:ti:genericfunc-types (string->symbol (car p)) arity (cadr p)))
                              (tmp (if (not ptypes)
                                       (impc:compiler:print-bad-arity-error ast)))
                              (code (caddr (cadr (impc:ti:genericfunc-types (string->symbol (car p)) arity (cadr p)))))
                              (pfunc (string->symbol (string-append (car p) "_poly_" etype))))
                         ;; pre-populate the closure cache for the new specialised func
                         (if (not (impc:ti:closure-exists? (symbol->string pfunc)))
                             (impc:ti:register-new-closure (symbol->string pfunc)
                                                           '()
                                                           *impc:default-zone-size*
                                                           ""
                                                           code))
                         ;; (println 'spec-compile1: pfunc 'code: code)
                         (set! code `(let ((,pfunc ,code)) ,pfunc))
                         (impc:ti:run pfunc code *impc:default-zone-size* #f (cons pfunc (string->symbol (cadr p))))
                         (impc:ti:register-new-polyfunc (car p)
                                                        (symbol->string pfunc)
                                                        (impc:ir:get-type-from-pretty-str (cadr p))
                                                        "")
                         (impc:ti:initialize-closure-with-new-zone (symbol->string pfunc)
                                                                   *impc:default-zone-size*)
                         pfunc))
                   (begin ;; (println 'here!)
                     (string->symbol (string-append (car p) "_poly_" etype))))
                 (if apoly?
                     (string->symbol (string-append (car p) "_adhoc_" etype))
                     (impc:compiler:print-missing-identifier-error ast 'variable)))))
          ((and (symbol? ast)
                (string-contains? (symbol->string ast) "##")
                (assoc-strcmp ast types)
                (impc:ti:polyfunc-exists? (impc:ir:get-base-type (symbol->string ast))))
           (let* ((nm (regex:split (symbol->string ast) "##"))
                  (n1 (car nm))
                  (type (cdr (assoc-strcmp ast types)))
                  (ptype (impc:ir:pretty-print-type type))
                  (cn (cname-encode (impc:ir:get-base-type ptype)))
                  (newn (string-append n1 "_adhoc_" cn)))
             (if (not (impc:ti:closure-exists? newn))
                 (impc:compiler:print-compiler-error (string-append "Bad type: " ptype " for polymorphic function " (car nm)) ast))
             (string->symbol newn)))
          ((and (symbol? ast)
                (string-contains? (symbol->string ast) "##")
                (assoc-strcmp ast types))
           (let* ((nm (regex:split (symbol->string ast) "##"))
                  (n1 (car nm))
                  (type (cdr (assoc-strcmp ast types)))
                  (ptype (impc:ir:pretty-print-type type))
                  (cn (cname-encode ptype))
                  (newn (string-append n1 "_poly_" cn)))
             (if (not (impc:ti:closure-exists? newn))
                 (let* ((arity (impc:ir:get-arity-from-pretty-closure ptype))
                        (ptypes (impc:ti:genericfunc-types (string->symbol n1) arity ptype))
                        (tmp (if (not ptypes)
                                 (impc:compiler:print-bad-arity-error ast)))
                        (code (caddr (cadr (impc:ti:genericfunc-types (string->symbol n1) arity ptype))))
                        (pfunc (string->symbol newn)))
                   ;; pre-populate the closure cache for the new specialised func
                   (if (not (impc:ti:closure-exists? (symbol->string pfunc)))
                       (impc:ti:register-new-closure (symbol->string pfunc)
                                                     '()
                                                     *impc:default-zone-size*
                                                     ""
                                                     code))
                   ;; (println 'spec-compile2: pfunc 'code: code)
                   (set! code `(let ((,pfunc ,code)) ,pfunc))
                   (impc:ti:run pfunc code *impc:default-zone-size* #f (cons pfunc (string->symbol ptype)))
                   (impc:ti:register-new-polyfunc n1
                                                  (symbol->string pfunc)
                                                  (impc:ir:get-type-from-pretty-str ptype)
                                                  "")
                   (impc:ti:initialize-closure-with-new-zone (symbol->string pfunc)
                                                             *impc:default-zone-size*)
                   pfunc))
             (string->symbol newn)))
          (else ast))))



;; add types to source
;; also add clrun for closure application
;; and inject polymorphic functions
(define impc:ti:add-types-to-source
  (lambda (symname ast types envvars . prev)
    ;; (println 'symname: symname)
    ;; (println 'ast: ast)
    ;; (println 'types: types)
    ;; (println 'envvars: envvars 'prev: prev)
    (if (atom? ast) ;; ast
        (apply impc:ti:add-types-to-source-atom symname ast types envvars prev)
        (cond ((member (car ast) '(__make-closure __make-closure-s __make-closure-h __make-closure-z))
               (if *impc:compiler:print-work-names
                   (println '>> 'worker: (string-append (symbol->string symname) "__"
                                                        (number->string (+ 1 (llvm:count))))))
               (list (car ast)
                     (cadr ast)
                     ;; global name
                     (string-append (symbol->string symname) "__" (number->string (llvm:count++)))
                     (if (or (null? prev) ;; this adds return type
                             (null? (cdr (assoc-strcmp (car prev) types))))
                         *impc:ir:other*
                         (caddr (assoc-strcmp (car prev) types)))
                     (map (lambda (v) ;; environment types
                            (if (member v envvars)
                                (let ((p (assoc-strcmp v types)))
                                  (cons (string->symbol (string-append (symbol->string (car p)) "__sub"))
                                        (cdr p)))
                                (assoc-strcmp v types)))
                          (cons symname (caddr ast)))
                     (map (lambda (v) ;; argument types
                            (assoc-strcmp v types))
                          (cadddr ast))
                     (impc:ti:add-types-to-source symname (car (cddddr ast)) types (append envvars (caddr ast)))))
              ((equal? (car ast) 'clrun->)
               (if (and (assoc-strcmp (cadr ast) types)
                        (<> (length (cdddr (assoc-strcmp (cadr ast) types)))
                            (length (cddr ast))))
                   (impc:compiler:print-compiler-error "You must provide a full type for this call" (cdr ast)))
               (list* (car ast)
                      (cadr ast)
                      (map (lambda (arg type)
                             ;;(print 'clrunargs-> arg type)
                             (let ((a (impc:ti:add-types-to-source symname arg types envvars ast)))
                               (if (null? type)
                                   (impc:compiler:print-could-not-resolve-type-error
                                    (symbol->string (cadr ast)))
                                   a)))
                           (cddr ast)
                           (cdddr (if (not (assoc-strcmp (cadr ast) types)) ;; if not in local env then get types from global var
                                      (if (impc:ti:globalvar-exists? (symbol->string (cadr ast)))
                                          (cons (cadr ast) (impc:ti:get-globalvar-type (symbol->string (cadr ast))))
                                          (cons (cadr ast) (impc:ti:get-closure-type (symbol->string (cadr ast)))))
                                      (assoc-strcmp (cadr ast) types))))))

              ;; inject (and potential compile) generic functions
              ;; do generic functions before polys
              ((and (symbol? (car ast))
                    (string-contains? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
                    (impc:ti:genericfunc-exists? (string->symbol (car (regex:split (symbol->string (car ast)) "##")))
                                                 (length (cdr ast))))
               ;; (println 'types types)
               ;; (println 'gpoly: (car ast))
               ;; (println 'gpoly: (impc:ti:genericfunc-types (string->symbol (car (regex:split (symbol->string (car ast)) "\\$\\$\\$")))))
               ;; (println 'compile 'generic? ast)
               ;; (println 'types types)
               (if (null? (cdr (assoc-strcmp (car ast) types)))
                   (impc:compiler:print-could-not-resolve-generic-type-error types ast))

               (let* ((polyname (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
                      (type (impc:ir:pretty-print-type (cdr (assoc-strcmp (car ast) types))))
                      (cname (cname-encode type))
                      (symp (regex:type-split (symbol->string symname) "_poly_"))
                      (symcname (if (null? (cdr symp)) "" (cadr symp)))
                      (arity (impc:ir:get-arity-from-pretty-closure type))
                      (code (caddr (cadr (impc:ti:genericfunc-types polyname arity type))))
                                        ;(lllll (println 'actual-code (caddr (cadr (impc:ti:genericfunc-types polyname)))))
                      (exists (if (string=? type "") #f (impc:ti:get-polyfunc-candidate (symbol->string polyname) (impc:ir:get-type-from-pretty-str type)))))
                 ;; (println 'gpoly: (car ast) 'type: type 'cname: cname 'code: code)
                 ;; (println 'exists exists)
                 ;; (println 'more (assoc-strcmp (car ast) types))
                 ;; (println 'polyname: polyname 'type: type 'exists: exists 'changed: (impc:ti:genericfunc-src-changed polyname arity))
                 ;; (impc:ti:genericfunc-src-changed polyname arity))
                 ;; (println 'p: (car ast) 'exists: exists 'changed: (impc:ti:genericfunc-src-changed polyname arity))
                 (if (or (if exists
                             (if (and (string-contains? (symbol->string exists) "_poly_")
                                      (not *impc:aot:current-output-port*)
                                      (impc:ti:genericfunc-src-changed polyname arity))
                                 #f
                                 #t)
                             #f)
                         (and (string=? (car (regex:split (symbol->string (car ast)) "##"))
                                        (car (regex:split (symbol->string symname) "_poly_")))
                              (string=? cname symcname)))
                     (if (and (string=? (car (regex:split (symbol->string (car ast)) "##"))
                                        (car (regex:split (symbol->string symname) "_poly_")))
                              (string=? cname symcname))
                         (begin ;; (println 'resursivepoly)
                           (cons 'clrun-> (cons symname
                                                (map (lambda (jj)
                                                       (impc:ti:add-types-to-source symname jj types envvars ast))
                                                     (cdr ast)))))
                         (begin ;; (println 'polyexists)
                           (cons exists
                                 (map (lambda (jj)
                                        (impc:ti:add-types-to-source symname jj types envvars ast))
                                      (cdr ast)))))
                     (let ((pfunc (string->symbol (string-append (car (regex:split (symbol->string (car ast)) "##")) "_poly_" (cname-encode type)))))
                       ;;(println 'pfunc: pfunc 'type: type 'code: code)
                       ;; (println 'kts: (cons pfunc (string->symbol type)))
                       (impc:ti:genericfunc-src-compiled polyname arity)
                       ;; pre-populate the closure cache for the new specialised func
                       (if (not (impc:ti:closure-exists? (symbol->string pfunc)))
                           (impc:ti:register-new-closure (symbol->string pfunc)
                                                         '()
                                                         *impc:default-zone-size*
                                                         ""
                                                         code))
                       ;; (println 'spec-compile3: pfunc 'code: code)
                       (set! code `(let ((,pfunc ,code)) ,pfunc))
                       (impc:ti:run pfunc code *impc:default-zone-size* #f (cons pfunc (string->symbol type)))
                       (impc:ti:register-new-polyfunc (symbol->string polyname)
                                                      (symbol->string pfunc)
                                                      (impc:ir:get-type-from-pretty-str type)
                                                      "")
                       (impc:ti:initialize-closure-with-new-zone (symbol->string pfunc)
                                                                 *impc:default-zone-size*)
                       (cons pfunc
                             (map (lambda (jj)
                                    (impc:ti:add-types-to-source symname jj types envvars ast))
                                  (cdr ast)))))))
              ;; inject polymorphic functions
              ((and (symbol? (car ast))
                    (string-contains? (symbol->string (car ast)) "##")) ;"\\$\\$\\$"))
               (let* ((pname (car (regex:split (symbol->string (car ast)) "##"))) ;"\\$\\$\\$"))))
                      (type (cdr (assoc-strcmp (car ast) types)))
                      (polyname (impc:ti:get-polyfunc-candidate pname type)))
                 (cons polyname
                       (map (lambda (jj)
                              (impc:ti:add-types-to-source symname jj types envvars ast))
                            (cdr ast)))))
              ;; environments
              ((member (car ast) '(__make-env __make-env-zone))
               (list (car ast)
                     (cadr ast)
                     (map (lambda (p)
                            (list (assoc-strcmp (car p) types)
                                  (impc:ti:add-types-to-source symname (cadr p) types envvars (car p))))
                          (caddr ast))
                     (impc:ti:add-types-to-source symname (cadddr ast) types envvars)))
              ((and
                (symbol? (car ast))
                (impc:ti:globalvar-exists? (symbol->string (car ast)))
                (impc:ir:closure? (impc:ti:get-globalvar-type (symbol->string (car ast)))))
               (impc:ti:add-types-to-source symname (cons 'clrun-> ast) types envvars))
              ((and (assoc-strcmp (car ast) types)
                    (impc:ir:closure? (cdr (assoc-strcmp (car ast) types))))
               (impc:ti:add-types-to-source symname (cons 'clrun-> ast) types envvars))
              ((list? ast)
               (map (lambda (x)
                      (impc:ti:add-types-to-source symname x types envvars ast))
                    ast))
              (else (cons (apply impc:ti:add-types-to-source symname (car ast) types envvars)
                          (apply impc:ti:add-types-to-source symname (cdr ast) types envvars)))))))


;; this is uggglly and needs to be redone!!!!!!!
;; adds ret tags
(define impc:ti:mark-returns
  (lambda (ast name in-body? last-pair? blocked?)
    (cond ((atom? ast)
           (if (and in-body? last-pair?)
               (if blocked? ast (list 'ret-> name ast))
               ast))
          ((pair? ast)
           (cond ((equal? (car ast) 'if)
                  (if (or (< (length ast) 3) (> (length ast) 4))
                      (impc:compiler:print-compiler-error "Badly formed conditional" ast))
                  ;; if statement need special syntax adjustments for returns
                  (append (if blocked? (list 'if) (list 'ifret)) (list (cadr ast))
                          (list (impc:ti:mark-returns (caddr ast) name in-body? last-pair? blocked?))
                          (if (not (null? (cdddr ast)))
                              (list (impc:ti:mark-returns (cadddr ast) name in-body? last-pair? blocked?)))))
                 ((member (car ast) *impc:letslist*)
                  (append (list (car ast))
                          (list (map (lambda (a)
                                       ;; let assigns always block (lambda can override but nothing else)
                                       (list (car a) (impc:ti:mark-returns (cadr a) (car a) #f #f #t)))
                                     (cadr ast)))
                          (impc:ti:mark-returns (cddr ast) name #t #f blocked?)))
                 ((member (car ast) *impc:lambdaslist*)
                  (append (list (car ast)) (list (cadr ast))
                          ;; lambda always unblocks because lambdas always need a return
                          (impc:ti:mark-returns (cddr ast) name #t #f #f)))
                                        ;((equal? (car ast) 'dotimes)
                                        ; (append '(dotimes) (list (cadr ast)) (impc:ti:mark-returns (cddr ast) name #t #f blocked?)))
                 ((equal? (car ast) 'begin)
                  (if (null? (cdr ast))
                      (impc:compiler:print-no-retval-error ast))
                  (let* ((rev (reverse (cdr ast)))
                         (last (car rev))
                         (rest (reverse (cdr rev)))
                         (newast (append '(begin)
                                         (append (map (lambda (a)
                                                        ;; block everything except ...
                                                        (impc:ti:mark-returns a name in-body? #f #t))
                                                      rest)
                                                 ;; the last one which we let through
                                                 ;; ONLY if it hasn't been blocked higher up!
                                                 (list (impc:ti:mark-returns last name in-body?
                                                                             (if blocked? #f #t)
                                                                             blocked?))))))
                    newast))
                 ((equal? (car ast) 'begin)
                  (append '(begin) (impc:ti:mark-returns (cdr ast) name in-body? #f blocked?)))
                 ((and in-body? last-pair? (not blocked?)) ;; if everything is good add a return!
                  (list 'ret-> name (cons (car ast) (impc:ti:mark-returns (cdr ast) name in-body? #f #t))))
                                        ;(list 'ret-> name ast))
                 (else (cons (impc:ti:mark-returns (car ast) name in-body? #f blocked?)
                             (impc:ti:mark-returns (cdr ast) name in-body? #f blocked?))))))))


;; this is a dodgy flatten :(
(define impc:ti:flatten-1
  (lambda (lst)
    (cond ((null? lst) '())
          ((list? (car lst))
           (append (car lst) (impc:ti:flatten-1 (cdr lst))))
          (else (list lst)))))


(define impc:ti:find-all-vars
  (lambda (full-ast syms)
    (letrec ((f (lambda (ast)
                  (cond ((pair? ast)
                         (cond ((and (symbol? (car ast)) ;; this for generics
                                     (regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
                                     (impc:ti:genericfunc-exists? (string->symbol (car (regex:split (symbol->string (car ast)) "##")))
                                                                  (length (cdr ast))))
                                ;; (println 'generics ast (regex:split (symbol->string (car ast)) "(\\$\\$\\$)|(_poly_)"))
                                (let* ((gname (string->symbol (car (regex:split (symbol->string (car ast)) "(##)|(_poly_)"))))
                                       (gnum (string->number (cadr (regex:split (symbol->string (car ast)) "(##)|(_poly_)"))))
                                       (arity (length (cdr ast)))
                                       (typestrs (cl:remove-duplicates
                                                  (impc:ir:get-pretty-closure-arg-strings
                                                   (symbol->string (car (impc:ti:genericfunc-types gname arity #f))))))
                                       (types (map (lambda (x) (impc:ir:get-type-from-pretty-str x)) typestrs))
                                       (newsyms (cl:remove-duplicates
                                                 (map (lambda (a b)
                                                        ;(println 'finding: a ': b)
                                                        (if (or (impc:ir:type? b)
                                                                (not (impc:ir:tuple? b)))
                                                            #f
                                                            (if (regex:match? a "^[A-Za-z0-9_-]*{")
                                                                (string->symbol (string-append a "##" (number->string gnum)))
                                                                (if (regex:match? a ":")
                                                                    (string->symbol (string-append a "##" (number->string gnum)))
                                                                    (if (not (null? (impc:ir:pretty-print-type b)))
                                                                        (string->symbol (string-append (impc:ir:get-base-type a)
                                                                                                       ":"
                                                                                                       (impc:ir:pretty-print-type b)
                                                                                                       "##" (number->string gnum)))
                                                                        #f)))))
                                                      typestrs types)))
                                       ;; (ll (println 'new1: newsyms))
                                       ;; (lll (println 'tstrings: typestrs))
                                       ;; (llll  (println 'types: types))
                                       (gvars
                                        (cl:remove-duplicates
                                         (cl:remove-if-not (lambda (x)
                                                             (and (symbol? x) (regex:match? (symbol->string x) "^!")))
                                                           (flatten types))))
                                       (newsyms_gvars (map (lambda (k)
                                                             (string->symbol (string-append (symbol->string k) "##" (number->string gnum))))
                                                           gvars)))
                                  (set! syms (append syms (list (car ast)) (cl:remove #f (cl:remove-duplicates (append newsyms newsyms_gvars)))))
                                  ;; (println 'newsyms: syms)
                                  (f (cdr ast))))
                               ((and (symbol? (car ast)) ;; this for polys
                                     (regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
                                     (impc:ti:get-polyfunc-candidate-types (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$")))))
                                ;(println 'poly!var (car ast))
                                (set! syms (append (list (car ast)) syms))
                                (f (cdr ast)))
                               ((member (car ast) '(__make-closure __make-closure-s __make-closure-h __make-closure-z))
                                (if (not (null? (cl:intersection (cadddr ast) syms)))
                                    (impc:compiler:print-shadow-var-error (car (cl:intersection (cadddr ast) syms)) 'as 'a 'shadow 'variable))
                                (set! syms (cl:remove-duplicates (append (caddr ast) (cadddr ast) syms)))
                                (f (car (cddddr ast))))
                               ((member (car ast) '(__make-env __make-env-zone))
                                (set! syms
                                      (append (map (lambda (p)
                                                     (if (member (car p) syms)
                                                         (impc:compiler:print-shadow-var-error (car p)))
                                                     (car p))
                                                   (caddr ast))
                                              syms))
                                (for-each (lambda (p)
                                            (f (cadr p)))
                                          (caddr ast))
                                (f (cadddr ast)))
                               (else (f (car ast))
                                     (f (cdr ast)))))
                        ((atom? ast) '())))))
      (f full-ast)
      syms)))



(define impc:ti:block:check-for-free-syms
  (lambda (ast esyms)
                                        ;(print 'check: 'ast: ast 'esyms: esyms)
    (cl:remove-duplicates (let loop ((lst ast))
                            (cond ((pair? lst)
                                   (append (loop (car lst))
                                           (loop (cdr lst))))
                                  ((atom? lst)
                                   (if (member lst esyms)
                                       (list lst)
                                       '())))))))

;;
;; adds make-closure and make-env tags
;;

(define impc:ti:allocate-var?
  (lambda (ast)
    (cond ((null? ast) #f)
          ((member ast *impc:lambdaslist*) #t)
          ((pair? ast)
           (or (impc:ti:allocate-var? (car ast))
               (impc:ti:allocate-var? (cdr ast))))
          (else #f))))

(define impc:ti:allocate-var?
  (lambda (ast)
    (cond ((null? ast) 0)
          ((member ast '(lambda lambdaz)) 3)
          ((eq? ast 'lambdah) 1)
          ((eq? ast 'lambdas) 2)
          ((pair? ast)
           (let ((a (impc:ti:allocate-var? (car ast)))
                 (b (impc:ti:allocate-var? (cdr ast))))
             (if (> a b) a b)))
          (else 0))))

;; adds make-closure and make-env tags
(define impc:ti:closure:convert
  (lambda (ast esyms)
    (cond ((pair? ast)
           (if (member (car ast) *impc:lambdaslist*)
               (let (;(env (impc:ti:block:check-for-free-syms ast esyms))
                     (allocate-mem-for-vars? (impc:ti:allocate-var? (cdr ast))))
                 (list (cond ((eq? (car ast) 'lambdah) '__make-closure-h)
                             ((eq? (car ast) 'lambdas) '__make-closure-s)
                             (else '__make-closure-z))
                       allocate-mem-for-vars?
                       ;; name of compiled function is always last
                       ;; so we can remove it by dropping it off the end
                       (cdr (reverse (cl:remove-duplicates esyms))) ;env
                       (cadr ast)
                       (impc:ti:closure:convert (caddr ast) (append (cadr ast) esyms))))
               (if (member (car ast) *impc:letslist*)
                   (let* ((allocate-mem-for-vars? (impc:ti:allocate-var? ast))
                          (bindings (map (lambda (binding)
                                           (car binding))
                                         (cadr ast))))
                                        ;(free-syms (impc:ti:block:check-for-free-syms (cddr ast) (append bindings esyms))))
                     (cons '__make-env
                           (cons allocate-mem-for-vars?
                                 (list (impc:ti:closure:convert (cadr ast) (append bindings esyms))
                                       (impc:ti:closure:convert (caddr ast) (append bindings esyms))))))
                   (cons (impc:ti:closure:convert (car ast) esyms)
                         (impc:ti:closure:convert (cdr ast) esyms)))))
          ((atom? ast) ast))))



;; expects t1 (i.e. original untransformed code)
(define impc:ti:get-closure-arg-symbols
  (lambda (closure-sym ast)
                                        ;(print 'ast: ast)
    (cond ((null? ast) '())
          ((atom? ast) '())
          ((vector? ast) '())
          ((and (pair? ast)
                (eq? (car ast) closure-sym))
           (if (and (not (null? (cdr ast)))
                    (list? (cadr ast))
                    (member (caadr ast) *impc:lambdaslist*))
               (cadr (cadr ast))
               '()))
          (else (append (impc:ti:get-closure-arg-symbols closure-sym (car ast))
                        (impc:ti:get-closure-arg-symbols closure-sym (cdr ast)))))))


(define impc:ti:spec-new-type?
  (lambda (x)
    ;; (println 'newspec? x)
    (if (and (string? x)
             (regex:match? x "_poly_")
             (not (impc:ti:namedtype-exists? x)))
        (let* ((p (regex:split x  "_poly_"))
               (basename (substring (impc:ir:get-base-type x) 1
                                    (string-length (impc:ir:get-base-type x))))
               (name (substring (car p) 1 (string-length (car p))))
               (ptrd (impc:ir:get-ptr-depth (cadr p)))
               (t1 (cname-decode (impc:ir:get-base-type (cadr p))))
               (t2 (impc:ir:get-pretty-tuple-arg-strings t1))
               ;; (gt (impc:ti:get-generictype-candidate-types name))
               (t3 (impc:ti:maximize-generic-type
                    (apply string-append name "{" (substring t1 1 (- (string-length t1) 1)) "}"
                           (make-list ptrd "*"))))
               (t3b (impc:ir:get-pretty-tuple-arg-strings (cadr (impc:ti:split-namedtype t3))))
               (t3c (cons 14 (map (lambda (x)
                                    (if (string? (impc:ir:get-type-from-pretty-str x))
                                        (impc:ir:get-type-from-pretty-str x)
                                        (if (regex:match? x (string-append "^" name "\\**"))
                                            (impc:ir:pointer++ (string-append "%" basename)
                                                               (impc:ir:get-ptr-depth x))
                                            (impc:ir:get-type-from-pretty-str x))))
                                  t3b)))
               (t3d (impc:ir:get-type-str t3c)))
          ;; (println 'newspec name basename t3c t3d)
          ;; (println 'compile:
          (if (llvm:compile-ir (string-append "%" basename " = type " t3d))
              (begin
                (impc:ti:register-new-polytype name
                                               basename
                                               t3c
                                               "")
                #t)
              #f))
        #f)))


(define impc:ti:handle-forced-types
  (lambda (t1 . args)
    (if (null? args) '()
        (let* ((forced-types (map (lambda (t)
                                    (map (lambda (tt)
                                           ;; (println 'tt: tt)
                                           (if (not (or (symbol? tt)
                                                        (list? tt)))
                                               (impc:compiler:print-bad-type-error t "bad fixed type")))
                                         (if (list? t) (cdr t) (list (cdr t))))
                                    (cons (car t) (impc:ir:convert-from-pretty-types (cdr t))))
                                  args))
               ;; (llllll (println 'ft forced-types))
               (forced-types-updated (apply append (list)
                                            (map (lambda (t)
                                                   ;; first off we might be introducing a new spec'd type here!
                                                   (if (string? (cdr t))
                                                      (impc:ti:spec-new-type? (cdr t)))
                                                   ;; on with the show!
                                                   (if (and (impc:ir:closure? (cdr t))
                                                            (not (null? (impc:ti:get-closure-arg-symbols (car t) t1))))
                                                       (if (<> (length (cdddr t))
                                                               (length (impc:ti:get-closure-arg-symbols (car t) t1)))
                                                           (impc:compiler:print-bad-type-error (cdr t) (car t))
                                                           (append (map (lambda (sym type)
                                                                          (cons sym type))
                                                                        (impc:ti:get-closure-arg-symbols (car t) t1)
                                                                        (cdddr t))
                                                                   (list t)))
                                                       (list t)))
                                                 forced-types)))
               ;; (lllllllllllll (println 'typesupdated forced-types-updated))
               (checked-for-duplicates (let loop ((types forced-types-updated))
                                         (if (null? types) (cl:remove-duplicates forced-types-updated)
                                             (if (and (assoc-strcmp (caar types) (cdr types))
                                                      (not (equal? (cdr (assoc-strcmp (caar types) (cdr types)))
                                                                   (cdr (car types)))))
                                                 (impc:compiler:print-type-mismatch-error
                                                  (assoc-strcmp (caar types) (cdr types))
                                                  (car types))
                                                 (loop (cdr types))))))
               (fullyqualified (cl:remove-if-not (lambda (t) (impc:ir:type? (cdr t))) checked-for-duplicates)))
          ;; return fully qualified types
          fullyqualified))))





(define impc:ti:get-closure-names
  (lambda (ast . args)
    (let ((blst '()))
      (let loop ((alst ast))
        (cond ((null? alst) '())
              ((atom? alst) '())
              ((pair? alst)
               (if (member (car alst) '(__make-closure __make-closure-h __make-closure-z __make-closure-s))
                   (set! blst (cons (caddr alst) blst)))
               (loop (car alst))
               (loop (cdr alst)))))
      blst)))


(define impc:ti:numeric-cast-operator
  (lambda (a b)
    (let* ((lowest (if (< a b) a b))
           (highest (if (= a lowest) b a))
           (caststr (string-append (if (impc:ir:floating-point? highest)
                                       (if (= highest *impc:ir:fp64*) "d" "f")
                                       (impc:ir:pretty-print-type highest))
                                   "to"
                                   (if (impc:ir:floating-point? lowest)
                                       (if (= lowest *impc:ir:fp64*) "d" "f")
                                       (impc:ir:pretty-print-type lowest)))))
      caststr)))


;; an optional compiler stage to support some basic type coercions
;; particular math coercions of forced types
(define impc:ti:coercion-run
  (lambda (ast forced-types)
    ;; (println 'ast: ast)
    (if (pair? ast)
        (cond ((member (car ast) '(< > * / = + - <>))
               (let ((a (assoc-strcmp (cadr ast) forced-types))
                     (b (assoc-strcmp (caddr ast) forced-types)))
                 (if (and (and a b)
                          (not (impc:ir:tuple? (cdr a)))
                          (not (impc:ir:vector? (cdr a)))
                          (<> (cdr a) (cdr b)))
                     (let ((ret (string->symbol (impc:ti:numeric-cast-operator (cdr a) (cdr b)))))
                       ;; (println '> (cdr a) (cdr b))
                       (if (> (cdr a) (cdr b))
                           `(,(car ast) (,ret ,(cadr ast)) ,(caddr ast))
                           `(,(car ast) ,(cadr ast) (,ret ,(caddr ast)))))
                     (if (and a (number? (caddr ast)))
                         (if (and (impc:ir:floating-point? (cdr a))
                                  (integer? (caddr ast)))
                             `(,(car ast) ,(cadr ast) ,(integer->real (caddr ast)))
                             ast)
                         (if (and b (number? (cadr ast)))
                             (if (and (impc:ir:floating-point? (cdr b))
                                      (integer? (cadr ast)))
                                 `(,(car ast) ,(integer->real (cadr ast)) ,(caddr ast))
                                 ast)
                             ast)))))
              (else (cons (impc:ti:coercion-run (car ast) forced-types)
                          (impc:ti:coercion-run (cdr ast) forced-types))))
        ast)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define impc:ti:scm_rt_check_string
  (lambda (n closure-name)
    (let* ((os (make-string 0))
           (n1 (substring n 1 (string-length n)))
           (name-str (impc:ir:make-const-string (string-append closure-name " Scheme wrapper error: check the arg arity and types\n")))
           (name (impc:ir:gname)))
      (emit n "_bool = icmp ne i32 " n "_rt_check, 0\n" os)
      (emit "br i1 " n "_bool, label " n "_true, label " n "_false\n" os)
      (emit "\n" n1 "_true:\n" os)
      (emit "br label " n "_continue\n" os)
      (emit "\n" n1 "_false:\n" os)
      (emit name-str os)
      (emit "call i32 (i8*, ...) @printf(i8* " (car name) ")\n" os)
      (emit n "_errret = call ccc i8* @mk_i64(i8* %_sc, i64 0)\n" os)
      (emit "ret i8* " n "_errret\n" os)
      (emit "\n" n1 "_continue:\n" os)
      ;;(emit n " = call ccc double @r64value(i8* " n "_val)\n" os)
      (impc:ir:strip-space os))))


(define impc:ti:get-expression-type
  (lambda (ast)
    (let* ((symname 'nosuchname)
           (c `(let ((xtm_exp_result ,ast)) xtm_exp_result))
           (shadows (impc:ti:rename-all-shadow-vars symname c '()))
           (c1 (impc:ti:get-var-types shadows)) ;; this is a cons pairof (ast . types)
           (ta (impc:ti:first-transform (car c1) #t)) ;; car is ast
           (shadow-code (impc:ti:rename-all-shadow-vars symname ta '()))
           (c2 (impc:ti:get-var-types shadow-code))
           (ccc (append (cdr c2) (cdr c1)))
           (cc (impc:ti:expand-generic-types ccc))
           (t1 (car c2))
           (t2 (impc:ti:closure:convert t1 (list))) ;(list symname)))
           (vars (map (lambda (x) (list x)) (impc:ti:find-all-vars t2 '())))
           (forced-types '()) ;(apply impc:ti:handle-forced-types t1 (append cc args)))
           (t4 (impc:ti:coercion-run t2 forced-types)) ;; t4 and t5 are optional
           (typespre (impc:ti:run-type-check vars forced-types t1))
           (t5 (impc:ti:closure:convert t4 (list symname)))
           (types (impc:ti:type-normalize typespre)))
      (cdr (assoc 'xtm_exp_result types)))))

(define impc:ti:get-global-var-types
  (lambda (ast)
    (if (atom? ast)
        (if (and (symbol? ast)
                 (impc:ti:globalvar-exists? (symbol->string ast)))
            (cons ast (string->symbol (impc:ir:pretty-print-type (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string ast))))))
            #f)
        (if (pair? ast)
            (list (impc:ti:get-global-var-types (car ast))
                  (impc:ti:get-global-var-types (cdr ast)))
            #f))))

(define *impc:ti:adhoc-cnt* 0)

(define impc:ti:run
  (lambda (symname code zone-size poly . args)
    ;; (println '-----------> 'impc:ti:run: symname 'poly: poly)
    ;; (println 'code: code)
    ;; (println 'args: args)
    (set! *impc:ir:sym-name-stack* '())
    (set! *impc:ir:ls_var* '())
    (set! *impc:ti:bound-lambdas* '())
    (set! *impc:ti:generic-type-mappings* '())
    (set! *impc:ti:nativef-generics-recurse-test* 0)
    ;; adhoc
    (set! *impc:ti:adhoc-cnt* (+ *impc:ti:adhoc-cnt* 1))
    (define adhoc-poly-name symname)
    (define adhoc-poly-name-string (symbol->string symname))
    (if (and poly ;*impc:ti:implicit-adhoc-compiles*
             (not (regex:match? adhoc-poly-name-string "(_poly_|_adhoc_)")))
        (begin
          (set! symname (string->symbol (string-append adhoc-poly-name-string
                                                       "_adhoc_"
                                                       (number->string *impc:ti:adhoc-cnt*))))
          (if (not (null? args))
              (set! args (replace-all args (list (cons adhoc-poly-name symname)))))
          (set! code (replace-all code (list (cons adhoc-poly-name symname))))))
    ;; don't want type checking to find existing native versions!
    (if *impc:compile*
        (begin
          (llvm:erase-function (string-append (symbol->string symname) "_setter"))
          (llvm:erase-function (string-append (symbol->string symname) "_maker"))))
    (let* ((symname-string (symbol->string symname))
           (oldsymname-string symname-string)
           ;(c code)
           (shadows (impc:ti:rename-all-shadow-vars symname code '()))
           (c1 (impc:ti:get-var-types shadows)) ;; this is a cons pairof (ast . types)
           (ta (impc:ti:first-transform (car c1) #t)) ;; car is ast
           ;; might be over kill doing shadow vars twice!
           (shadow-code (impc:ti:rename-all-shadow-vars symname ta '()))
           (c2 (impc:ti:get-var-types shadow-code)) ;; it is possible for macros in the first-transform to introduce new var-types
           (ccc (append (cdr c2) (cdr c1)))
           (cc (impc:ti:expand-generic-types ccc))
           (t1 (car c2))
           (t2 (impc:ti:mark-returns t1 symname #f #f #f))
           (t3 (impc:ti:closure:convert t2 (list symname)))
           (vars (map (lambda (x) (list x)) (impc:ti:find-all-vars t3 '())))
           ;; (llllllllll (begin (println 'vars: vars) (error)))
           (forced-types (apply impc:ti:handle-forced-types t1 (append cc args)))
           (t4 (impc:ti:coercion-run t2 forced-types)) ;; t4 and t5 are optional
           (typespre (impc:ti:run-type-check vars forced-types t4))
           (t5 (impc:ti:closure:convert t4 (list symname)))
           (types (impc:ti:type-normalize typespre))
           (newast '()))
      ;; (println 'forced: forced-types)
      ;; (println 'types-post: types)
      ;; (println 'run: (impc:ti:unity? types))
      ;; (println 'newast: newast)
      ;; (println 'forced: forced-types)
      ;; (println 'times: (- ct2 ct1) (- ct3 ct2) (- ct4 ct3) (- ct5 ct4) (- ct6 ct5) (- ct7 ct6) (- ct8 ct7) (- ct9 ct8) (- ct10 ct9) (- ct11 ct10))

      ;; (println 'typesa types)
      ;; A FINAL TYPE CLEANUP
      ;;
      ;; finally we remove !bang types which ultimately don't need to be resolved fully
      ;; don't need to be resolved because they are helpers to resolution not reified types in their own right
      ;;
      ;; also we make sure that any types of the form (sym "%list...") are converted to (sym . "%list...")
      ;; in other words change list ("%list...") into atom "%list..."

      (set! types (cl:remove #f (map (lambda (x)
                                       (if (or (regex:match? (symbol->string (car x)) "^!")
                                               (regex:match? (symbol->string (car x))
                                                             "^[A-Za-z0-9_-]*(:<|{).*##[0-9]*$"))
                                           #f
                                           (if (list? (cdr x))
                                               (if (= (length (cdr x)) 1)
                                                   (cons (car x) (cadr x))
                                                   x)
                                               x)))
                                     types)))
      ;; just added by andrew (can be safely removed)

      (if (null? types)
          (impc:compiler:print-could-not-resolve-type-error symname))

      ;; (println 'final-types: types)

      ;; if we didn't unify print error and bomb out!
      (if (not (cl:every (lambda (x) x) (impc:ti:unity? types)))
          (let ((name (car (regex:type-split (symbol->string symname) "(_adhoc_|_poly_)"))))
            (impc:compiler:print-could-not-resolve-types
             types
             (car (cdaadr t1))
             name)))

      ;; remove all t: expressions from source
      ;; i.e. (t: (* 2 3) i64) -> (* 2 3)
      ;; as (t: ...) is purely for type check stage (which is now complete)
      (letrec ((f (lambda (lst)
                    (if (or (atom? lst) (null? lst)) 'done
                        (begin
                          (if (and (list? lst)
                                   (equal? (car lst) 't:))
                              (let ((v (cadr lst)))
                                (set-car! lst (car v))
                                (set-cdr! lst (cdr v))))
                          (f (car lst))
                          (f (cdr lst)))))))
        (f t5))
      
      (if (and poly ;;*impc:ti:implicit-adhoc-compiles*
               (not (regex:match? adhoc-poly-name-string "(_poly_|_adhoc_)")))
          (let* ((p (assoc-strcmp symname types))
                 (n (car p))
                 (t (impc:ir:pretty-print-type (cdr p)))
                 (base (impc:ir:get-base-type t))
                 (depth (impc:ir:get-ptr-depth t))
                 (new (string-append adhoc-poly-name-string "_adhoc_" (cname-encode base)))
                 (tt (assoc-strcmp symname types))
                 (t6 (replace-all t5 (list (cons symname (string->symbol new))))))
            (set-car! tt (string->symbol new))
            (set! symname (string->symbol new))
            (set! symname-string new)
            (set! newast (impc:ti:add-types-to-source symname t6 (cl:tree-copy types) (list))))
          (set! newast (impc:ti:add-types-to-source symname t5 (cl:tree-copy types) (list))))

      ;; (println 'newast:)
      ;; (println newast)
      ;; (println 'newtypes:)
      ;; (for-each (lambda (t) (println t)) types)

      ;; If this function has been defined before make sure we aren't changing its signature!!
      (if (and (impc:ti:closure-exists? symname-string)
               (or (<> (length (impc:ti:get-closure-arg-types symname-string))
                       (length (cddr (assoc-strcmp symname types))))
                   (cl:position #f (map (lambda (a b)
                                          (equal? a b))
                                        (cons (+ *impc:ir:closure*
                                                 *impc:ir:pointer*
                                                 *impc:ir:pointer*)
                                              (map (lambda (x) (impc:ir:get-type-from-str x))
                                                   (impc:ti:get-closure-arg-types symname-string)))
                                        (cdr (assoc-strcmp symname types))))))
          (impc:compiler:print-no-redefinitions-error
           symname
           (impc:ir:pptype (cons (+ *impc:ir:closure*
                                    *impc:ir:pointer*
                                    *impc:ir:pointer*)
                                 (map (lambda (x) (impc:ir:get-type-from-str x))
                                      (impc:ti:get-closure-arg-types symname-string))))
           (impc:ir:pptype (cdr (assoc-strcmp symname types)))))
                                        ;(print-error "stop")
      (if *impc:compiler:print-ast* (println '---------------------------------))
      (if *impc:compiler:print-ast* (println 'types: types))
                                        ;(println 'ctypes: converted-types)
      (if *impc:compiler:print-ast* (println 'newast: newast))
      ;; check for unfound types
      (for-each (lambda (t)
                  (if (not (impc:ir:type? (cdr t)))
                      (impc:compiler:print-could-not-resolve-type-error (car t))))
                types)
      ;; compile to ir
      (define fstr (impc:ir:compiler newast types))
      ;;
      ;; now compile ir to x86 and make stub code
      (let* ((closure-type (cadr (impc:ir:gname)))
             (closure-type-- (impc:ir:get-type-str (impc:ir:pointer-- (impc:ir:get-type-from-str closure-type))))
             (compile-stub? (not (impc:ti:closure-exists? symname-string)))
             (maker-ir (string-append "define dllexport ccc " closure-type " @" symname-string "_maker"
                                      "(i8* %_impz) nounwind {\nentry:\n"
                                      ;; "%_zone = bitcast i8* %_impz to %mzone*\n"
                                      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                                      ;; ;; new lines for impz
                                      "%_impzPtr = alloca i8*\n"
                                      "store i8* %_impz, i8** %_impzPtr\n"
                                      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                                      fstr "}\n\n"))
             (setter-ir (string-append (if compile-stub? ;;(llvm:get-globalvar (string-append symname-string "_var"))
                                           (string-append "@" symname-string "_var = dllexport global [1 x i8*] [ i8* null ]\n\n"
                                                          "@" symname-string "_var_zone = dllexport global [1 x i8*] [ i8* null ]\n\n")
                                           "") ;; if global var alread exists do nothing
                                       "define dllexport ccc void @" (string-append symname-string "_setter")
                                       "() alwaysinline nounwind {\nentry:\n"
                                       "%_zone = call ccc %mzone* @llvm_peek_zone_stack()\n"
                                       "%_impz = bitcast %mzone* %_zone to i8*\n"
                                       "%oldzone1 = getelementptr [1 x i8*], [1 x i8*]* @" symname-string "_var_zone, i32 0, i32 0\n"
                                       "%oldzone2 = load i8*, i8** %oldzone1\n"
                                       "%oldzone3 = bitcast i8* %oldzone2 to %mzone*\n"
                                       "store i8* %_impz, i8** %oldzone1\n"
                                        ; existing code
                                       "%closure = call ccc " (cadr (impc:ir:gname))
                                       " @" symname-string "_maker" "(i8* %_impz)\n"
                                       "%ptr = bitcast " (cadr (impc:ir:gname)) " %closure to i8*\n"
                                       "%varptr = bitcast [1 x i8*]* @" symname-string "_var to i8**\n"
                                       "store i8* %ptr, i8** %varptr\n"
                                       ;; new code
                                       "; destroy oldzone if not null\n"
                                       "%test = icmp ne %mzone* %oldzone3, null\n"
                                       "br i1 %test, label %then, label %cont\n"
                                        ;"then:\ncall ccc void @llvm_zone_destroy(%mzone* %oldzone3)\nbr label %cont\n"
                                       "then:\ncall ccc void @llvm_destroy_zone_after_delay(%mzone* %oldzone3, i64 441000)\nbr label %cont\n"
                                       "cont:\n"
                                       "ret void\n}\n\n"))
             (stub-type (impc:ir:get-closure-type-from-str closure-type))
             (getter-ir (string-append "define dllexport ccc i8* @" symname-string "_getter() alwaysinline nounwind {\n"
                                       "entry:\n"
                                       "%ptr = getelementptr [1 x i8*], [1 x i8*]* @" symname-string "_var, i32 0, i32 0\n"
                                       "%func = load i8*, i8** %ptr\n"
                                       "ret i8* %func\n}\n\n"))
             (cb-struct-type (if (null? (cdr stub-type))
                                 '()
                                 (string-append ;"{void(i8*)*"
                                  "{"
                                  (impc:ir:get-type-str (cadr stub-type))
                                  (apply string-append
                                         (map (lambda (a)
                                                (string-append ", " (impc:ir:get-type-str a)))
                                              (cddr stub-type)))
                                  "}*")))
             (callback-ir (string-append "define dllexport ccc void @" (string-append symname-string "_callback(i8* %dat) alwaysinline nounwind {\n"
                                                                                      "entry:\n"
                                                                                      (if (null? cb-struct-type)
                                                                                          "%fstruct = select i1 true, i8* %dat, i8* %dat\n"
                                                                                          (string-append "%fstruct = bitcast i8* %dat to " cb-struct-type "\n"))
                                                                                      (apply string-append (map (lambda (n t ap a)
                                                                                                                  (string-append ap " = getelementptr " (impc:ir:pointer-- cb-struct-type) ", " cb-struct-type " %fstruct, i32 0, i32 " (number->string n) "\n"
                                                                                                                                 a " = load " (impc:ir:get-type-str t) ", " (impc:ir:get-type-str t) "* " ap "\n"))
                                                                                                                (make-list-with-proc (- (length stub-type) 1) (lambda (i) i)) ;(+ i 1)))
                                                                                                                (cdr stub-type)
                                                                                                                (make-list-with-proc (- (length stub-type) 1)
                                                                                                                                     (lambda (i) (string-append "%arg_p_" (atom->string i))))
                                                                                                                (make-list-with-proc (- (length stub-type) 1)
                                                                                                                                     (lambda (i) (string-append "%arg_" (atom->string i))))))
                                        ;"%_zone = call ccc %mzone* @llvm_peek_zone_stack()\n"
                                                                                      "%_zone = call ccc %mzone* @llvm_zone_callback_setup()\n"
                                                                                      "%_impz = bitcast %mzone* %_zone to i8*\n"
                                                                                      "%ptr = getelementptr [1 x i8*], [1 x i8*]* @" symname-string "_var, i32 0, i32 0\n"
                                                                                      "%ptrvar = load i8*, i8** %ptr\n"
                                                                                      "%closure_tmp = bitcast i8* %ptrvar to " closure-type "\n"
                                                                                      "%closure = load " closure-type-- ", " closure-type " %closure_tmp \n"
                                                                                      "%fPtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 2\n"
                                                                                      "%ePtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 1\n"
                                                                                      "%ff = load "
                                                                                      (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1") ", "
                                                                                      (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1")
                                                                                      "* %fPtr\n"
                                                                                      "%ee = load i8*, i8** %ePtr\n"
                                                                                      (if (impc:ir:void? (car stub-type)) "" "%result = ")
                                                                                      "call fastcc " (impc:ir:get-type-str (car stub-type)) " %ff(i8* %_impz, i8* %ee"
                                                                                      ;;"call ccc " (impc:ir:get-type-str (car stub-type)) " %ff(i8* %_impz, i8* %ee"
                                                                                      (apply string-append (map (lambda (t n)
                                                                                                                  (string-append ", "
                                                                                                                                 (impc:ir:get-type-str t)
                                                                                                                                 " " n))
                                                                                                                (cdr stub-type)
                                                                                                                (make-list-with-proc (length (cdr stub-type))
                                                                                                                                     (lambda (i) (string-append "%arg_" (atom->string i))))))
                                                                                      ")\n"
                                                                                      "call ccc %mzone* @llvm_pop_zone_stack()\n"
                                                                                      "ret void\n"
                                                                                      "}\n\n")))
             (scheme-stub-valid? #t)
             (scheme-stub-ir (string-append "define dllexport ccc i8* " ;(impc:ir:get-type-str (car stub-type))
                                            " @" (string-append symname-string "_scheme(i8* %_sc, i8* %args) nounwind\n"
                                                                "{\nentry:\n"
                                                                "%_zone = call ccc %mzone* @llvm_peek_zone_stack()\n"
                                                                "%_impz = bitcast %mzone* %_zone to i8*\n"

                                        ;(begin (println 'aaaaa) "")

                                                                (apply string-append
                                                                       (map (lambda (t n idx)
                                        ;(println 't: t 'n: n 'idx: idx)
                                                                              (string-append n "_val = call ccc i8* @list_ref(i8* %_sc, i32 " (number->string idx) ",i8* %args)\n"
                                                                                             (cond ((and (not (number? t))
                                                                                                         (not (impc:ir:pointer? t)))
                                                                                                    (set! scheme-stub-valid? #f)
                                                                                                    "")
                                                                                                   ((or (not (number? t))
                                                                                                        (not (or (impc:ir:number? t)
                                                                                                                 (impc:ir:void? t))))
                                                                                                    (if (and (number? t)
                                                                                                             (= t (+ *impc:ir:pointer* *impc:ir:si8*)))
                                                                                                        (string-append n "_rt_check = call i32 @is_cptr_or_str(i8* " n "_val)\n"
                                                                                                                       (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                       n " = call ccc i8*  @cptr_value(i8* " n "_val)\n")
                                                                                                        (string-append n "_rt_check = call i32 @is_cptr(i8* " n "_val)\n"
                                                                                                                       (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                       "%ttv_" (number->string idx) " = call ccc i8* @cptr_value(i8* " n "_val)\n"
                                                                                                                       n " = bitcast i8* %ttv_" (number->string idx) " to " (impc:ir:get-type-str t) "\n")))
                                                                                                   ((= t *impc:ir:fp64*) (string-append n "_rt_check = call i32 @is_real(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc double @r64value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:fp32*) (string-append n "_rt_check = call i32 @is_real(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc float  @r32value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:si64*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i64  @i64value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:ui64*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i64  @i64value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:si32*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i32  @i32value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:ui32*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i32  @i32value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:si16*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i16  @i16value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:ui16*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i16  @i16value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:si8*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                       (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                       n " = call ccc i8  @i8value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:ui8*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                       (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                       n " = call ccc i8  @i8value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:i1*) (string-append n "_rt_check = call i32 @is_integer(i8* " n "_val)\n"
                                                                                                                                      (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                      n " = call ccc i1  @i1value(i8* " n "_val)\n"))
                                                                                                   ((= t *impc:ir:char*) (string-append n "_rt_check = call i32 @is_string(i8* " n "_val)\n"
                                                                                                                                        (impc:ti:scm_rt_check_string n symname-string)
                                                                                                                                        n " = call ccc i8*  @string_value(i8* " n "_val)\n"))
                                                                                                   (else (impc:compiler:print-compiler-error "bad type in scheme stub")))))
                                                                            (cdr stub-type)
                                                                            (make-list-with-proc (length (cdr stub-type))
                                                                                                 (lambda (i) (string-append "%arg_" (atom->string i))))
                                                                            (make-list-with-proc (length (cdr stub-type)) (lambda (i) i))))

                                        ;(begin (println 'bbbbb) "")

                                                                "%ptr = getelementptr [1 x i8*], [1 x i8*]* @" symname-string "_var, i32 0, i32 0\n"
                                                                "%ptrvar = load i8*, i8** %ptr\n"
                                                                "%closure_tmp = bitcast i8* %ptrvar to " closure-type "\n"
                                                                "%closure = load " closure-type-- ", " closure-type " %closure_tmp \n"
                                                                "%fPtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 2\n"
                                                                "%ePtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 1\n"
                                                                "%ff = load "
                                                                (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1") ", "
                                                                (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1")
                                                                "* %fPtr\n"
                                                                "%ee = load i8*, i8** %ePtr\n"
                                                                (if (impc:ir:void? (car stub-type)) "" "%result = ")
                                                                "call fastcc " (impc:ir:get-type-str (car stub-type)) " %ff(i8* %_impz, i8* %ee"

                                                                (apply string-append
                                                                       (map (lambda (t n)
                                                                              (string-append ", " (impc:ir:get-type-str t) " " n))
                                                                            (cdr stub-type)
                                                                            (make-list-with-proc (length (cdr stub-type))
                                                                                                 (lambda (i) (string-append "%arg_" (atom->string i))))))
                                                                ")\n"

                                        ;(begin (println 'ccccc) "")

                                                                (let* ((t (car stub-type)))
                                                                  (cond ((and (not (number? t))
                                                                              (not (impc:ir:pointer? t)))
                                                                         (set! scheme-stub-valid? #f)
                                                                         "")
                                                                        ((or (not (number? t))
                                                                             (not (or (impc:ir:number? t)
                                                                                      (impc:ir:void? t))))
                                                                         (string-append "%tmpres = bitcast " (impc:ir:get-type-str t) " %result to i8*\n"
                                                                                        "%res = call ccc i8* @mk_cptr(i8* %_sc, i8* %tmpres)\n"))
                                                                        ((= t *impc:ir:void*) "%res = call ccc i8* @mk_i1(i8* %_sc, i1 1)\n") ;; don't do anything for void
                                                                        ((= t *impc:ir:fp64*) "%res = call ccc i8* @mk_double(i8* %_sc, double %result)\n")
                                                                        ((= t *impc:ir:fp32*) "%res = call ccc i8* @mk_float(i8* %_sc, float %result)\n")
                                                                        ((= t *impc:ir:si64*) "%res = call ccc i8* @mk_i64(i8* %_sc, i64 %result)\n")
                                                                        ((= t *impc:ir:ui64*) "%res = call ccc i8* @mk_i64(i8* %_sc, i64 %result)\n")
                                                                        ((= t *impc:ir:si32*) "%res = call ccc i8* @mk_i32(i8* %_sc, i32 %result)\n")
                                                                        ((= t *impc:ir:ui32*) "%res = call ccc i8* @mk_i32(i8* %_sc, i32 %result)\n")
                                                                        ((= t *impc:ir:si16*) "%res = call ccc i8* @mk_i16(i8* %_sc, i16 %result)\n")
                                                                        ((= t *impc:ir:ui16*) "%res = call ccc i8* @mk_i16(i8* %_sc, i16 %result)\n")
                                                                        ((= t *impc:ir:si8*) "%res = call ccc i8* @mk_i8(i8* %_sc, i8 %result)\n")
                                                                        ((= t *impc:ir:ui8*) "%res = call ccc i8* @mk_i8(i8* %_sc, i8 %result)\n")
                                                                        ((= t *impc:ir:i1*) "%res = call ccc i8* @mk_i1(i8* %_sc, i1 %result)\n")
                                                                        ((= t *impc:ir:char*) "%res = call ccc i8* @mk_string(i8* %_sc, i8* %result\n")
                                                                        (else (impc:compiler:print-compiler-error "return type error in scheme stub"))))

                                                                "ret i8* %res\n"
                                                                "}\n\n")))
             (stub-ir (string-append "define dllexport fastcc " (impc:ir:get-type-str (car stub-type))
                                     " @" (string-append symname-string "("
                                                         (apply string-append (map (lambda (t n c)
                                                                                     (string-append c (impc:ir:get-type-str t) " "
                                                                                                    n))
                                                                                   (cdr stub-type)
                                                                                   (make-list-with-proc (length (cdr stub-type))
                                                                                                        (lambda (i) (string-append "%arg_" (atom->string i))))
                                                                                   (cons "" (make-list (length (cdr stub-type)) ","))))
                                                         ") alwaysinline nounwind \n"
                                                         "{\nentry:\n"
                                                         "%_zone = call ccc %mzone* @llvm_peek_zone_stack()\n"
                                                         "%_impz = bitcast %mzone* %_zone to i8*\n"
                                                         "%ptr = getelementptr [1 x i8*], [1 x i8*]* @" symname-string "_var, i32 0, i32 0\n"
                                                         "%ptrvar = load i8*, i8** %ptr\n"
                                                         "%closure_tmp = bitcast i8* %ptrvar to " closure-type "\n"
                                                         "%closure = load " closure-type-- ", " closure-type " %closure_tmp \n"
                                                         "%fPtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 2\n"
                                                         "%ePtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 1\n"
                                                         "%ff = load "
                                                         (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1") ", "
                                                         (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1")
                                                         "* %fPtr\n"
                                                         "%ee = load i8*, i8** %ePtr\n"
                                                         (if (impc:ir:void? (car stub-type)) "" "%result = ")
                                                         "call fastcc " (impc:ir:get-type-str (car stub-type)) " %ff(i8* %_impz, i8* %ee"
                                                         (apply string-append (map (lambda (t n)
                                                                                     (string-append ", "
                                                                                                    (impc:ir:get-type-str t)
                                                                                                    " " n))
                                                                                   (cdr stub-type)
                                                                                   (make-list-with-proc (length (cdr stub-type))
                                                                                                        (lambda (i) (string-append "%arg_" (atom->string i))))))
                                                         ")\nret " (impc:ir:get-type-str (car stub-type))
                                                         (if (impc:ir:void? (car stub-type)) "\n" " %result\n")
                                                         "}\n\n")))
             (native-ir (string-append "define dllexport ccc " (impc:ir:get-type-str (car stub-type))
                                       " @" (string-append symname-string "_native("
                                                           (apply string-append (map (lambda (t n c)
                                                                                       (string-append c (impc:ir:get-type-str t) " "
                                                                                                      n))
                                                                                     (cdr stub-type)
                                                                                     (make-list-with-proc (length (cdr stub-type))
                                                                                                          (lambda (i) (string-append "%arg_" (atom->string i))))
                                                                                     (cons "" (make-list (length (cdr stub-type)) ","))))
                                                           ") alwaysinline nounwind \n"
                                                           "{\nentry:\n"
                                                           "%_zone = call ccc %mzone* @llvm_peek_zone_stack()\n"
                                                           "%_impz = bitcast %mzone* %_zone to i8*\n"
                                                           "%ptr = getelementptr [1 x i8*], [1 x i8*]* @" symname-string "_var, i32 0, i32 0\n"
                                                           "%ptrvar = load i8*, i8** %ptr\n"
                                                           "%closure_tmp = bitcast i8* %ptrvar to " closure-type "\n"
                                                           "%closure = load " closure-type-- ", " closure-type " %closure_tmp \n"
                                                           "%fPtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 2\n"
                                                           "%ePtr = getelementptr " (impc:ir:pointer-- closure-type--) ", " closure-type-- " %closure, i32 0, i32 1\n"
                                                           "%ff = load "
                                                           (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1") ", "
                                                           (regex:replace closure-type-- "\\{ ?i8\\*, ?i8\\*,(.*)\\}\\*" "$1")
                                                           "* %fPtr\n"
                                                           "%ee = load i8*, i8** %ePtr\n"
                                                           (if (impc:ir:void? (car stub-type)) "" "%result = ")
                                                           "call fastcc " (impc:ir:get-type-str (car stub-type)) " %ff(i8* %_impz, i8* %ee"
                                                           (apply string-append (map (lambda (t n)
                                                                                       (string-append ", "
                                                                                                      (impc:ir:get-type-str t)
                                                                                                      " " n))
                                                                                     (cdr stub-type)
                                                                                     (make-list-with-proc (length (cdr stub-type))
                                                                                                          (lambda (i) (string-append "%arg_" (atom->string i))))))
                                                           ")\nret " (impc:ir:get-type-str (car stub-type))
                                                           (if (impc:ir:void? (car stub-type)) "\n" " %result\n")
                                                           "}\n\n"))))
        (if *impc:compiler:print*
            (println '------------------------------compiling 'maker----------------------------------->))
        (if *impc:compiler:print* (print-full-nq maker-ir))
        (if *impc:compile*
            (impc:compiler:queue-ir-for-compilation maker-ir))
        (if *impc:compiler:print*
            (println '--------------------------------compiling 'setter----------------------------------->))
        (if *impc:compiler:print* (print-full-nq setter-ir))
        (if *impc:compile*
            (impc:compiler:queue-ir-for-compilation setter-ir))
        (if *impc:compiler:print*
            (println '--------------------------------compiling 'getter----------------------------------->))
        (if *impc:compiler:print* (print-full-nq getter-ir))
        (if (and *impc:compile* compile-stub?)
            (impc:compiler:queue-ir-for-compilation getter-ir))
        (if *impc:compiler:print*
            (println '--------------------------------compiling 'stubs----------------------------------->))
        (if *impc:compiler:print* (print-full-nq stub-ir))
        (if *impc:compiler:print* (print-full-nq native-ir))
        (if *impc:compiler:print* (print-full-nq scheme-stub-ir))
        (if (and *impc:compile* compile-stub?)
            (begin (impc:compiler:queue-ir-for-compilation stub-ir)
                   (impc:compiler:queue-ir-for-compilation native-ir)
                   (if scheme-stub-valid? (impc:compiler:queue-ir-for-compilation scheme-stub-ir) #t)))
        (if *impc:compiler:print*
            (println '----------------------------compiling 'callback----------------------------------->))
        (if *impc:compiler:print* (print-full-nq callback-ir))
        (if (and *impc:compile* compile-stub?)
            (impc:compiler:queue-ir-for-compilation callback-ir))
        (if (not (impc:aot:currently-compiling?))
            (if (not (impc:compiler:flush-jit-compilation-queue))
                (impc:compiler:print-compiler-error "could not compile helper functions" symname)))
        (if *impc:compile*
            ;; make sure the (now resolved) function types hit the
            ;; closure/nativefunc cache
            (let ((closure-type-list (impc:ir:get-type-from-str closure-type)))
              (if (and (impc:ti:closure-exists? symname-string)
                       (impc:aot:currently-compiling?))
                  (if (not (equal? closure-type-list (impc:ti:get-closure-type symname-string)))
                      (impc:compiler:print-no-redefinitions-error symname
                                                                  (impc:ti:get-closure-type symname-string)
                                                                  closure-type-list))
                  (begin
                    (if (and *impc:ti:implicit-adhoc-compiles*
                             (not (regex:match? adhoc-poly-name-string "(_poly_|_adhoc_)")))
                        (begin
                          (impc:ti:update-closure-name adhoc-poly-name-string symname-string)
                          (impc:ti:set-closure-type symname-string closure-type-list)
                          (impc:ti:set-closure-body symname-string code)
                          ;; add to the AOT-header if we're precompiling
                          (impc:aot:insert-closure-binding-details symname-string
                                                                   closure-type-list
                                                                   (impc:ti:get-closure-zone-size symname-string)
                                                                   (impc:ti:get-closure-docstring symname-string)
                                                                   (impc:ti:get-closure-body symname-string))
                          (eval `(bind-poly ,adhoc-poly-name ,symname) (interaction-environment)))
                        (begin
                          (impc:ti:set-closure-type symname-string closure-type-list)
                          ;; add to the AOT-header if we're precompiling
                          (impc:aot:insert-closure-binding-details symname-string
                                                                   closure-type-list
                                                                   (impc:ti:get-closure-zone-size symname-string)
                                                                   (impc:ti:get-closure-docstring symname-string)
                                                                   (impc:ti:get-closure-body symname-string))))))
              (cond ((regex:match? symname-string "_poly_")
                     ;; (println 'spec: symname-string)
                     (impc:compiler:print-bind-func-details-to-log
                      "Spec'zed:"
                      (string->symbol (car (regex:split symname-string "_poly_")))
                      (impc:ir:pretty-print-type closure-type)
                      zone-size))
                    ((regex:match? symname-string "_adhoc_")
                     (impc:compiler:print-bind-func-details-to-log
                      "Compiled:"
                      (string->symbol (car (regex:split symname-string "_adhoc_")))
                      (impc:ir:pretty-print-type closure-type)
                      zone-size))
                    (else
                     (impc:compiler:print-bind-func-details-to-log
                      "Compiled:"
                      symname
                      (impc:ir:pretty-print-type closure-type)
                      zone-size)))))
        symname-string))))
        ;; (cadr (impc:ir:gname))))))

(define-macro (xtm-closure-doc name)
  `(let ((docstring (impc:ti:get-closure-docstring ,name))
         (types (impc:ti:get-closure-type ,name))
         (form (impc:ti:get-closure-body ,name)))
     (if docstring
         (list (cdr docstring) (cdr types) (cdr form))
         (if types
             (list '() (cdr types) (cdr form))
             (if form
                 (list '() '() (cdr form))
                 #f)))))


(define-macro (definec symname poly . args)
  (let ((zone-size *impc:default-zone-size*))
    (if (number? (car args))
        (begin (set! zone-size (car args))
               (set! args (cdr args))))
    (let ((types (cdr (reverse args)))
          (expr (car (reverse args)))
          (aot_sexpr '()))
      (if (regex:match? (symbol->string symname) ":")
          (let ((sres (regex:type-split (symbol->string symname) ":")))
            (set! symname (string->symbol (car sres)))
            (set! types (cons (cons symname (string->symbol (cadr sres))) types))))
      ;; (print-full symname 'types: types 'e: expr 'args: args)
      `(let* ((newname (impc:ti:run ',symname
                                    '(let ((,symname ,expr)) ,symname)
                                    ,zone-size
                                    ,poly
                                    ,@(if (null? types)
                                          '()
                                          (map (lambda (k) (list 'quote k)) types)))))
         ;; (impc:ti:initialize-closure-with-new-zone (symbol->string ',symname)
         ;;                                           *impc:default-zone-size*)
         ;; (impc:ti:create-scheme-wrapper (symbol->string ',symname)))))))
         (impc:ti:initialize-closure-with-new-zone newname *impc:default-zone-size*)
         (impc:ti:create-scheme-wrapper newname)))))


(define-macro (bind-func . args)
  (if (list? (car args))
      (impc:compiler:print-compiler-error "bind-func requires a name!"))
  ;; if aot and func already exists then bomb out
  (if (and (output-port? *impc:aot:current-output-port*)
           (impc:ti:closure-exists? (symbol->string (car args))))
      (begin ;; (impc:aot:insert-sexpr `(println 'Warning: ',(car args) 'is 'overriden)) ;; insert warning into aot file
             #t)
      ;; if doc-string exists!
      (let ((func-name (car (regex:type-split (symbol->string (car args)) ":")))
            (zone-size (if (number? (cadr args)) (cadr args) *impc:default-zone-size*))
            (poly (if (boolean? (cadr args)) (cadr args) #t))
            (docstring (if (string? (cadr args))
                           (cadr args)
                           (if (and (not (null? (cddr args))) (string? (caddr args)))
                               (caddr args)
                               "")))
            ;; closure body is always in last position, preceeded by zone
            ;; size and/or docstring
            (closure-body (car (reverse args))))
        ;; strip docstring
        (set! args (cl:remove-if string? args))
        ;; strip poly
        (set! args (cl:remove-if boolean? args))
        ;; (if (impc:ti:polyfunc-exists? (car args))
        ;;     (impc:compiler:print-already-bound-error (car args) "polymorphic closure"))
        ;; (if (impc:ti:genericfunc-exists? (car args))
        ;;     (impc:compiler:print-already-bound-error (car args) "generic closure"))
        (if (regex:match? (symbol->string (car args)) ":")
            (let* ((res (regex:type-split (symbol->string (car args)) ":"))
                   (name (car res))
                   (type1 (cadr res))
                   (type (if (char=? (string-ref type1 0) #\[)
                             (if (= (impc:ir:get-ptr-depth type1) 1)
                                 type1
                                 (impc:compiler:print-bad-type-error type1 "must be a closure pointer"))
                             (if (impc:ti:typealias-exists? type1)
                                 (impc:ti:get-typealias-type-pretty type1)
                                 (impc:compiler:print-bad-type-error type1 "Bad closure type for bind-func"))))
                   (ags (impc:ir:get-pretty-closure-arg-strings type))
                   ;; expand all non-explict generic types
                   ;; i.e. expand list* into list:<!a,list*>*
                   (expand-polys (map (lambda (k)
                                        (if (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))
                                            (impc:ir:pointer++
                                             (string-append (impc:ir:get-base-type k) ":"
                                                            (symbol->string (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))))
                                             (impc:ir:get-ptr-depth k))
                                            k))
                                      ags))
                   (newtype (string-append "[" (string-join expand-polys ",") "]*"))
                   (newnametype (string->symbol (string-append name ":" newtype))))
              ;; (println 'oldargs: args)
              ;; (println 'newargs: (cons newnametype (cdr args)))
              (if (impc:ti:bang-type? newtype)
                  (begin
                    (impc:aot:insert-generic-func (cons 'bind-func (cons newnametype (cdr args))))
                    (impc:ti:register-new-genericfunc (cons 'bind-func (cons newnametype (cdr args))))
                    ;;(impc:ti:register-new-genericfunc (cons 'bind-func args))
                    `(impc:compiler:print-binding-details-to-log "GenrFunc:" ,(car res) ,(cadr res)))
                  (begin
                    (if (impc:ti:closure-exists? func-name)
                        (begin
                          (impc:ti:set-closure-docstring func-name docstring)
                          (impc:ti:set-closure-body func-name closure-body))
                        (impc:ti:register-new-closure func-name '() zone-size docstring closure-body))
                    `(eval '(definec ,(car args) ,poly ,@(cdr args)) (interaction-environment)))))
            (begin
              (if (impc:ti:closure-exists? func-name)
                  (begin
                    (impc:ti:set-closure-docstring func-name docstring)
                    (impc:ti:set-closure-body func-name closure-body))
                  (impc:ti:register-new-closure func-name '() zone-size docstring closure-body))
              `(eval '(definec ,(car args) ,poly ,@(cdr args)) (interaction-environment)))))))


(impc:ti:register-new-builtin
 "bind-func"
 ""
 "compile an xtlang closure"
 '(closure-name optional-zone-size optional-docstring closure-body))

;; bind-func-ipc is for passing an already compiled (and setter'd)
;; native function across to a non-primary process
(define bind-func-ipc
  (lambda (symname)
    (let ((zone-size *impc:default-zone-size*))
      (eval
       `(define ,symname
          (impc:ti:create-scheme-wrapper (symbol->string ',symname)))
       (interaction-environment)))))

(define ipc:bind-func
  (lambda (procname symname)
    (if (regex:match? (symbol->string symname) "_adhoc_")
        (ipc:call procname 'bind-func-ipc symname)
        (let* ((polyname (symbol->string symname))
               (polytypes (impc:ti:get-polyfunc-candidate-list polyname)))
          (if (and (list? polytypes)
                   (= (length polytypes) 1))
              (begin (ipc:call procname 'bind-func-ipc
                               (string->symbol (vector-ref (car polytypes) 0)))
                     (ipc:define procname symname (eval symname)))
              (print-error "Not a monomorphic xtlang function:" symname))))))

(define ipc:load
  (lambda (process-name file)
    (ipc:call process-name 'sys:load file)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (bind-alias symbol type . docstring)
  `(begin (impc:ti:register-new-typealias
           ,(symbol->string symbol)
           ',(impc:ir:get-type-from-pretty-str (symbol->string type))
           ,(if (null? docstring) "" (car docstring)))
          (impc:compiler:print-binding-details-to-log
           "SetAlias:"
           ',symbol
           ;;(print ',type)
           (begin
             (set! *impc:ir:get-type-callback-off* #t) ;; don't wait, do it immediately
             (let ((r (impc:ir:pretty-print-type ,(symbol->string symbol))))
               (set! *impc:ir:get-type-callback-off* #f)
               r))
           )))

(impc:ti:register-new-builtin
 "bind-alias"
 ""
 "bind an xtlang type alias"
 '(alias-name alias-target optional-docstring))

(define impc:ti:word-upcase
  (lambda (w)
    (let* ((n (string->list w))
           (u (char-upcase (car n)))
           (n1 (list->string (cons u (cdr n)))))
      n1)))

(define impc:ti:word-downcase
  (lambda (w)
    (let* ((n (string->list w))
           (u (char-downcase (car n)))
           (n1 (list->string (cons u (cdr n)))))
      n1)))

(define impc:ti:gather-all-gvars-helper
  (lambda (gtype)
    (foldl (lambda (lst val)
             (if (list? val)
                 (append (impc:ti:gather-all-gvars-helper val) lst)
                 (if (and (symbol? val)
                          (regex:match? (symbol->string val) "^!"))
                     (cons val lst)
                     lst)))
           '() gtype)))

(define impc:ti:gather-all-gvars
  (lambda (gtype)
    (reverse
     (cl:remove-duplicates
      (impc:ti:gather-all-gvars-helper gtype)))))

(define impc:ti:compile-type-dataconstructors
  (lambda (name type generic printer? constructor?)
    (if (or (not (string? type)) ;; if not already a pretty type
            (regex:match? type "^\\s*{"))
        (set! type (impc:ir:pretty-print-type type)))
    ;; (println 'DataConstructor: 'name: name 'type type 'gen generic 'print: printer? 'const: constructor?)
    ;; (println 'impc:ti:compile-type-dataconstructors name type generic)
    (let* ((tsplit (car (regex:type-split (symbol->string name) "_poly_")))
           (a (map (lambda (x)
                     (if (and (string=? tsplit (impc:ir:get-base-type x))
                              (= 1 (impc:ir:get-ptr-depth x)))
                         (string-append (symbol->string name) "*")
                         x))
                   (impc:ir:get-pretty-tuple-arg-strings type)))
           (arglst1 (make-list-with-proc (length a) (lambda (i) (string->symbol (string-append "arg_" (atom->string i))))))
           (arglst2 (range (length a)))
           (namestr (symbol->string name))
           ;;(namestrup (impc:ti:word-upcase (symbol->string name)))
           ;;(namestrdown (impc:ti:word-downcase (symbol->string name)))
           (ctype (string-append "["
                                 (if generic
                                     ;(apply string-append namestr ":" type "*"
                                     (apply string-append namestr
                                            "{"
                                            (string-join
                                             (map (lambda (x) (symbol->string x))
                                                  (impc:ti:gather-all-gvars (impc:ir:get-type-from-pretty-str type)))
                                             ",")
                                            "}*"

                                            (map (lambda (x)
                                                   (string-append
                                                    ","
                                                    (if (regex:match? x (string-append namestr "([{<:*)|$"))
                                                        (regex:replace x
                                                                       (string-append namestr "([*]*)")
                                                                       (string-append namestr ":" type "$1"))
                                                        x)))
                                                 a))
                                     (apply string-append (symbol->string name) "*"
                                            (map (lambda (x) (string-append "," x)) a)))
                                 "]*"))
           (argslist (map (lambda (a b) b) a arglst1))
           (hcopy_body (if generic #f
                           (map (lambda (a b c)
                                  (set! a (impc:ir:get-type-from-pretty-str a))
                                  (if (and (impc:ir:tuple? a)
                                           (string? a) ;; i.e. must be a named type "%Pair*" NOT <i32,i32>* (for example)
                                           (= 1 (impc:ir:get-ptr-depth a)))
                                      (let* ((t (substring a 1 (- (string-length a) 1)))
                                             (fname (if (string=? namestr t)
                                                        'hcopy
                                                        (string->symbol (string-append "hcopy:[" t "*," t "*]*")))))
                                        ;; (println 't: t 'name: name 'type: type)
                                        `(if (not (null? (tref x ,c)))
                                             (tset! obj ,b (,fname (tref x ,c)))))
                                      `(tset! obj ,b (tref x ,c))))
                                a arglst2 (range (length a)))))
           (hfree_body (if generic #f
                           (map (lambda (a c)
                                  (set! a (impc:ir:get-type-from-pretty-str a))
                                  (if (and (impc:ir:tuple? a)
                                           (string? a) ;; i.e. must be a named type "%Pair*" NOT <i32,i32>* (for example)
                                           (= 1 (impc:ir:get-ptr-depth a)))
                                      (let* ((t (substring a 1 (- (string-length a) 1)))
                                             (fname (if (string=? namestr t)
                                                        'hfree
                                                        (string->symbol (string-append "hfree:[void," t "*]*")))))
                                        `(if (not (null? (tref x ,c)))
                                             (,fname (tref x ,c))))))
                                a (range (length a)))))
           (zcopy_body (if generic #f
                           (map (lambda (a b c)
                                  (set! a (impc:ir:get-type-from-pretty-str a))
                                  (if (and (impc:ir:tuple? a)
                                           (string? a) ;; i.e. must be a named type "%Pair*" NOT <i32,i32>* (for example)
                                           (= 1 (impc:ir:get-ptr-depth a)))
                                      (let* ((t (substring a 1 (- (string-length a) 1)))
                                             (fname (if (string=? namestr t)
                                                        'zcopy
                                                        (string->symbol (string-append "zcopy:[" t "*," t "*,mzone*,mzone*]*")))))
                                        `(if (not (null? (tref x ,c)))
                                             (tset! obj ,b (,fname (tref x ,c) fromz toz))))
                                      (if (and (impc:ir:pointer? a)
                                               (= 1 (impc:ir:get-ptr-depth a)))
                                          `(if (llvm_ptr_in_zone fromz (cast (tref x ,c) i8*))
                                               (let ((newptr (zalloc (llvm_zone_ptr_size (cast (tref x ,c) i8*)))))
                                                 (memcpy (cast newptr i8*) (cast (tref x ,c) i8*)
                                                         (llvm_zone_ptr_size (cast (tref x ,c) i8*)))
                                                 (tset! obj ,b newptr))
                                               (tset! obj ,b (tref x ,c)))
                                          `(begin
                                             (tset! obj ,b (tref x ,c))))))
                                a arglst2 (range (length a)))))
           (body (map (lambda (a b c) `(tset! obj ,b ,c)) a arglst2 arglst1)))
      ;;(println 'hcopy: hcopy_body)
      (sys:with-quiet-compiler
       (if constructor?
           (begin
             (eval `(bind-func ,(string->symbol (string-append namestr ":" ctype)) #t
                      (lambda ,argslist
                        (let ((obj (zalloc)))
                          ,@body
                          obj)))
                   (interaction-environment))))
       ;; (eval `(bind-func ,(string->symbol (string-append namestr (if generic ":" "_z:") ctype)) #t
       (eval `(bind-func ,(string->symbol (string-append namestr "_z:" ctype)) #t                
                (lambda ,argslist
                  (let ((obj (zalloc)))
                    ,@body
                    obj)))
             (interaction-environment))
       (eval `(bind-func ,(string->symbol (string-append namestr "_h:" ctype)) #t
                (lambda ,argslist
                  (let ((obj (halloc)))
                    ,@body
                    obj)))
             (interaction-environment))
       (if (and generic printer?)
           (begin
             (eval `(bind-func ,(string->symbol (string-append "toString:[String*," namestr "*]*")) #t
                      (lambda (x)
                        (if (null? x)
                            (sprintout ,(string-append "<" namestr ":null"))
                            (sprintout ,(string-append "<" namestr ":")
                                       ,@(cdr (apply append '() (map (lambda (n) (list "," (list 'tref 'x n))) (range (length a)))))
                                       ">"))))
                   (interaction-environment))
             (eval `(bind-func ,(string->symbol (string-append "print:[void," namestr "*]*")) #t
                      (lambda (x)
                        (if (null? x)
                            (printout ,(string-append "<" namestr ":null"))
                            (printout ,(string-append "<" namestr ":")
                                      ,@(cdr (apply append '() (map (lambda (n) (list "," (list 'tref 'x n))) (range (length a)))))
                                      ">"))
                        void))
                   (interaction-environment))))
       (if (not generic)
           (begin
             (if (and (not (regex:match? namestr "_poly_")) printer?)
                 (begin
                   (eval `(bind-func ,(string->symbol (string-append "toString:[String*," namestr "*]*")) #t
                            (lambda (,(string->symbol (string-append "x:" namestr "*")))
                              (if (null? x)
                                  (sprintout ,(string-append "<" namestr ":null>"))
                                  (sprintout ,(string-append "<" namestr ":")
                                             ,@(cdr (apply append '() (map (lambda (n) (list "," (list 'tref 'x n)))
                                                                           (range (length a)))))
                                             ">"))))
                         (interaction-environment))
                   (eval `(bind-func ,(string->symbol (string-append "print:[void," namestr "*]*")) #t
                            (lambda (,(string->symbol (string-append "x:" namestr "*")))
                              (if (null? x)
                                  (printout ,(string-append "<" namestr ":null>"))
                                  (printout ,(string-append "<" namestr ":")
                                            ,@(cdr (apply append '() (map (lambda (n) (list "," (list 'tref 'x n)))
                                                                          (range (length a)))))
                                            ">"))
                              void))
                         (interaction-environment))))
             (eval `(bind-func ,(string->symbol (string-append namestr "_val"))
                      (lambda ,argslist
                        (let ((,(string->symbol (string-append "obj:" namestr "*")) (salloc)))
                          (tfill! obj ,@argslist)
                          (pref obj 0))))
                   (interaction-environment))
             (eval `(bind-func ,(string->symbol (string-append "hcopy:[" namestr "*," namestr "*]*"))
                      (lambda (,(string->symbol (string-append "x:" namestr "*")))
                        (let ((obj (halloc)))
                          ,@hcopy_body
                          obj)))
                   (interaction-environment))
             (eval `(bind-func ,(string->symbol (string-append "hfree:[void," namestr "*]*"))
                      (lambda (,(string->symbol (string-append "x:" namestr "*")))
                        ,@hfree_body
                        (free x)
                        void))
                   (interaction-environment))
             (eval `(bind-func ,(string->symbol (string-append "zcopy:[" namestr "*," namestr "*,mzone*,mzone*]*"))
                      (lambda (,(string->symbol (string-append "x:" namestr "*")) fromz toz)
                        (let ((obj (zalloc)))
                          ,@zcopy_body
                          obj)))
                   (interaction-environment)))))
      ;; (println 'dc-out: name)
      #t)))

;; bind-type expects: (symbol type [docstring])
(define-macro (bind-type . args)
  ;; (println 'bind-type args)
  (if (null? args)
      (impc:compiler:print-compiler-error "Bind type missing arguments! (symbol type [docstring])"))
  (let* ((symbol (car args))
         (type_1 (cadr args))
         (type (string->symbol
                (string-append "<"
                 (string-join
                  (map (lambda (x)
                         (if (impc:ti:typealias-exists? x)
                             (impc:ir:pretty-print-type (impc:ti:get-typealias-type x))
                             x))
                       (impc:ir:get-pretty-tuple-arg-strings (symbol->string type_1)))
                  ",")
                 ">")))
         (docstring (if (string? (car (reverse args))) (car (reverse args)) ""))
         (extras (cl:remove #f (map (lambda (x) (if (pair? x) x #f)) args)))
         (printer? (if (assoc-strcmp 'printer? extras)
                       (cdr (assoc-strcmp 'printer? extras))
                       #t))
         (constructor? (if (assoc-strcmp 'constructor? extras)
                           (cdr (assoc-strcmp 'constructor? extras))
                           #t)))
    (if (not (char=? (string-ref (symbol->string type_1) (- (string-length (symbol->string type_1)) 1)) #\>))
        (impc:compiler:print-bad-type-error type_1 "is a malformed tuple type"))
    (if (impc:ti:bang-type? type) ;; send generic named types to aot
        (impc:aot:insert-generic-type `(bind-type ,@args)))
    (if (<> (impc:ir:get-ptr-depth type) 0)
        (impc:compiler:print-bad-type-error type "cannot be a pointer"))
    (if (not (char=? (string-ref (symbol->string type) 0) #\<))
        (impc:compiler:print-bad-type-error type "must be a tuple type"))
    `(begin
       (set! *impc:ir:get-type-callback-off* #t)
       (let* ((ags (impc:ir:get-pretty-tuple-arg-strings ,(symbol->string type)))
              ;; expand all non-explict generic types
              ;; i.e. expand list* into list:<!a,list*>*
              (expand-polys (map (lambda (k)
                                   (if (and (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))
                                            (not (equal? (impc:ir:get-base-type k) ,(symbol->string symbol)))) ;; for recursive case!
                                       (impc:ir:pointer++
                                        (string-append (impc:ir:get-base-type k) ":"
                                                       (symbol->string (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))))
                                        (impc:ir:get-ptr-depth k))
                                       k))
                                 ags))
              (newtype (string-append "<" (string-join expand-polys ",") ">")))
         ;; (println 'authors_type: ,(symbol->string type))
         ;; (println 'transformed_type: newtype)
         ;; and on with the show!
         (if (impc:ti:bang-type? newtype) ;; then must be poly type
             (begin
               (impc:ti:register-new-generictype ',symbol (string->symbol newtype))
               (impc:compiler:print-binding-details-to-log "GenrType:" ',symbol ',type))
             (let ((typelist (cons *impc:ir:tuple* (impc:ir:get-type-from-pretty-tuple ,(symbol->string type)
                                                                                       ,(symbol->string symbol)))))
               (if (llvm:compile-ir (string-append "%" ,(symbol->string symbol) " = type "
                                                   (impc:ir:get-type-str typelist)))
                   (begin (impc:ti:register-new-namedtype ,(symbol->string symbol) typelist ,docstring)
                          (impc:compiler:print-binding-details-to-log "DataType:" ',symbol ',type))
                   (impc:compiler:print-compiler-error "could not compile IR for type" ',type)))))
       ;; the next line is to help specialize any element types that may not already be specialized!
       (map (lambda (a) (impc:ir:get-type-from-pretty-str a (symbol->string ',(car args)))) (impc:ir:get-pretty-tuple-arg-strings ,(symbol->string type)))
       (set! *impc:ir:get-type-callback-off* #f)
       ;; (sys:wait (now))
       ;; now compile data constructor
       (impc:ti:compile-type-dataconstructors
        ',symbol
        (if (impc:ti:get-generictype-candidate-types ',symbol)
            (symbol->string (impc:ti:get-generictype-candidate-types ',symbol))
            (impc:ir:pretty-print-type (impc:ti:get-namedtype-type ,(symbol->string symbol))))
        (if (impc:ti:get-generictype-candidate-types ',symbol) #t #f)
        ,printer?
        ,constructor?))))

(impc:ti:register-new-builtin
 "bind-type"
 ""
 "bind an xtlang named type"
 '(name type optional-docstring))

(define-macro (impc:pretty-print-vars . varlist)
  (map (lambda (var)
         `(begin (println '--- (quote ,var) '---)
                 (println ,var)))
       varlist))

(define impc:ti:construct-generic-type-if-valid
  (lambda (t)
    ;; named type might need to be constructed!
    (if (and (string? t)
             (char=? (string-ref t 0) #\%)
             (regex:match? t "_poly_"))
        (if (impc:ti:namedtype-exists? t)
            #t ;; if 't' exists don't do anything else
            (let* ((p (regex:split t "_poly_"))
                   (n (substring (car p) 1 (string-length (car p)))))
              (if (not (impc:ti:get-generictype-candidate-types n))
                  #f  ;; if not a generic type then bad :(
                  (begin
                    #t))))
        #t)))


;; bind-val takes an optional argument, the meaning of which depends
;; on the type of the val, and also an optional docstring
(define-macro (bind-val symbol type . args)
  (let* ((string-literal? (and (equal? 'i8* type)
                               (not (null? args))
                               (string? (car args))))
         (value (if string-literal?
                    (car args)
                    (if (not (or (null? args) (string? (car args))))
                        (car args)
                        #f)))
         (docstring (if (or (null? args)
                            (not (string? (car (reverse args))))
                            (and string-literal? (= (length args) 1)))
                        ""
                        (car (reverse args))))
         (t (impc:ir:get-type-from-pretty-str (atom->string type)))
         (oldt (impc:ti:get-globalvar-type (symbol->string symbol))))
    ;; this next line looks superflous but isn't!
    ;; 't' maybe a %blah_poly_Hldkfjs* etc. that is not
    ;; yet "constructed". calling get-type-from-pretty-str
    ;; will construct it if it doesn't yet exist
    (if (string? t) (impc:ir:get-type-from-pretty-str t))
    (cond (oldt
           `(impc:compiler:print-already-bound-error ',symbol ,(impc:ir:pretty-print-type (impc:ir:pointer-- oldt))))
          ;; string literal
          (string-literal?
           `(begin
              (llvm:compile-ir (string-append "@" ,(symbol->string symbol)
                                              " = dllexport global i8* zeroinitializer"))
              ;; we should really take the globalvar out of the cache
              ;; if the previous steps failed
              (impc:ti:register-new-globalvar ,(symbol->string symbol) ',t ,docstring)
              (impc:aot:insert-globalvar-binding-details *impc:aot:current-lib-name*
                                                         ,(symbol->string symbol)
                                                         ,(symbol->string type)
                                                         ,docstring)
              (impc:aot:do-or-emit
               (call-as-xtlang (set! ,symbol ,value) void))
              (impc:compiler:print-binding-details-to-log "SetValue:"
                                                          ,(symbol->string symbol)
                                                          ,(impc:ir:pretty-print-type t))))
          ;; non-pointer values
          ((and (or (impc:ir:number? t)
                    (impc:ir:boolean? t)
                    (not (impc:ir:pointer? t))))
           `(begin
              (llvm:compile-ir (string-append "@" ,(symbol->string symbol)
                                              " = dllexport global "
                                              ,(impc:ir:get-type-str t) " "
                                              ,(if (number? value)
                                                   ;; can we serialise the value straight into the
                                                   ;;  IR? (e.g. i32/i64/float/double)
                                                   (if (equal? t *impc:ir:fp32*)
                                                       (llvm:convert-float (atom->string value))
                                                       (atom->string value))
                                                   ;; otherwise use zeroinitializer and we'll just use a
                                                   ;; set! inside a call-as-xtlang a bit further down
                                                   "zeroinitializer")))
              (impc:ti:register-new-globalvar ,(symbol->string symbol) ',t ,docstring)
              (impc:aot:insert-globalvar-binding-details *impc:aot:current-lib-name*
                                                         ,(symbol->string symbol)
                                                         ,(symbol->string type)
                                                         ,docstring)
              ;; set value for non int/float literals
              ,(if (and value (not (number? value)))
                   `(impc:aot:do-or-emit
                     (call-as-xtlang (set! ,symbol (convert ,value ,type)) void)))
              ;; we should really take the globalvar out of the
              ;; cache if any of the previous steps failed
              (impc:compiler:print-binding-details-to-log "SetValue:"
                                                          ,(symbol->string symbol)
                                                          ,(impc:ir:pretty-print-type t))))
          ;; pointer
          ((impc:ir:pointer? t)
           (if (or (not value) (integer? value))
               `(begin
                  (llvm:compile-ir (string-append "@" ,(symbol->string symbol)
                                                  " = dllexport global "
                                                  ,(impc:ir:get-type-str t)
                                                  " zeroinitializer"))
                  (impc:ti:register-new-globalvar ,(symbol->string symbol) ',t ,docstring)
                  (impc:aot:insert-globalvar-binding-details *impc:aot:current-lib-name*
                                                             ,(symbol->string symbol)
                                                             ,(symbol->string type)
                                                             ,docstring)
                  (impc:aot:do-or-emit
                   (call-as-xtlang (set! ,symbol (cast (malloc ,(* (or value 1)
                                                                   (if (impc:ir:number? t)
                                                                       (impc:ir:get-type-size t)
                                                                       (/ (sys:pointer-size) 8))))
                                                       ,type))
                                   void))
                  ;; we should really take the globalvar out of the cache
                  ;; if the previous steps failed
                  (impc:compiler:print-binding-details-to-log "SetValue:"
                                                              ,(symbol->string symbol)
                                                              ,(impc:ir:pretty-print-type t)))
               (if (list? value)
                   `(begin
                      (llvm:compile-ir (string-append "@" ,(symbol->string symbol)
                                                      " = dllexport global "
                                                      ,(impc:ir:get-type-str t)
                                                      "zeroinitializer"))
                      (impc:ti:register-new-globalvar ,(symbol->string symbol) ',t ,docstring)
                      (impc:aot:insert-globalvar-binding-details *impc:aot:current-lib-name*
                                                                 ,(symbol->string symbol)
                                                                 ,(symbol->string type)
                                                                 ,docstring)
                      (impc:aot:do-or-emit
                       (call-as-xtlang (set! ,symbol ,value) void))
                      ;; we should really take the globalvar out of the cache
                      ;; if the previous steps failed
                      (impc:compiler:print-binding-details-to-log "SetValue:"
                                                                  ,(symbol->string symbol)
                                                                  ,(impc:ir:pretty-print-type t)))
                   `(impc:compiler:print-compiler-error "when binding global pointers, third argument should be size of buffer to allocate or a valid xtlang sexpr"))))
          ;; tuple/array/vector
          ((or (impc:ir:tuple? t) (impc:ir:array? t) (impc:ir:vector? t))
           `(begin
              (llvm:compile-ir
               (string-append
                "@" ,(symbol->string symbol)
                " = dllexport global "
                ,(impc:ir:get-type-str t) " zeroinitializer"))
              (impc:ti:register-new-globalvar ,(symbol->string symbol) ',t ,docstring)
              (impc:aot:insert-globalvar-binding-details *impc:aot:current-lib-name*
                                                         ,(symbol->string symbol)
                                                         ,(symbol->string type)
                                                         ,docstring)
              ;; we should really take the globalvar out of the cache
              ;; if the previous steps failed
              (impc:compiler:print-binding-details-to-log "SetValue:"
                                                          ,(symbol->string symbol)
                                                          ,(impc:ir:pretty-print-type t))))
          (else (impc:compiler:print-missing-identifier-error type 'type)))))

(impc:ti:register-new-builtin
 "bind-val"
 ""
 "bind a global variable"
 '(variable-name type optional-value optional-docstring))

(define-macro (bind-ext-val symname type . docstring)
  `(let* ((type-str ,(if (impc:ti:typealias-exists? (symbol->string type))
                         (impc:ti:get-typealias-ground-type-pretty (symbol->string type))
                         (symbol->string type)))
          (type-list (impc:ir:get-type-from-pretty-str type-str))
          (ds ,(if (null? docstring) "" (car docstring))))
      (llvm:compile-ir
        (string-append "@" ,(symbol->string symname) " = external global " (impc:ir:get-type-str type-list)))
      (impc:ti:register-new-globalvar ,(symbol->string symname) type-list ds)
      (impc:aot:insert-ext-globalvar-binding-details ,(symbol->string symname) ,(symbol->string type) ds)
      (impc:compiler:print-binding-details-to-log "bind-ext-val:" ,(symbol->string symname) ,(symbol->string type))))

(impc:ti:register-new-builtin
 "bind-ext-val"
 ""
 "bind an external global variable"
 '(variable-name type optional-value optional-docstring))

(define-macro (bind-poly poly_sym implementation_sym . docstring)
  ;; (println 'poly: poly_sym implementation_sym)
  (if (impc:ti:genericfunc-exists? implementation_sym)
      (impc:compiler:print-compiler-error (string-append "bind-poly only accepts monomorphic functions, not " (symbol->string implementation_sym))))
  (if (not (impc:ti:closure-or-nativefunc-exists? (symbol->string implementation_sym)))
      (impc:compiler:print-missing-identifier-error implementation_sym 'closure))
  (let ((type (impc:ti:get-closure-or-nativefunc-type (symbol->string implementation_sym))))
    ;;(set! type (impc:ir:get-type-from-pretty-str (symbol->string type)))
    (if type
        `(begin
           (impc:ti:register-new-polyfunc ,(symbol->string poly_sym) ,(symbol->string implementation_sym) ',type ,(if (null? docstring) "" (car docstring)))
           (impc:ti:create-scheme-wrapper (symbol->string ',implementation_sym))
           (if (not (regex:match? ,(symbol->string implementation_sym) "(_adhoc_|_poly_)"))
               (impc:compiler:print-polying-details-to-log "PolyFunc:" ,(symbol->string poly_sym) ,(symbol->string implementation_sym) ,(impc:ir:pretty-print-type type))))
        `(impc:compiler:print-missing-identifier-error ',implementation_sym 'closure))))

(impc:ti:register-new-builtin
 "bind-poly"
 ""
 "bind a polymorphic symbol"
 '(poly-name closure-name optional-docstring))

(define impc:ti:search-for-dylib
  (lambda (path)
    (let loop ((rel-paths
                (append
                 (list
                  path
                  (sanitize-platform-path (string-append (sys:share-dir) "/libs/aot-cache/" path))
                  (sanitize-platform-path (string-append (sys:share-dir) "/libs/platform-shlibs/" path)))
                 (unix-or-Windows (map
                                   (lambda (x)
                                     (sanitize-platform-path
                                      (string-append x "/" path)))
                                   (append (regex:split
                                            (sys:command-output
                                             "echo $LD_LIBRARY_PATH")
                                            ":")
                                           '("/usr/local/lib/" "/usr/lib/" "/opt/local/lib/" "/usr/lib/x86_64-linux-gnu")))
                                  (list (sanitize-platform-path (string-append "C:/Windows/System32/" path)))))))
      (if (null? rel-paths)
          #f
          (if (file-exists? (car rel-paths))
              (let ((dylib (sys:open-dylib (car rel-paths) #t)))
                (if dylib
                    (cons dylib (car rel-paths))
                    (begin
                      (print-with-colors *impc:compiler:pretty-print-error-color* 'default #t
                                         (print "Error"))
                      (print ": could not open ")
                      (print-with-colors *impc:compiler:pretty-print-type-color* 'default #t (car rel-paths))
                      (print " dynamic library\n")
                      (error ""))))
              (loop (cdr rel-paths)))))))

(define impc:ti:bind-dylib
  (lambda (library lib-paths)
    (let ((dylib-pair
           (let loop ((paths lib-paths))
             (if (null? paths)
                 #f
                 (or (impc:ti:search-for-dylib (car paths))
                     (loop (cdr paths)))))))
      (if dylib-pair
          (begin
            (eval (list 'define library (car dylib-pair))
                  (interaction-environment))
            (set! *impc:aot:current-load-dylib-info*
                  (cons library (cdr dylib-pair)))
            (impc:aot:add-win-link-library (cdr dylib-pair))
            (impc:compiler:print-dylib-loading-details-to-log (cdr dylib-pair))
            #t)
          (begin
            (print-with-colors *impc:compiler:pretty-print-error-color* 'default #t
                               (print "Error"))
            (print ": could not find ")
            (print-with-colors *impc:compiler:pretty-print-type-color* 'default #t (print library))
            (print " dynamic library\n")
            (error ""))))))

(define-macro (bind-dylib library lib-path)
  (let ((path (eval lib-path)))
    (if (string? path)
        (set! path (list path)))
    (impc:aot:insert-load-dylib-details library path)
    `(impc:ti:bind-dylib ',library ',path)))

(impc:ti:register-new-builtin
 "bind-dylib"
 ""
 "load a dynamic library

e.g.

(bind-dylib lib \"libGL.so\")

@param lib-symbol - symbol to refer to the library
@param lib-paths - a string (or list of strings) of paths to search for the dylib"
 '(lib-symbol lib-paths))

;; this here for wrapping llvm dynamic binds
(define-macro (bind-lib library symname type . args)
  `(impc:ti:bind-lib ',library ',symname ',type
                     ;; calling convention
                     ,(if (and (not (null? args)) (number? (car args)))
                          (car args)
                          0) ;; 0=ccc
                     ;; docstring
                     ,(if (and (not (null? args)) (string? (car (reverse args))))
                          (car (reverse args))
                          "")))

(impc:ti:register-new-builtin
 "bind-lib"
 ""
 "bind a C function from a shared library"
 '(libname function-name type optional-docstring))

;; this was previously called __dynamic-bind
(define impc:ti:bind-lib
  (lambda (library symname type calling-convention docstring)
    (if (not (eval library))
        (impc:compiler:print-compiler-error
         (string-append "the " (symbol->string library) " dynamic library appears to have not been loaded correctly"))
        (let* ((ctype (cdr (impc:ir:get-type-from-pretty-str (symbol->string type))))
               (ir-string (string-append "declare "
                                         "cc " (atom->string calling-convention)
                                         " "
                                         (impc:ir:get-type-str (car ctype))
                                         " @"
                                         (symbol->string symname)
                                         "("
                                         (if (null? (cdr ctype))
                                             ""
                                             (apply string-append
                                                    (impc:ir:get-type-str (cadr ctype))
                                                    (map (lambda (v)
                                                           (string-append "," (impc:ir:get-type-str v)))
                                                         (cddr ctype))))
                                         ") nounwind")))
          (if (and (llvm:compile-ir ir-string)
                   (llvm:bind-symbol (eval library) (symbol->string symname)))
              (begin
                (if (output-port? *impc:aot:current-output-port*)
                    (begin (write `(llvm:bind-symbol ,library ,(symbol->string symname)) *impc:aot:current-output-port*)
                           (newline *impc:aot:current-output-port*)))
                (impc:ti:register-new-nativefunc (symbol->string symname) (impc:ir:get-type-from-pretty-str (symbol->string type)) "" '())
                (impc:compiler:print-lib-binding-details-to-log library symname type)
                (impc:aot:insert-nativefunc-binding-details library symname type docstring))
              (impc:compiler:print-compiler-error (string-append "could not bind " (symbol->string symname))))))))

(define-macro (unbind-func symname)
  `(begin
     (llvm:remove-globalvar ,(string-append (symbol->string symname) "_var"))
     (llvm:erase-function ,(symbol->string symname))
     (llvm:erase-function ,(string-append (symbol->string symname) "_setter"))
     (llvm:erase-function ,(string-append (symbol->string symname) "_getter"))
     (llvm:erase-function ,(string-append (symbol->string symname) "_maker"))
     (llvm:erase-function ,(string-append (symbol->string symname) "_callback"))
     (llvm:erase-function ,(string-append (symbol->string symname) "_native"))
     (llvm:erase-function ,(string-append (symbol->string symname) "_maker"))
     (llvm:remove-globalvar ,(string-append (symbol->string symname) "_var_zone"))
     (if (llvm:get-function ,(string-append (symbol->string symname) "_scheme"))
         (llvm:erase-function ,(string-append (symbol->string symname) "_scheme")))))

(define-macro (bind-lib-type library name type docstring)
  (let* ((a (impc:ir:get-pretty-tuple-arg-strings (symbol->string type)))
         (namestr (symbol->string name))
         (typestr (symbol->string type)))
    `(begin
       (if (llvm:compile-ir ,(string-append "%" namestr " = type " (impc:ir:get-type-str (impc:ir:get-type-from-pretty-str typestr namestr))))
           (impc:ti:register-new-namedtype ,namestr
                                           ',(impc:ir:get-type-from-pretty-str typestr namestr)
                                           ,docstring)
           (impc:compiler:print-compiler-error "bind-lib-type failed" ,name)))))

;;; this here for binding to CLOSURE in dylib
;;
;; arg is for *optional* zone size arg
(define-macro (bind-lib-func library symname type zone-size docstring body)
  `(begin
     (bind-lib ,library ,symname ,type fastcc)
     (bind-lib ,library ,(string->symbol (string-append (symbol->string symname) "_setter")) [void]*)
     (bind-lib ,library ,(string->symbol (string-append (symbol->string symname) "_getter")) [i8*]*)
     (bind-lib ,library ,(string->symbol (string-append (symbol->string symname) "_callback")) [void,i8*]*)
     (if (impc:ti:create-scm-wrapper? ,(symbol->string symname))
         (bind-lib ,library ,(string->symbol (string-append (symbol->string symname) "_scheme")) [i8*,i8*,i8*]*))
     (bind-lib ,library ,(string->symbol (string-append (symbol->string symname) "_native")) ,type)
     (bind-lib ,library ,(string->symbol (string-append (symbol->string symname) "_maker"))
               ,(string->symbol (string-append "[" (symbol->string type) ",i8*]*")))
     (if (not (llvm:compile-ir
               (string-append "@" ,(symbol->string symname) "_var = external global [1 x i8*]\n\n"
                              "@" ,(symbol->string symname) "_var_zone = external global [1 x i8*]\n\n")))
         (impc:compiler:print-compiler-error "failed to compile IR in bind-lib-func" ,symname))
     (llvm:bind-symbol ,library ,(string-append (symbol->string symname) "_var"))
     (llvm:bind-symbol ,library ,(string-append (symbol->string symname) "_var_zone"))
     ;; bind scheme function
     (if (impc:ti:create-scm-wrapper? ,(symbol->string symname))
         (eval (define ,symname
                 (impc:ti:create-scheme-wrapper (symbol->string ',symname)))
               (interaction-environment))
         (impc:compiler:print-no-scheme-stub-notification (symbol->string ',symname)))
     (impc:ti:register-new-closure ,(symbol->string symname)
                                   (impc:ir:get-type-from-pretty-str ,(symbol->string type))
                                   ,zone-size
                                   ,docstring
                                   ,body)
     (impc:compiler:print-binding-details-to-log "LibBound:"
                                                 ,(symbol->string symname)
                                                 ,(symbol->string type))
     (impc:ti:initialize-closure-with-new-zone ,(symbol->string symname)
                                               ,zone-size)))

(define-macro (bind-lib-val library symname type . docstring)
  `(let* ((type-str ,(if (impc:ti:typealias-exists? (symbol->string type))
                         (impc:ti:get-typealias-ground-type-pretty (symbol->string type))
                         (symbol->string type)))
          (type-list (impc:ir:get-type-from-pretty-str type-str))
          (ds ,(if (null? docstring) "" (car docstring))))
     (if (and (llvm:compile-ir
               (string-append "@" ,(symbol->string symname) " = external global "
                              (impc:ir:get-type-str type-list)))
              (llvm:bind-symbol ,library ,(symbol->string symname)))
         (begin
           (impc:ti:register-new-globalvar ,(symbol->string symname)
                                           type-list
                                           ds)
           (impc:aot:insert-globalvar-binding-details ,(symbol->string library)
                                                      ,(symbol->string symname)
                                                      ,(symbol->string type)
                                                      ds)
           (impc:compiler:print-binding-details-to-log "LibBound:"
                                                       ,(symbol->string symname)
                                                       ,(symbol->string type)))
         (impc:compiler:print-compiler-error (string-append "could not bind-lib-val "
                                                            ,(symbol->string symname)
                                                            " from library "
                                                            ,(symbol->string library))))))

;; THIS IS A HELPER FUNCTION
;;
;; returns a (bind-lib-xtm) form for the named function
;; by using the xtm-closure-doc to get the type
;; function must already have been compiled into module
(define-macro (bind-lib-xtm-get-string name)
  (let ((res (eval `(xtm-closure-doc ,name))))
    (if (string? res)
        `(sexpr->string '(bind-lib-xtm mathlib ,name ,(string->symbol res)))
        `(sexpr->string '(bind-lib-xtm mathlib ,name ,(string->symbol (cdr res)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define impc:ti:initialize-closure-with-new-zone
  (lambda (func-name zone-size)
    (if (not (impc:aot:currently-compiling?))
        (let ((setter (llvm:get-function (string-append func-name "_setter"))))
          (if setter
              (begin
                (sys:push-memzone (sys:create-mzone zone-size))
                (llvm:run setter)
                ;; don't destroy - this happens in _setter func
                (sys:pop-memzone))
              (begin
                (error)
              (impc:compiler:print-missing-identifier-error (string->symbol (string-append func-name "_setter")) 'closure-setter)))))))

(define impc:ti:create-scm-wrapper?
  (lambda (func-name)
    (cl:every
     (lambda (type)
       (or (impc:ir:void? type)
           (impc:ir:floating-point? type)
           (impc:ir:fixed-point? type)
           (impc:ir:pointer? type)))
     (map impc:ir:get-type-from-str
          (impc:ti:get-closure-or-nativefunc-arg-types func-name)))))

(define impc:ti:adhoc-scheme-wrapper
  (lambda (polyname funcname)
    `(define ,(string->symbol polyname)
       (lambda args
         (if (and (not (null? args))
                  (symbol? (car args)))
             (if (equal? (car args) 'xtlang)
                 ',(string->symbol funcname)
                 (if (null? (cdr args))
                     (eval (string->sexpr (string-append "(" ,funcname "." (symbol->string (car args)) ")")))
                     (eval (append (string->sexpr (string-append "(" ,funcname "." (symbol->string (car args)) ")"))
                                   (list (cadr args))))))
             (apply ,(string->symbol funcname) args))))))


(define impc:ti:create-scheme-wrapper
  (lambda (func-name)
    (if (impc:aot:currently-compiling?)
        (lambda ()
          (if (not (impc:aot:currently-compiling?))
              (begin
                (print-with-colors 'yellow 'default #t (print "Compiler Warning:"))
                (print " the scheme wrapper for ")
                (print-with-colors *impc:compiler:pretty-print-name-color* 'default #t (print (string->symbol func-name)))
                (print " was called, but it doesn't exist (yet)\n"))))
        (let ((scheme-func (llvm:get-function-pointer (string-append func-name "_scheme")))
              (p (regex:split func-name "_adhoc_")))
          (if (and
               (or (not (defined? (string->symbol (car p))))
                   (defined? (string->symbol (string-append (car p) "_xtlang_name"))))
               (not (null? (cdr p)))) ;; if _adhoc_ is true
              (let ((polytypes (impc:ti:get-polyfunc-candidate-list (car p))))
                (if (and (list? polytypes)
                         (= (length polytypes) 1))
                    (begin
                      (eval `(define
                               ,(string->symbol (string-append (car p) "_xtlang_name"))
                               ,(vector-ref (car polytypes) 0))
                            (interaction-environment))
                      (eval (impc:ti:adhoc-scheme-wrapper
                             (car p)
                             (vector-ref (car polytypes) 0))
                            (interaction-environment)))
                    (begin
                      (eval `(define ,(string->symbol (string-append (car p) "_xtlang_name")) #f)
                            (interaction-environment))
                      (eval `(define ,(string->symbol (car p))
                               (lambda args
                                 (println 'Ambiguous 'or 'unavailable 'xtlang 'wrapper: ,(car p))))
                            (interaction-environment))))))
          (if scheme-func
              (begin
                (llvm:ffi-set-name scheme-func func-name)
                ;; (println 'mk-ff func-name)
                (mk-ff func-name scheme-func))
              (impc:compiler:print-no-scheme-stub-notification (string->symbol func-name)))))))

;; a helper for returning a native closure (if one exists!)
(define llvm:get-native-closure
  (lambda (name)
    (if (impc:aot:currently-compiling?)
        (impc:compiler:print-not-during-aot-error)
        (let ((f (llvm:get-function (string-append name "_getter"))))
          (if f (llvm:run f)
              '())))))

(define llvm:get-closure-setter
  (lambda (name)
    (if (impc:aot:currently-compiling?)
        (impc:compiler:print-not-during-aot-error)
        (llvm:get-function-pointer (string-append name "_setter")))))

;; a helper for returning a scheme closure native closure (if one exists!)
(define llvm:get-native-function
  (lambda (name)
    (if (impc:aot:currently-compiling?)
        (impc:compiler:print-not-during-aot-error)
        (llvm:get-function-pointer (string-append name "_native")))))

;; Wrap a native, bound C function, allowing it to be called from scheme
(define-macro (bind-wrapper local-sym native-sym)
  (let* ((types (cdr (impc:ti:get-closure-arg-types (symbol->string native-sym))))
         (args (map (lambda (t v) v)
                    types (make-list-with-proc
                           (length types)
                           (lambda (i)
                             (string->symbol (string-append "arg_" (atom->string i))))))))
    `(bind-func ,local-sym
       (lambda ,args
         ,(cons native-sym args)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; very dodgy
;; generic constraints
;;
;; simply forces supplied specialisations
;; add to polys and remove gpoly
;;
;; for example
;;
;; (bind-func test:[!a,!a]*
;;   (lambda (x) (* x x)))
;;
;; (constrain-genericfunc test [i32,i32]* [float,float]*)
;;
(define impc:ti:constrain-genericfunc
  (lambda (sym . types)
    ;; (println 'impc:ti:constrain-genericfunc 'sym: sym types)
    (if (not (impc:ti:genericfunc-exists? (string->symbol sym)))
        (impc:compiler:print-missing-identifier-error sym "generic function")
        (let ((printspec *impc:ti:print-code-specialization-compiles*))
          (set! *impc:ti:print-code-specialization-compiles* #t)
          (for-each
           (lambda (t)
             (if (regex:match? t "_poly_")
                 (set! t (cname-decode (cadr (regex:type-split t "_poly_")))))
             (let ((etype (cname-encode t)))
               (if (not (impc:ti:closure-exists? (string-append sym "_poly_" etype)))
                   (let* ((arity (impc:ir:get-arity-from-pretty-closure t))
                          (code (caddr (cadr (impc:ti:genericfunc-types (string->symbol sym) arity t))))
                          (pfunc (string->symbol (string-append sym "_poly_" etype))))
                     ;; (println 'arity: arity 'code: code 'pfunc: pfunc)
                     ;; pre-populate the closure cache for the new specialised func
                     (if (not (impc:ti:closure-exists? (symbol->string pfunc)))
                         (impc:ti:register-new-closure (symbol->string pfunc)
                                                       '()
                                                       *impc:default-zone-size*
                                                       ""
                                                       code))
                     (set! code `(let ((,pfunc ,code)) ,pfunc))
                     (impc:ti:run pfunc code *impc:default-zone-size* #f (cons pfunc (string->symbol t)))
                     (impc:ti:register-new-polyfunc sym
                                                    (symbol->string pfunc)
                                                    (impc:ir:get-type-from-pretty-str t)
                                                    "")
                     (impc:ti:initialize-closure-with-new-zone (symbol->string pfunc)
                                                               *impc:default-zone-size*)
                     pfunc))))
           types)
          (set! *impc:ti:print-code-specialization-compiles* printspec)
          (set! *impc:ti:genericfunc-cache*
                (cl:remove-if (lambda (x)
                                (if (string=? (symbol->string (car x)) sym)
                                    #t #f))
                              *impc:ti:genericfunc-cache*))
          #t))))

(define-macro (constrain-genericfunc sym . args)
  (apply impc:ti:constrain-genericfunc
         (symbol->string sym)
         (map (lambda (x)
                (if (regex:match? (symbol->string x) "^\\$")
                    (set! x (string->symbol (string-append (symbol->string sym) ":" (symbol->string x)))))
                (symbol->string (impc:ti:expand-generic-type x))) args)))

;; old name (for compatibility)
(define constrain-generic constrain-genericfunc)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; specialize generic type!
;;
(define impc:ti:specialize-generictype
  (lambda (sym . types)
    ;; (println 'impc:ti:specialize-generictype 'sym: sym types)
    (if (not (impc:ti:get-generictype-candidate-types (string->symbol sym)))
        (impc:compiler:print-missing-generic-type-error sym)
        (let ((printspec *impc:ti:print-code-specialization-compiles*))
          (set! *impc:ti:print-code-specialization-compiles* #t)
          (for-each
           (lambda (t)
             (if (regex:match? t ":")
                 (set! t (cadr (regex:type-split t ":"))))
             (let ((newname (string-append sym "_poly_" (cname-encode t))))
               (if (llvm:compile-ir (string-append "%" newname " = type " (impc:ir:get-type-str (impc:ir:get-type-from-pretty-str t))))
                   (impc:ti:compile-type-dataconstructors (string->symbol newname) t #f #t #t)
                   (impc:compiler:print-compiler-error "failed to compile IR in impc:ti:specialize-generictype" sym))))
           types)
          (set! *impc:ti:print-code-specialization-compiles* printspec)
          #t))))

(define-macro (specialize-generictype sym . args)
  (apply impc:ti:specialize-generictype
         (symbol->string sym)
         (map (lambda (x)
                (if (regex:match? (symbol->string x) "^\\$")
                    (set! x (string->symbol (string-append (symbol->string sym) ":" (symbol->string x)))))
                (symbol->string (impc:ti:expand-generic-type x))) args)))


;; force specializations on a generic funtion
(define impc:ti:specialize-genericfunc
  (lambda (sym . types)
    ;; (println 'impc:ti:specialize-genericfunc 'sym: sym types)
    (if (not (impc:ti:genericfunc-exists? (string->symbol sym)))
        (impc:compiler:print-missing-identifier-error sym "generic function")
        (let ((printspec *impc:ti:print-code-specialization-compiles*))
          (set! *impc:ti:print-code-specialization-compiles* #t)
          (for-each
           (lambda (t)
             (if (regex:match? t "_poly_")
                 (set! t (cname-decode (cadr (regex:type-split t "_poly_")))))
             (let ((etype (cname-encode t)))
               (if (not (impc:ti:closure-exists? (string-append sym "_poly_" etype)))
                   (let* ((arity (impc:ir:get-arity-from-pretty-closure t))
                          (gftypes (impc:ti:genericfunc-types (string->symbol sym) arity t))
                          (res (if (not gftypes)
                                   (impc:compiler:print-compiler-error "Bad generic closure type:" (list sym t))))
                          (code (caddr (cadr gftypes)))
                          (pfunc (string->symbol (string-append sym "_poly_" etype))))
                     ;; (println 'makesym etype 't: t)
                     ;; (println 'arity: arity 'code: code 'pfunc: pfunc)
                     ;; pre-populate the closure cache for the new specialised func
                     (if (not (impc:ti:closure-exists? (symbol->string pfunc)))
                         (impc:ti:register-new-closure (symbol->string pfunc)
                                                       '()
                                                       *impc:default-zone-size*
                                                       ""
                                                       code))
                     (set! code `(let ((,pfunc ,code)) ,pfunc))
                     (impc:ti:run pfunc code *impc:default-zone-size* #f (cons pfunc (string->symbol t)))
                     (impc:ti:register-new-polyfunc sym
                                                    (symbol->string pfunc)
                                                    (impc:ir:get-type-from-pretty-str t)
                                                    "")
                     (impc:ti:initialize-closure-with-new-zone (symbol->string pfunc)
                                                               *impc:default-zone-size*)
                     pfunc))))
           types)
          (set! *impc:ti:print-code-specialization-compiles* printspec)
          #t))))

(define-macro (call-as-xtlang . expr)
  (if (not (impc:aot:currently-compiling?))
      (sys:with-quiet-compiler
       (begin
         (set! *impc:ir:sym-name-stack* '())
         (set! *impc:ir:ls_var* '())
         (set! *impc:ti:bound-lambdas* '())
         (set! *impc:ti:generic-type-mappings* '())
         (set! *impc:ti:nativef-generics-recurse-test* 0)
         (let ((type (impc:ti:get-expression-type (car (reverse expr)))))
           (eval `(bind-func xtlang_expression
                    (lambda ()
                      ,(if (equal? type -1)
                           `(let ((s:i8* (halloc 2)))
                              ,@expr
                              s)
                           `(letz ((s:String* (sprintln (begin ,@expr)))
                                   (lgth (+ 1 (tref s 0)))
                                   (oldcs (tref s 1))
                                   (newcs:i8* (halloc lgth)))
                              (strcpy newcs oldcs)
                              newcs))))
                 (interaction-environment))
           (quote (string->atom (cptr->string (xtlang_expression)))))))))

(define xtmX call-as-xtlang)
(define $ call-as-xtlang)

;; this version uses a let instead of a letz
(define-macro (call-as-xtlang-leaky . expr)
  (if (not (impc:aot:currently-compiling?))
      (sys:with-quiet-compiler
       (begin
         (set! *impc:ir:sym-name-stack* '())
         (set! *impc:ir:ls_var* '())
         (set! *impc:ti:bound-lambdas* '())
         (set! *impc:ti:generic-type-mappings* '())
         (set! *impc:ti:nativef-generics-recurse-test* 0)
         (let ((type (impc:ti:get-expression-type (car (reverse expr)))))
           (eval `(bind-func xtlang_expression
                    (lambda ()
                      ,(if (not (impc:ir:pointer? type))
                           `(let ((s:i8* null))
                              ;; (println "returning null for non-pointer type")
                              ,@expr
                              s)
                           `(let ((res:i8* (cast (begin ,@expr) i8*)))
                              res))))
                 (interaction-environment))
           (quote (xtlang_expression)))))))

(define $$ call-as-xtlang-leaky)

;; helper macro for specializing generics
;;
;; i.e. (specialize-genericfunc blah [i32,i32]* [i64,i64]*)
(define-macro (specialize-genericfunc sym . args)
  (apply impc:ti:specialize-genericfunc
         (symbol->string sym)
         (map (lambda (x)
                (if (regex:match? (symbol->string x) "^\\$")
                    (set! x (string->symbol (string-append (symbol->string sym) ":" (symbol->string x)))))
                (symbol->string (impc:ti:expand-generic-type x))) args)))

;;;;;;;;;;;;
;; xtmdoc ;;
;;;;;;;;;;;;

;; the documentation function should return an associative list with
;; the following keys:

;; ((name . awesome_closure)
;;  (category . "closure")
;;  (type . "[i64]")
;;  (args . (arg1 arg2))
;;  (docstring . "the docstring))

;; the keys must be present, but the cdr of each element may be
;; missing where appropriate (e.g. scheme functions have no type field)

(define xtmdoc-strip-arg-type-annotations
  (lambda (form)
    (if (or (symbol? form)
            (not (list? form)))
        form
        (map (lambda (arg)
               (string->symbol (car (regex:split (symbol->string arg) ":"))))
             form))))

(define xtmdoc-get-args-from-form
  (lambda (form)
    (if (null? form)
        #f
        (if (equal? (car form) 'lambda)
            (xtmdoc-strip-arg-type-annotations (cadr form))
            (if (and (list? (car form)) (equal? (caar form) 'lambda))
                (xtmdoc-strip-arg-type-annotations (cadar form))
                ;; recurse!
                (xtmdoc-get-args-from-form (if (member (car form) '(let let* letz))
                                               (cddr form)
                                               (cdr form))))))))

;; currently only returns the result for the first arity
(define xtmdoc-get-xtlang-genericfunc-args
  (lambda (fn-sym)
    (xtmdoc-get-args-from-form
     (caddar (cdddar (assoc-strcmp-all fn-sym *impc:ti:genericfunc-cache*))))))

(define xtmdoc-builtin-handler
  (lambda (name-sym)
    (list
     '(category . "builtin")
     (cons 'name (symbol->string name-sym))
     (cons 'args (impc:ti:get-builtin-args (symbol->string name-sym)))
     (cons 'type
           (let ((type (impc:ti:get-builtin-type-str (symbol->string name-sym))))
             (if (string=? type "") '() type)))
     (cons 'docstring
           (let ((docstring (impc:ti:get-builtin-docstring (symbol->string name-sym))))
             (if (string=? docstring "") '() docstring))))))

(define xtmdoc-genericfunc-handler
  (lambda (name-sym)
    ;; once we have a way to handle multipe aritys, we should update
    ;; this function
    (list
     '(category . "generic closure")
     (cons 'name (symbol->string name-sym))
     (cons 'args (xtmdoc-get-xtlang-genericfunc-args name-sym))
     (cons 'type (impc:ti:simplify-genericfunc-pretty-type
                  (symbol->string (caddar (assoc-strcmp-all name-sym *impc:ti:genericfunc-cache*)))))
     (list 'docstring))))

(define xtmdoc-generictype-handler
  (lambda (name-sym)
    (list
     '(category . "generic type")
     (cons 'name (symbol->string name-sym))
     (list 'args)
     (cons 'type (impc:ti:simplify-generictype-pretty-type
                  (symbol->string (impc:ti:get-generictype-candidate-types name-sym))))
     (list 'docstring))))

(define xtmdoc-polyfunc-handler
  (lambda (name-sym)
    (list
     '(category . "polymorphic closure")
     (cons 'name (symbol->string name-sym))
     (cons 'args "")
     (list 'type)
     (cons 'docstring
           (let ((docstring (impc:ti:get-polyfunc-docstring (symbol->string name-sym)))
                 (poly-options-docstring
                  (string-join (map (lambda (pf)
                                      (let* ((option-name (vector-ref pf 0)))
                                        (string-append "@poly " option-name ":"
                                                       (impc:ir:pretty-print-type (vector-ref pf 1)))))
                                    (cl:remove-if
                                     (lambda (pf) (regex:match? (vector-ref pf 0) "_poly_"))
                                     (impc:ti:get-polyfunc-candidate-list (symbol->string name-sym))))
                               "\n")))
             (string-append docstring "\n\n" poly-options-docstring))))))

(define xtmdoc-polytype-handler
  (lambda (name-sym)
    (list
     '(category . "polymorphic type")
     (cons 'name (symbol->string name-sym))
     (list 'args)
     (cons 'type (string-join (map (lambda (pf) (impc:ir:pretty-print-type pf))
                                   (impc:ti:get-polytype-candidate-types (symbol->string name-sym)))
                              " "))
     (list 'docstring))))

(define xtmdoc-closure-handler
  (lambda (name-sym)
    (list
     '(category . "closure")
     (cons 'name (symbol->string name-sym))
     (cons 'args (xtmdoc-get-args-from-form (impc:ti:get-closure-body (symbol->string name-sym))))
     (cons 'type (impc:ir:pretty-print-type (impc:ti:get-closure-type (symbol->string name-sym))))
     (cons 'docstring
           (let ((docstring (impc:ti:get-closure-docstring (symbol->string name-sym))))
             (if (string=? docstring "") '() docstring))))))

(define xtmdoc-nativefunc-handler
  (lambda (name-sym)
    (list
     '(category . "C function")
     (cons 'name (symbol->string name-sym))
     (cons 'args (impc:ti:get-nativefunc-arg-names (symbol->string name-sym)))
     (cons 'type
           (let ((type (impc:ti:get-nativefunc-type (symbol->string name-sym))))
             (if (equal? type 'varargs)
                 "varargs"
                 (impc:ir:pretty-print-type type))))
     (cons 'docstring
           (let ((docstring (impc:ti:get-nativefunc-docstring (symbol->string name-sym))))
             (if (string=? docstring "") '() docstring))))))

(define xtmdoc-typealias-handler
  (lambda (name-sym)
    (list
     '(category . "type alias")
     (cons 'name (symbol->string name-sym))
     (list 'args)
     (cons 'type (impc:ir:pretty-print-type (impc:ti:get-typealias-ground-type (symbol->string name-sym))))
     (cons 'docstring
           (let ((docstring (impc:ti:get-typealias-docstring (symbol->string name-sym))))
             (if (string=? docstring "") '() docstring))))))

(define xtmdoc-namedtype-handler
  (lambda (name-sym)
    (list
     '(category . "named type")
     (cons 'name (symbol->string name-sym))
     (list 'args)
     (cons 'type (impc:ir:pretty-print-type (impc:ti:get-namedtype-type (symbol->string name-sym))))
     (cons 'docstring
           (let ((docstring (impc:ti:get-namedtype-docstring (symbol->string name-sym))))
             (if (string=? docstring "") '() docstring))))))

(define xtmdoc-globalvar-handler
  (lambda (name-sym)
    (list
     '(category . "global var")
     (cons 'name (symbol->string name-sym))
     (list 'args)
     ;; rememeber that global vars need to be "depointerised" by one level
     (cons 'type (impc:ir:pretty-print-type (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string name-sym)))))
     (cons 'docstring
           (let ((docstring (impc:ti:get-globalvar-docstring (symbol->string name-sym))))
             (if (string=? docstring "") '() docstring))))))

(define xtmdoc-scheme-function-handler
  (lambda (name-sym)
    (list
     '(category . "scheme closure")
     (cons 'name (symbol->string name-sym))
     (cons 'args (xtmdoc-get-args-from-form (get-closure-code (eval name-sym))))
     (list 'type)
     (list 'docstring))))

(define xtmdoc-scheme-macro-handler
  (lambda (name-sym)
    (list
     '(category . "scheme macro")
     (cons 'name (symbol->string name-sym))
     (cons 'args (cadadr (caddr (get-closure-code (eval name-sym)))))
     (list 'type)
     (list 'docstring))))

(define xtmdoc-documentation-function
  (lambda (name)
    (let ((sym (string->symbol name)))
      (cond ((impc:ti:builtin-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-builtin-handler sym)))
            ((impc:ti:typealias-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-typealias-handler sym)))
            ((impc:ti:genericfunc-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-genericfunc-handler sym)))
            ((impc:ti:polyfunc-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-polyfunc-handler sym)))
            ((impc:ti:closure-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-closure-handler sym)))
            ((impc:ti:nativefunc-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-nativefunc-handler sym)))
            ((impc:ti:globalvar-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-globalvar-handler sym)))
            ((impc:ti:generictype-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-generictype-handler sym)))
            ((impc:ti:polytype-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-polytype-handler sym)))
            ((impc:ti:namedtype-exists? name)
             (cons 'xtmdoc-docstring (xtmdoc-namedtype-handler sym)))
            ((and (defined? sym) (closure? (eval sym)))
             (cons 'xtmdoc-docstring (xtmdoc-scheme-function-handler sym)))
            ((and (defined? sym) (macro? (eval sym)))
             (cons 'xtmdoc-docstring (xtmdoc-scheme-macro-handler sym)))
            (else
             '(xtmdoc-docstring-nodocstring))))))

;; sort the alists (as returned by the various handler functions) into
;; a reasonably meaningful order (least to most important)
(define xtmdoc-alist-lessthan
  (lambda (left right)
    (let ((categories '("C function"
                        "global var"
                        "polymorphic closure"
                        "polymorphic type"
                        "closure"
                        "named type"
                        "generic closure"
                        "generic type"
                        "type alias"
                        "builtin")))
      (let ((lpos (cl:position (cdr (assoc-strcmp 'category left)) categories))
            (rpos (cl:position (cdr (assoc-strcmp 'category right)) categories)))
        (if (<> lpos rpos)
            (< lpos rpos)
            (string<? (cdr (assoc-strcmp 'name left))
                      (cdr (assoc-strcmp 'name right))))))))

(define xtmdoc-clean-nativefunc-alist
  (lambda (closure-alists nativefunc-alists)
    (cl:remove-if
     (lambda (nativefunc-data)
       (let ((nativefunc-name (cdr (assoc-strcmp 'name nativefunc-data))))
         (cl:find-if (lambda (closure-data)
                       ;; is it a closure?
                       (string=? (cdr (assoc-strcmp 'name closure-data)) nativefunc-name))
                     closure-alists)))
     nativefunc-alists)))

(define xtmdoc-all-doc-alists
  (lambda (include-nativefuncs?)
    (let* ((closure-alists
            (map (lambda (data) (xtmdoc-closure-handler (string->symbol (car data))))
                 *impc:ti:closure-cache*))
           (all-doc-alists
            (append
             (map (lambda (data) (xtmdoc-builtin-handler (string->symbol (car data)))) *impc:ti:builtin-cache*)
             (map (lambda (data) (xtmdoc-typealias-handler (string->symbol (car data)))) *impc:ti:typealias-cache*)
             (map (lambda (data) (xtmdoc-generictype-handler (car data))) *impc:ti:generictype-cache*)
             (map (lambda (data) (xtmdoc-genericfunc-handler (car data))) *impc:ti:genericfunc-cache*)

             (map (lambda (data) (xtmdoc-namedtype-handler (string->symbol (car data)))) *impc:ti:namedtype-cache*)
             closure-alists
             (map (lambda (data) (xtmdoc-polytype-handler (string->symbol (car data)))) *impc:ti:polytype-cache*)
             (map (lambda (data) (xtmdoc-polyfunc-handler (string->symbol (car data)))) *impc:ti:polyfunc-cache*)
             (map (lambda (data) (xtmdoc-globalvar-handler (string->symbol (car data)))) *impc:ti:globalvar-cache*)
             ;; make sure the "_native" versions of each closure don't get in
             ;; there (since the closure is already there)
             (if include-nativefuncs?
                 (xtmdoc-clean-nativefunc-alist
                  closure-alists
                  (map (lambda (x)
                         (xtmdoc-nativefunc-handler (string->symbol (car x))))
                       *impc:ti:nativefunc-cache*))
                 '()))))
      ;; filter out the things which shouldn't make it to the exported docs
      (cl:remove-if
       (lambda (doc-alist)
         (regex:match? (cdr (assoc-strcmp 'name doc-alist))
                       "(_setter$|_scheme$|_native$|_maker$|_getter$|_callback$|_poly_)"))
       all-doc-alists))))

;; we handle the args field separately, since there are a few special
;; cases to handle
(define xtmdoc-write-alist-args-as-json
  (lambda (xtmdoc-alist file-port)
    ;; (println (cdr (assoc-strcmp 'name xtmdoc-alist)))
    (display ",\n  \"args\": " file-port)
    (let ((category (cdr (assoc-strcmp 'category xtmdoc-alist)))
          (args (cdr (assoc-strcmp 'args xtmdoc-alist)))
          (type (cdr (assoc-strcmp 'type xtmdoc-alist))))
      ;; arg names and types
      (cond
       ((member category '("closure" "generic closure"))
        (display
         (string-append
          "["
          (string-join (map (lambda (name type)
                              (string-append "[\"" (symbol->string name) "\", \"" type "\"]"))
                            (cons 'RETURN args)
                            (impc:ir:get-pretty-closure-arg-strings type))
                       ", ")
          "]")
         file-port))
       ((string=? category "builtin")
        (if (or (not (string? type))
                (string=? type "")
                (<> (length (cdr (impc:ir:get-pretty-closure-arg-strings type)))
                    (length args)))
            ;; allow builtins have malformed arg/type relationships
            (display
             (string-append
              "["
              (string-join (map (lambda (name)
                                  (string-append "[\"" (symbol->string name) "\", null]"))
                                args)
                           ", ")
              "]")
             file-port)
            (display
             (string-append
              "["
              (string-join (map (lambda (name type)
                                  (string-append "[\"" (symbol->string name) "\", \"" type "\"]"))
                                (cons 'RETURN args)
                                (impc:ir:get-pretty-closure-arg-strings type))
                           ", ")
              "]")
             file-port)))
       ((string=? category "C function")
        (display
         (string-append
          "["
          ;; at the moment, there's no way of telling the xtlang
          ;; compiler about the names of the arguments to a C function
          (string-join (map (lambda (type)
                              (string-append "[null, \"" type "\"]"))
                            (impc:ir:get-pretty-closure-arg-strings type))
                       ", ")
          "]")
         file-port))
       ;; these are the ones for which "args" doesn't make sense
       ;; "named type"
       ;; "generic type"
       ;; "polymorphic closure"
       ;; "global var"
       ;; "polymorphic type"
       ;; "type alias"
       (else (write 'null file-port))))))

(define xtmdoc-write-alist-as-json
  (lambda (xtmdoc-alist file-port)
    (display "{\n  \"category\": " file-port)
    (write (cdr (assoc-strcmp 'category xtmdoc-alist)) file-port)
    (display ",\n  \"name\": " file-port)
    (write (cdr (assoc-strcmp 'name xtmdoc-alist)) file-port)
    (xtmdoc-write-alist-args-as-json xtmdoc-alist file-port)
    (display ",\n  \"type\": " file-port)
    (let ((type (cdr (assoc-strcmp 'type xtmdoc-alist))))
      (write (if (null? type) 'null type) file-port))
    (display ",\n  \"docstring\": " file-port)
    (let ((docstring (cdr (assoc-strcmp 'docstring xtmdoc-alist))))
      (write (if (null? docstring) 'null docstring) file-port))
    (display "\n}" file-port)))

(define xtmdoc-export-caches-to-json
  (lambda (file-path include-nativefuncs?)
    (let ((outfile-port (open-output-file file-path)))
      (display "[\n" outfile-port)
      (let loop ((doc-alists (cl:sort (xtmdoc-all-doc-alists include-nativefuncs?)
                                      (lambda (a b) (not (xtmdoc-alist-lessthan a b))))))
        (if (null? doc-alists)
            (begin
              (display "\n]" outfile-port)
              (close-port outfile-port)
              (print "Succesfully exported docs as json to " file-path "\n")
              #t)
            (begin
              (xtmdoc-write-alist-as-json (car doc-alists) outfile-port)
              (if (not (null? (cdr doc-alists)))
                  (display ",\n" outfile-port))
              (loop (cdr doc-alists))))))))

(define-macro (impc:ti:get-native-name closure-name . type)
  (let* ((pair (regex:type-split (symbol->string closure-name) ":"))
         (base (if (null? (cdr pair)) "" (impc:ir:get-base-type (cadr pair)))))
    (set! closure-name (symbol->string closure-name))
    (if (not (null? (cdr pair)))
        (string-append (car pair) "_adhoc_" (cname-encode base) "_native")
        (if (null? type)
            (if (and (impc:ti:polyfunc-exists? closure-name)
                     (= (length (impc:ti:get-polyfunc-candidate-types closure-name)) 1))
                (let* ((t (impc:ir:pretty-print-type (car (impc:ti:get-polyfunc-candidate-types closure-name))))
                       (bt (impc:ir:get-base-type t))
                       (fullname (string-append closure-name
                                                "_adhoc_"
                                                (cname-encode bt)
                                                "_native")))
                  fullname)
                (impc:compiler:print-compiler-error "Try forcing a type? Ambiguous call to get_native_fptr" (string->symbol closure-name)))
            (let* ((bt (impc:ir:get-base-type (symbol->string (car type))))
                   (fullname (string-append closure-name
                                            "_adhoc_"
                                            (cname-encode bt)
                                            "_native")))
              fullname)))))

(define-macro (impc:ti:get-mono-name closure-name . type)
  (let* ((pair (regex:type-split (symbol->string closure-name) ":"))
         (base (if (null? (cdr pair)) "" (impc:ir:get-base-type (cadr pair)))))
    (set! closure-name (symbol->string closure-name))
    (if (not (null? (cdr pair)))
        (string-append (car pair) "_adhoc_" (cname-encode base) "_native")
        (if (null? type)
            (if (and (impc:ti:polyfunc-exists? closure-name)
                     (= (length (impc:ti:get-polyfunc-candidate-types closure-name)) 1))
                (let* ((t (impc:ir:pretty-print-type (car (impc:ti:get-polyfunc-candidate-types closure-name))))
                       (bt (impc:ir:get-base-type t))
                       (fullname (string-append closure-name
                                                "_adhoc_"
                                                (cname-encode bt)
                                                "")))
                  fullname)
                (impc:compiler:print-compiler-error "Try forcing a type? Ambiguous call to get_native_fptr" (string->symbol closure-name)))
            (let* ((bt (impc:ir:get-base-type (symbol->string (car type))))
                   (fullname (string-append closure-name
                                            "_adhoc_"
                                            (cname-encode bt)
                                            "")))
              fullname)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; print ir & x86 assm
;;

(define-macro (llvm:ir name . type)
  (let ((t (if (null? type) #f (car type))))
    `(let* ((n1 ,(if t
                     `(impc:ti:get-mono-name ,name ,t)
                     `(impc:ti:get-mono-name ,name)))
            (n2 (llvm:get-closure-work-name n1)))
       ;; (println 'n1 n1 'n2 n2)
       (llvm:print-closure n2))))

(define-macro (llvm:asm name . args)
  (let* ((a1 (if (null? args) #f (car args)))
         (a2 (if (null? args) #f (if (null? (cdr args)) #f (cadr args))))
         (type (if (symbol? a1) a1 (if (symbol? a2) a2 #f)))
         (assm_print_type (if (number? a1) a1 (if (number? a2) a2 #f))))
    `(let ((n1 ,(if type
                    `(impc:ti:get-mono-name ,name ,type)
                    `(impc:ti:get-mono-name ,name))))
       ,(if (not assm_print_type)
            `(print (llvm:disassemble n1 0) "\n")
            `(print (llvm:disassemble n1 ,assm_print_type) "\n")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; helper functions for constraint checking
;;
;; note that these need to take *impc:ir:notype* into acct
;; 
;; in other words they should only fail for actual types
;; they should succeed against *impc:ir:notype*
;;

;; (define t:integer? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:fixed-point? x))))
;; (define t:float? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:floating-point? x))))
;; (define t:number? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:number? x))))
;; (define t:void? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:void? x))))
;; (define t:signed? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:signed? x))))
;; (define t:closure? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:closure? x))))
;; (define t:vector? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:vector? x))))
;; (define t:array? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:array? x))))
;; (define t:tuple? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:tuple? x))))
;; (define t:scalar? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:scalar? x))))
;; (define t:pointer? (lambda (x) (or (equal? x *impc:ir:notype*) (impc:ir:pointer? x))))
;; (define t:notype? (lambda (x) (equal? x *impc:ir:notype*)))

(define t:integer? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:fixed-point? x)))
(define t:float? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:floating-point? x)))
(define t:number? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:number? x)))
(define t:void? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:void? x)))
(define t:signed? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:signed? x)))
(define t:closure? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:closure? x)))
(define t:vector? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:vector? x)))
(define t:array? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:array? x)))
(define t:tuple? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:tuple? x)))
(define t:scalar? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:scalar? x)))
(define t:pointer? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (impc:ir:pointer? x)))
(define t:notype? (lambda (x) (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x))) (equal? x *impc:ir:notype*)))

;; how many elements (or args for closure) does type have
;; 
(define t:elts? (lambda (x num)
                  (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x)))
                  (cond ((string? x) (= num -1))
                        ((or (t:array? x) (t:vector? x))
                         (= (cadr x) num))
                        ((t:tuple? x)
                         (= (- (length x) 1) num))
                        ((t:closure? x)
                         (= (- (length x) 2) num))
                        (else (= num 1)))))

;; named type check strips pointers!
;; (you can use t:pointer? fo
;; (define t:cleanup-string-type
;;   (lambda (a)
;;     (let* ((nt (impc:ti:get-named-type (impc:ir:get-base-type (impc:ir:clean-named-type a))))
;;            (bt (impc:ir:get-base-type (impc:ir:clean-named-type a)))
;;            (ptrdepth (impc:ir:get-ptr-depth a))
;;            (strtype (impc:ir:pointer++ nt ptrdepth)))
;;       ;; (println 'bt bt 'ptrdepth ptrdepth 'nt nt 'strtype strtype)
;;       (apply string-append bt (make-list ptrdepth "*")))))

(define t:cleanup-string-type
  (lambda (a)
    (let* ((nt (impc:ti:get-named-type (impc:ir:get-base-type (impc:ir:clean-named-type a))))
           (bt (impc:ir:get-base-type (impc:ir:clean-named-type a))))
      bt)))

(define reduce-ptrdepth-to-zero
  (lambda (t)
    (if (> (impc:ir:get-ptr-depth t) 0)
        (reduce-ptrdepth-to-zero (impc:ir:pointer-- t))
        t)))

(define t:named? (lambda (x y)
                   (if (or (t:notype? x) (t:notype? y))
                       #t
                       (begin
                         (if (symbol? x) (set! x (symbol->string x)))
                         (if (symbol? y) (set! y (symbol->string y)))
                         (if (string? x) (set! x (impc:ir:get-type-from-pretty-str x)))
                         (if (string? y) (set! y (impc:ir:get-type-from-pretty-str y)))
                         (set! x (reduce-ptrdepth-to-zero x))
                         (set! y (reduce-ptrdepth-to-zero y))
                         ;; (println 'x x 'y y)
                         (if (and (string? x) (string? y))
                             (if (string=? (t:cleanup-string-type x) (t:cleanup-string-type y))
                                 #t
                                 #f)
                             (impc:ir:types-equal? x y))))))

;; (define t:named? (lambda (x y)
;;                    (if (or (t:notype? x) (t:notype? y))
;;                        #t
;;                        (begin
;;                          (if (symbol? x) (set! x (symbol->string x)))
;;                          (if (symbol? y) (set! y (symbol->string y)))
;;                          (if (not (and (string? x) (string? y)))
;;                              (impc:compiler:print-compiler-error "poorly formed t:named? constraint args" (list x y)))
;;                          (if (string=? (t:cleanup-string-type-b x) (t:cleanup-string-type-b y))
;;                                  #t
;;                                  #f)))))                  
                   

(define t:poly-exists?
  (lambda (name type)
    (if (member *impc:ir:notype* type)
        #t
        (begin
          (if (symbol? name) (set! name (symbol->string name)))
          (if (impc:ti:get-polyfunc-candidate name (cons 213 type)) #t #f)))))


;; to catch the dreaded heisenbug...

(define s-p-a-c-e-s___
  (lambda ()
    (string-append "  ")))