jlfrontend.scm

(load "./flisp/aliases.scm")
(load "./flisp/profile.scm")
(load "utils.scm")
(load "ast.scm")
(load "match.scm")
(load "macroexpand.scm")
(load "julia-parser.scm")
(load "julia-syntax.scm")


;; exception handler for parser. turns known errors into special expressions,
;; and prevents throwing an exception past a C caller.
(define (parser-wrap thk)
  (with-exception-catcher
   (lambda (e)
     (if (and (pair? e) (eq? (car e) 'error))
         (let ((msg (cadr e))
               (pfx "incomplete:"))
           (if (and (string? msg) (>= (string-length msg) (string-length pfx))
                    (equal? pfx
                            (substring msg 0 (string-length pfx))))
               `(incomplete ,msg)
               e))
         (begin
           ;;(newline)
           ;;(display "unexpected error: ")
           ;;(prn e)
           ;;(print-stack-trace (stacktrace))
           '(error "malformed expression"))))
   thk))

;; assigned variables except those marked local or inside inner functions
(define (find-possible-globals- e tab)
  (cond ((atom? e)   tab)
        ((quoted? e) tab)
        (else (case (car e)
                ((=)            (if (not (ssavalue? (cadr e)))
                                    (put! tab (decl-var (cadr e)) #t))
                                (find-possible-globals- (caddr e) tab))
                ((method)       (let ((n (method-expr-name e)))
                                  (if (symbol? n)
                                      (put! tab n #t)
                                      tab)))
                ((lambda)       tab)
                ((local)        tab)
                ((break-block)  (find-possible-globals- (caddr e) tab))
                ((module toplevel) '())
                (else
                 (for-each (lambda (x) (find-possible-globals- x tab))
                           (cdr e))))
              tab)))

;; find variables that should be forced to be global in a toplevel expr
(define (find-possible-globals e)
  (table.keys (find-possible-globals- e (table))))

;; this is overwritten when we run in actual julia
(define (defined-julia-global v) #f)

(define (some-gensym? x)
  (or (gensym? x) (memq x *gensyms*)))


;; return a lambda expression representing a thunk for a top-level expression
;; note: expansion of stuff inside module is delayed, so the contents obey
;; toplevel expansion order (don't expand until stuff before is evaluated).
(define (expand-toplevel-expr-- e)
  (let ((ex0 (julia-expand-macroscope e)))
    (if (and (pair? ex0) (eq? (car ex0) 'toplevel))
        ex0
        (let* ((ex (julia-expand0 ex0))
               (lv (find-decls 'local ex))
               (gv (diff (delete-duplicates
                           (append (find-decls 'const ex) ;; convert vars declared const outside any scope block to outer-globals
                                   (find-decls 'global ex) ;; convert vars declared global outside any scope block to outer-globals
                                   ;; vars assigned at the outer level
                                   (filter (lambda (x) (not (some-gensym? x)))
                                           (find-assigned-vars ex '()))))
                         lv))
               ;; vars assigned anywhere, if they have not been explicitly defined
               (existing-gv (filter (lambda (x) (and (not (or (memq x lv) (memq x gv))) (defined-julia-global x)))
                                    (find-possible-globals ex)))
               (th (julia-expand1
                    `(lambda () ()
                             (scope-block
                              (block ,@(map (lambda (v) `(implicit-global ,v)) existing-gv)
                                     ,@(map (lambda (v) `(implicit-global ,v)) gv)
                                     ,ex))))))
          (if (and (null? (cdadr (caddr th)))
                   (= 0 (cadddr (caddr th))))
              ;; if no locals, return just body of function
              (cadddr th)
              `(thunk ,th))))))

(define *in-expand* #f)

(define (expand-toplevel-expr e)
  (cond ((or (atom? e)
             (and (pair? e)
                  (or (memq (car e) '(toplevel line module import importall using export
                                               error incomplete))
                      (and (eq? (car e) 'global) (every symbol? (cdr e))))))
         (if (underscore-symbol? e)
             (syntax-deprecation #f "underscores as an rvalue" ""))
         e)
        (else
         (let ((last *in-expand*))
           (if (not last)
               (begin (reset-gensyms)
                      (set! *in-expand* #t)))
           (let ((ex (expand-toplevel-expr-- e)))
             (set! *in-expand* last)
             (if (and (length= ex 2) (eq? (car ex) 'body))
                 ;; (body (return x)) => x
                 (cadadr ex)
                 ex))))))

;; construct default definitions of `eval` for non-bare modules
;; called by jl_eval_module_expr
(define (module-default-defs e)
  (jl-expand-to-thunk
   (let* ((name (caddr e))
          (body (cadddr e))
          (loc (cadr body))
          (x (if (eq? name 'x) 'y 'x)))
     `(block
       (= (call eval ,x)
          (block
           ,loc
           (call (core eval) ,name ,x)))
       (= (call eval m ,x)
          (block
           ,loc
           (call (core eval) m ,x)))
       (= (call include ,x)
          (block
           ,loc
           (call (top include) ,name ,x)))))))

;; parse only, returning end position, no expansion.
(define (jl-parse-one-string s pos0 greedy)
  (let ((inp (open-input-string s)))
    (io.seek inp pos0)
    (let ((expr (parser-wrap (lambda ()
                               (if greedy
                                   (julia-parse inp)
                                   (julia-parse inp parse-atom))))))
      (cons expr (io.pos inp)))))

(define (jl-parse-string s filename)
  (with-bindings ((current-filename (symbol filename)))
    (parser-wrap (lambda ()
                 (let ((inp  (make-token-stream (open-input-string s))))
                   ;; parse all exprs into a (toplevel ...) form
                   (let loop ((exprs '()))
                     ;; delay expansion so macros run in the Task executing
                     ;; the input, not the task parsing it (issue #2378)
                     ;; used to be (expand-toplevel-expr expr)
                     (let ((expr (julia-parse inp)))
                       (if (eof-object? expr)
                           (cond ((null? exprs)     expr)
                                 ((length= exprs 1) (car exprs))
                                 (else (cons 'toplevel (reverse! exprs))))
                           (if (and (pair? expr) (eq? (car expr) 'toplevel))
                               (loop (nreconc (cdr expr) exprs))
                               (loop (cons expr exprs)))))))))))

(define (jl-parse-all io filename)
  (unwind-protect
   (with-bindings ((current-filename (symbol filename)))
    (let ((stream (make-token-stream io)))
      (let loop ((exprs '()))
        (let ((lineno (parser-wrap
                       (lambda ()
                         (skip-ws-and-comments (ts:port stream))
                         (input-port-line (ts:port stream))))))
          (if (pair? lineno)
              (cons 'toplevel (reverse! (cons lineno exprs)))
              (let ((expr (parser-wrap
                           (lambda ()
                             (julia-parse stream)))))
                (if (eof-object? expr)
                    (cons 'toplevel (reverse! exprs))
                    (let* ((iserr (and (pair? expr) (eq? (car expr) 'error)))
			   (next (list* expr
					;; for error, get most recent line number (#16720)
					(if iserr
					    `(line ,(input-port-line io))
					    `(line ,lineno))
					exprs)))
                      (if iserr
                          (cons 'toplevel (reverse! next))
                          (loop next))))))))))
   (io.close io)))

;; parse file-in-a-string
(define (jl-parse-string-stream str filename)
  (jl-parse-all (open-input-string str) filename))

(define (jl-parse-file filename)
  (trycatch
   (jl-parse-all (open-input-file filename) filename)
   (lambda (e) #f)))

(define *depwarn* #t)
(define (jl-parser-depwarn w)
  (let ((prev *depwarn*))
    (set! *depwarn* (eq? w #t))
    prev))

(define *deperror* #f)
(define (jl-parser-deperror e)
  (let ((prev *deperror*))
    (set! *deperror* (eq? e #t))
    prev))

; expand a piece of raw surface syntax to an executable thunk
(define (jl-expand-to-thunk expr)
  (parser-wrap (lambda ()
                 (expand-toplevel-expr expr))))

; run whole frontend on a string. useful for testing.
(define (fe str)
  (expand-toplevel-expr (julia-parse str)))

(define (profile-e s)
  (with-exception-catcher
   (lambda (e)
           (newline)
           (prn e))
   (lambda () (profile s))))