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