(define-macro (bind-static . args)
(if (string? (cadr args))
(if (not (equal? (caaddr args) 'lambda))
(impc:compiler:print-compiler-error "static functions cannot be closures!"))
(if (not (equal? (caadr args) 'lambda))
(impc:compiler:print-compiler-error "static functions cannot be closures!")))
;; if aot and func already exists then bomb out
(if (and (output-port? *impc:aot:current-output-port*)
(impc:ti:closure-exists? (symbol->string (car args))))
(begin ;; (impc:aot:insert-sexpr `(println 'Warning: ',(car args) 'is 'overriden)) ;; insert warning into aot file
#t)
;; if doc-string exists!
(let ((func-name (car (regex:type-split (symbol->string (car args)) ":")))
(zone-size (if (number? (cadr args)) (cadr args) *impc:default-zone-size*))
(poly (if (boolean? (cadr args)) (cadr args) #t))
(docstring (if (string? (cadr args))
(cadr args)
(if (and (not (null? (cddr args))) (string? (caddr args)))
(caddr args)
"")))
;; closure body is always in last position, preceeded by zone
;; size and/or docstring
(closure-body (car (reverse args))))
(if (member func-name *impc:reserved-keywords*)
(begin (println "ERROR: " func-name " is a reserved keyword") (error "")))
;; strip docstring
(set! args (cl:remove-if string? args))
;; strip poly
(set! args (cl:remove-if boolean? args))
(if (impc:ti:polyfunc-exists? (car args))
(impc:compiler:print-already-bound-error (car args) " static function"))
;; (if (impc:ti:genericfunc-exists? (car args))
;; (impc:compiler:print-already-bound-error (car args) "generic closure"))
(if (regex:match? (symbol->string (car args)) ":")
(let* ((res (regex:type-split (symbol->string (car args)) ":"))
(name (car res))
(type1 (cadr res))
(type (if (char=? (string-ref type1 0) #\[)
(if (= (impc:ir:get-ptr-depth type1) 1)
type1
(impc:compiler:print-bad-type-error type1 "must be a closure pointer"))
(if (impc:ti:typealias-exists? type1)
(impc:ti:get-typealias-type-pretty type1)
(impc:compiler:print-bad-type-error type1 "Bad closure type for bind-static"))))
(ags (impc:ir:get-pretty-closure-arg-strings type))
;; expand all non-explict generic types
;; i.e. expand list* into list:<!a,list*>*
(expand-polys (map (lambda (k)
(if (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))
(impc:ir:pointer++
(string-append (impc:ir:get-base-type k) ":"
(symbol->string (impc:ti:get-generictype-candidate-types (impc:ir:get-base-type k))))
(impc:ir:get-ptr-depth k))
k))
ags))
(newtype (string-append "[" (string-join expand-polys ",") "]*"))
(newnametype (string->symbol (string-append name ":" newtype))))
;; (println 'oldargs: args)
;; (println 'newargs: (cons newnametype (cdr args)))
(if (impc:ti:bang-type? newtype)
(begin
(impc:compiler:print-compiler-error "static functions cannot be generic!"))
(begin
(if (impc:ti:closure-or-nativefunc-exists? func-name)
(impc:compiler:print-compiler-error "static functions cannot be redefined!")
(impc:ti:register-new-closure func-name '() zone-size docstring closure-body))
`(eval '(define-static ,(car args) ,@(cdr args)) (interaction-environment)))))
(begin
(if ;; (impc:ti:closure-exists? func-name)
(impc:ti:closure-or-nativefunc-exists? func-name)
(impc:compiler:print-compiler-error "static functions cannot be redefined!")
(impc:ti:register-new-closure func-name '() zone-size docstring closure-body))
`(eval '(define-static ,(car args) ,@(cdr args)) (interaction-environment)))))))