Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

5251 lines (4781 sloc) 237.294 kb
;;
;; Copyright (c) 2011, Andrew Sorensen
;;
;; All rights reserved.
;;
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
;; Neither the name of the authors nor other contributors may be used to endorse
;; or promote products derived from this software without specific prior written
;; permission.
;;
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLEXTD. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
;;
;;
(define *impc:docstrings* '())
(define *impc:closuretypes* '())
(define *impc:ti:print-sub-checks* #f)
(define *impc:ti:print-main-check* #f)
(define *impc:ti:print-unifications* #f)
(define *impc:compile* #t)
(define *impc:compiler:print* #f)
(define *impc:compiler:print-types* #f)
(define *impc:compiler:verbose* #f)
(define *impc:compiler:print-raw-llvm* #f)
(define *impc:compiler:precomp* (make-string 0))
(define *impc:compiler:precomp-llvm* #f)
(define *impc:compiler:process* (ipc:get-process-name))
;(define *impc:compiler:process* "utility")
(define *impc:zone* (sys:default-mzone))
(define *impc:default-zone-size* (* 8 1024))
(define icr:new-zone
(lambda args
(if (null? args)
(sys:create-mzone *impc:default-zone-size*)
(sys:create-mzone (car args)))))
(define icr:destroy-zone
(lambda (zone)
(if (equal? *impc:zone* zone)
(set! *impc:zone* (sys:default-mzone)))
(if (equal? zone (sys:default-mzone))
(print-notification "You are not allowed to destroy the default zone")
(sys:destrop-mzone zone))))
(define icr:set-zone
(lambda (zone)
(set! *impc:zone* zone)))
(define icr:set-zone-default
(lambda ()
(set! *impc:zone* (sys:default-mzone))))
(define llvm:get-function-args-withoutzone
(lambda (name)
(if (llvm:get-function (string-append name "_getter"))
(let ((ftype (llvm:get-function-args name)))
(list* (car ftype) (cddr ftype)))
(llvm:get-function-args name))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strips pretty-types from source code
;; returns a cons of (the-new-ast any-explicit-types)
;;
(define impc:ti:get-var-types
(lambda (ast)
(let* ((types '())
(f (lambda (ast)
;(print 'ast: ast 'types: types)
(cond ((null? ast) '())
((atom? ast) ast)
;; ((equal? (car ast) 'dotimes)
;; (list* 'dotimes
;; (list (if (regex:match? (symbol->string (caadr ast)) ":")
;; (let ((t (regex:split (symbol->string (caadr ast)) ":")))
;; (if (regex:match? (cadr t) "^\\<|\\[")
;; (if (not (regex:match? (cadr t) "\\>|\\]"))
;; (print-error 'Compiler 'Error: 'Syntax 'error: 'bad 'type (cadr t))))
;; (set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
;; (string->symbol (car t)))
;; (caadr ast))
;; (cadadr ast))
;; (f (cddr ast))))
((equal? (car ast) 'lambda)
(list* 'lambda
(map (lambda (a)
(if (regex:match? (symbol->string a) ":")
(let ((t (regex:split (symbol->string a) ":")))
(if (regex:match? (cadr t) "^\\<|\\[")
(if (not (regex:match? (cadr t) "\\>|\\]"))
(print-error 'Compiler 'Error: 'Syntax 'error: 'bad 'type (cadr t))))
(set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
(string->symbol (car t)))
a))
(cadr ast))
(f (cddr ast))))
((member (car ast) '(let let* letrec))
(list* (car ast)
(map (lambda (a)
(if (or (atom? a)
(null? (cdr a))
(> (length (cdr a)) 1))
(print-error 'Compiler 'Error: 'syntax 'error: 'badly 'formed 'let 'expression (sexpr->string a)))
(if (regex:match? (symbol->string (car a)) ":")
(let ((t (regex:split (symbol->string (car a)) ":")))
(if (regex:match? (cadr t) "^\\<|\\[")
(if (not (regex:match? (cadr t) "\\>|\\]"))
(print-error 'Compiler 'Error: 'Syntax 'error: 'bad 'type (cadr t))))
(set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
(list (string->symbol (car t)) (car (f (cdr a)))))
(list (car a) (car (f (cdr a))))))
(cadr ast))
(f (cddr ast))))
((pair? ast)
(cons (f (car ast))
(f (cdr ast))))))))
(cons (f ast) types))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Simple Compile Time Generics using type classes
;;
(define *impc:ti:vtypes* (list))
(define impc:ti:add-vtype
(lambda (name type)
(if (string? type)
(set! type (impc:ir:get-type-from-pretty-str type)))
(if (string? name)
(set! name (string->symbol name)))
(let ((v (assoc-strcmp name *impc:ti:vtypes*)))
(if v
(if (member type v) #t
(set-cdr! v (cons type (cdr v))))
(set! *impc:ti:vtypes* (cons (list name type) *impc:ti:vtypes*)))
(ascii-print-color 0 7 10)
(print "Appended type variable ")
(ascii-print-color 1 2 10)
(print name)
(ascii-print-color 0 7 10)
(print " >>> ")
(ascii-print-color 1 3 10)
(print type)
(ascii-print-color 0 7 10)
(print)
#t)))
(define impc:ti:vtypes
(lambda (name)
(let ((res (assoc-strcmp name *impc:ti:vtypes*)))
(if res (cdr res)
#f))))
(define impc:ti:vtype-match?
(lambda (name type)
(let ((res (assoc-strcmp name *impc:ti:vtypes*)))
(if (list? res) (if (member type res) #t #f)
#f))))
(define impc:ti:check-for-vtypes
(lambda (ast)
(let* ((atypes (cdr (impc:ti:get-var-types ast)))
(types (map (lambda (v) (impc:ti:vtypes (cdr v))) atypes))
(rest (cl:remove #f types)))
;(println 'atypes: atypes 'types: types 'rest: rest)
(if (> (length rest) 0) #t #f))))
(define impc:ti:force-vtypes
(lambda (ast)
(replace-all ast '((y:num . y:double)))))
(define impc:ti:vtype-transforms
(lambda (name ast)
(if (symbol? name) (set! name (symbol->string name)))
(let* ((stripped (impc:ti:get-var-types ast))
(args (cadr (caddr (car stripped))))
(atypes (reverse (cdr stripped))) ;; statically bound types
(tvar-lists (map (lambda (v) (impc:ti:vtypes (cdr v))) atypes))
(tlists (cl:remove #f tvar-lists))
(combinations (if (= (length tlists) 1)
(map (lambda (x) (list x)) (car tlists))
(apply multi-list-combination tlists)))
(fixedtype-lists (map (lambda (comb)
(map (lambda (at c)
(let ((findstr (string-append (symbol->string (car at))
":"
(symbol->string (cdr at))))
(replacestr (string-append (symbol->string (car at))
":"
(symbol->string c))))
(cons (string->symbol findstr)
(string->symbol replacestr))))
atypes
comb))
combinations))
(fixedtype-lists2 (map (lambda (comb)
(map (lambda (at c)
(let ((findstr (string-append ":" (symbol->string (cdr at))))
(replacestr (impc:ir:get-base-type (symbol->string c))))
(cons (string->symbol findstr)
(string->symbol replacestr))))
atypes
comb))
combinations))
(newnames (map (lambda (r)
(let* ((hash (string-hash (apply string-append
(map (lambda (t)
(symbol->string t))
r))))
(nameandhash (string-append name "--" (number->string hash))))
(cons (string->symbol name) (string->symbol nameandhash))))
combinations)))
(list (map (lambda (n) (cdr n)) newnames)
(map (lambda (n r r2)
;(println '-> (cons n (append r r2)))
(replace-all (cl:copy-list ast) (cons n (append r r2))))
newnames
fixedtype-lists
fixedtype-lists2)))))
(define impc:ti:parametric-poly-pass
(lambda (ast)
;(println 'impc:ti:parametric-poly-pass ast)
(if (not (impc:ti:check-for-vtypes ast))
(eval ast (interaction-environment)) ;; if not generic func compile normally
(let* ((storeprint print) ;; set print to nothing but store original as storeprint
(name (cadr ast)) ;; otherwise compile all required templates
(dat (impc:ti:vtype-transforms name ast))
(_ (set! print (lambda args (storeprint "")))) ;;setting print to suppress compiler output
(res (map (lambda (fname nast)
;(println 'fname: fname)
(let ((val (call/cc (lambda (k)
(set! print-error (lambda args
;(println "andrew world")
;(apply pprint-error args)
(k #f)))
#t))))
;(println 'bingo: val 'fname: fname)
(if (equal? val #t)
(let* ((rr (eval nast (interaction-environment)))
(type (impc:ir:get-function-type (symbol->string fname)))
(strtype (impc:ir:pretty-print-type type)))
(if (null? type)
#f
(begin
(eval `(bind-poly ,name ,fname ,(string->symbol strtype))
(interaction-environment))
type))))))
(car dat)
(cadr dat))))
;; restore print-error and print
(set! print-error (lambda args (apply pprint-error args) (error "")))
(set! print storeprint)
(print)
(if (> (length (cl:remove '() (cl:remove #f res))) 0)
(begin
(ascii-print-color 0 7 10)
(print 'Compiled 'generic 'function )
(ascii-print-color 1 2 10)
(print "" name)
(ascii-print-color 0 7 10)
(print)
(ascii-print-color 1 3 10)
(for-each (lambda (k)
(print)
(print "\t" (impc:ir:pretty-print-type k)))
(cl:remove '() (cl:remove #f res)))
(ascii-print-color 0 7 10)
(print)
(print)
(print ".... ")
(ascii-print-color 1 2 10)
(print name)
(ascii-print-color 0 7 10)
(print) (print)
#t)
(begin (print-error 'Compile 'Error: 'failed 'to 'find 'any 'valid 'forms 'for 'generic 'function: name)
#f))))))
;;
;; TRANSFORM CODE
;;
;; Transform straight R5RS code into
;; a simpler but still valid R5RS scheme code
;;
(define impc:ti:and
(lambda (ast)
(if (pair? ast)
(list 'if (car ast)
(if (null? (cdr ast))
(car ast)
(impc:ti:and (cdr ast)))
#f))))
(define impc:ti:or
(lambda (ast)
(if (pair? ast)
(list 'if (car ast)
(car ast)
(if (null? (cdr ast))
#f
(impc:ti:or (cdr ast)))))))
(define impc:ti:cond
(lambda (ast)
(if (null? ast) '()
(list 'if (caar ast)
(if (null? (cdar ast))
'()
(apply list 'begin (cdar ast)))
(impc:ti:cond (cdr ast))))))
(define impc:ti:list
(lambda (ast)
(if (null? ast) 'null
(list 'cons
(car ast)
(impc:ti:list (cdr ast))))))
;; (define impc:ti:map
;; (lambda (ast)
;; (list 'let 'maplloop (append (map (lambda (p l)
;; (cons l (list p)))
;; (cdr ast)
;; (list 'l1 'l2 'l3 'l4 'l5 'l6 'l7 'l8 'l9))
;; (list (list 'll '(list))))
;; (list 'if '(null? l1) '(reverse ll)
;; (append '(maplloop)
;; (map (lambda (p l)
;; (list 'cdr l))
;; (cdr ast)
;; (list 'l1 'l2 'l3 'l4 'l5 'l6 'l7 'l8 'l9))
;; (list (list 'cons (append (list (car ast))
;; (map (lambda (p l)
;; (list 'car l))
;; (cdr ast)
;; (list 'l1 'l2 'l3 'l4 'l5 'l6 'l7 'l8 'l9)))
;; 'll)))))))
(define impc:ti:not
(lambda (ast)
(list 'if ast #f #t)))
(define impc:ti:case
(lambda (expr body)
(if (null? body)
'(list)
`(if ,(if (eq? 'else (caar body))
#t
(list 'member expr (cons 'list (caar body))))
,@(cdar body)
,(impc:ti:case expr (cdr body))))))
(define impc:ti:quote
(lambda (ast)
(cond ((null? ast) '(impc_null)) ;(list))
((symbol? ast) `(llvm_make_symbol ,(symbol->string ast)))
((list? ast)
(cons 'list (map (lambda (a)
(if (or (eq? 'NIL a)
(null? a))
'(list)
a))
ast)))
(else ast))))
(define impc:ti:random
(lambda (ast)
(case (length ast)
((0) (append (list 'imp_rand) ast))
((1) (append (list 'imp_rand1) ast))
((2) (append (list 'imp_rand2) ast)))))
;; no anonymous lambdas !!!
(define impc:ti:lambda
(lambda (ast)
(let* ((fname (gensym))
(rest (cons (impc:ti:first-transform (cadr ast) #t)
(list (cons 'begin (impc:ti:first-transform (cddr ast) #t)))))
(expr (cons 'lambda rest)))
`(let ((,fname ,expr))
(begin ,fname)))))
;; replace (* 2 3 4 5) or (+ 2 3 4 5)
;; with (* 2 (* 3 (* 4 5))) etc..
(define impc:ti:binary-arity
(lambda (ast inbody?)
(let ((op (car ast))
(inlst (reverse (cdr ast))))
(let loop ((rest (cdr inlst))
(lst (car inlst)))
(if (null? rest) lst
(loop (cdr rest) (cons op (cons (impc:ti:first-transform (car rest) inbody?) (list lst)))))))))
(define impc:ti:binary-arity
(lambda (ast inbody?)
(let ((op (car ast))
(inlst (cdr ast)))
(if (< (length inlst) 2)
(print-error 'Compiler 'Error: 'Bad 'arity 'in 'math 'expr ast))
(let loop ((rest (cddr inlst))
(lst (list op
(impc:ti:first-transform (car inlst) inbody?)
(impc:ti:first-transform (cadr inlst) inbody?))))
(if (null? rest) lst
(loop (cdr rest) (list op lst (impc:ti:first-transform (car rest) inbody?))))))))
(define impc:ti:bitwise-not-to-eor
(lambda (ast inbody?)
(list 'bitwise-eor (cadr ast) -1)))
(define impc:ti:afill!
(lambda (ast)
(append '(begin)
(map (lambda (arg idx)
(list 'aset! (car ast) idx arg))
(cdr ast)
(make-list-with-proc (length ast) (lambda (i) i))))))
(define impc:ti:pfill!
(lambda (ast)
(append '(begin)
(map (lambda (arg idx)
(list 'pset! (car ast) idx arg))
(cdr ast)
(make-list-with-proc (length ast) (lambda (i) i))))))
(define impc:ti:tfill!
(lambda (ast)
(append '(begin)
(map (lambda (arg idx)
(list 'tset! (car ast) idx arg))
(cdr ast)
(make-list-with-proc (length ast) (lambda (i) i))))))
(define impc:ti:vfill!
(lambda (ast)
(append '(begin)
(map (lambda (arg idx)
(list 'vset! (car ast) idx arg))
(cdr ast)
(make-list-with-proc (length ast) (lambda (i) i))))))
;; This function expects a generic type with specification
;;
;; so for example:
;; xlist_t*~i8*
;;
;; which goes to intermediate:
;; <i8*,xlist_t*>
;;
;; and will specialise to:
;; xlist_t--8491014222608498578*
;;
(define impc:ti:generic-type-specification
(lambda (t)
(let ((split (regex:split (symbol->string t) "~")))
(if (null? (impc:ir:get-named-type (impc:ir:get-base-type (car split))))
(print-error 'Compiler 'Error: 'don't 'use '~ 'in 'non 'generic 'types 'or 'variables: t)
(let* ((ntype (impc:ir:get-named-type (impc:ir:get-base-type (car split))))
(gvars (cl:remove-duplicates (regex:match-all (symbol->string ntype) "![a-z_A-Z]*")))
;; (ttype (impc:ir:get-type-from-pretty-str (symbol->string ntype)))
(depth (impc:ir:get-ptr-depth (car split)))
(base (impc:ir:get-base-type (car split)))
(ts (cdr split)) ;(regex:split (cadr split) ","))
(hash 0)
(newtype (symbol->string ntype)))
(if (<> (length ts) (length gvars))
(print-error 'Compiler 'Error: 'mismatched 'types ts '-> gvars))
(map (lambda (t g)
(set! newtype (regex:replace-all newtype g t)))
ts gvars)
(set! hash (string-hash newtype))
(set! newtype (regex:replace newtype
(string-append base "")
(string-append base "--" (number->string hash))))
(set! newtype (impc:ir:get-type-str (impc:ir:get-type-from-pretty-str newtype (string-append base "--" (number->string hash)))))
;; (println 'compile: (string-append "%" (string-append base "--" (number->string hash)) " = type " newtype))
(llvm:compile (string-append "%" (string-append base "--" (number->string hash)) " = type " newtype))
(string->symbol (apply string-append base "--" (number->string hash) (make-list depth "*"))))))))
;; takes any type with generic specialisations
;; and returns type with any specialisations (i.e. ~'s)
;; turned into proper hashed named types
;;
;; currently this only works when there is a SINGLE ~ type
(define impc:ti:generic-spec-to-hashed
(lambda (t)
(if (symbol? t) (set! t (symbol->string t)))
(let* ((aa (regex:matched t "~.*~"))
(bb (regex:matched t "[^~]*[,\\[<]([^~]*)"))
;; (kkkkk (println 'aa: aa))
;; (kkkkkk (println 'bb: bb))
(v (if (or (null? aa)
(null? bb))
(print-error 'Compiler 'Error: 'trying 'to 'parse 'generic 'spec 'without '~ t)
(string-append (cadr bb) (car aa))))
(s (impc:ti:generic-type-specification (string->symbol v)))
(n (regex:replace t (string-append "\\Q" v "\\E") (symbol->string s))))
;; (println 'v v 's s 'n n)
(if (regex:match? n "~")
(impc:ti:generic-spec-to-hashed n)
(string->symbol n)))))
(define *unique-polynum* 0)
(define impc:ti:first-transform
(lambda (ast inbody?)
;(println inbody? 'transforming-ast: ast)
(if (null? ast) '()
(cond ((list? ast)
(cond ((or (impc:ir:poly-types (car ast))
(impc:ir:gpoly-types (car ast)))
;; (and (impc:ir:poly-types (car ast))
;; (not (impc:ir:gpoly-types (car ast))))
(set! *unique-polynum* (+ 1 *unique-polynum*))
(cons (string->symbol (string-append (symbol->string (car ast))
"##" ;"$$$"
(number->string *unique-polynum*)))
(impc:ti:first-transform (cdr ast) inbody?)))
((eq? (car ast) 'and)
(impc:ti:first-transform (impc:ti:and (cdr ast)) inbody?))
((eq? (car ast) 'random)
(impc:ti:first-transform (impc:ti:random (cdr ast)) inbody?))
((eq? (car ast) 'quote)
(impc:ti:first-transform (impc:ti:quote (cadr ast)) inbody?))
((eq? (car ast) 'list)
(impc:ti:first-transform (impc:ti:list (cdr ast)) inbody?))
;; ((member (car ast) '(map for-each))
;; (impc:ti:first-transform (impc:ti:map (cdr ast)) inbody?))
((eq? (car ast) 'case)
(impc:ti:first-transform (impc:ti:case (cadr ast) (cddr ast)) inbody?))
((eq? (car ast) 'afill!)
(impc:ti:first-transform (impc:ti:afill! (cdr ast)) inbody?))
((eq? (car ast) 'pfill!)
(impc:ti:first-transform (impc:ti:pfill! (cdr ast)) inbody?))
((eq? (car ast) 'tfill!)
(impc:ti:first-transform (impc:ti:tfill! (cdr ast)) inbody?))
((eq? (car ast) 'vfill!)
(impc:ti:first-transform (impc:ti:vfill! (cdr ast)) inbody?))
((eq? (car ast) 'or)
(impc:ti:first-transform (impc:ti:or (cdr ast)) inbody?))
((eq? (car ast) 'free)
(list 'free (list 'bitcast (impc:ti:first-transform (cadr ast) inbody?)
'i8*)))
((member (car ast) '(array))
(impc:ti:first-transform (impc:ti:array ast) inbody?))
((member (car ast) '(tuple))
(impc:ti:first-transform (impc:ti:tuple ast) inbody?))
;((eq? (car ast) 'null?)
; (impc:ti:first-transform `(impc_isnull ,(cadr ast)) inbody?))
((eq? (car ast) 'not)
(impc:ti:first-transform (impc:ti:not (cadr ast)) inbody?))
;; ((eq? (car ast) 'list)
;; (impc:ti:first-transform (impc:ti:binary-arity (cons 'mcons (append (cdr ast) '(nilnil))) inbody?) inbody?))
((and (member (car ast) '(* - / + % bitwise-and bitwise-or bitwise-eor bitwise-shift-left bitwise-shift-right))
(<> (length ast) 3))
(impc:ti:first-transform (impc:ti:binary-arity ast inbody?) inbody?))
((member (car ast) '(bitwise-not ~))
(impc:ti:bitwise-not-to-eor ast inbody?))
((eq? (car ast) 'lambda)
(if inbody?
(impc:ti:lambda ast)
(cons (impc:ti:first-transform (car ast) inbody?)
(cons (impc:ti:first-transform (cadr ast) #t)
(list (cons 'begin (impc:ti:first-transform (cddr ast) #t)))))))
;; ((eq? (car ast) 'cons)
;; (println 'ast: ast)
;; (impc:ti:first-transform (impc:ti:cons ast) inbody?))
((eq? (car ast) 'cond)
(impc:ti:first-transform (impc:ti:cond (cdr ast)) inbody?))
((eq? (car ast) 'cset!)
(list 'closure-set!
(impc:ti:first-transform (cadr ast) inbody?)
(symbol->string (caddr ast))
(impc:ti:first-transform (cadddr ast) inbody?)
(if (not (null? (cddddr ast)))
(impc:ir:get-type-str (impc:ir:convert-from-pretty-types (car (cddddr ast)))))))
((eq? (car ast) 'cref)
(list 'closure-ref
(impc:ti:first-transform (cadr ast) inbody?)
(symbol->string (caddr ast))
(if (not (null? (cdddr ast)))
(impc:ir:get-type-str (impc:ir:convert-from-pretty-types (cadddr ast))))))
((eq? (car ast) 'dotimes)
(list 'dotimes
(impc:ti:first-transform (cadr ast) inbody?)
(cons 'begin (impc:ti:first-transform (cddr ast) inbody?))))
;; ((member (car ast) '(let let* letrec))
;; (cons (impc:ti:first-transform (car ast) inbody?)
;; (cons (impc:ti:first-transform (cadr ast) #f)
;; (list (cons 'begin (impc:ti:first-transform (cddr ast) #t))))))
((member (car ast) '(let let* letrec))
(cons (impc:ti:first-transform (car ast) inbody?)
(cons (map (lambda (p)
(list (impc:ti:first-transform (car p) #f)
(impc:ti:first-transform (cadr p) #f))
)
(cadr ast))
(list (cons 'begin (impc:ti:first-transform (cddr ast) #t))))))
((and (symbol? (car ast)) ;; transform generic like xlist_t*~i8*
(regex:match? (symbol->string (car ast)) "~"))
(list (impc:ti:generic-type-specification (car ast))))
((and (symbol? (car ast))
(regex:match? (symbol->string (car ast)) ".*\\..*"))
(if (regex:match? (symbol->string (car ast)) ".*\\..*:.*")
(let* ((subs (regex:split (symbol->string (car ast)) "\\."))
(a (string->symbol (car subs)))
(subs2 (regex:split (cadr subs) ":"))
(b (string->symbol (car subs2)))
(c (string->symbol (cadr subs2))))
(if (= (length ast) 1)
(impc:ti:first-transform (list 'cref a b c) inbody?)
(impc:ti:first-transform (list 'cset! a b (cadr ast) c) inbody?)))
(let* ((subs (regex:split (symbol->string (car ast)) "\\."))
(a (string->symbol (car subs)))
(b (string->symbol (cadr subs))))
(if (= (length ast) 1)
(impc:ti:first-transform (list 'cref a b) inbody?)
(impc:ti:first-transform (list 'cset! a b (cadr ast)) inbody?)))))
((and (atom? (car ast))
(symbol? (car ast))
(not (eq? 'dotimes (car ast)))
(defined? (car ast))
(macro? (eval (car ast))))
(impc:ti:first-transform (macro-expand ast) 'inbody?))
(else (cons ;(impc:ti:first-transform (car ast) inbody?)
(impc:ti:first-transform (car ast) #t)
;(impc:ti:first-transform (cdr ast) inbody?)))))
(impc:ti:first-transform (cdr ast) #t)))))
(else (cond ((eq? ast #f) '(impc_false))
((eq? ast #t) '(impc_true))
((eq? ast 'cast) 'bitcast)
((eq? ast 'convert) 'bitconvert)
((eq? ast '&) 'bitwise-and)
((eq? ast 'bor) 'bitwise-or) ; can't use a pipe
((eq? ast '^) 'bitwise-eor)
((eq? ast '<<) 'bitwise-shift-left)
((eq? ast '>>) 'bitwise-shift-right)
((eq? ast '~) 'bitwise-not)
((eq? ast 'else) '(impc_true))
((eq? ast 'printf) 'llvm_printf)
((eq? ast 'sprintf) 'llvm_sprintf)
((eq? ast 'null) '(impc_null))
((eq? ast 'now) 'llvm_now)
((eq? ast 'pset!) 'pointer-set!)
((eq? ast 'pref) 'pointer-ref)
((eq? ast 'pref-ptr) 'pointer-ref-ptr)
((eq? ast 'vset!) 'vector-set!)
((eq? ast 'vref) 'vector-ref)
((eq? ast 'aset!) 'array-set!)
((eq? ast 'aref) 'array-ref)
((eq? ast 'aref-ptr) 'array-ref-ptr)
((eq? ast 'tset!) 'tuple-set!)
((eq? ast 'tref) 'tuple-ref)
((eq? ast 'tref-ptr) 'tuple-ref-ptr)
((eq? ast 'salloc) 'stack-alloc)
((eq? ast 'halloc) 'heap-alloc)
((eq? ast 'zalloc) 'zone-alloc)
((eq? ast 'alloc) 'zone-alloc)
((eq? ast 'schedule) 'callback)
((eq? ast 'void) '(void))
(else ast)))))))
;;
;; TYPE INFERENCE CODE
;;
;; request? can be a type - or a symbol if it's a symbol it must be a free variable available in vars
;;
;;
;; is 't' a complex type?
(define impc:ti:complex-type?
(lambda (t)
(if (atom? t) #f
(if (and (number? (car t)) ;; if list starts with a number (i.e. not a symbol)
(<> (car t) *impc:ir:void*) ;; if not void
(> (modulo (car t) *impc:ir:pointer*) 10)) ;; if proper complex type (tuple,array,closure)
#t
#f))))
;; newname mappings is an assoc list
;; containing xlist*##105 -> "xlist--3823948324392" mappings
;; it is reset by llvm:ti:run
(define *impc:ti:generic-type-mappings* '())
(define regex:replace-all
(lambda (str replace with)
(if (regex:match? str replace)
(regex:replace-all (regex:replace str replace with) replace with)
str)))
;; takes a gpolytype (i.e. <!head,xlist*> )
;; and tries to expand on all !bang types ...
;; in other words try to change
;; this <!head,xlist*> into <i64,xlist*>
;; return #f or an expanded
(define impc:ti:reify-generic-type-expand
(lambda (type gnum spec vars)
;; (println 'reifyin: type 'gnum: gnum 'spec: spec)
(for-each (lambda (v)
;;(println 'type: type 'v: v)
(if (and (regex:match? (symbol->string (car v)) "!")
(if (not spec) #t
(regex:match? (symbol->string (car v)) (string-append "%" spec)))
(if (not gnum) #t
(regex:match? (symbol->string (car v)) (string-append "##" gnum)))
(regex:match? type (car (regex:split (symbol->string (car v)) "(##)|(%)")))
(not (null? (cdr v))))
(let* ((t (impc:ti:type-unify (cdr v) vars))
(tl (if (impc:ir:type? t)
(impc:ir:pretty-print-type t)
'())))
(if (not (null? tl))
(set! type (regex:replace-all type (car (regex:split (symbol->string (car v)) "(##)|(%)")) tl))))
#f))
vars)
type))
;; this will basically try to turn xlist*##664 into "%xlist--382948372893247*"
;;
;; 1. try to reify the generic type (vs) using (vars)
;; 2. check against specifications of the polytype that may already exist
;; 3. if 2. exists then return the typename of the specification of the generic type
;; 4. if 2. does not exist then create specific type, add it to type polys and return it
;; 5. if type cannot be unified throw compiler error.
;; (define impc:ti:reify-generic-type
;; (lambda (vs vars all-vs)
;; ;; (println 'gtype: vs 'vars: vars 'allvs: all-vs)
;; (let* ((rsplit1 (regex:split (symbol->string vs) "##")) ;\\$\\$\\$"))
;; (gnum (if (> (length rsplit1) 1) (cadr rsplit1) #f))
;; (rsplit2 (regex:split (car rsplit1) "(%)|(\\*)"))
;; (gpolyname (car rsplit2))
;; (spec (if (> (length rsplit2) 1) (cadr rsplit2) #f))
;; (ptrdepth (impc:ir:get-ptr-depth (car rsplit1)))
;; (t1 (symbol->string (impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type gpolyname))))))
;; ;; (println 't11: t1)
;; ;; attempt to expand any <!head,xlist*> into <i64,xlist*>
;; (set! t1 (impc:ti:reify-generic-type-expand t1 gnum spec vars))
;; (if (string? t1) (set! t1 (string->symbol t1)))
;; ;; (println 't12: t1)
;; ;; if t1 is a valid solid type (i.e. not generic anymore)
;; ;; then we can compile to llvm and return it as a "%xlist--3827439287234"
;; ;;
;; ;; otherwise if t1 is not a valid type then return 'vs' unchanged!
;; (if (impc:ir:type? (impc:ir:get-type-from-pretty-str (regex:replace (symbol->string t1) (string-append gpolyname "([^-][^-])") "$1")))
;; (let* ((t2 (symbol->string t1))
;; (base (impc:ir:get-base-type gpolyname)) ;(symbol->string vs)))
;; (newname (string-append base "--" (number->string (string-hash t2))))
;; (newtype1 (regex:replace t2 (string-append base "([^-][^-])") (string-append newname "$1")))
;; (newtype2 (impc:ti:type-unify (impc:ir:get-type-from-pretty-str newtype1 (apply string-append newname (make-list-with-proc ptrdepth (lambda (kk) "*")))) vars))
;; ;; we should do a type normalize but we CAN'T include newname
;; ;; because we haven't added it to LLVM
;; (newtype3 (impc:ir:get-type-str
;; (map (lambda (ttt)
;; ;;(println 'ttt: ttt)
;; (if (and (string? ttt) (regex:match? ttt newname))
;; ttt
;; (impc:ti:type-normalize ttt)))
;; newtype2))))
;; ;; ok now we have a type we need to add it to llvm and polytype
;; (llvm:compile (string-append "%" newname " = type " newtype3))
;; ;; next we should try to normalize the newtype
;; (let* ((newtype4 (impc:ti:type-normalize (impc:ir:get-type-from-str (apply string-append newtype3 (make-list-with-proc ptrdepth (lambda (kk) "*"))))))
;; (newtype5 (impc:ir:get-type-str newtype4)))
;; ;; (println 'newtype 'vs: vs 'type: newtype4 't1 t1)
;; (impc:ti:update-var vs vars '() newtype4)
;; (impc:ir:add-polytype (string->symbol base) (string->symbol newname) (string->symbol newtype5))
;; newtype6))
;; vs))))
;; this will basically try to turn xlist*##664 into "%xlist--382948372893247*"
;;
;; 1. try to reify the generic type (vs) using (vars)
;; 2. check against specifications of the polytype that may already exist
;; 3. if 2. exists then return the typename of the specification of the generic type
;; 4. if 2. does not exist then create specific type, add it to type polys and return it
;; 5. if type cannot be unified throw compiler error.
(define impc:ti:reify-generic-type
(lambda (vs vars all-vs)
;; (println 'reify: vs)
;; (println 'gtype: vs 'vars: vars 'allvs: all-vs)
(if (and (symbol? vs)
(regex:match? (symbol->string vs) "##")
(not (regex:match? (symbol->string vs) "^!")))
(let* ((rsplit1 (regex:split (symbol->string vs) "##")) ;\\$\\$\\$"))
(gnum (if (> (length rsplit1) 1) (cadr rsplit1) #f))
(rsplit2 (regex:split (car rsplit1) "(%)|(\\*)"))
(gpolyname (car rsplit2))
(spec (if (> (length rsplit2) 1) (cadr rsplit2) #f))
(ptrdepth (impc:ir:get-ptr-depth (car rsplit1)))
(t1 (symbol->string (impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type gpolyname))))))
;; (println 't11: t1)
;; attempt to expand any <!head,xlist*> into <i64,xlist*>
(set! t1 (impc:ti:reify-generic-type-expand t1 gnum spec vars))
(if (string? t1) (set! t1 (string->symbol t1)))
;; (println 't12: t1)
;; (println '-- (impc:ir:get-type-from-pretty-str (regex:replace (symbol->string t1) (string-append gpolyname "([^-][^-])") "$1")))
;; if t1 is a valid solid type (i.e. not generic anymore)
;; then we can compile to llvm and return it as a "%xlist--3827439287234"
;;
;; otherwise if t1 is not a valid type then return 'vs' unchanged!
(if (impc:ir:type? (impc:ir:get-type-from-pretty-str (regex:replace (symbol->string t1) (string-append gpolyname "([^-][^-])") "$1")))
(let* ((t2 (symbol->string t1))
(base (impc:ir:get-base-type gpolyname)) ;(symbol->string vs)))
(newname (string-append base "--" (number->string (string-hash t2))))
(newtype1 (regex:replace t2 (string-append base "([^-][^-])") (string-append newname "$1")))
(newtype2 (impc:ti:type-unify (impc:ir:get-type-from-pretty-str newtype1 (apply string-append newname (make-list-with-proc ptrdepth (lambda (kk) "*")))) vars))
;; we should do a type normalize but we CAN'T include newname
;; because we haven't added it to LLVM
(newtype3 (impc:ir:get-type-str
(map (lambda (ttt)
;;(println 'ttt: ttt)
(if (and (string? ttt) (regex:match? ttt newname))
ttt
(impc:ti:type-normalize ttt)))
newtype2))))
;; ok now we have a type we need to add it to llvm and polytype
(llvm:compile (string-append "%" newname " = type " newtype3))
;; next we should try to normalize the newtype
(let* ((newtype4 (impc:ti:type-normalize (impc:ir:get-type-from-str (apply string-append newtype3 (make-list-with-proc ptrdepth (lambda (kk) "*"))))))
(newtype5 (impc:ir:get-type-str newtype4))
(newtype6 (apply string-append "%" newname (make-list ptrdepth "*"))))
;; (println 'newtype newtype6 'vs: vs 'type: newtype4 't1: t1)
(impc:ti:update-var vs vars '() newtype6) ; newtype4))
(impc:ir:add-polytype (string->symbol base) (string->symbol newname) (string->symbol newtype5))
newtype6))
vs))
vs)))
;; takes types with symbols and expands them
;; using types associated with symbols in vars
;; if a particular var doesn't have a type yet
;; then we try to reverse expand
;; (i.e. look at other closure options that may include type values
;; and assign those values into vars)
;; (define impc:ti:symbol-expand
;; (lambda (vs vars all-vs)
;; ;(println 'symbol-expand: vs) ; 'vars: vars)
;; ;(println 'all-vs: all-vs)
;; (if (atom? vs)
;; (if (symbol? vs)
;; (if (impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type (car (regex:split (car (regex:split (symbol->string vs) "##")) "%"))))) ;"\\$\\$\\$")) "%")))))
;; (impc:ti:symbol-expand-generic-type vs vars all-vs)
;; (if (not (assoc-strcmp vs vars)) ;; if not in vars
;; (if (regex:match? (symbol->string vs) "^![^#]*$") ;; then check to see if symbol is a !gvar
;; vs
;; (print-error 'Compiler 'Error: 'variable 'not 'marked 'as 'free! (symbol->string vs) 'check 'the 'variable 'name 'in 'the 'polytype))
;; ;; check to see a type has been defined
;; ;; otherwise return null
;; (let ((t (cdr (assoc vs vars))))
;; ;; first check to see if the symbol vs has a value
;; (if (null? t) ;; if it doesn't we might need to reverse match!
;; (let* ((positions (map (lambda (x)
;; (println 'xxx: x 'vs: vs)
;; (if (atom? x)
;; (if (and (symbol? x)
;; (regex:match? (symbol->string x) "!"))
;; (print-error 'Compiler 'Error: 'generics 'error: 'this 'closure 'must 'have 'a 'suitable 'generic 'type 'signature)
;; (print-error 'Compiler 'Error: 'severe 'type 'error: 'have 'you 'specified 'an 'incorrect 'type? x))
;; (cl:position vs x)))
;; all-vs))
;; (lllll (println 'positions: positions))
;; (position (cl:find-if number? positions))
;; (values (if position
;; (map (lambda (x)
;; (println 'xyz: x)
;; (list-ref x position))
;; all-vs)
;; '()))
;; (value (cl:find-if impc:ir:type? values)))
;; (println 'hereweare)
;; ;; if we found a value force it into vars
;; (if value (impc:ti:update-var vs vars '() value))
;; ;(if value (impc:ti:force-var vs vars '() value))
;; ;(if value (print-notification 'backward 'assigning value 'to vs))
;; (if (and (not (null? value))
;; value)
;; value
;; vs)) ;; replace with 't' to go back!!
;; t)))) ;; else if symbol does have a value then return it
;; (begin ;(println 'ccc: vs)
;; vs))
;; (cons (impc:ti:symbol-expand (car vs) vars all-vs)
;; (impc:ti:symbol-expand (cdr vs) vars all-vs)))))
;; trys to type unify vs against any other
;; choices available in all-vs
(define impc:ti:symbol-expand-reverse-check
(lambda (vs vars all-vs)
;; (println 'vs vs 'all-vs all-vs 'vars vars)
(impc:ti:type-unify all-vs vars)
;; (println 'vs: vs 'vars: vars)
(if (not (null? (cdr (assoc vs vars))))
(cdr (assoc vs vars))
vs)))
;; takes types with symbols and expands them
;; using types associated with symbols in vars
;; if a particular var doesn't have a type yet
;; then we try to reverse expand
;; (i.e. look at other closure options that may include type values
;; and assign those values into vars)
(define impc:ti:symbol-expand
(lambda (vs vars all-vs)
;(println 'symbol-expand: vs 'allvs: all-vs) ; 'vars: vars)
;(println 'all-vs: all-vs)
(if (atom? vs)
(if (symbol? vs)
(if (impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type (car (regex:split (car (regex:split (symbol->string vs) "##")) "%"))))) ;"\\$\\$\\$")) "%")))))
(impc:ti:reify-generic-type vs vars all-vs)
(if (not (assoc-strcmp vs vars)) ;; if not in vars
(if (regex:match? (symbol->string vs) "^![^#]*$") ;; then check to see if symbol is a !gvar
vs
(print-error 'Compiler 'Error: 'variable 'not 'marked 'as 'free! (symbol->string vs) 'check 'the 'variable 'name 'in 'the 'polytype))
;; check to see a type has been defined
;; otherwise return null
(let ((t (cdr (assoc-strcmp vs vars))))
;; first check to see if the symbol vs has a value
(if (null? t) ;; if it doesn't we might need to reverse match!
(impc:ti:symbol-expand-reverse-check vs vars all-vs)
t))))
(begin ;(println 'ccc: vs)
vs))
(cons (impc:ti:symbol-expand (car vs) vars all-vs)
(impc:ti:symbol-expand (cdr vs) vars all-vs)))))
;; impc:ti:intersection* is cl:intersection for
;; an arbirary number of sets (i.e. args)
;; also handles *impc:ir:other* which we want
;; to match against anything.
(define impc:ti:intersection*
(lambda args
(let loop ((a args)
(res '()))
(if (null? a)
res
(loop (cdr a)
(if (null? res)
(car a)
(if (null? (car a))
res
(cl:intersection (car a) res))))))))
(define impc:ti:complex-unify
(lambda (sym types vars)
;; (println 1 'sym: sym 'types: types)
;; (set! types (map (lambda (x)
;; (if (string? x)
;; (let ((x2 (if (char=? (string-ref x 0) #\%)
;; (substring x 1 (string-length x))
;; x)))
;; (if (llvm:get-named-type (impc:ir:get-base-type x2))
;; (let ((t (llvm:get-named-type (impc:ir:get-base-type x2)))
;; (ptrdepth (impc:ir:get-ptr-depth x2)))
;; ;(set! named-type x)
;; (set! t (apply string-append t (make-list-with-proc ptrdepth (lambda (i) "*"))))
;; (impc:ir:get-type-from-str t))
;; x))
;; x))
;; types))
(set! types (cl:remove-duplicates types))
;; (println 2 'sym: sym 'types: types)
;; this is here to catch any trailing complex types
;; i.e. ((211 2 106) (211 2 106) 211 2 106)
;; we turn them into
;; ((211 2 106) (211 2 106) (211 2 106))
(set! types
(let loop ((lst types))
(if (null? lst) '()
(if (or (list? (car lst))
(string? (car lst)))
(cons (car lst) (loop (cdr lst)))
(list lst)))))
;; (println 3 'sym: sym 'types: types)
(set! types (impc:ti:type-unify types vars))
;; (println 4 'sym: sym 'types: types)
types))
;; this goes through IN ORDER and returns either:
;; NULL if the lists don't match
;; or
(define impc:ti:unify-lists
(lambda args
;(println 'unify: args 'norm: (impc:ti:type-normalize args))
(if (null? args)
args
(let ((lgths (map (lambda (k) (length k)) args)))
(if (not (null? (cl:remove (car lgths) lgths)))
'()
(let ((result
(apply map (lambda args
(let ((l1 (cl:remove '() args)))
(if (null? l1) l1
(let ((l2 (cl:remove-duplicates l1)))
(if (null? l2)
l2
;;(car l2))))))
(if (= 1 (length l2))
(car l2)
'()))))))
args)))
;(println 'result: result)
(if (member '() result)
'()
result)))))))
;; this is here to normalize any recursive tuples
;; i.e. put them in their simplist "named" form
;; you can pass in a a complete list of types
;; at the end and have this normalize them
(define impc:ti:type-normalize
(lambda (t)
;; (println 'type-normalize: t)
(cond ((atom? t) t)
((and (list? t)
(not (null? t))
(number? (car t))
(= *impc:ir:tuple* (modulo (car t) *impc:ir:pointer*)))
;; first check all sub tuples for possible normalization!
(set! t (map (lambda (a) (impc:ti:type-normalize a)) t))
(let ((named-types (cl:remove-if-not string? t)))
(if (null? named-types)
t
(let ((res (map (lambda (k)
;; (println 'k: k)
(let* ((split (regex:split k "%|(--)"))
(gen-type (if (impc:ir:gpolytype-types (cadr split))
(symbol->string (impc:ir:gpolytype-types (cadr split)))
""))
;; (gen-type (symbol->string (impc:ir:gpolytype-types (cadr split))))
(named-type (impc:ir:get-type-from-str (llvm:get-named-type k)))
(domatch? (if (and (list? named-type)
(= (length named-type) (length t)))
#t #f))
(match (if domatch?
(map (lambda (a b)
;; (println 'aa a 'bb b)
(if (equal? a b) #t
(if (and (symbol? a)
(regex:match? gen-type (symbol->string a)))
#t
#f)))
t ;; type coming in
named-type)
(list k))))
(if (member #f match) #f k)))
named-types)))
(set! res (cl:remove-if-not string? res))
(if (null? res)
(impc:ti:type-normalize (cdr t))
(if (car res)
(car res)
t))))))
((pair? t)
(cons (impc:ti:type-normalize (car t))
(impc:ti:type-normalize (cdr t)))))))
;; this function is here to support type-unify
;; in the following way:
;;
;; when going through type-unify it is possible
;; for a situation to arrise where a unification
;; over something like this may occur:
;; (("%list--3834748* (112 !head##829 list*##829"))
;;
;; the result for the unification will be "%list-3834748*"
;; check-to-update-generic-vars is here to do a quick
;; check of the (112 !head##829 list*##829) to update
;; any possible vars (such as !head##829) which could get
;; useful information from the "%list--3834748*" before
;; they get thrown away.
(define impc:ti:check-to-update-generic-vars
(lambda (atom lists vars)
;; (println 'checktoupdategenericvars: atom 'lists lists 'vars: vars)
(let ((atom-type (if (string? atom)
(impc:ir:get-type-from-str (llvm:get-named-type atom))
atom)))
;; (println 'atom: atom 'atom-type atom-type 'lists lists)
(if (list? atom-type)
(map (lambda (e)
;; (println 'type-match: atom-type 'against e)
(if (and (list? e)
(= (length e) (length atom-type)))
(if (and (number? (car e))
(number? (car atom-type))
(= (car e) (car atom-type)))
(map (lambda (a b)
(if (and (symbol? a)
(assoc-strcmp a vars))
(begin ;;(println '__________update-var a 'with b)
(impc:ti:update-var a vars '() b))))
(cdr e)
(cdr atom-type)))))
lists))
#t)))
;; (define impc:ti:type-unify
;; (lambda (t vars)
;; ;; (println 'type-unify: t)
;; (cond ((atom? t)
;; (if (and (symbol? t)
;; (assoc t vars))
;; (impc:ti:type-unify (cdr (assoc t vars)) vars)
;; (if (and (symbol? t)
;; (impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type (car (regex:split (car (regex:split (symbol->string t) "##")) "%"))))))
;; (impc:ti:reify-generic-type t vars '())
;; t)))
;; ((list? t)
;; (cond ((impc:ti:complex-type? t)
;; (map (lambda (v) (impc:ti:type-unify v vars)) t))
;; (else (let* ((trick (impc:ti:type-normalize
;; (map (lambda (v)
;; (impc:ti:type-unify v vars))
;; t)))
;; (typelgth (if (list? (car trick)) (length (car trick)) 1))
;; (atoms (cl:remove-duplicates (cl:remove #f (map (lambda (v) (if (and (atom? v) (not (null? v))) v #f)) trick))))
;; (lists (cl:remove #f (map (lambda (v) (if (list? v) v #f)) trick))))
;; ;; (println)
;; ;; (println 'type: t)
;; ;; (println 'typelgth: typelgth)
;; ;; (println 'trick: trick)
;; ;; (println 'atoms: atoms)
;; ;; (println 'lists: lists)
;; ;; (println)
;; (set! lists (apply impc:ti:unify-lists lists))
;; ;; typelgth helps us to decide if the returned type has
;; ;; been artificially shortened because of unification
;; ;; for example (f (112 2 3) (112 2 3) (112 2 sym))
;; ;; may unify as (112 2) if sym cannot be expanded.
;; ;; this length check basically says we cannot unify
;; ;; succesfully in this instance so return null
;; (if (<> (length lists) typelgth)
;; (set! lists '()))
;; (let ((result (if (null? atoms) lists
;; (if (> (length atoms) 1)
;; (append atoms lists)
;; (if (or (null? lists)
;; (member (car atoms) lists))
;; (car atoms)
;; (append atoms lists))))))
;; ;; if result is a firm type then we
;; (if (impc:ir:type? result)
;; (impc:ti:check-to-update-generic-vars result t vars))
;; result)))))
;; ((pair? t)
;; (impc:ti:type-unify (cdr t) vars))
;; (else (print-error 'Compiler 'Error: 'bad 'type t 'in 'unification)))))
;; this is the old type-unify (but works)
(define impc:ti:type-unify
(lambda (t vars)
;; (println 'type-unify: t)
(cond ((atom? t)
(if (and (symbol? t)
(assoc t vars))
(impc:ti:type-unify (cdr (assoc t vars)) vars)
(if (and (symbol? t)
(impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type (car (regex:split (car (regex:split (symbol->string t) "##")) "%"))))))
(impc:ti:reify-generic-type t vars '())
t)))
((list? t)
(cond ((impc:ti:complex-type? t)
(map (lambda (v) (impc:ti:type-unify v vars)) t))
(else (let* ((trick (impc:ti:type-normalize
(map (lambda (v)
(impc:ti:type-unify v vars))
t)))
(typelgth (if (list? (car trick)) (length (car trick)) 1))
(atoms (cl:remove-duplicates (cl:remove #f (map (lambda (v) (if (and (atom? v) (not (null? v))) v #f)) trick))))
(lists (cl:remove #f (map (lambda (v) (if (list? v) v #f)) trick))))
(set! lists (apply impc:ti:unify-lists lists))
;; (println)
;; (println 'type: t)
;; (println 'typelgth: typelgth)
;; (println 'trick: trick)
;; (println 'atoms: atoms)
;; (println 'lists: lists)
;; (println)
;; typelgth helps us to decide if the returned type has
;; been artificially shortened because of unification
;; for example (f (112 2 3) (112 2 3) (112 2 sym))
;; may unify as (112 2) if sym cannot be expanded.
;; this length check basically says we cannot unify
;; succesfully in this instance so return null
(if (<> (length lists) typelgth)
(set! lists '()))
(let ((result (if (null? atoms) lists
(if (> (length atoms) 1)
(append atoms lists)
(if (or (null? lists)
(member (car atoms) lists))
(car atoms)
(append atoms lists))))))
;; if result is a firm type then we
(if (impc:ir:type? result)
(impc:ti:check-to-update-generic-vars result t vars))
;; (println 'type: t 'result: result 'vars: vars)
result)))))
((pair? t)
(impc:ti:type-unify (cdr t) vars))
(else (print-error 'Compiler 'Error: 'bad 'type t 'in 'unification)))))
;; this is the new type unify (but doesn't work)
;;
;; IF TYPE CANNOT BE UNIFIED SUCCESSFULLY THEN WE SHOULD RETURN NULL '()
;; i.e. if we have ((114 0 0) (14 0 0)) don't return this -> return '()
;;
(define impc:ti:type-unify
(lambda (t vars)
;; (println 'type-unify: t)
(cond ((atom? t)
(if (and (symbol? t)
(assoc t vars))
(let ((r (impc:ti:type-unify (cdr (assoc t vars)) vars)))
(if (null? r) t r)) ;; if r is NULL or false return t
(if (and (symbol? t)
(impc:ir:gpolytype-types (string->symbol (impc:ir:get-base-type (car (regex:split (car (regex:split (symbol->string t) "##")) "%"))))))
(impc:ti:reify-generic-type t vars '())
t)))
((list? t)
(cond ((impc:ti:complex-type? t)
;; (println 'aaa: t)
(map (lambda (v) (impc:ti:type-unify v vars)) t))
((= (length t) 1)
;; (println 'bbb: t)
(impc:ti:type-unify (car t) vars))
(else (let* ((ts (impc:ti:type-normalize
(map (lambda (v)
(let ((vvv (impc:ti:type-unify v vars)))
;; (println 'vvv: vvv)
(impc:ti:type-clean vvv)))
t)))
(ts2 (cl:remove-duplicates ts))
(result ts2))
;; (println 1 t 'unified: result)
;; first check result to see if we have a valid named-type (i.e. "%string")
(if (and (= (length result) 2) ;; find all occurences of ((112 0 1) "%string--38293482")
(cl:find-if string? result)
(cl:find-if (lambda (k) (not (string? k))) result))
(set! result (list (cl:find-if string? result))))
;; (println 2 t 'unified: result)
;; this is here for cases like
;; (!head%a##287 0 1) ;; which should resolve to (0 1) if !head%a##287 has no type
(if (and (not (cl:find-if impc:ti:complex-type? result))
(not (cl:find-if string? result))
(cl:find-if symbol? result))
(set! result (cl:remove-if symbol? result)))
;; (println 3 t 'unified: result)
;; next check to see if we need to do some number crunching
;; basically checking to solve things like
;; ((0 1) 1) which should resolve to 1
;; (0 (0 1) (0 1 2)) which should resolve to 0
;; ((0 1) (0 1 2)) sould resolve to (0 1 2)
(if (and (cl:find-if list? result)
(not (cl:find-if impc:ti:complex-type? result)))
(let ((non-choices (cl:remove-duplicates (cl:remove-if list? result)))
(choices (cl:remove-duplicates (flatten (cl:remove-if atom? ts2)))))
;; (println 'non-choices: non-choices)
(if (and (= (length non-choices) 1)
(member (car non-choices) choices))
(set! result (car non-choices))
(set! result (cl:remove-duplicates (flatten result))))))
;; (println 4 t 'unified: result)
;; if there is a choice between resolved types and unresolved types
;; then obviously we should choose resolved types!
(if (list? result)
(let ((resolved (cl:remove-duplicates
(cl:remove-if-not (lambda (k)
(if (and (impc:ir:type? k)
(impc:ti:complex-type? k))
#t #f))
result))))
(if (not (null? resolved))
;; (set! result (car resolved)))))
(set! result resolved))))
;; (println 5 t 'unified: result)
;; finally return type (and do generic update check)
(if (and (not (number? result))
(not (null? result))
(not (impc:ir:type? result))
(list? result)
(or (impc:ir:closure? (car result))
(impc:ir:tuple? (car result))))
(begin (impc:ti:check-to-update-generic-vars (car result) t vars)
(car result)) ;; result is a proper tuple or closure
(if (and (list? result)
(not (null? result))
(= (length result) 1))
(car result) ;; if result only has 1 element then return that
(if (or (impc:ir:type? result) ;; either result is a propert type
(not (cl:find-if (lambda (k) (not (number? k))) result))) ;; or list of number '(0 1 2 3) for example
result ;; if list is either a propert type OR a list of numeric types (i.e. '(0 1 2))
'()))))))) ;; if we still have mixed choice of complex types then return NULL
((pair? t)
(impc:ti:type-unify (cdr t) vars))
(else (print-error 'Compiler 'Error: 'bad 'type t 'in 'unification)))))
(define impc:ti:generic-type-details
(lambda (a)
(if (and (symbol? a)
(regex:match? (symbol->string a) "##"))
(let* ((gname (car (regex:split (symbol->string a) "##")))
(gnum (string->number (cadr (regex:split (symbol->string a) "##"))))
(basename (impc:ir:get-base-type gname))
(gchar (cdr (regex:split basename "%")))
(gname2 (car (regex:split basename "%")))
(gpt (impc:ir:gpolytype-types gname2)))
(if gpt
(list (string->symbol gname2) gnum (if (null? gchar) "" (car gchar)) (impc:ir:get-type-from-pretty-str (symbol->string gpt)))
(list (string->symbol gname2) gnum (if (null? gchar) "" (car gchar)) '())))
#f)))
;; try to find a type for a !bang from a reified type
;;
;; example use is in impc:ti:sym-unify
(define impc:ti:check-bang-against-reified
(lambda (bang-sym reified-sym vars)
(let ((r (assoc-strcmp reified-sym vars)))
(if (null? r)
#f
(let* ((gtd (impc:ti:generic-type-details reified-sym))
(gtd2 (impc:ti:generic-type-details bang-sym))
(type (cdr r))
(gtype (cadddr gtd))
(pos (cl:position (car gtd2) gtype)))
(if (and type pos (list? (car type)) (> (length (car type)) pos))
(let ((val (list-ref (car type) pos)))
val)
#f))))))
(define impc:ti:sym-unify
(lambda (sym types vars)
;; if sym is a !bang symbol and has no type set
;; then we trawl through vars looking for reified
;; types which we might be able to match it against.
(if (and (null? types)
(regex:match? (symbol->string sym) "^!"))
(let ((gtd (impc:ti:generic-type-details sym)))
(map (lambda (k)
(if (and (not (null? (cdr k)))
(impc:ir:type? (cadr k)))
(let ((gtd2 (impc:ti:generic-type-details (car k))))
(if (and gtd2 (= (cadr gtd) (cadr gtd2)))
(let ((val (impc:ti:check-bang-against-reified sym (car k) vars)))
(if val
(begin (println 'update sym 'with-> val)
(impc:ti:update-var sym vars '() val))))))))
vars)))
;; (if (not (cl:find-if list? types))
;; (begin (set! types (cl:remove-duplicates types)) ;; first normalize and check for duplicates
;; (if (= (length types) 1)
;; (car types) ;; if only 1 element in list return as atom
;; (impc:ti:complex-unify types types vars)))
;; (impc:ti:complex-unify sym types vars))))
(let ((result (impc:ti:complex-unify sym types vars)))
;; (println 'sym: sym 't: types 'result result 'vars: vars)
(if (and (list? result)
(= (length result) 1))
(car result)
(impc:ti:type-clean result)))))
;; unify is a little bit ugly
;; 1st it expands all symbols - during this process vars can be modified (force-var, update-var)
;; 2nd because var can change we check result against var to see if any change to var has improved things
;; 3rd because step 2 may have made changes for the better we should do a final symbol check
;; basically means going through the final result list to see if any symbols left in complex
;; types can be given types.
(define impc:ti:unify
(lambda (vars)
;; (println 'unifyvars: vars)
(let ((result (map (lambda (v)
;(println 'unify-v: v)
(let* ((sym (car v))
;(kkkkkk (println 'sym sym))
;; expand any symbols and do reverse symbol checks
(types-expanded (map (lambda (t)
;; first CLEAN the type (remove extraneous lists)
(set! t (impc:ti:type-clean t))
(if (or (symbol? t)
(list? t))
(let ((res (impc:ti:symbol-expand t vars (cdr v))))
(set! res (impc:ti:type-clean res))
res)
t))
(cdr v)))
;; (kkkkkkkk (println 'unify-v-expanded: v 'expanded: types-expanded))
(types-unified (impc:ti:sym-unify sym types-expanded vars)))
;; (println 'sym_____: v)
;; (println 'expanded: types-expanded)
;; (println 'unified_: types-unified)
;; (println 'vars____: vars)
;; (println 'types-unified: types-unified)
;; (println 'un-expanded (cdr v))
;; (println 'un-unified types-expanded)
;; (println 'unified types-unified)
;; (println 'vdone: v)
(cons sym types-unified)))
vars)))
;; a final comparison between vars and result
;; this is because things in VAR may well have changed
;;
;; anything in result that is NULL will hopefully
;; have a value in vars that we can use
(let ((result2 (map (lambda (a b)
(if (null? (cdr a))
(if (not (null? (cdr b)))
(cons (car a) (cdr b))
a)
a))
result
vars)))
;; (println 'result: result)
;; (println 'vars: vars)
;; (println 'result2: result2)
;; and return result
result2))))
;; unify is a little bit ugly
;; 1st it expands all symbols - during this process vars can be modified (force-var, update-var)
;; 2nd because var can change we check result against var to see if any change to var has improved things
;; 3rd because step 2 may have made changes for the better we should do a final symbol check
;; basically means going through the final result list to see if any symbols left in complex
;; types can be given types.
;; (define impc:ti:unify
;; (lambda (vars)
;; ;; (println 'unifyvars: vars)
;; (let ((result (map (lambda (v)
;; (println 'unify-v: v)
;; (if (null? (cdr v))
;; (if (regex:match? (symbol->string (car v)) "^!")
;; (let* ((sym (car v))
;; (types-expanded (map (lambda (t)
;; ;; first CLEAN the type (remove extraneous lists)
;; (set! t (impc:ti:type-clean t))
;; (if (or (symbol? t)
;; (list? t))
;; (let ((res (impc:ti:symbol-expand t vars (cdr v))))
;; (set! res (impc:ti:type-clean res))
;; res)
;; t))
;; (cdr v)))
;; ;; (kkkkkkkk (println 'unify-v-expanded: v 'expanded: types-expanded))
;; (types-unified (impc:ti:sym-unify sym types-expanded vars)))
;; (cons sym types-unified))))
;; vars)))
;; ;; a final comparison between vars and result
;; ;; this is because things in VAR may well have changed
;; ;;
;; ;; anything in result that is NULL will hopefully
;; ;; have a value in vars that we can use
;; (let ((result2 (map (lambda (a b)
;; (if (null? (cdr a))
;; (if (not (null? (cdr b)))
;; (cons (car a) (cdr b))
;; a)
;; a))
;; result
;; vars)))
;; ;; and return result
;; result2))))
;; checks to see if a type system is completely unified
(define impc:ti:unity?
(lambda (vars)
(map (lambda (x)
(if (impc:ir:type? (cdr x)) #t #f))
vars)))
;; join elements into a list (without including nulls)
(define impc:ti:join
(lambda args
(cl:remove-if null? args)))
;; this function removes any uneccessary lists
;; it just checks for lists of 1 element and
;; extracts the atom from the list
;;
;; i.e. (211 (2) (211 3 3) (xlist*##123)) should be
;; (211 2 (211 3 3) xlist*##123)
(define impc:ti:type-clean
(lambda (type)
(if (or (null? type)
(not (list? type)))
type
(if (and (list? type)
(list? (car type)))
(list (impc:ti:type-clean (car type)))
(map (lambda (k)
(if (list? k)
(if (= (length k) 1)
(car k)
k)
k))
type)))))
;; don't allow update to add to kts values
(define impc:ti:update-var
(lambda (sym vars kts t)
;;
;; clean type
;; i.e. change (211 4 (0) (1) 0)) -> (211 4 0 1 0)
;;
(set! t (impc:ti:type-clean t))
;; (if (regex:match? (symbol->string sym) "v4")
;; (println 'sym sym 't: t))
;; don't ever add oursevles (i.e. sym) as a type arg or NULL
(if (or (null? t)
(and (list? t)
(equal? sym (car t)))
(equal? sym t))
'exit
(begin ;; (println 'update-var:> sym 'in: vars 'with: t 'kts: kts)
(if (member sym kts) ;; if in known types don't do anything
'()
(if (and (not (assoc sym vars))
(not (llvm:get-function (symbol->string sym)))
(not (llvm:get-globalvar (symbol->string sym))))
(print-error 'Compiler 'Error: 'var (symbol->string sym) 'does 'not 'exist)
(let ((pair (assoc sym vars)))
(if pair
(let ((pair-rest (cdr pair)))
;; (if (not (null? pair-rest))
;; (if (or (impc:ir:tuple? (car pair-rest))
;; (impc:ir:closure? (car pair-rest))
;; (impc:ir:array? (car pair-rest))
;; (impc:ir:vector? (car pair-rest)))
;; (set! pair-rest (list pair-rest))))
(if (impc:ir:type? t)
(begin ;; uncomment the following lines to do reverse bang tests
;; (if (and (string? t) ;; if a named type
;; (regex:match? (symbol->string sym) "##"))
;; (let ((gtd (impc:ti:generic-type-details sym)))
;; (impc:ti:reverse-set-bangs-from-reified sym t (cadr gtd) vars)))
(set-cdr! pair (cl:remove-duplicates (append (list t) pair-rest)))
)
(set-cdr! pair (cl:remove-duplicates (append t pair-rest))))))
'())))))))
;; force a var to a particular type
;; (i.e. wipe out other choices)
;;
;; do allow force-var to overwrite kts values
(define impc:ti:force-var
(lambda (sym vars kts t)
(set! t (impc:ti:type-clean t))
;(if (equal? sym 'length) (begin (println '-> 'forcing 'length t))) ; (error)))
;(if (equal? sym 'l) (println '-> 'forcing 'l t))
;(println 'force-var:> sym 'in: vars 'with: t 'kts: kts)
(if (and (not (assoc sym vars))
(not (llvm:get-globalvar (symbol->string sym))))
(print-error 'Compiler 'Error: 'var (symbol->string sym) 'does 'not 'exist)
(let ((pair (assoc sym vars)))
(if pair
(if (impc:ir:type? t)
(begin ;; uncomment the following lines to do reverse bang tests
;; (if (and (string? t) ;; if a named type
;; (regex:match? (symbol->string sym) "##"))
;; (let ((gtd (impc:ti:generic-type-details sym)))
;; (impc:ti:reverse-set-bangs-from-reified sym t (cadr gtd) vars)))
(set-cdr! pair (list t)))
(set-cdr! pair t))
'())))))
(define impc:ti:get-var
(lambda (sym vars)
(if (not (assoc sym vars))
(print-error 'Compiler 'Error: 'var (symbol->string sym) 'does 'not 'exist)
(assoc sym vars))))
(define impc:ti:get-var
(lambda (sym vars)
(if (not (assoc sym vars))
(if (llvm:get-global-variable-type (symbol->string sym))
(cons sym (- (impc:ir:get-type-from-str (llvm:get-global-variable-type (symbol->string sym)))
*impc:ir:pointer*))
(print-error 'Compiler 'Error: 'var (symbol->string sym) 'does 'not 'exist))
(assoc sym vars))))
;; clear all vars
(define impc:ti:clear-all-vars
(lambda (vars)
(map (lambda (x)
(set-cdr! x '()))
vars)))
;; resolve "string" types by looking up get-named-type
;; resolve 'symbol types by looking in vars
;; otherwise just return t
(define impc:ti:try-to-resolve-named-types
(lambda (t vars)
;; check for named types
(if (string? t)
(let ((t (impc:ir:get-type-from-str (llvm:get-named-type (impc:ir:clean-named-type t))))
(ptr-level (impc:ir:get-ptr-depth t)))
(dotimes (i ptr-level) (set! t (impc:ir:pointer++ t)))
(list t))
(if (symbol? t)
(if (null? (assoc t vars))
'()
(cdr (assoc t vars)))
t))))
(define impc:ti:numeric-check
(lambda (ast vars kts request?)
;; (println 'ast: ast 'request? request?)
(if *impc:ti:print-sub-checks* (println 'num:> 'ast: ast 'request? request?))
(if (and request?
(not (null? request?)))
(cond ((symbol? request?)
(let* ((t1 (impc:ti:symbol-check request? vars kts #f))
(t2 (impc:ti:numeric-check ast vars kts #f))
(t3 (cl:intersection t1 t2)))
(if (null? t1) t2 t3)))
((list? request?)
(let* ((t1 (impc:ti:numeric-check ast vars kts #f))
(t2 (cl:intersection request? t1)))
t2))
((number? request?)
(let* ((t1 (impc:ti:numeric-check ast vars kts #f))
(t2 (cl:intersection (list request?) t1)))
t2))
((string? request?)
(let* ((t1 (impc:ti:numeric-check ast vars kts #f))
(t2 (cl:intersection (list request?) t1)))
t2))
(else (print-error 'Compiler 'Error: 'shouldn't 'reach 'here 'in 'numeric 'check 'request? request?)
(print-error '-> 'You 'might 'be 'using 'a 'pref 'where 'you 'should 'be 'using 'a 'tref?)))
(if (integer? ast) ;; preference goes to start of list
(if (or (= 1 ast) (= 0 ast))
(list *impc:ir:si64* *impc:ir:si32* *impc:ir:ui8* *impc:ir:i1*)
(if (< ast 256)
(list *impc:ir:si64* *impc:ir:si32* *impc:ir:ui8*)
(list *impc:ir:si64* *impc:ir:si32*))) ;*impc:ir:double* *impc:ir:float*))
(list *impc:ir:double* *impc:ir:float*)))))
;; IS NEW
(define impc:ti:symbol-check
(lambda (ast vars kts request?)
(if (not (symbol? ast)) (print-error 'Tyring 'to 'symbol 'check 'a 'non-symbol: ast))
;; (println 'symbolcheck 'ast: ast 'vars: vars 'request: request?)
;; if we get a generic function here it means that someone
;; is trying to pass it as a value (which is illegal!)
(if (and (symbol? ast)
(impc:ir:gpoly-types (string->symbol (impc:ir:get-base-type (symbol->string ast)))))
;; (regex:match? (symbol->string ast) "##")
;; (not (regex:match? (symbol->string ast) "!")))
(print-error 'Compiler 'Error: 'trying 'to 'use 'generic 'function 'as 'value: ast))
(if *impc:ti:print-sub-checks* (println 'sym:> 'ast: ast 'request? request?))
;; if a request is made - assume it's forced
;; find the intersection between the request
;; and the current values and force that intersection
(if (and (not (assoc-strcmp ast vars))
(not (llvm:get-function (symbol->string ast)))
(not (llvm:get-globalvar (symbol->string ast))))
(print-error 'Compiler 'Error: 'unbound 'symbol: ast))
(let ((type (if (assoc ast vars)
(cdr (assoc ast vars))
(if (llvm:get-function (symbol->string ast))
(list (cons (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (map impc:ir:get-type-from-str (llvm:get-function-args-withoutzone (symbol->string ast)))))
(list (impc:ir:pointer-- (impc:ir:get-type-from-str (llvm:get-global-variable-type (symbol->string ast)))))))))
;; (println 'sym: ast 'type: type 'kts: kts 'request? request?)
(if (and request?
(not (member ast kts)) ;; if we're in KTS then we should ignore requests!
(not (null? request?)))
;; (let ((intersection (cl:intersection (if (null? type) ;; if type is null then force request
;; (if (atom? request?) (list request?) request?)
;; (if (atom? type) (list type) type))
;; ;; if request is not a set make it one
;; (if (atom? request?) (list request?) request?))))
(if (null? type)
(begin
(impc:ti:update-var ast vars kts (list request?))
request?)
(let ((intersection (impc:ti:type-unify (list request? type) vars)))
;(println 'intersection intersection 'request? request? 'type: type)
(if (not (null? intersection))
(begin ;; (println 'bing ast 'request? request? 'type: type 'intersection: intersection)
;; (println vars)
(impc:ti:update-var ast vars kts (list intersection))
(list intersection))
type)))
type))))
(define impc:ti:math-check
(lambda (ast vars kts request?)
(let* ((a (impc:ti:type-unify (impc:ti:type-check (cadr ast) vars kts request?) vars))
(b (impc:ti:type-unify (impc:ti:type-check (caddr ast) vars kts request?) vars))
(t (impc:ti:type-unify (list a b) vars)))
;; (println 'math: a b 't: t 'request? request? 'ast: ast 'vars: vars)
(if *impc:ti:print-sub-checks* (println 'math:> 'ast: ast 'a: a 'b: b 't: t 'request? request?))
(if (not (null? t))
(begin (if (symbol? (cadr ast)) (impc:ti:force-var (cadr ast) vars kts t))
(if (symbol? (caddr ast)) (impc:ti:force-var (caddr ast) vars kts t))
(if (and (not (null? t)) ;; this here because math functions always return non-pointer vectors
(impc:ir:vector? t) ;; we want to do this because these vectors are always stack allocated
(impc:ir:pointer? t)) ;; also these vectors are immutable (i.e. cannot use vector-set!)
(impc:ir:pointer-- t)
t))
(cond ((impc:ir:vector? a)
(if (symbol? (cadr ast)) (impc:ti:update-var (cadr ast) vars kts a))
(if (impc:ir:pointer? a) (impc:ir:pointer-- a) a))
((impc:ir:vector? b)
(if (symbol? (caddr ast)) (impc:ti:update-var (cadr ast) vars kts b))
(if (impc:ir:pointer? b) (impc:ir:pointer-- b) b))
((not (cl:find-if symbol? (cdr ast))) t) ;; return t
((and (symbol? (cadr ast))
(symbol? (caddr ast))
(not (null? (cdr (impc:ti:get-var (cadr ast) vars))))
(not (null? (cdr (impc:ti:get-var (caddr ast) vars)))))
;; if both are symbols and their types cannot unify on anything
;; then we have a problem! So force both types to NULL
(impc:ti:force-var (cadr ast) vars kts '())
(impc:ti:force-var (caddr ast) vars kts '())
t) ;; and return t (which should be NULL)
((and (symbol? (cadr ast)) (not (null? b)))
(impc:ti:update-var (cadr ast) vars kts b) b) ;; return b
((and (symbol? (caddr ast)) (not (null? a)))
(impc:ti:update-var (caddr ast) vars kts a) a) ;; return a
(else t))))))
(define impc:ti:compare-check
(lambda (ast vars kts request?)
(let* ((n1 (if (number? (cadr ast)) (caddr ast) (cadr ast)))
(n2 (if (number? (cadr ast)) (cadr ast) (caddr ast)))
(a (impc:ti:type-unify (impc:ti:type-check n1 vars kts request?) vars))
(b (impc:ti:type-unify (impc:ti:type-check n2 vars kts request?) vars))
(t (impc:ti:type-unify (list a b) vars)))
;; (println 'a a 'b b 't t)
(if *impc:ti:print-sub-checks* (println 'compare:> 'ast: ast 'a: a 'b: b 't: t 'request? request?))
(if (not (null? t))
(begin (if (symbol? (cadr ast)) (impc:ti:force-var (cadr ast) vars kts t))
(if (symbol? (caddr ast)) (impc:ti:force-var (caddr ast) vars kts t))
(if (and (not (null? t))
(impc:ir:vector? t))
(if (impc:ir:pointer? t)
(list (- (car t) *impc:ir:pointer*) (cadr t) *impc:ir:i1*)
(list (car t) (cadr t) *impc:ir:i1*))
(list *impc:ir:i1*)))
(cond ((impc:ir:vector? a)
(if (symbol? (cadr ast)) (impc:ti:update-var (cadr ast) vars kts a))
(let ((retvec (if (impc:ir:pointer? a) (impc:ir:pointer-- a) a)))
(list (car retvec) (cadr retvec) *impc:ir:i1*)))
((impc:ir:vector? b)
(if (symbol? (caddr ast)) (impc:ti:update-var (cadr ast) vars kts b))
(let ((retvec (if (impc:ir:pointer? b) (impc:ir:pointer-- b) b)))
(list (car retvec) (cadr retvec) *impc:ir:i1*)))
((not (cl:find-if symbol? (cdr ast))) (list *impc:ir:i1*)) ;; return t
((and (symbol? n1)
(symbol? n2)
(not (null? (cdr (impc:ti:get-var n1 vars))))
(not (null? (cdr (impc:ti:get-var n2 vars)))))
;; if both are symbols and their types cannot unify on anything
;; then we have a problem! So force both types to NULL
(impc:ti:force-var n1 vars kts '())
(impc:ti:force-var n2 vars kts '())
(list *impc:ir:i1*)) ;; and return t (which should be NULL)
((and (symbol? n1) (not (null? b)))
(impc:ti:update-var n1 vars kts b)
(list *impc:ir:i1*)) ;; return b
((and (symbol? n2) (not (null? a)))
(impc:ti:update-var n2 vars kts a)
(list *impc:ir:i1*)) ;; return a
(else (list *impc:ir:i1*)))))))
(define impc:ti:nativef-check
(lambda (ast vars kts request?)
;; (println 'type-checking: (car ast))
;(println 'native-check 'ast: ast 'vars: vars 'request: request?)
(let ((ftype (map impc:ir:get-type-from-str
(llvm:get-function-args-withoutzone (symbol->string (car ast))))))
;(println 'ftype:> 'ast: ast 'type: ftype)
(if *impc:ti:print-sub-checks* (println 'ftype:> 'ast: ast 'type: ftype))
(if (<> (length ftype)
(length ast))
(print-error 'Compiler 'Error: 'bad 'arity 'in 'call ast))
;; we don't care what we get back because we already know the return type
(for-each (lambda (a t)
;; if a is a symbol then add type t to a
;; we also know that for native functions there
;; is no choice about the type so we should
;; force it to the type not update it
;(if (symbol? a) (impc:ti:force-var a vars kts t))
(if (symbol? a) (impc:ti:update-var a vars kts t))
(impc:ti:type-check a vars kts t))
(cdr ast)
(cdr ftype))
(list (car ftype)))))
;; type inferencing for generic functions arguments
(define impc:ti:nativef-generics-check-args
(lambda (ast gpoly-type vars kts request?)
;; (println 'generic-check-args 'ast: ast)
;; (println '____ast: ast)
;; (println 'generic: gpoly-type)
;; type inferencing for generic functions arguments
(map (lambda (a gt)
;; (println 'arg-in: a 'gt: gt)
;;(println 'avars: (assoc a vars))
;; gt for generics type
(let ((tt (impc:ti:type-check a vars kts gt))
(subcheck #t))
;; (println 'arg-in: a 'gt: gt 'tt: tt)
;; (println 'vars: vars)
;; generics are unforgiving to choice
;; so if we have number choice then
;; let's always force i64 or double
(if (or (equal? tt '(2 4))
(equal? tt '(2 4 7))
(equal? tt '(2 4 7 8)))
(set! tt '(2)))
(if (equal? tt '(0 1))
(set! tt '(0)))
;; (println 1 'a: a 'tt: tt 'gt: gt)
(if (and (list? tt) (= (length tt) 1)) (set! tt (car tt)))
(if (and (atom? gt)
(symbol? gt)
(assoc-strcmp gt vars))
;; (regex:match? (symbol->string gt) "!"))
(begin ;; (println 'matched-polytype-1: gt '-> tt)
(if (symbol? tt)
(if (null? (cdr (assoc-strcmp tt vars)))
(impc:ti:update-var gt vars kts (list tt))
(begin
;; (println gt '-> (impc:ti:type-unify (cdr (assoc tt vars)) vars))
;; (set! tt (impc:ti:type-unify (cdr (assoc-strcmp tt vars)) vars))
;;(impc:ti:update-var gt vars kts tt)))
(impc:ti:update-var gt vars kts (impc:ti:type-unify (cdr (assoc-strcmp tt vars)) vars))))
(impc:ti:update-var gt vars kts (impc:ti:type-unify tt vars)))))
;; (if (and (atom? gt)
;; (symbol? gt)
;; (assoc-strcmp gt vars))
;; ;; (regex:match? (symbol->string gt) "!"))
;; (begin (println 'matched-polytype-1: gt '-> tt)
;; (if (symbol? tt)
;; (if (null? (cdr (assoc-strcmp tt vars)))
;; (impc:ti:update-var gt vars kts (list tt))
;; (impc:ti:update-var gt vars kts t))
;; (impc:ti:update-var gt vars kts (impc:ti:type-unify tt vars)))))
(if (atom? tt)
(set! tt (list tt)))
(if (and (list? tt)
(list? (car tt))
(not (atom? gt)))
(set! tt (car tt)))
(if (atom? gt)
(set! gt (list gt)))
;(println 2 'a: a 'tt: tt 'gt: gt)
;; if gt and tt still not equal tt maybe a named-type
(if (<> (length gt) (length tt))
(if (and (string? (car tt)) ;; named type?
(= (length gt) (length (impc:ir:get-type-from-str (llvm:get-named-type (car tt))))))
(set! tt (impc:ir:get-type-from-str (llvm:get-named-type (car tt))))
(set! subcheck #f)))
;;(print-error 'Compiler 'Error: 'type 'mismatch 'in 'generics gt '- tt)))
;; GCHANGE
;; we might be able to update-vars based by matching our request 'gt vs our result 'tt
(if subcheck
(for-each
(lambda (aa bb)
;;(println 'matched-polytype-2: aa '-> bb)
(if (and (atom? aa)
(symbol? aa)
(assoc-strcmp aa vars))
(if (and (symbol? bb) (assoc-strcmp bb vars))
(begin
;(set! tt (impc:ti:type-unify (cdr (assoc-strcmp bb vars)) vars))
;(impc:ti:update-var aa vars kts tt))
(impc:ti:update-var aa vars kts (cdr (assoc-strcmp bb vars))))
(if (string? bb)
(impc:ti:update-var aa vars kts bb)
(impc:ti:update-var aa vars kts (list bb))))))
gt tt))
;; (println 'a: a 'tt: tt)
;; (if (and (not (impc:ir:type? tt))
;; (symbol? a))
;; (begin (println 'setting 'tt '-> a)
;; (set! tt a)))
;; (println 'arg-out: a 'tt: tt 'vars: vars)
;; (print)
tt))
(cdr ast)
(cddr gpoly-type))))
;; adds ##gnum's to all poly types
(define impc:ti:nativef-generics-make-gtypes-unique
(lambda (pt gnum)
(cond ((null? pt) '())
((symbol? pt)
;; (println 'bingo pt)
(cond ((regex:match? (symbol->string pt) "!") ;; check for !head and !head%b
(let ((kk (string->symbol (string-append (symbol->string pt) "##" (number->string gnum)))))
;; (println 'pt: pt 'kk: kk)
kk))
;; check for xlist*
((assoc (string->symbol (impc:ir:get-base-type (symbol->string pt))) *impc:ir:gpolytypes*)
(let ((kk (string->symbol (string-append (symbol->string pt) "##" (number->string gnum)))))
;; (println 'pt: pt 'kk: kk)
kk))
;; check for xlist%b*
((and (regex:match? (symbol->string pt) "%") ;; check for
(assoc (string->symbol (impc:ir:get-base-type (car (regex:split (symbol->string pt) "%")))) *impc:ir:gpolytypes*))
(let ((kk (string->symbol (string-append (symbol->string pt) "##" (number->string gnum)))))
;; (println 'pt: pt 'kk: kk)
kk))
(else
;; (println 'pt: pt 'kk: pt)
pt)))
((pair? pt)
(cons (impc:ti:nativef-generics-make-gtypes-unique (car pt) gnum)
(impc:ti:nativef-generics-make-gtypes-unique (cdr pt) gnum)))
(else pt))))
;; returns details of a generic type
(define impc:ti:generic-type-details
(lambda (a)
(if (and (symbol? a)
(regex:match? (symbol->string a) "##"))
(let* ((gname (car (regex:split (symbol->string a) "##")))
(gnum (string->number (cadr (regex:split (symbol->string a) "##"))))
(basename (impc:ir:get-base-type gname))
(gchar (cdr (regex:split basename "%")))
(gname2 (car (regex:split basename "%")))
(gpt (impc:ir:gpolytype-types gname2)))
(if gpt
(list (string->symbol gname2) gnum (if (null? gchar) "" (car gchar)) (impc:ir:get-type-from-pretty-str (symbol->string gpt)))
(list (string->symbol gname2) gnum (if (null? gchar) "" (car gchar)) '())))
#f)))
;; this attempts to update-var !bangs from reified types
;; i.e. if we have allready resolved xlist*##289 to %xlist--2812497382948
;; but we have failed to resolve !head##289
;; then we try to get back from %xlist--2812497382948 to set !head##289
;; (define impc:ti:reverse-set-bangs-from-reified
;; (lambda (poly reified gnum vars)
;; (println 'poly poly 'reified reified 'gnum: gnum)
;; (if (regex:match? (symbol->string poly) "^!")
;; 'done ;; we can only check reified if poly IS a list not a reference to a list (which happens with !)
;; (let* ((t (impc:ir:get-named-type reified))
;; (ptrdepth (impc:ir:get-ptr-depth t))
;; (gtd (impc:ti:generic-type-details poly))
;; (tt (impc:ir:gpolytype-types (car gtd)))
;; ;; (m1 (cl:remove-if (lambda (k) (or (string=? k "*")
;; ;; (string=? k "")))
;; ;; (regex:split t "(,)|({)|(})|(\\s)")))
;; (m1 (impc:ir:get-type-from-str t))
;; ;; (m2 (cl:remove-if (lambda (k)
;; ;; (or (string=? k "*")
;; ;; (string=? k "")))
;; ;; (regex:split (symbol->string tt) "(,)|(<)|(>)")))
;; (m2 (impc:ir:get-type-from-pretty-str (apply string-append (symbol->string tt) (make-list ptrdepth "*")))))
;; (println 'bangmatch: poly '-> reified)
;; (println 't_: t)
;; (println 'tt: tt)
;; (println 'm1: m1)
;; (println 'm2: m2)
;; (println 'vars: vars)
;; (if (= (length m1) (length m2))
;; (map (lambda (a b)
;; (println 'a: a 'b: b)
;; (if (and (symbol? a)
;; (regex:match? (symbol->string a) "^!"))
;; (let* ((aa (symbol->string a))
;; (bangname (string->symbol
;; (if (string=? "" (caddr gtd))
;; (string-append aa "##" (number->string gnum))
;; (string-append aa "%" (caddr gtd) "##" (number->string gnum)))))
;; (llllllllll (println 'bangname: bangname))
;; (bangname_current (cdr (assoc-strcmp bangname vars)))
;; (llllllllll (println 'bangname_current: bangname_current))
;; (bangname_current_unified (impc:ti:type-unify (cdr (assoc-strcmp bangname vars)) vars)))
;; (println 'ttt)
;; ;; (if (not (regex:match? b "^%")) (set! b (impc:ir:get-type-from-str b)))
;; ;;(println 'bangname_current bangname_current 'bangname_current_unified bangname_current_unified)
;; ;; possibly recursive decent
;; (if (and (null? bangname_current_unified)
;; (not (null? bangname_current))
;; (symbol? (car bangname_current))
;; (impc:ir:type? b))
;; (let ((gtd2 (impc:ti:generic-type-details (car bangname_current))))
;; ;;(println '_1_update-var (car bangname_current) b)
;; ;;(println 'gtd gtd2)
;; (impc:ti:update-var (car bangname_current) vars '() b)
;; (if (and gtd2
;; (eq? (car gtd) (car gtd2))
;; (string? b)) ;; string b at this stage should be a "%..." reified type
;; (impc:ti:reverse-set-bangs-from-reified (car bangname_current) b (cadr gtd2) vars))))
;; ;; and local change :)
;; (if (impc:ir:type? b)
;; (begin
;; ;; (println 'bangname: bangname 'newtype: b 'current bangname_current)
;; (impc:ti:update-var bangname vars '() b))))))
;; m2 m1))
;; 'done))))
;; this attempts to update-var !bangs from reified types
;; i.e. if we have allready resolved xlist*##289 to %xlist--2812497382948
;; but we have failed to resolve !head##289
;; then we try to get back from %xlist--2812497382948 to set !head##289
(define impc:ti:reverse-set-bangs-from-reified
(lambda (poly reified gnum vars)
;; (println 'poly poly 'reified reified 'gnum: gnum)
(if (regex:match? (symbol->string poly) "^!")
'done ;; we can only check reified if poly IS a list not a reference to a list (which happens with !)
(let* ((t (impc:ir:get-named-type reified))
(ptrdepth (impc:ir:get-ptr-depth t))
(gtd (impc:ti:generic-type-details poly))
(tt (impc:ir:gpolytype-types (car gtd)))
(m1 (impc:ir:get-type-from-str t))
(m2 (impc:ir:get-type-from-pretty-str (apply string-append (symbol->string tt) (make-list ptrdepth "*")))))
;; (println 'bangmatch: poly '-> reified)
;; (println 't_: t)
;; (println 'tt: tt)
;; (println 'm1: m1)
;; (println 'm2: m2)
;; (println 'vars: vars)
(if (= (length m1) (length m2))
(map (lambda (a b)
;; (println 'a: a 'b: b)
(if (and (symbol? a)
(regex:match? (symbol->string a) "^!"))
(let* ((aa (symbol->string a))
(bangname (string->symbol
(if (string=? "" (caddr gtd))
(string-append aa "##" (number->string gnum))
(string-append aa "%" (caddr gtd) "##" (number->string gnum))))))
(if (assoc-strcmp bangname vars)
(let ((bangname_current (cdr (assoc-strcmp bangname vars)))
(bangname_current_unified (impc:ti:type-unify (cdr (assoc-strcmp bangname vars)) vars)))
;; (if (not (regex:match? b "^%")) (set! b (impc:ir:get-type-from-str b)))
;;(println 'bangname_current bangname_current 'bangname_current_unified bangname_current_unified)
;; possibly recursive decent
(if (and (null? bangname_current_unified)
(not (null? bangname_current))
(symbol? (car bangname_current))
(impc:ir:type? b))
(let ((gtd2 (impc:ti:generic-type-details (car bangname_current))))
;;(println '_1_update-var (car bangname_current) b)
;;(println 'gtd gtd2)
(impc:ti:update-var (car bangname_current) vars '() b)
(if (and gtd2
(eq? (car gtd) (car gtd2))
(string? b)) ;; string b at this stage should be a "%..." reified type
(impc:ti:reverse-set-bangs-from-reified (car bangname_current) b (cadr gtd2) vars))))
;; and local change :)
(if (impc:ir:type? b)
(begin
;; (println 'bangname: bangname 'newtype: b 'current bangname_current)
(impc:ti:update-var bangname vars '() b))))
'donothing))))
m2 m1))
'done))))
;; (println (regex:match-all "<!a,!b>" ","))
;; (println (regex:split "<!a,!b,!c,!d>" "(,)|(<)|(>)"))
;; (println (cl:remove-if (lambda (k) (string=? k "")) (regex:split "{ i32 , stuff }" "(,)|({)|(})|(\\s)")))
;; (println (cl:remove-if
;; (println 'hi)
;;
;; first for generic functions we do a gnum test
;;
;; basically the gnum test looks to see if all of the types
;; in the gftype are of the same gnum as the generic function
;; if they aren't of the same gnum (i.e. if they are NEW links)
;; then we might be able to do additonal reverse lookups on the
;; OLD gnum vars by looking into NEW gnum vars
;;
;; for example:
;; if ORIGINAL type (gpoly-type) = (211 !head##110 xlist*##110)
;; and NEW type (gftype) = (211 !head##110 xlist*##109)
;; then we might be able to match !head##110 against !head##109
;;
(define impc:ti:nativef-generics-final-tests
(lambda (ast gpoly-type gftype gnum vars kts)
;; do a final check of all !bang types in original gpoly-type to see
;; if we can improve them with any reified types we may have
(for-each (lambda (k)
;; (println 'k: k 'vars: vars)
(if (symbol? k)
(if (not (null? (assoc-strcmp k vars)))
(let ((v (cdr (assoc-strcmp k vars))))
;; (println 'v: v)
(if (string? v)
(impc:ti:reverse-set-bangs-from-reified k v gnum vars)
(if (and (list? v)
(= (length v) 1)
(string? (car v)))
(impc:ti:reverse-set-bangs-from-reified k (car v) gnum vars)))))))
(cdr gpoly-type))
;; attempt to reify any gtype symbols that don't currenty have type values (i.e. not var entry)
(for-each (lambda (a)
;; (println 'a: a)
(if (and (symbol? a)
(regex:match? (symbol->string a) "##")
(null? (cdr (assoc-strcmp a vars))))
;; should call this impc:ti:symbol-tryto-reify-generic-type
(let ((res (impc:ti:reify-generic-type a vars '())))
(if (not (equal? res a))
(begin ;; (println 'genupdate: a '-> res)
(impc:ti:update-var a vars kts res))))))
(cdr gftype))
#t))
;; recursion test
(define *impc:ti:nativef-generics-recurse-test* 0)
(define impc:ti:nativef-generics-check-code-for-return-type
(lambda (ast lambda-code gpoly-type vars res)
(let ((grtype '()))
;;
;; this section is here to check for a return type
;; for this generic function.
;; we do this by grabbing the gpoly's lambda code and
;; sending it through type checking.
;;
;; This whole section can actually be taken out
;;
(if (< *impc:ti:nativef-generics-recurse-test* 10)
(begin
;; (println 'prevars: vars 'res: res)
(set! *impc:ti:nativef-generics-recurse-test*
(+ *impc:ti:nativef-generics-recurse-test* 1))
;; type inferencing for generic functions return argument!
(let* ((symname 'placeholder)
(c1 (impc:ti:get-var-types lambda-code))
(t1 (impc:ti:first-transform (car c1) #t))
(t2 (impc:ti:mark-returns t1 symname #f #f #f))
(t3 (impc:ti:closure:convert t2 (list symname)))
(lvars (map (lambda (x) (list x)) (impc:ti:find-all-vars t3 '())))
(trequest (impc:ti:type-unify gpoly-type (cl:copy-list vars)))
(ttype '()))
;; if trequest is not yet fulled defined
;; then try to add variable arguments
;; update lvars with res results
(for-each (lambda (s t) ;; symbol from lambda args and type from res
;; (println 's: s 't: t 'u: (impc:ti:type-unify t vars))
(if (impc:ir:type? (impc:ti:type-unify t vars))
(impc:ti:update-var s lvars '() (impc:ti:type-unify t vars))))
(cadr lambda-code)
res)
;; (println 'pre-gpoly--> (car ast) 'res: res)
;; (println 'lambda-code lambda-code)
;; (println 'prelvars: lvars)
;; (println 'request?: trequest)
(set! ttype (impc:ti:type-check t1 lvars '() trequest))
;; (println 'post-gpoly--> (car ast) 'res: res)
;; (println 'postlvars: lvars)
;; (println 'result: (car ast) 'type: ttype)
(set! *impc:ti:nativef-generics-recurse-test* (- *impc:ti:nativef-generics-recurse-test* 1))
(if (< *impc:ti:nativef-generics-recurse-test* 0)
(set! *impc:ti:nativef-generics-recurse-test* 0))
(if (and (not (null? ttype))
(impc:ir:closure? (car ttype))
(impc:ir:type? (cadar ttype)))
(begin
(set! grtype (car ttype))))))
(begin ;; (println 'hit-recursion-limit)
#f))
grtype)))
;; generics check
(define impc:ti:nativef-generics
(lambda (ast vars kts request?)
;; (println 'generics-check 'ast: ast 'vars: vars 'request: request?)
;; (print)
;; (println 'genericf: ast 'request? request?)
(set! impc:ir:get-type-expand-poly #f)
(let* ((gname (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
(gnum (string->number (cadr (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
(gpoly-code (cadr (impc:ir:gpoly-types gname)))
(lambda-code (caddr gpoly-code))
(gpoly-type (impc:ir:get-type-from-pretty-str (symbol->string (car (impc:ir:gpoly-types gname))))))
(set! impc:ir:get-type-expand-poly #t)
;; (println 'gpoly-type1: gpoly-type)
;;(println 'gpoly-typeb:> (car (impc:ir:gpoly-types gname)))
(if (<> (length (cdr gpoly-type))
(length ast))
(print-error 'Compiler 'Error: 'bad 'arity 'in 'generics 'call ast))
;; add ##gnum's to all gpoly types (both !bangs like !head and gpoly types like xlist*)
(set! gpoly-type (impc:ti:nativef-generics-make-gtypes-unique gpoly-type gnum))
;; (println 'gpoly-type2: gpoly-type)
;; (set! gpoly-type-x (impc:ti:nativef-generics-make-gtypes-unique gpoly-type-x gnum))
;; (println 'pt_: gpoly-type)
;; (println 'ptx: gpoly-type-x)
;; (println 'gtypes: *impc:ti:generic-type-mappings*)
;; (set! gpoly-type gpoly-type-x)
;; (println 'gpoly-type2:> gpoly-type)
;; (println 'b: (cdr ast) (cddr gpoly-type))
;; (println 'vars: vars)
;; type inferencing for generic functions arguments and return type
(let* ((res (impc:ti:nativef-generics-check-args ast gpoly-type vars kts request?))
(grtype (impc:ti:nativef-generics-check-code-for-return-type ast lambda-code gpoly-type vars res)))
;; (println 'genericf: ast)
;; (println 'request? request? 'gpoly-type: (cadr gpoly-type) 'res: res 'vars: vars)
;; (println 'args: (car ast) 'args1: res)
;; check to see if for-each is possible (i.e. request and (cadr gpoly-type)) are same length
(if (list? request?)
(if (and (list? (cadr gpoly-type))
(<> (length request?) (length (cadr gpoly-type))))
(set! request? #f))
;; (if (or (not (list? (cadr gpoly-type)))
;; (<> (length request?) (length (cadr gpoly-type))))
;; (set! request? #f))
(if (list? (cadr gpoly-type))
(if (and (string? request?) ;; named type?
(= (length (cadr gpoly-type)) (length (impc:ir:get-type-from-str (llvm:get-named-type request?)))))
(set! request? (impc:ir:get-type-from-str (llvm:get-named-type request?)))
(set! request? #f))
(if (<> (length (list request?)) (length (list (cadr gpoly-type))))
(set! request? #f))))
(if request?
(if (and (list? request?)
(atom? (cadr gpoly-type))
(symbol? (cadr gpoly-type)))
(impc:ti:update-var (cadr gpoly-type) vars kts request?)
(for-each
(lambda (aa bb)
;;(println '_a_: aa 'bb: bb)
(if (and (atom? aa)
(symbol? aa)
(assoc-strcmp aa vars))
(impc:ti:update-var aa vars kts bb)))
(if (atom? request?)
(list (cadr gpoly-type))
(cadr gpoly-type))
(if (atom? request?)
(list request?)
request?))))
;; (set! gpoly-type gpoly-type-x)
;; if request? is not a fully formed type
;; then we will stick to the the current poly type
(if (not (impc:ir:type? request?))
(set! request? #f))
;; (println 'ast: 'preset: vars)
;; set generic functions type ( (cadr gpoly-type)|request? + res)
(let ((gftype (if request?
(list (cons (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))
(cons (list request?) res)))
(list (cons (+ *impc:ir:closure* (* 2 *impc:ir:pointer*))
(cons (list (cadr gpoly-type)) res))))))
(set! gftype (impc:ti:type-clean (car gftype)))
;; (println (car ast) 'gftype: gftype)
;; (println 'g-vars-a: vars)
;; this is a call for *inplace* changes to vars (i.e. impc:ti:update-var)
(impc:ti:nativef-generics-final-tests ast gpoly-type gftype gnum vars kts)
;; (println 'g-vars-b: vars)
;;(println 'gpoly-type gpoly-type)
;; (impc:ti:update-var (car ast) vars kts (list gftype))))
;; if grtype is VALID
;; and if the return type of gftype is a symbol
;; THEN update the return type of gftype (symbol)
;; with the reified return type of grtype
(if (and (symbol? (cadr gftype))
(impc:ir:type? grtype))
(impc:ti:update-var (cadr gftype) vars kts (cadr grtype)))
;; (println 'vars: vars)
;; (println 'request? request?)
;; (println 'gftype gftype (impc:ir:type? gftype))
;; (println 'grtype grtype (impc:ir:type? grtype))
(if (impc:ir:type? grtype)
(impc:ti:update-var (car ast) vars kts (list grtype))
(impc:ti:update-var (car ast) vars kts (list gftype)))))
;; (println 'genericf-sig: (car ast) ': (assoc-strcmp (car ast) vars))
;; return request? or (cadr gpoly-type if no request was made
(if request?
(list request?)
(list (cadr gpoly-type))))))
;; polymorphic version
(define impc:ti:nativef-poly-check
(lambda (ast vars kts request?)
;; (println 'type-checking: (car ast))
;(println 'poly-check 'ast: ast 'vars: vars 'request: request?)
(let* ((polyf (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
(ftypes (impc:ir:poly-types polyf))
(valid-lgth (map (lambda (type)
(if (<> (length (cdr type))
(length ast)) #f #t))
ftypes))
(valid-args (map (lambda (type valid)
;(println 'type: type valid)
(if valid
(let* ((checked-types
(map (lambda (a t)
(let ((t2 (impc:ti:type-unify (impc:ti:type-check a vars kts t) vars)))
;; (println 'a: a 't: t 't2: t2)
t2))
(cdr ast)
(cddr type)))
(ct2 (map (lambda (ct ft) ;; checked type against poly type
;; (println 'ct: ct 'ft: ft)
(if (and (number? ct) (number? ft))
(if (= ct ft) #t #f)
(if (and (string? ct) (string? ft))
(if (string=? ct ft) #t #f)
(if (list? ct)
#f ;;(if (member ft ct) #t #f)
#f))))
checked-types
(cddr type))))
(if (member #f ct2) #f #t))
#f))
ftypes
valid-lgth))
(valid-polys (remove '()
(map (lambda (type valid)
;; (println 'type: type 'valid: valid)
(if valid type '()))
ftypes
valid-args))))
;; (println 'va valid-args)
;; (println '-> ast 'valid-polys: valid-polys 'request: request?)
(if (null? valid-polys)
(print-error 'Compiler 'Error: 'no 'valid 'polymorphic 'options 'for: ast 'vars: vars))
;(println 'valid-polysa: valid-polys 'request? request? 'ast: ast)
(let ((returns (map (lambda (t)
(cadr t))
valid-polys)))
;(println 'returnsa: returns 'request? request?)
(if request?
;; (begin (if (atom? request?)
;; (set! request? (list request?)))
(set! returns (impc:ti:intersection* returns (list request?))))
;; (println 'valid-polysa: valid-polys 'returns: returns 'request? request?)
(set! valid-polys (cl:remove #f
(map (lambda (v)
(if (member (cadr v) returns)
v
#f))
valid-polys)))
;; update valid-polys to reflect return types (from request?)
(impc:ti:update-var (car ast) vars kts valid-polys)
;(println 'returns: returns)
returns))))
(define impc:ti:callback-check
(lambda (ast vars kts request?)
;(println 'callback-check 'ast: ast 'vars: vars 'request: request?)
(let ((ftype (map impc:ir:get-type-from-str
(let ((ags (llvm:get-function-args-withoutzone (symbol->string (caddr ast)))))
(if ags ags '())))))
;(println 'ftype: ftype)
(if *impc:ti:print-sub-checks* (println 'ftype:> 'ast: ast 'type: ftype))
(if (null? ftype)
(begin (impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
(impc:ti:type-check (cddr ast) vars kts '())
(list *impc:ir:void*))
(begin (if (<> (+ 2 (length ftype))
(length ast))
(print-error 'Compiler 'Error: 'bad 'arity 'in 'call ast))
;; we don't care what we get back
(for-each (lambda (a t)
(if (symbol? a) (impc:ti:update-var a vars kts t))
(impc:ti:type-check a vars kts t))
(cdddr ast)
(cdr ftype))
;; callback returns void
(list *impc:ir:void*))))))
(define impc:ti:push_zone-check
(lambda (ast vars kts request?)
(if (<> (length ast) 2)
(print-error 'Compiler 'Error: 'bad 'arity 'for (sexpr->string ast)))
(impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
(list "%mzone*")))
(define impc:ti:pop_zone-check
(lambda (ast vars kts request?)
;(println 'memzonecheck ast (list? (cadr ast)))
(list *impc:ir:void*)))
(define impc:ti:memzone-check
(lambda (ast vars kts request?)
(if (or (> (length ast) 4)
(< (length ast) 3))
(print-error 'Compiler 'Error: 'memzone 'must 'be 'of 'the 'form '(memzone size [delay] body) 'where "delay" 'is 'optional 'and "body" 'is 'a 'let, 'begin, 'lambda 'etc..))
;(println 'memzonecheck ast (list? (cadr ast)))
(if (= (length ast) 3)
(begin (impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
(impc:ti:type-check (caddr ast) vars kts request?))
(begin (impc:ti:type-check (cadr ast) vars kts *impc:ir:si64*)
(impc:ti:type-check (caddr ast) vars kts *impc:ir:si64*)
(impc:ti:type-check (cadddr ast) vars kts request?)))))
(define impc:ti:let-check
(lambda (ast vars kts request?)
;(println 'vars: vars '(cadr ast) (cadr ast))
;; for the symbols we want to set each return type
(for-each (lambda (e)
;; let should not impose return type request!
;; on individual parameter type checks
;; (println 'e: e)
(let ((a (impc:ti:type-check (cadr e) vars kts
(if (member (car e) kts)
(cadr (assoc (car e) vars))
#f))))
;; request?))))
;; (println '---update: (car e) 'with: a)
(impc:ti:update-var (car e) vars kts a)
;; (println '---vars: vars)
))
(cadr ast))
;; then return the return type for the whole let
;; which should have a begin body! so caddr should work
;(println 'letvars: vars)
(let ((ret (impc:ti:type-check (caddr ast) vars kts request?)))
;; (println 'letret: ret)
ret)))
(define impc:ti:null?-check
(lambda (ast vars kts request?)
;;(println 'nullcheck)
(let ((a (impc:ti:type-check (cadr ast) vars kts request?)))
(if (null? a) ;; couldn't resolve yet!
(list *impc:ir:i1*)
(if (if (not (impc:ir:type? a))
(impc:ir:pointer? (car a))
(impc:ir:pointer? a))
(list *impc:ir:i1*)
(print-error 'Compiler 'Error: 'null? 'must 'take 'a 'pointer 'type (sexpr->string ast)))))))
(define impc:ti:null-check
(lambda (ast vars kts request?)
;; (println 'null-check 'ast: ast 'request? request?)
(let ((res (if (and (symbol? request?)
(regex:match? (symbol->string request?) "##"))
(if (assoc-strcmp request? vars)
(if (null? (cdr (assoc-strcmp request? vars)))
request?
(cdr (assoc-strcmp request? vars))))
(if (and request?
(impc:ir:pointer? request?))
(list request?)
'())))) ;; forcing to i8* causes problems for generics
;(list (+ *impc:ir:pointer* *impc:ir:si8*))))))
res)))
(define impc:ti:ret-check
(lambda (ast vars kts request?)
;(println 'retcheck: request?)
;(println 'ast: ast)
;; grab function name from ret->
(let* ((sym (if (equal? (caddr ast) (cadr ast))
'()
(impc:ti:get-var (cadr ast) vars)))
(t (if (null? sym) #f
(if (null? (cdr sym))
#f
(if (impc:ir:type? (cdr sym))
(cdr sym)
(car (cdr sym))))))
;(car (cdr sym)))))
;; if closure has a return type set
;; pass it as a request
(a (impc:ti:type-check (caddr ast) vars kts
(if (and t
(impc:ir:type? t)
(impc:ir:closure? t))
(if (list? t) (cadr t) request?)
;#f)))) ;; or else pass #f
request?)))) ;; or pass on request
;;(println 'retchecked-> a 'request? request?)
;; if t is not a closure type we have a problem!
(if (and t
(or (not (list? t));(not (impc:ir:type? t))
(not (impc:ir:closure? t))))
(print-error 'Compiler 'Error: 'type 'error 'calculating 'return 'type: ast
'have 'you 'specified 'an 'incorrect 'closure 'type?))
(if *impc:ti:print-sub-checks* (println 'ret:> 'ast: ast 'a: a 'sym: sym))
(if t
;; if the return value is a symbol then it should be
;; give then return type of 't
(if (symbol? (caddr ast))
(impc:ti:update-var (caddr ast) vars kts (list (cadr t)))
;; else the return value is not a symbol
;; and we should use it's value to update the lambda's type
(impc:ti:update-var (car sym) vars kts
(list (impc:ir:pointer++ (impc:ir:pointer++ (list* *impc:ir:closure* a (cddr t))))))))
a)))
(define impc:ti:begin-check
(lambda (ast vars kts request?)
;;(println 'request: request?)
(let ((a (car (reverse (map (lambda (e)
(println 'e: e)
(impc:ti:type-check e vars kts request?))
(cdr ast))))))
(if *impc:ti:print-sub-checks* (println 'begin:> 'ast: ast 'a: a))
a)))
(define impc:ti:begin-check
(lambda (ast vars kts request?)
;;(println 'request: request?)
;; we should ONLY use request? on the LAST sexpr in the begin
;; i.e. we should only use the LAST begin sexpr for a return type
(let ((sexplst (reverse (cdr ast))))
;; we need type check coverage for ALL sexpr's
;; by only the last one counts towards the returned type
;; so we start with type coverage
;; reverse order shouldn't matter because there
;; should be no type dependencies between these sexpressions
;; also we don't want to pass any request? to these
(map (lambda (e) (impc:ti:type-check e vars kts #f)) (cdr sexplst))
;; now we do the last sexpr in the begin for a return type
;; it SHOULD get passed the request?
(let ((res (impc:ti:type-check (car sexplst) vars kts request?)))
;; and return res
res))))
(define impc:ti:bitcast-check
(lambda (ast vars kts request?)
;; (println 'bitcastcheck'req: request?)
(if (null? (cddr ast))
(if request? (list request?) (list))
;; for the symbols we want to set each return type
;;(impc:ti:update-var (cadr ast) vars kts (impc:ir:convert-from-pretty-types (caddr ast)))
(list (impc:ir:convert-from-pretty-types (caddr ast))))))
(define impc:ti:bitconvert-check
(lambda (ast vars kts request?)
;; (println 'bitcastcheck'req: request?)
(if (null? (cddr ast))
(if request? (list request?) (list))
;; for the symbols we want to set each return type
;;(impc:ti:update-var (cadr ast) vars kts (impc:ir:convert-from-pretty-types (caddr ast)))
(list (impc:ir:convert-from-pretty-types (caddr ast))))))
(define impc:ti:if-check
(lambda (ast vars kts request?)
;(println 'if: ast 'request? request?)
(let* ((a (impc:ti:type-check (cadr ast) vars kts #f)) ;request?))
(b (impc:ti:type-check (caddr ast) vars kts request?))
(c (if (null? (cdddr ast))
'()
(impc:ti:type-check (cadddr ast) vars kts request?)))
(t (impc:ti:type-unify (list b c) vars)))
;(t (cl:intersection (if (atom? b) (list b) b) (if (atom? c) (list c) c))))
(if *impc:ti:print-sub-checks* (println 'if:> 'a: a 'b: b 'c: c 't: t))
;(println 'a: a 'b: b 'c: c 't: t)
(if (null? b)
(set! t c))
(if (null? c)
(set! t b))
;(println '-> 'a: a 'b: b 'c: c 't: t)
;; return intersection of b and c
(if (null? t)
(print-error 'Compiler 'Error: 'cannot 'unify 'then b 'and 'else c 'in ast) ;(map (lambda (v) (impc:ir:get-type-str v)) b) 'and 'else (map (lambda (v) (impc:ir:get-type-str v)) c) 'clauses 'in ast)
t))))
(define impc:ti:void-check
(lambda (ast vars kts request?)
(if (> (length ast) 1)
(print-error 'Compiler 'Error: 'void 'does 'not 'take 'any 'arguments)
(list *impc:ir:void*))))
(define impc:ti:array-set-check
(lambda (ast vars kts request?)
(if (<> (length ast) 4)
(print-error 'Compiler 'Error: 'error 'parsing (atom->string (car ast)) 'incorrect 'number 'of 'arguments))
(let* ((a (impc:ti:type-check (cadr ast) vars kts '())) ;request?))
;; b should be fixed point types
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*)))
;; c should be of type a*
(c (impc:ti:type-check (cadddr ast) vars kts (if (null? a) #f
(if (and (not (impc:ir:type? a))
(impc:ir:array? (car a)))
(list (caddr (car a)))
(list (impc:ir:pointer-- (car a))))))))
(if (or (and (not (null? a))
(not (impc:ir:array? (car a))))
(and (not (null? a))
(> (impc:ir:get-ptr-depth (car a)) 1)))
(print-error 'Compiler 'Error: 'invalid 'aset! 'type (impc:ir:get-type-str (car a))))
;; array set check will return the value set
c)))
(define impc:ti:array-ref-ptr-check
(lambda (ast vars kts request?)
(if (<> (length ast) 3)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let ((a (impc:ti:type-check (cadr ast) vars kts '())) ;request?))
;; b should be fixed point
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
(if (impc:ir:type? a) (set! a (list a)))
(if (null? a)
a
(if (or (not (impc:ir:array? (car a)))
(> (impc:ir:get-ptr-depth (car a)) 1))
(print-error 'Compiler 'Error: 'invalid 'array-ref-ptr 'type (impc:ir:get-type-str (car a)) 'in ast)
(list (impc:ir:pointer++ (caddr (car a)))))))))
(define impc:ti:array-ref-check
(lambda (ast vars kts request?)
;(println 'request? request?)
;(println 'array-ref-check: 'ast: ast 'vars: vars 'kts: kts)
(if (<> (length ast) 3)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let ((a (impc:ti:type-check (cadr ast) vars kts '()))
;; b should be fixed point
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
(if (impc:ir:type? a) (set! a (list a)))
(if (null? a)
a
(if (or (not (impc:ir:array? (car a)))
(> (impc:ir:get-ptr-depth (car a)) 1))
(print-error 'Compiler 'Error: 'invalid 'array-ref 'type (impc:ir:get-type-str (car a)) 'in ast)
(list (caddr (car a))))))))
(define impc:ti:vector-set-check
(lambda (ast vars kts request?)
;(println 'ast: ast 'vars: vars)
(if (<> (length ast) 4)
(print-error 'Compiler 'Error: 'error 'parsing (atom->string (car ast)) 'incorrect 'number 'of 'arguments))
(let* ((a (impc:ti:type-check (cadr ast) vars kts '())) ;request?))
;; b should be i32
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*)))
;; c should be of type a*
(c (impc:ti:type-check (cadddr ast) vars kts (if (null? a) #f (list (caddr (car a)))))))
(if (or (and (not (null? a))
(not (impc:ir:vector? (car a))))
(and (not (null? a))
(> (impc:ir:get-ptr-depth (car a)) 1)))
(print-error 'Compiler 'Error: 'invalid 'vset! 'type (impc:ir:get-type-str (car a))))
;; vector set returns a whole new vector! check llvm ir doc
a)))
(define impc:ti:vector-ref-check
(lambda (ast vars kts request?)
;(println 'request? request?)
;(println 'vector-ref-check: 'ast: ast 'vars: vars 'kts: kts)
(if (<> (length ast) 3)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let ((a (impc:ti:type-check (cadr ast) vars kts '()))
;; b should be i32
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*))))
(if (impc:ir:type? a) (set! a (list a)))
(if (null? a)
a
(if (or (not (impc:ir:vector? (car a)))
(> (impc:ir:get-ptr-depth (car a)) 1))
(print-error 'Compiler 'Error: 'invalid 'vector-ref 'type (impc:ir:get-type-str (car a)) 'in ast)
(list (caddr (car a))))))))
(define impc:ti:pointer-set-check
(lambda (ast vars kts request?)
(if (<> (length ast) 4)
(print-error 'Compiler 'Error: 'error 'parsing (atom->string (car ast)) 'incorrect 'number 'of 'arguments ': ast))
(let* ((a (impc:ti:type-check (cadr ast) vars kts request?))
;; b should be fixed point types
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*)))
;; c should be of type a*
(c (impc:ti:type-check (cadddr ast) vars kts (if (null? a) #f
(if (and (not (impc:ir:type? a))
(impc:ir:array? (car a)))
(list (caddr (car a)))
(list (impc:ir:pointer-- (car a))))))))
;; array set check will return the type of the value set
c)))
(define impc:ti:pointer-ref-ptr-check
(lambda (ast vars kts request?)
(if (<> (length ast) 3)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let ((a (impc:ti:type-check (cadr ast) vars kts request?))
;; b should be fixed point
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
(if (impc:ir:type? a) (set! a (list a)))
(if (null? a)
a
(if (impc:ir:array? (car a))
(list (impc:ir:pointer++ (caddr (car a))))
(list (car a)))))))
(define impc:ti:pointer-ref-check
(lambda (ast vars kts request?)
;(println 'pointer-ref-check: 'ast: ast 'request? request?) ;'vars: vars 'kts: kts)
(if (<> (length ast) 3)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let ((a (impc:ti:type-check (cadr ast) vars kts '())) ;request?))
;; b should be fixed point
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si64* *impc:ir:si32*))))
(if (impc:ir:type? a) (set! a (list a)))
;(println 'a: a 'b: b)
(if (null? a)
a
(if (impc:ir:array? (car a))
(list (caddr (car a)))
(list (impc:ir:pointer-- (car a))))))))
;; make should be of the form
;; (make type)
;; where type is a valid type
;; (make i64)
;; memory is allocated on the head
(define impc:ti:heap-alloc-check
(lambda (ast vars kts request?)
;; make should return a ptr to type a
(let ((a (impc:ir:convert-from-pretty-types (if (< (length ast) 3) (cadr ast) (caddr ast)))))
;; returns a pointer of tuple type 'a'
(if (null? a) a
(impc:ir:pointer++ a)))))
;; make should be of the form
;; (halloc type)
;; where type is a valid type
;; (nalloc i64)
;; memory is allocated on the head
(define impc:ti:heap-alloc-check
(lambda (ast vars kts request?)
request?))
;; make should be of the form
;; (make type)
;; where type is a valid type
;; (make i64)
;; memory is allocated on the head
(define impc:ti:zone-alloc-check
(lambda (ast vars kts request?)
;; make should return a ptr to type a
(let ((a (impc:ir:convert-from-pretty-types (if (< (length ast) 3) (cadr ast) (caddr ast)))))
;(println 'zone-alloc-check 'a: a 'request: request?)
;; returns a pointer of tuple type 'a'
(if (null? a) a
(impc:ir:pointer++ a)))))
;; make should be of the form
;; (alloc type)
;; where type is a valid type
;; (alloc i64)
;; memory is allocated on the head
(define impc:ti:zone-alloc-check
(lambda (ast vars kts request?)
request?))
;; (if (null? (cdr ast))
;; request?
;; ;; make should return a ptr to type a
;; (let ((a (impc:ir:convert-from-pretty-types (if (< (length ast) 3) (cadr ast) (caddr ast)))))
;; (println 'zone-alloc-check 'a: a 'request: request?)
;; ;; returns a pointer of tuple type 'a'
;; (if (null? a) a
;; (impc:ir:pointer++ a))))))
;; make should be of the form
;; (make type)
;; where type is a valid type
;; (make i64)
;; memory is allocated on the stack
(define impc:ti:stack-alloc-check
(lambda (ast vars kts request?)
;; alloc should return a ptr to type a
(let ((a (impc:ir:convert-from-pretty-types (if (< (length ast) 3) (cadr ast) (caddr ast)))))
;; returns a pointer of tuple type 'a'
(if (null? a) a
(impc:ir:pointer++ a)))))
;; make should be of the form
;; (salloc type)
;; where type is a valid type
;; (salloc i64)
;; memory is allocated on the head
(define impc:ti:stack-alloc-check
(lambda (ast vars kts request?)
request?))
(define impc:ti:get-tuple-type-from-name
(lambda (str)
(let ((t (llvm:get-named-type (substring (impc:ir:get-base-type (car res))
1
(string-length (impc:ir:get-base-type (car res)))))))
(dotimes (i (impc:ir:get-ptr-depth str)) (set! t (impc:ir:pointer++ t)))
t)))
(define impc:ti:tuple-set-check
(lambda (ast vars kts request?)
;(println 'tsetcheck ast) ; vars kts request?)
(if (<> (length ast) 4)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
;; (caddr ast) must be an integer
(if (not (integer? (caddr ast)))
(print-error 'Compiler 'Error: 'tuple-set! 'must 'use 'a 'literal 'integer 'index! ast))
(let* (;; a should be a tuple of some kind
(a (let ((res (impc:ti:type-check (cadr ast) vars kts request?)))
(if (null? res) res
(if (and (string? (car res))
(char=? (string-ref (car res) 0) #\%))
(let ((t (llvm:get-named-type (substring (impc:ir:get-base-type (car res))
1
(string-length (impc:ir:get-base-type (car res)))))))
(dotimes (i (impc:ir:get-ptr-depth (car res))) (set! t (impc:ir:pointer++ t)))
(list (impc:ir:get-type-from-str t)))
res))))
;; b should be 32bit fixed point type -- llvm structs only support 32bit indexes
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*)))
(req? (if (and (not (null? a))
(list? a))
(if (impc:ir:tuple? (car a))
(list-ref (car a) (+ 1 (caddr ast)))
#f)
#f))
;(llllll (println 'req: req? 'cara: (car a) 'z: (caddr ast) 'list-ref: (+ 1 (caddr ast))))
;; c should be an element of a tuple
(c (impc:ti:type-check (cadddr ast) vars kts req?)))
;; (if (and (not (null? a))
;; (list? a))
;; (if (impc:ir:tuple? (car a))
;; (list-ref (car a) (+ 1 (caddr ast)))
;; #f)
;; #f))))
(if (and (not (null? a))
(not (symbol? (car a))) ;; symbol may not have yet been defined!!
(not (impc:ir:tuple? (car a))))
(print-error 'Compiler 'Error: 'invalid 'tuple-set-check 'type (impc:ir:get-type-str (car a))))
;; if (cadddr ast) is a symbol we should update
;; it's type with c but for polymorphic cases
;; we should ensure that we also do a type-unification
(if (symbol? (cadddr ast))
(let* ((types (cdr (assoc (cadddr ast) vars)))
(utype (impc:ti:type-unify (list c types) vars)))
;(println 'types: types 'utype: utype 'c: (list c types))
(if (null? utype)
(impc:ti:force-var (cadddr ast) vars kts (list c))
(impc:ti:force-var (cadddr ast) vars kts (list utype)))))
;; tuple set check will return the type of the value set
c)))
(define impc:ti:tuple-ref-ptr-check
(lambda (ast vars kts request?)
;; (caddr ast) must be an integer
(if (not (integer? (caddr ast)))
(print-error 'Compiler 'Error: 'tuple-ref 'must 'use 'a 'literal 'integer 'index! ast))
(let* (; a should be a tuple of some kind!
(a (impc:ti:type-check (cadr ast) vars kts #f)) ;;(if (impc:ir:type? request?)
;;(impc:ir:tuple? request?)
;;request?
;;#f))) ;request?))
;; b should be fixed point -- llvm structs only support 32bit indexes
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*))))
(if (impc:ir:type? a)
(set! a (list a)))
;; check for named types
(if (not (null? a)) (set! a (impc:ti:try-to-resolve-named-types (car a) vars)))
;; (if (and (not (null? a)) (string? (car a)))
;; (let ((t (impc:ir:get-type-from-str (llvm:get-named-type (impc:ir:clean-named-type (car a)))))
;; (ptr-level (impc:ir:get-ptr-depth (car a))))
;; (dotimes (i ptr-level) (set! t (impc:ir:pointer++ t)))
;; (set! a (list t))))
;(println 'tupref-check 'a: a 'ast: ast (list-ref (car a) (+ 1 (caddr ast))))
(if (and (not (null? a))
(list? a)
(impc:ir:tuple? (car a)))
(list (impc:ir:pointer++ (list-ref (car a) (+ 1 (caddr ast)))))
;;'()))))
(if (null? a)
'()
(print-error 'Compiler 'Error: 'invalid 'tuple-ref-ptr 'type (impc:ir:get-type-str (car a))))))))
(define impc:ti:tuple-ref-check
(lambda (ast vars kts request?)
;(println 'ref-check ast request?) ;kts vars)
;; (caddr ast) must be an integer
(if (not (integer? (caddr ast)))
(print-error 'Compiler 'Error: 'tuple-ref 'must 'use 'a 'literal 'integer 'index! ast))
(let* (; a should be a tuple of some kind!
(a (impc:ti:type-check (cadr ast) vars kts #f)) ;(if (and (impc:ir:type? request?)
; (impc:ir:tuple? request?))
; request?
; #f))) ;request?))
;; b should be fixed point -- llvm structs only support 32bit indexes
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si32*))))
;; unify a?
(if (not (null? a)) (set! a (impc:ti:type-unify (car a) vars)))
(if (impc:ir:type? a) (set! a (list a)))
;; we MUST expand named types!
(if (not (null? a)) (set! a (impc:ti:try-to-resolve-named-types (car a) vars)))
(if (impc:ir:type? a) (set! a (list a)))
;; (println 'tupref-check 'a: a 'ast: ast (list-ref (car a) (+ 1 (caddr ast))))
(if (and (not (null? a))
(list? a)
(impc:ir:tuple? (car a)))
(begin (if (>= (caddr ast)
(- (length (car a)) 1))
(print-error 'Compiler 'Error: 'tuple 'index 'beyond 'type 'boundary ast))
(list-ref (car a) (+ 1 (caddr ast))))
(if (null? a)
'()
(print-error 'Compiler 'Error: 'invalid 'tuple-ref 'type (impc:ir:get-type-str (car a))))))))
; '()))))
;;(closure-set! closure a i32 5)
(define impc:ti:closure-set-check
(lambda (ast vars kts request?)
;(println 'cset 'ast: ast 'request? request?)
(if (<> (length ast) 5)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let* (;; a should be a closure of some kind
(a (if (and (symbol? (cadr ast))
(llvm:get-function (symbol->string (cadr ast))))
#t ; // yes (cadr ast) is a globally defined closure
(impc:ti:type-check (cadr ast) vars kts request?)))
;; b should be a string (the var's name)
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si8*)))
;; c should be a value for var's name
(c (impc:ti:type-check (cadddr ast) vars kts
(if (null? (car (cddddr ast)))
request?
(impc:ir:get-type-from-str (car (cddddr ast)))))))
c)))
;;(closure-ref closure a i32)
(define impc:ti:closure-ref-check
(lambda (ast vars kts request?)
;(println 'cls 'ref 'check: ast 'request? request?)
(if (<> (length ast) 4)
(print-error 'Compiler 'Error: 'invalid 'number 'of 'operands 'in (sexpr->string ast)))
(let* (;; a should be a closure of some kind
(a (if (and (symbol? (cadr ast))
(llvm:get-function (symbol->string (cadr ast))))
#t ; // yes (cadr ast) is a globally defined closure
(impc:ti:type-check (cadr ast) vars kts request?)))
;; b should be a string (the var's name)
(b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si8*))))
(if (null? (cadddr ast))
(if request?
request?
'())
(impc:ir:get-type-from-str (cadddr ast))))))
(define impc:ti:set-check
(lambda (ast vars kts request?)
(let* ((sym (impc:ti:get-var (cadr ast) vars))
(a (impc:ti:type-check (caddr ast) vars kts (cdr sym))))
(if *impc:ti:print-sub-checks* (println 'set!:> 'ast: ast 'a: a))
;; if sym is not a global var then add return type to sym
(if (assoc (car sym) vars)
(impc:ti:update-var (car sym) vars kts a))
a)))
(define impc:ti:pdref-check
(lambda (ast vars kts request?)
(let* ((a (impc:ti:type-check (cadr ast) vars kts request?)))
(if *impc:ti:print-sub-checks* (println 'ptrref:> 'ast: ast 'a: a))
;; return type of ptrref is 'a' dereferenced'
(if (list? a)
(set! a (car a)))
(if (and (impc:ir:type? a)
(impc:ir:pointer? a))
(impc:ir:pointer-- a)
(print-error 'Compiler 'Error: 'ptrref 'takes 'a 'pointer 'argument 'not a)))))
(define impc:ti:pref-check
(lambda (ast vars kts request?)
(let* ((a (impc:ti:type-check (cadr ast) vars kts request?)))
(if *impc:ti:print-sub-checks* (println 'ptrref:> 'ast: ast 'a: a))
;; return type of ptrref is 'a' referenced
(if (list? a)
(set! a (car a)))
(if (and (impc:ir:type? a)
(impc:ir:pointer? a))
(impc:ir:pointer++ a)
(print-error 'Compiler 'Error: 'ptrref 'takes 'a 'pointer 'argument 'not a)))))
(define impc:ti:lambda-check
(lambda (ast vars kts request?)
;; (println 'lcheck: ast 'request? request?) ;'ast: ast 'request? request? 'vars: vars 'kts: kts)
;; first we check if a type request has been made
(if (and request?
(impc:ir:closure? request?))
;; if there is a request then cycle through
;; and set lambda arg symbols
(begin (map (lambda (sym req)
;; (println 'sym: sym 'req: req)
(if (symbol? sym)
(impc:ti:update-var sym vars kts req)))
(cadr ast)
(cddr request?))
;; finally set request? to the return type
(set! request? (cadr request?))))
;; run body for type coverage
;; grab the last result as return type
;; (println 'aaaa: (caddr ast))
;; (println 'vars: vars)
(let ((res (impc:ti:type-check (caddr ast) vars kts request?)))
;(println 'bbbb: res '-> request? request?) ; '-> (caddr ast))
;; if we have a choice between numeric options we force one!
(if (and (not (impc:ti:complex-type? res))
(list? res)
(> (length res) 1)
(not (member #f (map (lambda (t) (impc:ir:floating-point? t)) res))))
(set! res (list *impc:ir:double*))) ;; force doubles
(if (and (not (impc:ti:complex-type? res))
(list? res)
(> (length res) 1)
(not (member #f (map (lambda (t) (impc:ir:fixed-point? t)) res))))
(set! res (list *impc:ir:si64*))) ;; force i64
;; (println 'cccc: res)
;; return lambda type which is made up of
;; argument symbols plus return type from last body expression
;; (println 'vars: vars)
(let* ((ret (list (impc:ir:pointer++ (impc:ir:pointer++ (list* *impc:ir:closure* res (cadr ast))))))
(uret (impc:ti:type-unify ret vars)))
;; (println 'ret: ret 'uret: uret)
(if (null? uret) ret uret)))))
;; whenever a closure is called we calculate a type for it
;; at the end these possibly multiple views should unify!
(define impc:ti:closure-call-check
(lambda (ast vars kts request?)
;(println 'cchint 'ast: ast 'vars: vars 'request: request?)
;; otherwise we need to try to find a type definition for the closure
(let* ((ctype (if (assoc (car ast) vars)
(cdr (assoc (car ast) vars))
(if (llvm:get-globalvar (symbol->string (car ast)))
(list (impc:ir:get-type-from-str (llvm:get-global-variable-type (symbol->string (car ast)))))
(print-error 'Compiler 'Error: 'no 'closure 'named: (car ast)))))
;(llllllll (println 'ctype: ctype))
;; get argument expression types
(res (map (lambda (e t)
;(println 'e: e 't: t)
(let ((res (impc:ti:type-check e vars kts
(if (symbol? t)
(impc:ti:symbol-check t vars kts #f)
t))))
;; if t is a symbol then add res to t
(if (symbol? t)
(if (or (and (list? res)
(impc:ir:type? (car res)))
(impc:ir:type? res))
(impc:ti:force-var t vars kts res)
;(impc:ti:update-var t vars kts res)
(impc:ti:update-var t vars kts res)))
;(if (symbol? t) (impc:ti:update-var t vars kts res))
res))
(cdr ast)
(if (or (null? ctype)
(and (number? (car ctype))
(= (car ctype) 211))
(not (impc:ir:closure? (car ctype))))
(make-list (length (cdr ast)) #f)
;; if we are using an existing definition then check arity
(if (<> (length (cddr (car ctype)))
(length (cdr ast)))
(print-error 'Compiler 'Error: 'bad 'arity 'for ast)
(cddr (car ctype))))))
;; (lllll (println 'res: res 'from (car ast) 'request? request?))
;; if there was a request that will be the return type
;; otherwise if we already have a type defined we can use it's return type
;; otherwise we cannot know it
;; (ret (if (and request?
;; (not (null? request?)))
;; request?
;; (if (or (null? ctype)
;; (not (impc:ir:closure? (car ctype))))
;; '()
;; (cadr (car ctype))))))
;; if we already have a type defined we can use it's return type
;; otherwise
;; if there was a request that will be the return type
;; otherwise we cannot know it
(ret (if (and (not (null? ctype))
(not (atom? (car ctype)))
(impc:ir:closure? (car ctype)))
(cadr (car ctype))
(if (and request?
(not (null? request?)))
request?
'()))))
(if *impc:ti:print-sub-checks* (println 'closure:> 'ast: ast 'res: res 'ret: ret))
; set the closure type for the symbol (if not a global var)
;(if (not (null? ret))
;(println 'setting-closure-type: (list (impc:ir:pointer++ (impc:ir:pointer++ (list* *impc:ir:closure* ret res)))))
(if (assoc (car ast) vars)
(impc:ti:update-var (car ast) vars kts
(list (impc:ir:pointer++ (impc:ir:pointer++ (list* *impc:ir:closure* ret res))))))
;(println 'return: ret 'request? request?) ; 'from (car ast) 'vars: vars)
; and return the new closure's return type
(if (list? ret) ret
(list ret)))))
(define impc:ti:dotimes-check
(lambda (ast vars kts request?)
(let ((a (impc:ti:type-check (cadr (cadr ast)) vars kts
(list *impc:ir:double* *impc:ir:float* *impc:ir:si64* *impc:ir:si32* *impc:ir:ui8*))))
;; if numeric? and multiple choice - then force a type!
(if (number? (cadr (cadr ast)))
(cond ((equal? (cl:sort a <)
(cl:sort (list *impc:ir:double* *impc:ir:float* *impc:ir:si64* *impc:ir:si32* *impc:ir:ui8*) <))
(set! a (list *impc:ir:si64*)))
((equal? (cl:sort a <)
(cl:sort (list *impc:ir:double* *impc:ir:float*) <))
(set! a (list *impc:ir:double*)))
(else 'leave-a-alone)))
;; (car (cadr ast)) should be a symbol that we want to update with a
(if (not (symbol? (car (cadr ast)))) (print-error 'Compiler 'Error: 'bad 'form 'for 'dotimes. 'Needs 'a 'symbol ast))
(impc:ti:update-var (car (cadr ast)) vars kts a)
;; stretch over body code but don't worry about return types
(impc:ti:type-check (caddr ast) vars kts #f)
;; dotimes returns void
(list *impc:ir:void*))))
(define impc:ti:printf-check
(lambda (ast vars kts request?)
(let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
;; run through everything else for completeness but don't care about the results
(for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cddr ast))
;; printf returns i32
(list *impc:ir:si32*))))
(define impc:ti:sprintf-check
(lambda (ast vars kts request?)
(let ((a (impc:ti:type-check (cadr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*))))
(b (impc:ti:type-check (caddr ast) vars kts (list (+ *impc:ir:si8* *impc:ir:pointer*)))))
;; run through everything else for completeness but don't care about the results
(for-each (lambda (x) (impc:ti:type-check x vars kts #f)) (cdddr ast))
;; printf returns i32
(list *impc:ir:si32*))))
(define impc:ti:string-check
(lambda (ast vars kts request?)
(if (string? ast)
(list (+ *impc:ir:si8* *impc:ir:pointer*))
'())))
(define impc:ti:carcdr-check
(lambda (ast vars kts request?)
;; check that we are getter a pair as an argument
(impc:ti:type-check (cadr ast) vars kts (list (impc:ir:pointer++ *impc:ir:pair*)))
;; don't do anything about return type yet
'()))
(define impc:ti:coerce-check
(lambda (ast vars kts request?)
(impc:ti:type-check (cadr ast) vars kts #f)
(list (caddr ast))))
(define impc:ti:closure-in-first-position
(lambda (ast vars kts request?)
;; first check return type of car ast (which will be a closure)
;; then check against it's arg types
(let ((type (impc:ti:type-check (car ast) vars kts request?)))
(if (null? type)
(print-error 'Compiler 'Error: 'Bad 'type 'for 'closure 'expression ast))
(if (not (impc:ir:type? type))
(set! type (car type)))
(if (<> (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (car type))
(print-error 'Compiler Error: 'Bad 'type 'for 'closure 'expression ast)
(begin (map (lambda (a b)
(impc:ti:type-check b vars kts a))
(cddr type)
(cdr ast))
(cadr type))))))
;; vars is statefull and will be modified in place
(define impc:ti:type-check
(lambda (ast vars kts request?)
;(println 'tc: ast)
;(println 'l1: (assoc 'l1 vars))
;(println 'type-check: ast 'vars: vars 'kts: kts 'request? request?)
(if *impc:ti:print-main-check* (println 'type-check: ast 'kts: kts 'request? request?))
(if *impc:ti:print-main-check* (println 'vars------: vars))
(cond ((null? ast) '())
((and (atom? ast) (number? ast)) (impc:ti:numeric-check ast vars kts request?))
((and (atom? ast) (symbol? ast)) (impc:ti:symbol-check ast vars kts request?)) ;#f)) ;request?))
((and (atom? ast) (string? ast)) (impc:ti:string-check ast vars kts request?))
((atom? ast) (print-error 'Compiler 'Error: 'internal 'error 'unhandled 'atom: ast))
((and (list? ast) (member (car ast) '(let let* letrec))) (impc:ti:let-check ast vars kts request?))
((and (list? ast) (member (car ast) '(lambda))) (impc:ti:lambda-check ast vars kts request?))
((and (list? ast) (member (car ast) '(* / + - % modulo bitwise-and bitwise-or bitwise-eor bitwise-shift-left bitwise-shift-right bitwise-not))) (impc:ti:math-check ast vars kts request?))
((and (list? ast) (member (car ast) '(< > = <>))) (impc:ti:compare-check ast vars kts request?))
((and (list? ast) (member (car ast) '(dotimes))) (impc:ti:dotimes-check ast vars kts request?))
((and (list? ast) (member (car ast) '(llvm_printf))) (impc:ti:printf-check ast vars kts request?))
((and (list? ast) (member (car ast) '(push_zone))) (impc:ti:push_zone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pop_zone))) (impc:ti:pop_zone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(memzone))) (impc:ti:memzone-check ast vars kts request?))
((and (list? ast) (member (car ast) '(callback))) (impc:ti:callback-check ast vars kts request?))
((and (list? ast) (member (car ast) '(llvm_sprintf))) (impc:ti:sprintf-check ast vars kts request?))
;((and (list? ast) (member (car ast) '(make-array))) (impc:ti:make-array-check ast vars kts request?))
((and (list? ast) (member (car ast) '(vector-set!))) (impc:ti:vector-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(vector-ref))) (impc:ti:vector-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(array-set!))) (impc:ti:array-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(array-ref))) (impc:ti:array-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(array-ref-ptr))) (impc:ti:array-ref-ptr-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pointer-set!))) (impc:ti:pointer-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pointer-ref))) (impc:ti:pointer-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pointer-ref-ptr))) (impc:ti:pointer-ref-ptr-check ast vars kts request?))
((and (list? ast) (member (car ast) '(stack-alloc))) (impc:ti:stack-alloc-check ast vars kts request?))
((and (list? ast) (member (car ast) '(heap-alloc))) (impc:ti:heap-alloc-check ast vars kts request?))
((and (list? ast) (member (car ast) '(zone-alloc))) (impc:ti:zone-alloc-check ast vars kts request?))
;((and (list? ast) (member (car ast) '(make-tuple))) (impc:ti:make-tuple-check ast vars kts request?))
((and (list? ast) (member (car ast) '(tuple-set!))) (impc:ti:tuple-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(tuple-ref))) (impc:ti:tuple-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(tuple-ref-ptr))) (impc:ti:tuple-ref-ptr-check ast vars kts request?))
((and (list? ast) (member (car ast) '(closure-set!))) (impc:ti:closure-set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(closure-ref))) (impc:ti:closure-ref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pref))) (impc:ti:pref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(pdref))) (impc:ti:pdref-check ast vars kts request?))
((and (list? ast) (member (car ast) '(null?))) (impc:ti:null?-check ast vars kts request?))
((and (list? ast) (member (car ast) '(impc_null))) (impc:ti:null-check ast vars kts request?))
((and (list? ast) (member (car ast) '(bitcast))) (impc:ti:bitcast-check ast vars kts request?))
((and (list? ast) (member (car ast) '(bitconvert))) (impc:ti:bitconvert-check ast vars kts request?))
((and (list? ast) (member (car ast) '(void))) (impc:ti:void-check ast vars kts request?))
((and (list? ast) ;; generic function
(symbol? (car ast))
(regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ir:gpoly-types (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))) ;"\\$\\$\\$")))))
;; (impc:ir:gpoly-types (car ast)))
;(println 'generic (car ast))
(impc:ti:nativef-generics ast vars kts request?))
((and (list? ast) ;; polymorphic function
(symbol? (car ast))
(regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ir:poly-types (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))) ;"\\$\\$\\$")))))
;(println 'poly (car ast))
(let ((reses (impc:ti:nativef-poly-check ast vars kts request?)))
;(println 'ast: ast reses)
reses))
((and (list? ast) ;; native function
(symbol? (car ast))
(llvm:get-function (symbol->string (car ast))))
(impc:ti:nativef-check ast vars kts request?))
((and (list? ast) (member (car ast) '(begin))) (impc:ti:begin-check ast vars kts request?))
((and (list? ast) (member (car ast) '(if ifret))) (impc:ti:if-check ast vars kts request?))
((and (list? ast) (member (car ast) '(set!))) (impc:ti:set-check ast vars kts request?))
((and (list? ast) (member (car ast) '(ret->))) (impc:ti:ret-check ast vars kts request?))
((and (list? ast) (assoc (car ast) vars)) (impc:ti:closure-call-check ast vars kts request?))
((and (list? ast) (list? (car ast))) (impc:ti:closure-in-first-position ast vars kts request?))
((and (list? ast) ;; this is here to check against closures as global vars (i.e. not in local environment)
(symbol? (car ast))
(llvm:get-globalvar (symbol->string (car ast)))
(impc:ir:closure? (impc:ir:get-type-from-str (llvm:get-global-variable-type (symbol->string (car ast))))))
(impc:ti:closure-call-check ast vars kts request?))
(else (impc:ti:join (impc:ti:type-check (car ast) vars kts request?)
(impc:ti:type-check (cdr ast) vars kts request?))))))
(define impc:ti:find-unresolved-simple-types
(lambda (union)
(let ((unresolved (cl:remove #f (map (lambda (x) ;; return the first bad variable that is not a closure
(if (null? (cdr x)) #f
(if (and (list? (cdr x)) ;; check there are multiple choices
(number? (cadr x))
(not (member (modulo (cadr x) *impc:ir:pointer*)
(list *impc:ir:tuple* *impc:ir:closure* *impc:ir:array* *impc:ir:vector*))) ;; make sure it's a base type (not closure or tuple)
(cl:every impc:ir:type? (cdr x))) ;; check that it's choices are valid (not null)
x #f)))
union))))
(if (null? unresolved) #f
unresolved))))
(define impc:ti:remove-single-element-lists
(lambda (l)
(map (lambda (k)
(println 'k k)
(if (list? k)
(if (= (length k) 1)
(car k)
(impc:ti:remove-single-element-lists k))
k))
l)))
(define impc:ti:clean-fvars
(lambda (vars)
(println 'cleaning: vars)
;; first remove all single element lists
(map (lambda (v)
(set-cdr! v (impc:ti:remove-single-element-lists (cdr v))))
vars)
(println 'vars2: vars)
vars))
;; run the type checker
;; if we fail to unify completely the first time
;; try some possible substitutions!
;; (define impc:ti:run-type-check
;; (lambda (vars forced-types ast . cnt)
;; ;; (println '------------------------------------)
;; ;; (println 'forced-types forced-types)
;; ;; (println 'vars: vars)
;; ;; (println 'run-type-check 'ast: ast)
;; ;(if (null? cnt) (sys:clear-log-view))
;; (let* ((fvars (map (lambda (t) ;; add any forced-type values to vars
;; (if (assoc (car t) forced-types)
;; (let ((tt (cdr (assoc (car t) forced-types))))
;; (cons (car t) (list tt)))
;; t))
;; vars))
;; ;(lll (println 'vars1: vars))
;; (kts (map (lambda (x) (car x)) forced-types)) ;; just need symbols from forced-types
;; ;; fvars gets modified 'in place' during this next operation
;; (ret (impc:ti:type-check ast fvars kts #f))
;; (llllllll (println 'pre-unified-vars: fvars))
;; (u (impc:ti:unify fvars))
;; (lllll (println 'post-unified-vars: u))
;; (t (impc:ti:unity? u))
;; ;(lllllll (println (println 'cccccc)))
;; (tt (cl:every (lambda (x) x) t))
;; (a (if tt #t
;; (impc:ti:find-unresolved-simple-types u))))
;; ;(println 'fvars: fvars)
;; ;(println 'types: u)
;; (if *impc:ti:print-unifications* (println 'tirun:> a '-> u))
;; ;(println 'tt: tt 'a: a 'u: u)
;; (println 'a: a)
;; ;; if we have unified types then return them otherwise run through options!
;; (if tt
;; u
;; (if (or (not (null? cnt)) ;; else if we're not on the first run die
;; (not a))
;; (if a a u)
;; ;; if we are on the first run then attempt substitutions
;; ;; we grab the first unresolved simple type and start
;; ;; testing each of it's options in turn
;; ;; also attempting to unify that choice with all other
;; ;; unresolved simple types before each run
;; (let ((res (map (lambda (x)
;; (println 'xxx: x)
;; ;; first clear vars
;; (impc:ti:clear-all-vars fvars)
;; (impc:ti:run-type-check fvars
;; ;; as well as all simple types which have resolved fully
;; (append (cl:remove-if-not (lambda (z) (and (not (list? z))
;; (pair? z))) u)
;; ;; and any simple types that unify on x
;; (cl:remove 'failed
;; (map (lambda (k)
;; (if (null? (cl:intersection (list x) (cdr k)))
;; 'failed
;; (cons (car k) x)))
;; (impc:ti:find-unresolved-simple-types u)))
;; forced-types)
;; ast 1))
;; (cdr (car a)))))
;; (let ((r (cl:find-if (lambda (x)
;; (cl:every (lambda (x) x) (impc:ti:unity? x)))
;; res)))
;; ;(println 'res: res)
;; ;; old version below as backup
;; (if (not r)
;; (apply print-error 'Compiler 'Error: 'could 'not 'resolve 'types:
;; (map (lambda (x) (symbol->string (car x)))
;; (cl:remove-if (lambda (x)
;; (impc:ir:type? (cdr x)))
;; (car res))))
;; (car res))
;; r)))))))
;; run the type checker
;; if we fail to unify completely the first time
;; try some possible substitutions!
;; (define impc:ti:run-type-check
;; (lambda (vars forced-types ast . cnt)
;; ;; (println '------------------------------------)
;; ;; (println 'forced-types forced-types)
;; ;; (println 'vars: vars)
;; ;; (println 'run-type-check 'ast: ast)
;; ;(if (null? cnt) (sys:clear-log-view))
;; (let* ((fvars (map (lambda (t) ;; add any forced-type values to vars
;; (if (assoc (car t) forced-types)
;; (let ((tt (cdr (assoc (car t) forced-types))))
;; (cons (car t) (list tt)))
;; t))
;; vars))
;; ;(lll (println 'vars1: vars))
;; (kts (map (lambda (x) (car x)) forced-types)) ;; just need symbols from forced-types
;; ;; fvars gets modified 'in place' during this next operation
;; (ret (impc:ti:type-check ast fvars kts #f))
;; (llllllll (println 'pre-unified-vars: fvars))
;; (u (impc:ti:unify fvars))
;; (lllll (println 'post-unified-vars: u))
;; (t (impc:ti:unity? u))
;; ;(lllllll (println (println 'cccccc)))
;; (tt (cl:every (lambda (x) x) t))
;; (a (if tt #t
;; (impc:ti:find-unresolved-simple-types u))))
;; ;(println 'fvars: fvars)
;; ;(println 'types: u)
;; (if *impc:ti:print-unifications* (println 'tirun:> a '-> u))
;; ;(println 'tt: tt 'a: a 'u: u)
;; ;(println 'a: a)
;; ;; if we have unified types then return them otherwise run through options!
;; (if tt
;; u
;; (if (not (null? cnt)) ;; else if we're not on the first run die
;; u
;; (begin (println 'failed-first-pass-with: u)
;; (if (not a)
;; (begin
;; ;; (let* ((ret2 (impc:ti:type-check ast
;; ;; (map (lambda (k)
;; ;; (if (list? k)
;; ;; k
;; ;; (cons (car k) (list (cdr k)))))
;; ;; u)
;; ;; kts #f))
;; (println 'known-types: (cl:remove #f (map (lambda (k) (if (impc:ir:type? (cdr k)) k #f)) u)))
;; (impc:ti:clear-all-vars fvars)
;; (let* ((ret (impc:ti:run-type-check fvars
;; ;; kts for all solved types
;; (cl:remove #f (map (lambda (k)
;; (if (impc:ir:type? (cdr k)) k #f))
;; u))
;; ast 1)))
;; ret))
;; ;; (u2 (impc:ti:unify fvars))
;; ;; (t2 (impc:ti:unity? u2))
;; ;; (tt2 (cl:every (lambda (x) x) t2))
;; ;; (a2 (if tt2 #t (impc:ti:find-unresolved-simple-types u2))))
;; ;; (println 'u2 u)
;; ;; u))
;; ;; if we are on the first run then attempt substitutions
;; ;; we grab the first unresolved simple type and start
;; ;; testing each of it's options in turn
;; ;; also attempting to unify that choice with all other
;; ;; unresolved simple types before each run
;; (let ((res (map (lambda (x)
;; ;; first clear vars
;; (impc:ti:clear-all-vars fvars)
;; (impc:ti:run-type-check fvars
;; ;; as well as all simple types which have resolved fully
;; (append (cl:remove-if-not (lambda (z) (and (not (list? z))
;; (pair? z))) u)
;; ;; and any simple types that unify on x
;; (cl:remove 'failed
;; (map (lambda (k)
;; (if (null? (cl:intersection (list x) (cdr k)))
;; 'failed
;; (cons (car k) x)))
;; (impc:ti:find-unresolved-simple-types u)))
;; forced-types)
;; ast 1))
;; (cdr (car a)))))
;; (let ((r (cl:find-if (lambda (x)
;; (cl:every (lambda (x) x) (impc:ti:unity? x)))
;; res)))
;; ;(println 'res: res)
;; ;; old version below as backup
;; (if (not r)
;; (apply print-error 'Compiler 'Error: 'could 'not 'resolve 'types:
;; (map (lambda (x) (symbol->string (car x)))
;; (cl:remove-if (lambda (x)
;; (impc:ir:type? (cdr x)))
;; (car res))))
;; (car res))
;; r)))))))))
;; run the type checker
;; if we fail to unify completely the first time
;; try some possible substitutions!
(define impc:ti:run-type-check
(lambda (vars forced-types ast . cnt)
;; (println '------------------------------------)
;; (println 'forced-types forced-types)
;; (println 'vars: vars)
;; (println 'run-type-check 'ast: ast)
;(if (null? cnt) (sys:clear-log-view))
(let* ((fvars (map (lambda (t) ;; add any forced-type values to vars
(if (assoc (car t) forced-types)
(let ((tt (cdr (assoc (car t) forced-types))))
(cons (car t) (list tt)))
t))
vars))
;(lll (println 'vars1: vars))
(kts (map (lambda (x) (car x)) forced-types)) ;; just need symbols from forced-types
;; fvars gets modified 'in place' during this next operation
(ret (impc:ti:type-check ast fvars kts #f))
;; (llllllll (println 'pre-unified-vars: fvars))
(u (impc:ti:unify fvars))
;; (lllll (println 'post-unified-vars: u))
(t (impc:ti:unity? u))
;(lllllll (println (println 'cccccc)))
(tt (cl:every (lambda (x) x) t))
(a (if tt #t
(impc:ti:find-unresolved-simple-types u))))
;(println 'fvars: fvars)
;(println 'types: u)
(if *impc:ti:print-unifications* (println 'tirun:> a '-> u))
;; if we have unified types then return them otherwise run through options!
(if tt
u
(if (and (not (null? cnt))
(member u (car cnt)))
u
(begin ;; (println 'failed-type-check-pass-with: u)
(if (not a) ;; this run is for generics
(begin ;; (println 'bingo1)
(impc:ti:clear-all-vars fvars)
(let* ((ret (impc:ti:run-type-check fvars
;; kts for all solved types
(cl:remove #f (map (lambda (k)
(if (impc:ir:type? (cdr k)) k #f))
u))
ast (cons u (if (null? cnt) cnt (car cnt))))))
ret))
;; try unresolved simple types
(begin ;; (println 'bingo2: a)
(let ((res (map (lambda (x) ;; call run-type-check for each version of a simple type
;; first clear vars
(impc:ti:clear-all-vars fvars)
(impc:ti:run-type-check fvars
;; as well as all simple types which have resolved fully
(append (cl:remove-if-not (lambda (z) (and (not (list? z))
(pair? z))) u)
;; and any simple types that unify on x
(cl:remove 'failed
(map (lambda (k)
(if (null? (cl:intersection (list x) (cdr k)))
'failed
(cons (car k) x)))
(impc:ti:find-unresolved-simple-types u)))
forced-types)
;; ast (cons u (car cnt))))
ast (cons u (if (null? cnt) cnt (car cnt)))))
(cdr (car a)))))
;; then see what versions might be OK?
(let ((r (cl:find-if (lambda (x)
(cl:every (lambda (x) x) (impc:ti:unity? x)))
res)))
(if (not r) ;; if no options are any good then :(
(apply print-error 'Compiler 'Error: 'could 'not 'resolve 'types:
(map (lambda (x) (symbol->string (car x)))
(cl:remove-if (lambda (x)
(impc:ir:type? (cdr x)))
(car res)))))
r))))))))))
;;
;;
;; Other utility code
;;
;;
;; add types to source
;; also add clrun for closure application
;; and inject polymorphic functions
(define impc:ti:add-types-to-source
(lambda (symname ast types envvars . prev)
;; (println 'symname: symname 'envvars: envvars 'ast: ast 'prev: prev)
(if (atom? ast) ast
(cond ((equal? (car ast) 'make-closure)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these lines just added by AS
(if (and (null? (cdr prev))
(list? (car prev)))
(set! prev (car prev)))
;; can safely be removed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(list (car ast)
(cadr ast)
;; global name
(string-append (symbol->string symname) "__" (number->string (llvm:count++)))
(if (or (null? prev) ;; this adds return type
(null? (cdr (assoc (car prev) types))))
*impc:ir:other*
(caddr (assoc (car prev) types)))
(map (lambda (v) ;; environment types
(if (member v envvars)
(let ((p (assoc v types)))
(cons (string->symbol (string-append (symbol->string (car p)) "__sub"))
(cdr p)))
(assoc v types)))
(cons symname (caddr ast)))
(map (lambda (v) ;; argument types
(assoc v types))
(cadddr ast))
(impc:ti:add-types-to-source symname (car (cddddr ast)) types (append envvars (caddr ast)))))
((equal? (car ast) 'clrun->)
(list* (car ast)
(cadr ast)
(map (lambda (arg type)
;(print 'clrunargs-> arg type)
(let ((a (impc:ti:add-types-to-source symname arg types envvars ast)))
(if (null? type)
(print-error 'Compiler 'Error: 'cannot 'infer 'closure 'type 'for
(symbol->string (cadr ast)))
a)))
(cddr ast)
(cdddr (if (not (assoc (cadr ast) types)) ;; if not in local env then get types from global var
(cons (cadr ast) (impc:ir:get-type-from-str (llvm:get-global-variable-type (symbol->string (cadr ast)))))
(assoc (cadr ast) types))))))
;; inject (and potential compile) generic functions
;; do generic functions before polys
((and (symbol? (car ast))
(regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ir:gpoly-types (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))) ;"\\$\\$\\$")))))
;; (println 'types types)
;; (println 'gpoly: (car ast))
;; (println 'gpoly: (impc:ir:gpoly-types (string->symbol (car (regex:split (symbol->string (car ast)) "\\$\\$\\$")))))
;; (println 'gpt: (assoc (car ast) types))
;;(println 'envvars: envvars)
;; (println 'ast: ast 'types: types)
;; (println (cdr (assoc (car ast) types)))
;; (println 'types types)
(if (null? (cdr (assoc (car ast) types)))
(print-error 'Compiler 'Error: 'could 'not 'resolve 'generic: ast 'types: types))
;;(println 'prev: prev)
(let* ((polyname (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
;(type (impc:ir:pretty-print-type (cdr (assoc (car ast) types))))
(type (if (null? (cdr (assoc (car ast) types)))
(print-error 'Compiler 'Error: 'unresolved 'type (car ast))
(impc:ir:pretty-print-type (cdr (assoc (car ast) types)))))
(code (caddr (cadr (impc:ir:gpoly-types polyname))))
;(lllll (println 'actual-code (caddr (cadr (impc:ir:gpoly-types polyname)))))
(exists (if (string=? type "") #f (impc:ir:check-poly polyname type))))
;; (println 'symname: symname 'poly polyname 'of 'type: type 'exists: exists)
(if (or exists ;; check to see if a poly function already exists for type
(string=? (car (regex:split (symbol->string (car ast)) "##")) ;"\\$\\$\\$")) ;; or recursive poly function
(car (regex:split (symbol->string symname) "--"))))
(if (string=? (car (regex:split (symbol->string (car ast)) "##")) ;"\\$\\$\\$")) ;; or recursive poly function
(car (regex:split (symbol->string symname) "--")))
(begin ;(println 'resursivepoly)
(cons 'clrun-> (cons symname
(map (lambda (jj)
(impc:ti:add-types-to-source symname jj types envvars ast))
(cdr ast)))))
(begin ;(println 'polyexists)
(cons exists
(map (lambda (jj)
(impc:ti:add-types-to-source symname jj types envvars ast))
(cdr ast)))))
(let ((pfunc (string->symbol (string-append (car (regex:split (symbol->string (car ast)) "##")) "--" (number->string (string-hash type))))))
(set! code `(let ((,pfunc ,code)) ,pfunc))
;(print)
;(println 'pfunc: pfunc 'type: type 'code: code)
;(println 'kts: (cons pfunc (string->symbol type)))
;(print)
(impc:ti:run pfunc code (cons pfunc (string->symbol type)))
(impc:ir:add-poly polyname pfunc type)
(let ((setter (llvm:get-function (string-append (symbol->string pfunc) "_setter"))))
(llvm:run setter (sys:create-mzone *impc:default-zone-size*)))
(cons pfunc
(map (lambda (jj)
(impc:ti:add-types-to-source symname jj types envvars ast))
(cdr ast)))))))
;; inject polymorphic functions
((and (symbol? (car ast))
(regex:match? (symbol->string (car ast)) "##")) ;"\\$\\$\\$"))
(let* ((pname (string->symbol (car (regex:split (symbol->string (car ast)) "##")))) ;"\\$\\$\\$"))))
(type (cdr (assoc (car ast) types)))
(polyname (impc:ir:check-poly pname type)))
;(println 'pname: pname 'type: type 'polyname: polyname)
(cons polyname
(map (lambda (jj)
(impc:ti:add-types-to-source symname jj types envvars ast))
(cdr ast)))))
;; environments
((member (car ast) '(make-env make-env-zone))
(list (car ast)
(cadr ast)
(map (lambda (p)
(list (assoc (car p) types)
(impc:ti:add-types-to-source symname (cadr p) types envvars (car p))))
(caddr ast))
(impc:ti:add-types-to-source symname (cadddr ast) types envvars)))
((or (and (assoc (car ast) types)
;; (if (null? prev) #t
;; (not (member (car ast) (car prev))))
(impc:ir:closure? (cdr (assoc (car ast) types))))
(and (not (list? (car ast)))
(symbol? (car ast))
;; (if (null? prev) #t
;; (not (member (car ast) (car prev))))
(llvm:get-globalvar (symbol->string (car ast)))
(impc:ir:closure? (llvm:get-global-variable-type (symbol->string (car ast))))))
;;(println 'bingo: ast envvars prev)
(impc:ti:add-types-to-source symname (cons 'clrun-> ast) types envvars))
((list? ast)
(map (lambda (x)
(impc:ti:add-types-to-source symname x types envvars ast))
ast))
(else (cons (apply impc:ti:add-types-to-source symname (car ast) types envvars)
(apply impc:ti:add-types-to-source symname (cdr ast) types envvars)))))))
;; this is uggglly and needs to be redone!!!!!!!
;; adds ret tags
(define impc:ti:mark-returns
(lambda (ast name in-body? last-pair? blocked?)
(cond ((atom? ast)
(if (and in-body? last-pair?)
(if blocked? ast (list 'ret-> name ast))
ast))
((pair? ast)
(cond ((equal? (car ast) 'if)
;; if statement need special syntax adjustments for returns
(append (if blocked? (list 'if) (list 'ifret)) (list (cadr ast))
(list (impc:ti:mark-returns (caddr ast) name in-body? last-pair? blocked?))
(if (not (null? (cdddr ast)))
(list (impc:ti:mark-returns (cadddr ast) name in-body? last-pair? blocked?)))))
((member (car ast) '(let* let letrec))
(append (list (car ast))
(list (map (lambda (a)
;; let assigns always block (lambda can override but nothing else)
(list (car a) (impc:ti:mark-returns (cadr a) (car a) #f #f #t)))
(cadr ast)))
(impc:ti:mark-returns (cddr ast) name #t #f blocked?)))
((member (car ast) '(lambda))
(append '(lambda) (list (cadr ast))
;; lambda always unblocks because lambdas always need a return
(impc:ti:mark-returns (cddr ast) name #t #f #f)))
;((equal? (car ast) 'dotimes)
; (append '(dotimes) (list (cadr ast)) (impc:ti:mark-returns (cddr ast) name #t #f blocked?)))
((equal? (car ast) 'begin)
(let* ((rev (reverse (cdr ast)))
(last (car rev))
(rest (reverse (cdr rev)))
(newast (append '(begin)
(append (map (lambda (a)
;; block everything except ...
(impc:ti:mark-returns a name in-body? #f #t))
rest)
;; the last one which we let through
;; ONLY if it hasn't been blocked higher up!
(list (impc:ti:mark-returns last name in-body?
(if blocked? #f #t)
blocked?))))))
newast))
((equal? (car ast) 'begin)
(append '(begin) (impc:ti:mark-returns (cdr ast) name in-body? #f blocked?)))
((and in-body? last-pair? (not blocked?)) ;; if everything is good add a return!
(list 'ret-> name (cons (car ast) (impc:ti:mark-returns (cdr ast) name in-body? #f #t))))
;(list 'ret-> name ast))
(else (cons (impc:ti:mark-returns (car ast) name in-body? #f blocked?)
(impc:ti:mark-returns (cdr ast) name in-body? #f blocked?))))))))
;; this is a dodgy flatten :(
(define impc:ti:flatten-1
(lambda (lst)
(cond ((null? lst) '())
((list? (car lst))
(append (car lst) (impc:ti:flatten-1 (cdr lst))))
(else (list lst)))))
;; find all free vars
;; currently we don't allow shadow vars
(define impc:ti:find-all-vars
(lambda (full-ast syms)
(letrec ((f (lambda (ast)
;(println 'ast: ast)
(cond ((pair? ast)
(cond ((and (symbol? (car ast)) ;; this for generics
(regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ir:gpoly-types (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))) ;"\\$\\$\\$")))))
;;(impc:ir:gpoly-types (car ast)))
;; (println 'generics ast (regex:split (symbol->string (car ast)) "(\\$\\$\\$)|(--)"))
;; (let ((gname (string->symbol (car (regex:split (symbol->string (car ast)) "(\\$\\$\\$)|(--)"))))
;; (gnum (string->number (cadr (regex:split (symbol->string (car ast)) "(\\$\\$\\$)|(--)")))))
(let ((gname (string->symbol (car (regex:split (symbol->string (car ast)) "(##)|(--)"))))
(gnum (string->number (cadr (regex:split (symbol->string (car ast)) "(##)|(--)")))))
(set! impc:ir:get-type-expand-poly #f)
;; (println 'gname: gname)
;; (println 'tt: (car (impc:ir:gpoly-types gname)))
;; (println 'type: (impc:ir:get-type-from-pretty-str (symbol->string (car (impc:ir:gpoly-types gname)))))
(letrec ((t (impc:ir:get-type-from-pretty-str (symbol->string (car (impc:ir:gpoly-types gname)))))
(ff (lambda (a)
;; (println 'aaa: a)
(cond ((null? a) 'done)
((atom? a)
(if (and (symbol? a) ;; GCHANGE
(or (regex:match? (symbol->string a) "^!")
(impc:ir:gpolytype-types (impc:ir:get-base-type-g (symbol->string a)))))
(let* ((newgsym (string-append (symbol->string a) "##" (number->string gnum))))
(set! syms (append (list (string->symbol newgsym)) syms)))
'done))
((list? a)
(ff (car a))
(ff (cdr a))
'done)
(else 'done)))))
(set! impc:ir:get-type-expand-poly #t)
(ff t)
(set! syms (cl:remove-duplicates (append syms (list (car ast)))))
(f (cdr ast)))))
((and (symbol? (car ast)) ;; this for polys
(regex:match? (symbol->string (car ast)) "##") ;"\\$\\$\\$")
(impc:ir:poly-types (string->symbol (car (regex:split (symbol->string (car ast)) "##"))))) ;"\\$\\$\\$")))))
;(println 'poly!var (car ast))
(set! syms (append (list (car ast)) syms))
(f (cdr ast)))
((equal? (car ast) 'make-closure)
(if (not (null? (cl:intersection (cadddr ast) syms)))
(print-error 'Compiler 'Error: 'Sorry 'single 'definition 'variables 'only! 'caught 'trying 'to 'redefine (symbol->string (car (cl:intersection (caddr ast) syms))) 'as 'a 'shadow 'variable))
(set! syms (cl:remove-duplicates (append (caddr ast) (cadddr ast) syms)))
(f (car (cddddr ast))))
((member (car ast) '(make-env make-env-zone))
(set! syms
(append (map (lambda (p)
(if (member (car p) syms)
(print-error 'Compiler 'Error: 'Sorry 'single 'definition 'variables 'only! 'caught 'trying 'to 'redefine (symbol->string (car p)) p 'as 'a 'shadow 'variable))
(car p))
(caddr ast))
syms))
(for-each (lambda (p)
(f (cadr p)))
(caddr ast))
(f (cadddr ast)))
(else (f (car ast))
(f (cdr ast)))))
((atom? ast) '())))))
(f full-ast)
syms)))
(define impc:ti:block:check-for-free-syms
(lambda (ast esyms)
;(print 'check: 'ast: ast 'esyms: esyms)
(cl:remove-duplicates (let loop ((lst ast))
(cond ((pair? lst)
(append (loop (car lst))
(loop (cdr lst))))
((atom? lst)
(if (member lst esyms)
(list lst)
'())))))))
;;
;; adds make-closure and make-env tags
;;
(define impc:ti:allocate-var?
(lambda (ast)
(cond ((null? ast) #f)
((eq? ast 'lambda) #t)
((pair? ast)
(or (impc:ti:allocate-var? (car ast))
(impc:ti:allocate-var? (cdr ast))))
(else #f))))
;; adds make-closure and make-env tags
(define impc:ti:closure:convert
(lambda (ast esyms)
(cond ((pair? ast)
(if (equal? (car ast) 'lambda)
(let (;(env (impc:ti:block:check-for-free-syms ast esyms))
(allocate-mem-for-vars? (impc:ti:allocate-var? (cdr ast))))
(list 'make-closure allocate-mem-for-vars?
;; name of compiled function is always last
;; so we can remove it by dropping it off the end
(cdr (reverse (cl:remove-duplicates esyms))) ;env
(cadr ast)
(impc:ti:closure:convert (caddr ast) (append (cadr ast) esyms))))
(if (member (car ast) '(let let* letrec))
(let* ((allocate-mem-for-vars? (impc:ti:allocate-var? ast))
(bindings (map (lambda (binding)
(car binding))
(cadr ast))))
;(free-syms (impc:ti:block:check-for-free-syms (cddr ast) (append bindings esyms))))
(cons 'make-env
(cons allocate-mem-for-vars?
(list (impc:ti:closure:convert (cadr ast) (append bindings esyms))
(impc:ti:closure:convert (caddr ast) (append bindings esyms))))))
(cons (impc:ti:closure:convert (car ast) esyms)
(impc:ti:closure:convert (cdr ast) esyms)))))
((atom? ast) ast))))
;; expects t1 (i.e. original untransformed code)
(define impc:ti:get-closure-arg-symbols
(lambda (closure-sym ast)
;(print 'ast: ast)
(cond ((null? ast) '())
((atom? ast) '())
((vector? ast) '())
((and (pair? ast)
(eq? (car ast) closure-sym))
(if (and (not (null? (cdr ast)))
(list? (cadr ast))
(eq? (caadr ast) 'lambda))
(cadr (cadr ast))
'()))
(else (append (impc:ti:get-closure-arg-symbols closure-sym (car ast))
(impc:ti:get-closure-arg-symbols closure-sym (cdr ast)))))))
(define impc:ti:handle-forced-types
(lambda (t1 . args)
(if (null? args) '()
(let* ((forced-types (map (lambda (t)
(map (lambda (tt)
(if (not (or (symbol? tt)
(list? tt)))
(print-error 'Compiler 'Error: 'Bad 'fixed 'type t)))
(if (list? t) (cdr t) (list (cdr t))))
(cons (car t) (impc:ir:convert-from-pretty-types (cdr t))))
args))
(forced-types-updated (apply append (list)
(map (lambda (t)
(if (and (impc:ir:closure? (cdr t))
(not (null? (impc:ti:get-closure-arg-symbols (car t) t1))))
(if (<> (length (cdddr t)) (length (impc:ti:get-closure-arg-symbols (car t) t1)))
(begin
;(println '------ (cdddr t) (impc:ti:get-closure-arg-symbols (car t) t1))
(print-error 'Compiler 'Error: 'bad 'type (cdr t) 'for (car t)))
(append (map (lambda (sym type)
(cons sym type))
(impc:ti:get-closure-arg-symbols (car t) t1)
(cdddr t))
(list t)))
(list t)))
forced-types)))
(checked-for-duplicates (let loop ((types forced-types-updated))
(if (null? types) (cl:remove-duplicates forced-types-updated)
(if (and (assoc (caar types) (cdr types))
(not (equal? (cdr (assoc (caar types) (cdr types)))
(cdr (car types)))))
(print-error 'Compiler 'Error: 'Type 'mismatch 'with 'fixed 'types
(assoc (caar types) (cdr types))
'and (car types) '- 'do 'you 'have 'a 'conflicing 'closure 'type?)
(loop (cdr types)))))))
;(print 'checked checked-for-duplicates 'forced-types-udpated forced-types-updated 'forced: forced-types)
checked-for-duplicates))))
(define impc:ti:get-closure-names
(lambda (ast . args)
(let ((blst '()))
(let loop ((alst ast))
(cond ((null? alst) '())
((atom? alst) '())
((pair? alst)
(if (equal? (car alst) 'make-closure)
(set! blst (cons (caddr alst) blst)))
(loop (car alst))
(loop (cdr alst)))))
blst)))
(define impc:ti:numeric-cast-operator
(lambda (a b)
(let* ((lowest (if (< a b) a b))
(highest (if (= a lowest) b a))
(caststr (string-append (if (impc:ir:floating-point? highest)
(if (= highest 0) "d" "f")
(impc:ir:pretty-print-type highest))
"to"
(if (impc:ir:floating-point? lowest)
(if (= lowest 0) "d" "f")
(impc:ir:pretty-print-type lowest)))))
caststr)))
;; an optional compiler stage to support some basic type coercions
;; particular math coercions of forced types
(define impc:ti:coercion-run
(lambda (ast forced-types)
;(println 'ast: ast)
(if (pair? ast)
(cond ((member (car ast) '(< > * / = + - <>))
(let ((a (assoc (cadr ast) forced-types))
(b (assoc (caddr ast) forced-types)))
(if (and (and a b)
(not (impc:ir:vector? (cdr a)))
(<> (cdr a) (cdr b)))
(let ((ret (string->symbol (impc:ti:numeric-cast-operator (cdr a) (cdr b)))))
(if (> (cdr a) (cdr b))
`(,(car ast) (,ret ,(cadr ast)) ,(caddr ast))
`(,(car ast) ,(cadr ast) (,ret ,(caddr ast)))))
(if (and a (number? (caddr ast)))
(if (and (impc:ir:floating-point? (cdr a))
(integer? (caddr ast)))
`(,(car ast) ,(cadr ast) ,(integer->real (caddr ast)))
(if (and (impc:ir:fixed-point? (cdr a))
(real? (caddr ast)))
`(,(car ast) ,(cadr ast) ,(real->integer (caddr ast)))
ast))
(if (and b (number? (cadr ast)))
(if (and (impc:ir:floating-point? (cdr b))
(integer? (cadr ast)))
`(,(car ast) ,(integer->real (cadr ast)) ,(caddr ast))
(if (and (impc:ir:fixed-point? (cdr b))
(real? (cadr ast)))
`(,(car ast) ,(real->integer (cadr ast)) ,(caddr ast))
ast))
ast)))))
(else (cons (impc:ti:coercion-run (car ast) forced-types)
(impc:ti:coercion-run (cdr ast) forced-types))))
ast)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define impc:ti:run
(lambda (symname code . args)
;; (println '-----------> 'impc:ti:run: symname)
;; (println 'code: code)
;(println 'args: args)
(set! *impc:ir:ls_var* '())
(set! *impc:ti:generic-type-mappings* '())
(set! *impc:ti:nativef-generics-recurse-test* 0)
;; don't want type checking to find existing native versions!
(if *impc:compile*
(begin ;(llvm:remove-globalvar (string-append (symbol->string symname) "_var"))
;(llvm:erase-function (symbol->string symname))
(llvm:erase-function (string-append (symbol->string symname) "_setter"))
(llvm:erase-function (string-append (symbol->string symname) "_maker"))))
(let* ((c code)
;(l (println 'c: code))
;(ct1 (now))
(c1 (impc:ti:get-var-types c)) ;; this is a cons pair of (ast . types)
;(ll (println 'c1vt: c1))
;(ct2 (now))
(t1 (impc:ti:first-transform (car c1) #t)) ;; car is ast
;(lllll (println 't1: t1))
;(ct3 (now))
(t2 (impc:ti:mark-returns t1 symname #f #f #f))
;(llllllll (println 't2: t2))
;(ct4 (now))
(t3 (impc:ti:closure:convert t2 (list symname)))
;(llllllllll (println 't3: t3))
;(ct5 (now))
(vars (map (lambda (x) (list x)) (impc:ti:find-all-vars t3 '())))
;(llllllllllll (println 'vars: vars))
;(ct6 (now))
(forced-types (apply impc:ti:handle-forced-types t1 (append (cdr c1) args)))
;(lllllllllllll (println 'forced-types: forced-types))
;(ct7 (now))
(t4 (impc:ti:coercion-run t2 forced-types)) ;; t4 and t5 are optional
;(ct8 (now))
(t5 (impc:ti:coercion-run t3 forced-types)) ;; also there is doubling dipping here :(
;(ct9 (now))
(typespre (impc:ti:run-type-check vars forced-types t4))
;(lllllll (println 'types-pre: typespre))
(types (impc:ti:type-normalize typespre))
;(lllllllll (println 'types-normal: types))
;(ct10 (now))
(newast '()))
;; (println 'types-post: types)
;; (println 'run: (impc:ti:unity? types))
;; (println 'newast: newast)
;; (println 'forced: forced-types)
;; (println 'times: (- ct2 ct1) (- ct3 ct2) (- ct4 ct3) (- ct5 ct4) (- ct6 ct5) (- ct7 ct6) (- ct8 ct7) (- ct9 ct8) (- ct10 ct9) (- ct11 ct10))
;; (println 'typesa types)
;; A FINAL TYPE CLEANUP
;;
;; finally we remove !bang types which ultimately don't need to be resolved fully
;; don't need to be resolved because they are helpers to resolution not reified types in their own right
;;
;; also we make sure that any types of the form (sym "%list...") are converted to (sym . "%list...")
;; in other words change list ("%list...") into atom "%list..."
(set! types (cl:remove #f (map (lambda (x)
(if (regex:match? (symbol->string (car x)) "^!") #f ;; remove !bang types
(if (list? (cdr x))
(if (= (length (cdr x)) 1)
(cons (car x) (cadr x))
x)
x)))
types)))
;; if we didn't unify print error and bomb out!
(if (not (cl:every (lambda (x) x) (impc:ti:unity? types)))
(begin
(println 'types_: types)
(print-error 'Compiler 'Error: 'could 'not 'resolve (symbol->string symname) 'unresolved 'types:
(cl:remove 'good (map (lambda (x y) (if y 'good (symbol->string (car x))))
types (impc:ti:unity? types)))
'you 'could 'try 'forcing 'the 'type 'of 'one 'or 'more 'of 'these 'symbols)))
;; if we have type checked ok then set addtypes to source and create new ast
(set! newast (impc:ti:add-types-to-source symname t5 (cl:tree-copy types) (list)))
;; if this function has been defined before make sure we aren't changing its signature!!
(if (and (llvm:get-function (symbol->string symname))
(or (<> (length (llvm:get-function-args-withoutzone (symbol->string symname)))
(length (cddr (assoc symname types))))
(cl:position #f (map (lambda (a b)
(equal? a b))
(cons (+ *impc:ir:closure*
*impc:ir:pointer*
*impc:ir:pointer*)
(map (lambda (x) (impc:ir:get-type-from-str x))
(llvm:get-function-args-withoutzone (symbol->string symname))))
(cdr (assoc symname types))))))
(print-error 'Compiler 'Error: 'sorry 'the 'compiler 'does 'not 'currently
'allow 'you 'to 'redefine 'or 'overload 'the 'type 'signature 'of 'existing 'functions.
'in 'this 'case (symbol->string symname) 'to:
(impc:ir:pptype (cdr (assoc symname types))) 'from:
(impc:ir:pptype (cons (+ *impc:ir:closure*
*impc:ir:pointer*
*impc:ir:pointer*)
(map (lambda (x) (impc:ir:get-type-from-str x))
(llvm:get-function-args-withoutzone (symbol->string symname)))))))
;(print-error "stop")
(if *impc:compiler:print-types* (println '---------------------------------))
(if *impc:compiler:print-types* (println 'types: types))
;(println 'ctypes: converted-types)
(if *impc:compiler:print-types* (println 'newast: newast))
;; check for unfound types
(for-each (lambda (t)
(if (not (impc:ir:type? (cdr t)))
(print-error 'Compiler 'Error: 'unresolved 'type 'error 'for 'symbol (car t))))
types)
;; compile to ir
(define fstr (impc:ir:compiler newast types))
;; compile to x86 - i.e. call jit on any new ir functions to force jit compilation
(for-each (lambda (fn) (llvm:jit-compile-function fn)) (impc:ti:get-closure-names newast))
;;
;; now compile ir to x86 and make stub code
(let* ((closure-type (cadr (impc:ir:gname)))
(closure-type-- (impc:ir:get-type-str (impc:ir:pointer-- (impc:ir:get-type-from-str closure-type))))
(compile-stub? (if (llvm:get-globalvar (string-append (symbol->string symname) "_var")) #f #t))
(fs (string-append "define ccc " closure-type " @" (string-append (symbol->string symname) "_maker")
"(i8* %_impz){\nentry:\n"
;; "%_zone = bitcast i8* %_impz to %mzone*\n"
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; new lines for impz
"%_impzPtr = alloca i8*\n"
"store i8* %_impz, i8** %_impzPtr\n"
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
fstr "}\n"))
(fssetter (string-append (if (llvm:get-globalvar (string-append (symbol->string symname) "_var"))
"" ;; if global var alread exists do nothing
(string-append "@" (symbol->string symname) "_var = global [1 x i8*] [ i8* null ]\n\n"
"@" (symbol->string symname) "_var_zone = global [1 x i8*] [ i8* null ]\n\n"))
"define ccc void @" (string-append (symbol->string symname) "_setter")
"(i8* %_impz){\nentry:\n"
"%oldzone1 = getelementptr [1 x i8*]* @" (symbol->string symname) "_var_zone, i32 0, i32 0\n"
"%oldzone2 = load i8** %oldzone1\n"
"%oldzone3 = bitcast i8* %oldzone2 to %mzone*\n"
"store i8* %_impz, i8** %oldzone1\n"
; existing code
"%closure = call ccc " (cadr (impc:ir:gname))
" @" (string-append (symbol->string symname) "_maker") "(i8* %_impz)\n"
"%ptr = bitcast " (cadr (impc:ir:gname)) " %closure to i8*\n"
"%varptr = bitcast [1 x i8*]* @" (symbol->string symname) "_var to i8**\n"
"store i8* %ptr, i8** %varptr\n"