;;
;;
;; Other utility code
;;
;;
(define impc:ti:add-types-to-source-atom
(lambda (symname ast types envvars . prev)
;; (println 'symname: symname 'ast: ast 'envvars: envvars)
(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 #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 #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))))