compiler

#lang racket/base
;; Arc/Nu Compiler -- Manifest Destiny
;; http://www.youtube.com/watch?v=qXp3qjeM0e4

;; TODO: quasiquote is really slow (compare "\`(1 2 3 4 . 5)" in the timeit program)
;; TODO: look for uses of null? and replace them with empty-stream? as needed
;; TODO: use Racket's custom write/display stuff, so that printing infinite lists works
;; TODO: keyword args ???

(provide (all-defined-out)
         (all-from-out racket/base)
         #|#%app #%top #%datum quote begin set! lambda if let* #%top-interaction
         namespace-require|#
         )

(require racket/unsafe/ops)
(require racket/path)
(require racket/list)

;; Layer 1
(define names            (make-hasheq))
(define t                't)
(define nil              null)

(define exec-dir         (make-parameter #f))
(define filename         (make-parameter #f))

(define ac-read          (make-parameter #f))
(define ac-fn-call       (make-parameter #f))
(define ac-mac-call      (make-parameter #f))
(define ac-string        (make-parameter #f))
(define ac-ssexpand      (make-parameter #f))

(define debug?           (make-parameter #f))
(define hygienic-macros? (make-parameter #f))
(define hyper-static?    (make-parameter #f))

(define lang-cache       (make-parameter #f))
(define import-cache     (make-parameter #f))
(define import-dirs      (make-parameter #f))

(define local?           (make-parameter #f))
(define locals           (make-parameter #f))

(define procedure-var    (make-parameter #f))
(define box-constructor  (make-parameter #f))
(define assigned-globals (make-parameter #f))
(define orig-globals     (make-parameter #f))
(define exported-globals (make-parameter #f))
(define globals          (make-parameter #f))

(define ac-fn-let*       (make-parameter #f))
(define uniq-counter     (make-parameter #f))

(struct bypass (value))

(struct box (uniq file)
  #:constructor-name make-box
  #:guard (lambda (uniq file _)
            (if (symbol-interned? uniq)
                (values (string->uninterned-symbol (symbol->string uniq)) file)
                (values uniq file)))
  #:methods gen:custom-write
    [(define (write-proc x port mode)
       (display "#<box:" port)
       (display (box-uniq x) port)
       (display ">" port))])

(struct box-const     box ())
(struct box-parameter box ())

(struct tagged (type rep)
  ;; TODO: make mutable later, maybe
  ;#:mutable
  #:methods gen:custom-write
    [(define (write-proc x port mode)
       (begin (display "#(tagged " port)
              (display (tagged-type x) port)
              (display " " port)
              (display (tagged-rep x) port)
              (display ")" port)))])

(define (rel-path x)
  (build-path (current-load-relative-directory) x))

(define (list? x)
  (or (pair? x) (null? x)))

; TODO: is there seriously no built-in way to do this?
(define (->pair x)
  (cond ((null? x)
          x)
        ((null? (cdr x))
          (list (list (car x) null)))
        (else
          (cons (list (car x) (cadr x))
                (->pair (cddr x))))))

(define (hash-if-key hash key yes no)
  (if (hash-has-key? hash key)
      (yes hash (hash-ref hash key))
      (no hash)))

(define (hash-merge to from)
  (hash-for-each from
    (lambda (key val)
      (set! to (hash-set to key val))))
  to)

(define (hash-merge! to from)
  (hash-for-each from
    (lambda (key val)
      (hash-set! to key val))))

(define (hash-different? old key val)
  (or (not (hash-has-key? old key))
      (not (eq? (hash-ref old key) val))))

(define (hash-diff old new f)
  (hash-for-each new
    (lambda (key val)
      (when (hash-different? old key val)
        (f key val)))))

(define (fraction? x)
  (and (number? x)
       (exact? x)
       (not (integer? x))))

; TODO
(define (byte/string? x)
  (string? x)
  ;(or (string? x) (bytes? x))
)

;; generic comparison
(define (make-comparer a b c)
  (lambda (x y)
          ;; TODO: better ordering for speed
    (cond ((number? x)       (a x y))
          ((byte/string? x)  (b x y)) ; TODO test this on byte strings
          ((char? x)         (c x y))
          ((symbol? x)       (b (symbol->string x)
                                (symbol->string y)))
          (else              (a x y)))))

;; based on Arc's reduce. Can't use foldl because it doesn't work well with
;; multiple types (e.g. +-2)
(define (reduce f xs)
  (if (null? (cdr xs))
      (car xs) ;(f (car xs))
      (reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))))

(define (dottedrec f xs)
  (let self ((xs xs))
    (if (pair? xs)
        (cons (f (self (car xs))) ; TODO should this be (self (f ...)) ?
              (self (cdr xs)))
        (f xs))))

#|(define (keyword-args? args)
  (let self ((x args))
    (if (pair? x)
        (if (keyword? (car x))
            #t
            (self (cdr x)))
        #f)))|#

(define (ac-car x)
  (cond ((pair? x)
          (unsafe-car x))
        ((null? x)
          x)
        (else
          (raise-type-error 'car "cons" x))))

(define (ac-cdr x)
  (cond ((pair? x)
          (unsafe-cdr x))
        ((null? x)
          x)
        (else
          (raise-type-error 'cdr "cons" x))))

;; Layer 2
;; convert Racket booleans to Arc booleans
(define (tnil x) (if x t nil))

(define (sym->nil x)
  (if (eq? x 'nil) nil x))

;; definition of falseness for Arc's if
(define (false? x)
  (or (eq? x nil)
      (eq? x #f)))

;; (pairwise pred '(a b c d)) =>
;;   (and (pred a b) (pred b c) (pred c d))
;; pred returns #t/#f, pairwise returns t/nil
(define (pairwise pred lst)
        ; TODO: does this need to check the cdr?
  (cond ((null? (cdr lst))
          t)
        ((pred (car lst) (cadr lst))
          (pairwise pred (cdr lst)))
        (else nil)))

(define (make-reduce f init)
  (case-lambda
    ((x y) (f x y))
    ((x)   x)
    (()    init)
    (args  (reduce f args))))

;; Non-fn constants in functional position are valuable real estate, so
;; should figure out the best way to exploit it.  What could (1 foo) or
;; ('a foo) mean?  Maybe it should mean currying.
;;
;; For now the way to make the default val of a hash table be other than
;; nil is to supply the val when doing the lookup.  Later may also let
;; defaults be supplied as an arg to table.  To implement this, need: an
;; eq table within scheme mapping tables to defaults, and to adapt the
;; code in arc.arc that reads and writes tables to read and write their
;; default vals with them.  To make compatible with existing written tables,
;; just use an atom or 3-elt list to keep the default.
;;
;; experiment: means e.g. [1] is a constant fn
;;       ((or (number? fn) (symbol? fn)) fn)
;; another possibility: constant in functional pos means it gets
;; passed to the first arg, i.e. ('kids item) means (item 'kids).
(define ref
  (case-lambda
    ((x k)    (cond ((hash? x)         (hash-ref x k nil))
                    ((byte/string? x)  (string-ref x k)) ; TODO test this
                    ((pair? x)         (list-ref x k))
                    (else              (error "function call on inappropriate object" x k))))
    ((x k d)  (if   (hash? x)          (hash-ref x k d)
                                       (error "function call on inappropriate object" x k d)))
    (args     (apply error "function call on inappropriate object" args))))

;; Layer 3
(define (true? x)
  (not (false? x)))

(define (make-pairwise f)
  (case-lambda
    ((x y) (tnil (f x y)))
    ((x)   t)
    (()    t)
    (args  (pairwise f args))))

;; call a function or perform an array ref, hash ref, etc.
(define call
  ;; uses case-lambda for ridiculous speed: now using call for *all* function
  ;; calls is just as fast as using the funcall functions, and unlike
  ;; funcall, this hardcodes up to 6 arguments rather than only 4
  ;;
  ;; I could go higher but it'd be kinda pointless and would just make the
  ;; definition of call even bigger than it already is
  (case-lambda
    ((x)              (if (procedure? x)
                          (x)
                          (ref x)))
    ((x a)            (if (procedure? x)
                          (x a)
                          (ref x a)))
    ((x a b)          (if (procedure? x)
                          (x a b)
                          (ref x a b)))
    ((x a b c)        (if (procedure? x)
                          (x a b c)
                          (ref x a b c)))
    ((x a b c d)      (if (procedure? x)
                          (x a b c d)
                          (ref x a b c d)))
    ((x a b c d e)    (if (procedure? x)
                          (x a b c d e)
                          (ref x a b c d e)))
    ((x a b c d e f)  (if (procedure? x)
                          (x a b c d e f)
                          (ref x a b c d e f)))
    ((x . args)       ;(prn "warning: called with 7+ arguments:" x args)
                      (if (procedure? x)
                          (apply x args)
                          (apply ref x args)))))

(define (tagged-mac? x)
  (and (tagged? x)
       (eq? (tagged-type x) 'mac)))

;; Layer 4
(define (macro? x yes no)
  (let ((b (lookup x
             (lambda (x) x)
             (lambda ()  x))))
    (if (tagged-mac? b)
        (yes (tagged-rep b))
        (no))))

;; Layer 5
(define (fn-call-normal x args)
          ;; optimization for (#<fn> ...) and ((fn ...) ...)
  (if (or (procedure? x)
          (and (pair? x)
               (eq? (car x) 'lambda))
          (and (symbol? x)
               (hash-ref (procedure-var) x (lambda () #f)))
          ;; needed because call doesn't accept keyword args
          ;(keyword-args? args)
          )
      (cons x args)
      (list* call x args)))

(define (fn-call x args)
  (lookup x
    (lambda (f)
      (let ((x    (ac x))
            (args (ac-all args)))
        ((ac-fn-call) x f args (lambda () (fn-call-normal x args)))))
    (lambda ()
      (fn-call-normal (ac x) (ac-all args)))))

(define (mac-call x y)
  (macro? x
    (lambda (x) (ac (apply x y)))
    (lambda ()  (fn-call x y))))

(define (ac-call f args)
  (let ((f ((ac-ssexpand) f)))
    (if (pair? f)
        (let ((c (car f)))
          (macro? c
            (lambda (_)
              ((ac-mac-call) c f args (lambda () (mac-call f args))))
            (lambda ()
              (mac-call f args))))
        (mac-call f args))))

(define (->racket x)
  (if (null? x)
      ;; this causes it to return null
      ;null
      `(quote ,x)
      x))

(define (ac x)
  (cond ((symbol? x)
          (let ((y ((ac-ssexpand) x)))
            (if (eq? x y)
                (ac (->box y))
                (ac y))))
        ((box? x)
          (cond ((box-const? x)
                  (lookup x
                    (lambda (x)
                      (->racket x))
                    (lambda ()
                      (box-uniq x))))
                ((box-parameter? x)
                  (list (box-uniq x)))
                (else
                  (box-uniq x))))
        ((pair? x)
          (ac-call (car x) (cdr x)))
        ; TODO test this
        ((byte/string? x)
          ((ac-string) x))
        ((bypass? x)
          (bypass-value x))
        (else
          (->racket x))))

(define (ac-all x)
  (let self ((x x))
    (if (pair? x)
        (cons (ac (car x))
              (self (cdr x)))
        x)))

(define (macex1 e)
  (if (pair? e)
      (macro? (car e)
        (lambda (x)
          (let ((x (apply x (cdr e))))
            (if (bypass? x)
                e
                x)))
        (lambda () e))
      e))

(define (macex e)
  (let ((v (macex1 e)))
    (if (eq? v e)
        v
        (macex v))))

; TODO
(define (is? x y)
  (or (eqv? x y)
      ; TODO byte/string?
      (and (string? x) (string? y) (string=? x y))
      ;; TODO: why is this here in Arc 3.1?
      ;(and (false? x) (false? y))
      ))

;; Layer 6
; ac-quasiquote takes an Arc list containing a quasiquotation expression
; (the x in `x), and returns an Arc list containing Arc code.  The Arc
; code, when evaled by Arc, will construct an Arc list, the
; expansion of the quasiquotation expression.
;
; This implementation is a modification of Alan Bawden's quasiquotation
; expansion algorithm from "Quasiquotation in Lisp"
; http://repository.readscheme.org/ftp/papers/pepm99/bawden.pdf
(define (ac-quasiquote-atom x)
  (if (symbol? x)
      (if (hygienic-macros?)
          (if (global? x)
              (bypass (->box x))
              (->box x))
          (bypass `(quote ,x))) ; TODO (list (->orig-box 'quote) x) ?
      x))

(define (ac-quasiquote-start x rec)
  (if (pair? x)
      (let ((c (car x)))
              ; TODO orig-box?
        (cond ((eq? c rec)
                (ac-quasiquote-start (ac-quasiquote-start (cadr x) rec) rec))
              #|
              ; TODO orig-box?
              ((eq? c 'quote) ; TODO
                (ac-quasiquote-quote x rec))|#
              ; TODO orig-box?
              ((eq? c 'unquote)
                (cadr x))
              ; TODO orig-box?
              ((eq? c 'unquote-splicing)
                (error ",@ cannot be used immediately after `"))
              (else
                (ac-quasiquote-pair x rec))))
      (ac-quasiquote-atom x)))

(define (ac-quasiquote x [rec 'quasiquote])
  (ac-quasiquote-start x rec))

#|
; TODO: probably shouldn't special-case quote... figure out another way?
(define (ac-quasiquote-quote c rec)
  (list cons (ac-quasiquote-pair (car c) rec)
             ;(parameterize ((hygienic-macros? #f)) ) TODO
             (ac-quasiquote-pair (cdr c) rec)))|#

(define (ac-quasiquote-pair x rec)
  (if (pair? x)
      (let ((c (car x)))
              ;; TODO handle 'quote here too ?
                    ; TODO orig-box?
        (cond ((and (eq? c 'unquote)
                    (null? (cddr x)))
                (cadr x))
                    ; TODO orig-box?
              ((and (eq? c 'unquote-splicing)
                    (null? (cddr x)))
                (error "cannot use ,@ after ."))
              ((pair? c)
                      ; TODO orig-box?
                (cond ((eq? (car c) rec)
                        (list cons (ac-quasiquote-pair (ac-quasiquote-start (cadr c) rec) rec)
                                   (ac-quasiquote-pair (cdr x) rec)))
                      #|
                      ; TODO orig-box?
                      ((eq? (car c) 'quote)
                        (list cons (ac-quasiquote-quote c rec)
                                   (ac-quasiquote-pair (cdr x) rec)))|#
                      ; TODO orig-box?
                      ((eq? (car c) 'unquote)
                        (list cons (cadr c)
                                   (ac-quasiquote-pair (cdr x) rec)))
                      ; TODO orig-box?
                      ((eq? (car c) 'unquote-splicing)
                        (if (null? (cdr x))
                            (cadr c)
                            (list append (cadr c)
                                         (ac-quasiquote-pair (cdr x) rec))))
                      (else
                        ;; TODO: code duplication
                        (list cons (ac-quasiquote-pair c rec)
                                   (ac-quasiquote-pair (cdr x) rec)))))
              (else
                (list cons (ac-quasiquote-pair c rec)
                           (ac-quasiquote-pair (cdr x) rec)))))
      (ac-quasiquote-atom x)))

;=============================================================================
;  import
;=============================================================================
(define (->sym x)
  (cond ((symbol? x)
          x)
        ; TODO byte/string?
        ((string? x)
          (string->symbol x))
        (else
          (error (format "can't convert ~s to a symbol" x)))))

(define (->all-string args)
  (apply string-append (map ->string args)))

(define (->string x)
  (cond ((string? x)
          x)
        ((symbol? x)
          (symbol->string x))
        ((char? x)
          (string x)) ; TODO is this needed ?
        ((list? x)
          (->all-string x))
        ((number? x)
          (number->string x))
        ((path? x)
          (path->string x))
        ; TODO
        ((bytes? x)
          (bytes->string/utf-8 x))
        (else
          (error (format "can't convert ~s to a string" x)))))

(define (exists? p dir file none)
  (cond ((file-exists? p)
          (file p))
        ((directory-exists? p)
          (dir p))
        (else
          (none))))

(define (abspath x y)
  (normal-case-path
    (simplify-path
      (resolve-path
        (path->complete-path (expand-user-path x) y)))))

(define (find-filename p dir file)
  (let self ((x (import-dirs)))
    ;(path-only p)
    (if (pair? x)
        (let ((p (path->string (abspath p (car x)))))
          (exists? p dir file
            (lambda ()
                       ; TODO: don't hardcode .arc?
              (exists? (string-append p ".arc") dir file
                (lambda ()
                  (self (cdr x)))))))
        (error (format "file \"~a\" was not found" p)))))

(define (globals-diff old)
  ; TODO: how am I going to handle deletions?
  ;       maybe, rather than using a table, use a list of
  ;       functions, each of which sets or removes from the
  ;       global hash table
  (let ((new (exported-globals)))
    (globals (hash-merge old new))
    new))

(define (load-file p)
  (parameterize ((filename p)
                 (import-dirs (import-dirs)) ; TODO
                 (exported-globals (make-hasheq)))
    (let ((old (globals)))
      (call-with-input-file p
        (lambda (x)
          (let self ()
            (let ((x ((ac-read) x)))
              (if (eof-object? x)
                  (globals-diff old)
                  (let ((x (ac x)))
                    (begin (eval x)
                           (self)))))))))))

(define (ac-load p #:reimport [reimport #f]
                   #:export   [export   #f])
  (find-filename (->string p)
    (lambda (p)
      (import-dirs (cons p (import-dirs))))
    (lambda (p)
      (if reimport
          (hash-set! (import-cache) p (load-file p))
          (hash-if-key (import-cache) p
            (lambda (x y)
              (globals (hash-merge (globals) y)))
            (lambda (x)
              (hash-set! x p (load-file p)))))
      (when export
        (let ((hash (exported-globals)))
          (when hash
            (hash-merge! hash (hash-ref (import-cache) p)))))
      (void))))

(define (ac-lang lang f)
  (let ((path (abspath (build-path "lang" lang "main") (exec-dir))))
    (hash-if-key (lang-cache) path
      (lambda (x y)
        (call-with-parameterization y f))
      (lambda (x)
        (ac-init
          (lambda ()
            (parameterize ((current-load-relative-directory (path-only path))
                           (filename (path->string path)))
              (load path)
              (let ((y (current-parameterization)))
                (hash-set! x path y)
                (call-with-parameterization y f)))))))))

(define (w/lang x body)
  (let-values (((x glob)
                (ac-lang (symbol->string x)
                  (lambda ()
                    (let* ((old  (globals))
                           (body (ac-all body))
                           (new  (make-hasheq)))
                      (hash-diff old (globals) (lambda (key val)
                        (hash-set! new key val)))
                      (values (bypass
                                `(begin ,@body))
                              new))))))
    (globals (hash-merge (globals) glob))
    x))

;=============================================================================
;  fn
;=============================================================================
(define (ac-fn-push x y)
  (ac-fn-let* (cons (list x y) (ac-fn-let*))))

(define (ac-fn-destructure-cdr u args)
  (when (not (null? (cdr args)))
    (ac-fn-push u (list ac-cdr u))))

(define (ac-fn-destructure-car u x args)
  (ac-fn-push x (list ac-car u))
  (ac-fn-destructure-cdr u args))

(define (ac-fn-optional args)
  (let ((args (cddar args)))
    (if (null? args)
        (ac nil)
        (ac (car args)))))

(define (ac-fn-destructure u args)
  (cond ((pair? args)
          (if (pair? (car args))
              (if (eq? (caar args) 'o)
                  (begin (ac-fn-push (box-uniq (make-local-box (cadar args)))
                                     `(if (,pair? ,u)
                                          (,car ,u)
                                          ,(ac-fn-optional args)))
                         (ac-fn-destructure-cdr u args)
                         (ac-fn-destructure u (cdr args)))
                  (let ((v (gensym)))
                    (ac-fn-destructure-car u v args)
                    (ac-fn-destructure v (car args))
                    (ac-fn-destructure u (cdr args))))
              (begin (ac-fn-destructure-car u (box-uniq (make-local-box (car args))) args)
                     (ac-fn-destructure u (cdr args)))))
        ((not (null? args))
          (ac-fn-push (box-uniq (make-local-box args)) u))))

(define (ac-fn-args args)
  (cond ((pair? args)
          (if (pair? (car args))
              (if (eq? (caar args) 'o)
                  (cons (list (box-uniq (make-local-box (cadar args)))
                              (ac-fn-optional args))
                        (ac-fn-args (cdr args)))
                  (let ((u (gensym)))
                    (ac-fn-destructure u (car args))
                    (cons u (ac-fn-args (cdr args)))))
              (cons (box-uniq (make-local-box (car args)))
                    (ac-fn-args (cdr args)))))
        ((null? args)
          args)
        (else
          (box-uniq (make-local-box args)))))

(define (ac-fn1 parms body)
  (parameterize ((local? #t)
                 (locals (locals))
                 (ac-fn-let* null))
    (let* ((parms (ac-fn-args parms))
           (body  (ac-all (if (null? body)
                              (list nil)
                              body))))
      (if (null? (ac-fn-let*))
          `(lambda ,parms ,@body)
          `(lambda ,parms
             (let* ,(reverse (ac-fn-let*)) ,@body))))))

;=============================================================================
;  I/O
;=============================================================================
(define (read-square-brackets ch port src line col pos)
  `(square-brackets ,(read/recursive port #\[ #f)))

(define (read-curly-brackets ch port src line col pos)
  `(curly-brackets ,(read/recursive port #\{ #f)))

#|(define (read-keyword ch port src line col pos)
  (read/recursive (input-port-append #t (open-input-string "#:") port) #f #f))|#

(define arc-readtable
  (make-readtable #f #\[ 'terminating-macro read-square-brackets
                     #\{ 'terminating-macro read-curly-brackets
                     ;#\: 'non-terminating-macro read-keyword
                     ))

(define (warn . args)
  (display "warning: " (current-error-port))
  (for ((x args))
    (display x (current-error-port)))
  (newline (current-error-port)))

(define (make-write f)
  (lambda (c (out (current-output-port)))
    (f c out)
    c))

(define (make-read f)
  (lambda ((in (current-input-port)) (eof nil))
    (let ((x (f in)))
      (if (eof-object? x) eof x))))

(define (->name x)
  (or (hash-ref names x #f)
      (and (not (tagged? x))
           (object-name x))))

(define (nameit x y)
  (when (or (procedure? y)
            (tagged-mac? y))
    ; TODO: this uses symbols rather than boxes
    (hash-set! names y x))
  y)

(define (print-w/name x l m r port)
  (let ((x (->name x)))
    (display l port)
    (when x
      (display m port)
      (display x port))
    (display r port)))

(define (print-w/list f x port)
  (display "(" port)
  (let self ((x x))
    (if (pair? x)
        (begin (print f (car x) port)
               (unless (null? (cdr x))
                 (display " " port)
                 (self (cdr x))))
        (begin (display ". " port)
               (print f x port))))
  (display ")" port))

(define (print f x port)
        ;; TODO: should probably use (no x) or whatever
  (cond ((null? x)       (display "nil" port))
        ;; TODO: maybe use isa for pair? and procedure?
        ((pair? x)       (print-w/list f x port))
        #|((keyword? x)        (begin (display ":" port)
                                    (display (keyword->string x) port)))|#
        ((procedure? x)  (print-w/name x "#<fn" ":" ">" port))
        ((tagged-mac? x) (print-w/name x "#<mac" ":" ">" port))
        ((fraction? x)   (f (exact->inexact x) port))
        (else            (f x port)))
  nil)

;=============================================================================
;  Boxes
;=============================================================================
(define (ac-set-box a a2 b name first)
  (if (box? a2)
      (cond ((and (not first) (box-const? a2))
              (error (format "~a is immutable" a)))
            ((box-parameter? a2)
              (if first
                  ; TODO code duplication
                  `(set! ,(box-uniq a2) ,b)
                  (list (box-uniq a2) b)))
            (else
              `(set! ,(box-uniq a2) ,b)))
      (error (format "first argument to ~a must be a symbol: ~a" name a2))))

(define (ac-nameit a b)
  (if (global? a)
      (list nameit `(quote ,a) (ac b))
      (ac b)))

(define (set!-box name a b f #:first [first #f])
  (let* ((b   (ac-nameit a b))
         (a2  (if (symbol? a)
                  (f a)
                  a)))
    (ac-set-box a a2 b name first)))

(define (ac-assign1 a b name each)
  #|(when (and (global? a)
             (assigned-globals))
    (displayln a)
    (hash-set! (assigned-globals) a #t))|#
  (if (and each (pair? a))
      (set!-box name (car a) (each a b) ->box)
      (set!-box name a b ->box))
    #|(lambda (x)
      (if (hyper-static?)
          (->box x)
          (->global-alias x)))|#
)

(define (make-new-box x)
  (if (local?)
      (let ((x (make-local-box x)))
        (ac-fn-push (box-uniq x) #f)
        x)
      (make-global-box x)))

(define (ac-var1 a b name make)
  (set!-box name a b #:first #t
    (lambda (x)
      (parameterize ((box-constructor make))
        (make-new-box x)))))

(define (make-global-box x)
  (let ((r ((box-constructor) x (filename))))
    (globals (hash-set (globals) x r))
    (let ((hash (exported-globals)))
      (when hash
        (hash-set! hash x r)))
    r))

#|(define (->global-alias x)
  (if-global x
    (lambda (y)
      (let ((x (make-global-box x)))
        (set-box-alias! x y)
        ;(set-box-get! x (lambda ()  (ac y)))
        ;(set-box-set! x (lambda (x) `(set! ,(ac y) ,x)))
        x))
    (lambda ()
      (->box x))))|#

(define (make-local-box x)
  (let ((r ((box-constructor) x (filename))))
    (locals (hash-set (locals) x r))
    r))

; Used to create new global boxes, if they don't already exist
(define (->global-box! x)
  (hash-ref (globals) x
    (lambda ()
      (make-global-box x))))

; Used to convert a symbol to a box
(define (->box x)
  (hash-ref (locals) x
    (lambda ()
      (hash-ref (globals) x
        (lambda ()
          (if (hyper-static?)
              (error "undefined variable:" x)
              (make-global-box x)))))))

; Like ->box except it returns #f if the box doesn't exist
(define (->safe-box x)
  (hash-ref (locals) x
    (lambda ()
      (hash-ref (globals) x
        (lambda () #f)))))

(define (global? x)
  (and (symbol? x)
       (not (hash-has-key? (locals) x))))

(define (if-global x yes no)
  (if (and (global? x)
           (hash-has-key? (globals) x))
      (yes (hash-ref (globals) x))
      (no)))

(define (lookup-raw x yes no)
  (let* ((u (gensym))
         (x (namespace-variable-value x #t (lambda () u))))
    (if (eq? x u)
        (no)
        (yes x))))

(define (lookup x yes no)
  (let ((x (if-global x
             (lambda (x) x)
             (lambda ()  x))))
    (if (box? x)
        (lookup-raw (box-uniq x) yes no)
        (no))))

(define (set-raw n v)
  (namespace-set-variable-value!
    (box-uniq (->global-box! n))
    v
    #f))

(define (set-name n v)
  (set-raw n (nameit n v)))

(define (w/-maker body f)
  (let* ((old  (globals))
         (body (ac-all body))
         (new  (globals)))
    (globals (f old new))
    (bypass
      `(begin ,@body))))

(define (w/exclude1 old new x)
  (if (hash-has-key? old x)
      (hash-set new x (hash-ref old x))
      (hash-remove new x)))

;=============================================================================
;  Helper functions for macros
;=============================================================================
; (if)           -> nil
; (if x)         -> x
; (if t a ...)   -> a
; (if nil a b)   -> b
; (if nil a b c) -> (if b c)
(define (ac-if1 args)
        ;; TODO: maybe simplify this a little, like by using ac-cdr
  (cond ((null? args)
          (ac nil)) ; TODO: hardcodes null, rather than using the variable 'nil
        ((null? (cdr args))
          (ac (car args)))
        (else
          ;; TODO: fix this if I expose true? to Arc
          `(if (,true? ,(ac (car args)))
               ,(ac (cadr args))
               ,(ac-if1 (cddr args))))))

(define (ac-assign args name #:each [each #f])
  (let ((args (->pair args)))
    (bypass
      `(begin ,@(map (lambda (x) (ac-assign1 (car x) (cadr x) name each))
                     args)
              ,(ac (car (last args)))))))

(define (ac-var args name #:make [make make-box])
  (let ((args (->pair args)))
    (bypass
      `(begin ,@(map (lambda (x) (ac-var1 (car x) (cadr x) name make))
                     args)
              ,(ac (car (last args)))))))

(define (zip x)
  (apply map list x))

(define (ac-const1 x)
  (if (symbol? x)
      (parameterize ((box-constructor box-const))
        (let ((x (make-new-box x)))
          (procedure-var (hash-set (procedure-var) (box-uniq x) #t))
          x))
      x))

(define (ac-const args name)
  (parameterize ((procedure-var (procedure-var)))
    (let* ((args   (->pair args))
           (boxes  (map (lambda (x)
                          (ac-const1 (car x)))
                        args))
           (vals   (map (lambda (x)
                          (ac-nameit (car x) (cadr x)))
                        args)))
      (bypass
        `(begin ,@(map (lambda (x)
                         (ac-set-box (car x) (cadr x) (caddr x) name #t))
                       (zip (list (map car args) boxes vals)))
                ,(ac (last boxes)))))))

(define (ac-quote x)
  (let ((x (dottedrec sym->nil x)))
    (bypass `(quote ,x))))

(define (ac-if args)
  (bypass (ac-if1 args)))

(define (ac-fn parms body)
  (bypass (ac-fn1 parms body)))

(define (ac-uniq name num)
  (when (false? num)
    (set! num (uniq-counter))
    (uniq-counter (+ (uniq-counter) 1)))
  (string->uninterned-symbol
    (string-append (->string name)
                   (->string num))))

(define (%1 x)
  (if (and (symbol? x)
           (symbol-interned? x))
      (lookup-raw x
        (lambda (f)
          ;(if (procedure? f) f x)
          f)
        (lambda () x))
      x))

(define (% args)
  (bypass
    (let ((args (dottedrec %1 args)))
      (if (null? (cdr args))
          (car args)
          `(begin ,@args)))))

(define (w/include x body)
  (w/-maker body (lambda (old new)
    (for ((x x))
      (set! old (hash-set old x (hash-ref new x))))
    old)))

(define (w/exclude x body)
  (w/-maker body (lambda (old new)
    (for ((x x))
      (set! new (w/exclude1 old new x)))
    new)))

(define (w/rename x body)
  (w/-maker body (lambda (old new)
    (for ((x (->pair x)))
      (set! new (hash-set new (cadr x) (hash-ref new (car x))))
      (set! new (w/exclude1 old new (car x))))
    new)))

(define (w/prefix x body)
  (w/-maker body (lambda (old new)
    (hash-diff old new (lambda (key val)
      (set! old (hash-set old
                  (string->symbol (string-append (->string x) ; TODO ?
                                                 (->string key)))
                  val))))
    old)))

; TODO: re/im/export should probably eval its args
(define (import args)
  (for ((x args))
    (ac-load x))
  nil)

(define (export args)
  (for ((x args))
    (ac-load x #:export #t))
  nil)

(define (reimport args)
  (for ((x args))
    (ac-load x #:reimport #t))
  nil)

#|
; TODO: move orig-box stuff into arc/3.1/main
(define (init)
  (parameterize ((box-constructor make-box))
    (make-global-box 'fn)
    (make-global-box 'and)
    (make-global-box 'compose)
    (make-global-box 'complement)
    (make-global-box 'no)
    (make-global-box 'andf)
    (make-global-box 'string)
    (make-global-box 'quote)
    (make-global-box 'unquote)
    (make-global-box 'unquote-splicing)
    (make-global-box 'quasiquote)
    (make-global-box 'get)))|#

(define (ac-init f)
  (parameterize ((compile-allow-set!-undefined #f)
                 (ac-read          read)
                 (ac-fn-call       (lambda (x f args done) (done)))
                 (ac-mac-call      (lambda (c f args done) (done)))
                 (ac-string        (lambda (s) s))
                 (ac-ssexpand      (lambda (x) x))
                 (hygienic-macros? #f)
                 (hyper-static?    #f)
                 (box-constructor  make-box)
                 (globals          (orig-globals)))
    (f)))

(define (w/init dir path lang f #:debug [debug #f])
  ;; This is so that it's possible to retrieve the column/line of an input port
  ; (port-count-lines-enabled #t)
  (parameterize ((current-readtable arc-readtable)
                 (filename          (path->string path))
                 (debug?            debug)
                 (exec-dir          dir)
                 (import-dirs       (list ;(path->string (current-directory)) ; TODO
                                          ; TODO it should recursively search all folders in lib
                                          (path->string (build-path dir "lib"))
                                          (path->string (build-path dir "lib/arc3.1"))
                                          (path->string dir)
                                          ))
                 (import-cache      (make-hash))
                 (lang-cache        (make-hash))
                 (globals           (hasheq))
                 (locals            (hasheq))
                 (procedure-var     (hasheq))
                 (uniq-counter      1))
    ;(init)
    (parameterize ((orig-globals (globals)))
      (ac-lang lang (lambda ()
        ;; These files have Arc/Nu's dir prefixed to them
        ;; and are automatically loaded when Arc/Nu
        ;; starts up.
        #|(for ((x (list "02 arc"
                       "03 utils"
                       "04 paths"
                       "lib/strings"
                       "lib/re")))
          (ac-load (build-path dir x)))|#
        (f ac-load))))))