impc:ti:create-scheme-wrapper   scheme


Defined in:  https://github.com/digego/extempore/tree/v0.8.9/runtime/llvmti.xtm

Implementation

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


Back to Index