impc:ti:register-new-genericfunc   scheme


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

Implementation

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


Back to Index