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