impc:ti:first-transform   scheme


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

Implementation

(define impc:ti:first-transform
  (lambda (ast inbody?)
    ;; (println 'ast: ast)
    (if (null? ast) '()
        (cond ((list? ast)
               (cond ((or (and (symbol? (car ast))
                               (impc:ti:get-polyfunc-candidate-types (symbol->string (car ast))))
                          (impc:ti:genericfunc-exists? (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?)))
                     ((and ;; exact poly match (with type)
                       (symbol? (car ast))
                       (regex:match? (symbol->string (car ast)) ":\\[")
                       ;;(impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string (car ast)) ":"))
                       (impc:ti:get-polyfunc-candidate (car (regex:type-split (symbol->string (car ast)) ":"))
                                                       (impc:ir:get-type-from-pretty-str
                                                        (cadr (regex:type-split (symbol->string (car ast)) ":")))))
                      (let ((p (regex:type-split (symbol->string (car ast)) ":")))
                        (cons
                         (impc:ti:get-polyfunc-candidate (car p)
                                                         (impc:ir:get-type-from-pretty-str (cadr p)))
                         (impc:ti:first-transform (cdr ast) inbody?))))
                     ((and ;; generic match (with type)
                       (symbol? (car ast))
                       (regex:match? (symbol->string (car ast)) ":\\[")
                       (impc:ti:genericfunc-exists? (car (regex:type-split (symbol->string (car ast)) ":"))))
                      (let* ((p (regex:type-split (symbol->string (car ast)) ":"))
                             (ptrdepth (impc:ir:get-ptr-depth (cadr p))))
                        (impc:ti:specialize-genericfunc (car p) (cadr p))
                        (cons
                         (string->symbol (impc:ir:pointer++ (string-append (car p) "_poly_" (cname-encode (cadr p))) (- ptrdepth 1)))
                         (impc:ti:first-transform (cdr ast) inbody?))))
                     ((and ;; non exact poly match with (with type)
                       (symbol? (car ast))
                       (regex:match? (symbol->string (car ast)) ":\\[")
                       (impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string (car ast)) ":"))))
                      (let* ((p (regex:type-split (symbol->string (car ast)) ":"))
                             (t (if (impc:ti:typealias-exists? (cadr p))
                                    (impc:ti:get-typealias-type (cadr p))
                                    (cadr p)))
                             (cname (cname-encode (impc:ir:get-base-type t)))
                             (ptrdepth (impc:ir:get-ptr-depth t)))
                        (cons
                         (string->symbol (string-append (car p) "_adhoc_" cname))
                         (impc:ti:first-transform (cdr ast) inbody?))))
                     ((eq? (car ast) 'letz)
                      (impc:ti:first-transform (impc:ti:letz ast) inbody?))
                     ((eq? (car ast) 'memzone)
                      (impc:ti:first-transform (impc:ti:memzone ast) inbody?))
                     ((eq? (car ast) 'beginz)
                      (impc:ti:first-transform (impc:ti:beginz ast) inbody?))
                     ((eq? (car ast) 'zone_cleanup)
                      (impc:ti:first-transform (impc:ti:zone_cleanup ast) inbody?))
                     ((eq? (car ast) '>=)
                      (impc:ti:first-transform (impc:ti:gteq ast) inbody?))
                     ((eq? (car ast) '<=)
                      (impc:ti:first-transform (impc:ti:lteq 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?))
                     ((or (eq? (car ast) 'strln)
                          (eq? (car ast) 'strj))
                      (impc:ti:first-transform (impc:ti:format (cdr ast)) inbody?))
                     ((eq? (car ast) 'sprintln)
                      (impc:ti:first-transform (impc:ti:sprintln (cdr ast)) inbody?))
                     ((eq? (car ast) 'sprintout)
                      (impc:ti:first-transform (impc:ti:sprintln2 (cdr ast)) inbody?))
                     ((eq? (car ast) 'println)
                      (impc:ti:first-transform (impc:ti:println (cdr ast)) inbody?))
                     ((eq? (car ast) 'printout)
                      (impc:ti:first-transform (impc:ti:println2 (cdr 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) '(vector_ref))
                      (impc:ti:first-transform `(let ((v1 (alloc)) (v2 (vector ,@(cdr ast)))) (pset! v1 0 v2) v1) inbody?))
                     ((member (car ast) '(array_ref))
                      (impc:ti:first-transform `(let ((a1 (alloc)) (a2 (array ,@(cdr ast)))) (pset! a1 0 a2) a1) inbody?))
                     ((member (car ast) '(tuple_ref))
                      (impc:ti:first-transform `(let ((t1 (alloc)) (t2 (tuple ,@(cdr ast)))) (pset! t1 0 t2) t1) inbody?))
                     ((member (car ast) '(vector))
                      `(make-vector ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast))))
                     ((member (car ast) '(array))
                      `(make-array ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast))))
                     ((member (car ast) '(tuple))
                      `(make-tuple ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast))))
                     ((eq? (car ast) 'not)
                      (impc:ti:first-transform (impc:ti:not (cadr ast)) inbody?))
                     ((member (car ast) '(callback schedule))
                      (impc:ti:first-transform (impc:ti:callback (impc:ti:first-transform (cdr ast) inbody?)) inbody?))
                     ((and (member (car ast) *impc:mathbinaryaritylist*)
                           (<> (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?))
                     ((member (car ast) *impc:lambdaslist*)
                      (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) '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) 'refcheck)
                      (list 'closure-refcheck
                            (impc:ti:first-transform (cadr ast) inbody?)
                            (symbol->string (caddr ast))))
                     ((member (car ast) '(cast convert))
                      (if (= (length ast) 2)
                          (impc:ti:first-transform (list (if (eq? (car ast) 'cast)
                                                             'bitcast
                                                             'bitconvert)
                                                         (cadr ast)) inbody?)
                          (let* ((p (regex:type-split (symbol->string (caddr ast)) ":"))
                                 (ptrdepth (impc:ir:get-ptr-depth (caddr ast)))
                                 (basetype (if (null? (cdr p)) #f (impc:ir:get-base-type (cadr p))))
                                 (etype (if (null? (cdr p)) #f (cname-encode basetype))))
                            (impc:ti:first-transform
                             (list (if (eq? (car ast) 'cast)
                                       'bitcast
                                       'bitconvert)
                                   (cadr ast)
                                   (if etype
                                       (string->symbol
                                        (impc:ir:pointer++ (string-append "%" (car p) "_poly_" etype)
                                                           ptrdepth))
                                       (string->symbol (car p))))
                             inbody?))))
                     ((eq? (car ast) 'doloop) (impc:ti:doloop ast inbody?))
                     ((eq? (car ast) 'dotimes) (impc:ti:dotimes ast inbody?))
                     ((eq? (car ast) 'while) (impc:ti:while ast inbody?))
                     ((member (car ast) *impc:letslist*)
                      (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))
                           (regex:match? (symbol->string (car ast)) ".*\\..*")
                           (not (regex:match? (symbol->string (car ast)) "\\.[0-9]*i$"))
                           ;; this last case here to catch of '.' in
                           ;; floating point numbers of type 1.000:float etc..
                           (not (number? (string->atom (car (regex:type-split (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:type-split (car (reverse subs)) ":"))
                                 (b (string->symbol (car subs2)))
                                 (c (string->symbol (cadr subs2))))
                            (cond ((and (= (length ast) 1) (= (length subs) 2)) ;; cref
                                   (impc:ti:first-transform (list 'cref a b c) inbody?))
                                  ((= (length subs) 2) ;; cset
                                   (impc:ti:first-transform (list 'cset! a b (cadr ast) c) inbody?))
                                  ((and (> (length subs) 2) (= (length ast) 2)) ;; multipart cset
                                   (impc:ti:first-transform
                                    (impc:ti:multicset
                                     (append (map (lambda (x) (string->symbol x))
                                                  (append (reverse (cdr (reverse subs))) subs2))
                                             (cdr ast)))
                                    inbody?))
                                  ((and (> (length subs) 2) (= (length ast) 1)) ;; multipart cref
                                   (impc:ti:first-transform
                                    (impc:ti:multicref
                                     (map (lambda (x) (string->symbol x))
                                          (append (reverse (cdr (reverse subs))) subs2)))
                                    inbody?))
                                  (else ;; error!
                                   (impc:compiler:print-compiler-error "Bad form!" ast))))
                          (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))
                           (impc:ti:xtmacro-exists? (symbol->string (car ast))))
                      (impc:ti:first-transform
                       (macro-expand (cons (string->symbol
                                            (string-append "xtmacro_"
                                                           (symbol->string (car ast))))
                                           (cdr 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
               ;; (println 'atom: ast)
               (cond ((rational? ast)
                      (impc:ti:first-transform `(Rat ,(rational->n ast) ,(rational->d ast)) inbody?))
                     ((eq? ast #f) '(impc_false))
                     ((eq? ast #t) '(impc_true))
                     ((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 '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 'vshuffle) 'vector-shuffle)
                     ((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 'randomf) 'imp_randf)
                     ((eq? ast 'void) '(void))
                     ((and (symbol? ast)
                           (regex:match? (symbol->string ast) "^[+-]?[0-9]*\\.?[0-9]*[+-][0-9]*\\.?[0-9]*i$"))
                      (let ((p (regex:matched (symbol->string ast) "^([+-]?[0-9]*\\.?[0-9]*)([+-][0-9]*\\.?[0-9]*)i$")))
                        ;;`(Cpxd ,(* 1.0 (string->number (cadr p))) ,(* 1.0 (string->number (caddr p))))))
                        (impc:ti:first-transform `(Cpxd ,(* 1.0 (string->number (cadr p))) ,(* 1.0 (string->number (caddr p)))) inbody?)))
                     ((and (symbol? ast)
                           (regex:match? (symbol->string ast) ":\\$(\\[|<)"))
                      (let ((t (impc:ti:expand-generic-type ast)))
                        (if (impc:ti:closure-exists? (symbol->string t))
                            t
                            (let ((p (regex:type-split (symbol->string t) "_poly_")))
                              (impc:ti:specialize-genericfunc (car p) (cname-decode (cadr p)))
                              t))))
                     ((and (symbol? ast)
                           (regex:match? (symbol->string ast) ":(f)|(i)|(f32)|(f64)|(float)|(double)|(i1)|(i8)|(i64)|(i32)|(i64)"))
                      (let ((p (regex:type-split (symbol->string ast) ":")))
                        (if (not (number? (string->atom (car p))))
                            ast
                            ;; otherwise do a convert
                            (cond ((string=? (cadr p) "f")
                                   (list 'bitconvert (string->atom (car p)) 'float))
                                  ((string=? (cadr p) "i")
                                   (list 'bitconvert (string->atom (car p)) 'i32))
                                  ((string=? (cadr p) "f32")
                                   (list 'bitconvert (string->atom (car p)) 'float))
                                  ((string=? (cadr p) "f64")
                                   (list 'bitconvert (string->atom (car p)) 'double))
                                  (else
                                   (list 'bitconvert (string->atom (car p)) (string->symbol (cadr p))))))))
                     (else ast)))))))


Back to Index