lib/coro.arc: add generators

lib/coro.arc: add generators

(require "lib/util.arc")
(require "lib/extend.arc")

; simpler than point and robust against changes in it, given that 'point
; indicates that the form it produces must only be used as an escape procedure.
(mac lcc (var . body)
  " Binds the current contination to `var' within `body'.
    See also [[point]] "
  `(ccc (fn (,var) ,@body)))

(def yielder (update consume)
  " Returns a fn that, when called, captures and calls `update' on its
    continuation, then applies `consume' to its arguments. A building block
    for coroutines in arc.
    See also [[cowrap]] "
  (fn args
    (lcc cont
      (update cont)
      (apply consume args))))

(def cowrap (func (o end nilfn))
  " `func' is called with a fn `yield' to produce a fn `inner'. 'cowrap returns
    a fn `wrapped' that, when called with input, gives it to `inner', then
    returns what `inner' subsequently calls `yield' with. If `inner' does not
    call `yield', `wrapped' returns the result of calling `end' on the input
    instead.
    See also [[yielder]] [[ccc]] "
  (let (enter exit done) nil
    (withs (yield (yielder (fn (k) (assign enter k))
                           (fn args (apply exit args)))
            outer (yielder (fn (k) (assign exit k))
                           (fn input
                             (assign done (fn () (apply end input)))
                             (apply enter input)
                             ; inner did not call yield.
                             ; can't just use compose without wrapping in fn
                             ; because values of 'exit and 'done can change.
                             ((= enter (fn _ (exit:done)))))))
      (= enter (func yield))
      outer)))

(mac cofn (name args . body)
  " Creates a coroutine which yields via `name', takes `args' as initial input,
    and executes `body'.
    See also [[yfn]] [[cowrap]] [[cofngen]] "
  `(cowrap (fn (,name) (fn ,args ,@body))))

(mac yfn (args . body)
  " Creates a coroutine which yields via 'yield, takes `args' as initial input,
    and executes `body'.
    See also [[cofn]] [[cowrap]] [[yfngen]] "
  `(cofn yield ,args ,@body))

(mac cofngen (name args . body)
  " Creates a coroutine generator which takes `args' and returns a coroutine
    which yields via `name', takes no initial input, and executes `body'.
    See also [[cofn]] [[yfngen]] "
  `(fn ,args (cofn ,name () ,@body)))

(mac yfngen (args . body)
  " Creaes a coroutine generator which takes `args' and returns a coroutine
    which yields via 'yield, takes no initial input, and executes `body'.
    See also [[yfn]] [[cofngen]] "
  `(cofngen yield ,args ,@body))

(mac coro (name args . body)
  " Defines a coroutine-generator `name' which takes `args' and returns a
    coroutine that yields via 'yield, takes no initial input, and executes
    `body'.
    See also [[yfn]] [[yfngen]] [[cowrap]] "
  `(def ,name ,args
     (yfn () ,@body)))

; generators - coroutines which take no input and can be iterated over
(def genwrap (func (o default-sym))
  " Returns a generator `gen'. When called, `gen' calls `func' with a `yield' fn
    and returns whatever `func' calls `yield' with. Successive calls continue
    `func' and return the results of `func''s successive calls to `yield'. `gen'
    may also be passed an argument; if `func' terminates, this argument is
    returned instead of nil.

    Generators can be iterated over with 'walk and 'each.

    See also [[cowrap]] [[cofngen]] "
  (annotate 'generator
            (cowrap (fn (yield) (fn _ (func yield)))
                    (fn ((o endsym default-sym)) endsym))))

(set-coercer 'fn 'generator rep)

(extend walk generator
  (fn (seq . _) (isa seq 'generator))
  (fn (gtor func) (w/uniq done
                    (afnwith ()
                      (let x (gtor done)
                        (unless (is x done)
                          (func x)
                          (self)))))))

(mac ngen (name . body)
  " Creates a generator executing `body' which uses `name' to yield.
    See also [[gen]] [[genwrap]] "
  `(genwrap (fn (,name) ,@body)))

(mac gen body
  " Creates a generator executing `body' which uses 'yield to yield.
    See also [[ngen]] [[genwrap]]"
  `(ngen yield ,@body))

(mac defgen (name args . body)
  " Defines a function `name' which returns a generator executing `body' that
    uses 'yield to yield.
    See also [[gen]] [[genwrap]] [[coro]] "
  `(def ,name ,args
     (gen ,@body)))

(defgen genwalk (l)
  " Turns anything that can be `walk'ed into a generator.
    See also [[walk]] [[gen]] [[genwrap]] "
  (walk l yield))

(require "lib/util.arc")

; simpler than point and robust against changes in it, given that 'point
; indicates that the form it produces must only be used as an escape procedure.
(mac lcc (var . body)
  " Binds the current contination to `var' within `body'.
    See also [[point]] "
  `(ccc (fn (,var) ,@body)))

(def yielder (update consume)
  " Returns a fn that, when called, captures and calls `update' on its
    continuation, then applies `consume' to its arguments. A building block
    for coroutines in arc.
    See also [[cowrap]] "
  (fn args
    (lcc cont
      (update cont)
      (apply consume args))))

(def cowrap (func (o end nilfn))
  " `func' is called with a fn `yield' to produce a fn `inner'. 'cowrap returns
    a fn `wrapped' that, when called with input, gives it to `inner', then
    returns what `inner' subsequently calls `yield' with. If `inner' does not
    call `yield', `wrapped' returns the result of calling `end' on the input
    instead.
    See also [[yielder]] [[ccc]] "
  (let (enter exit done) nil
    (withs (yield (yielder (fn (k) (assign enter k))
                           (fn args (apply exit args)))
            outer (yielder (fn (k) (assign exit k))
                           (fn input
                             (assign done (fn () (apply end input)))
                             (apply enter input)
                             ; inner did not call yield.
                             ; can't just use compose without wrapping in fn
                             ; because values of 'exit and 'done can change.
                             ((= enter (fn _ (exit:done)))))))
      (= enter (func yield))
      outer)))

(mac cofn (name args . body)
  " Creates a coroutine which yields via `name', takes `args' as initial input,
    and executes `body'.
    See also [[yfn]] [[cowrap]] [[cofngen]] "
  `(cowrap (fn (,name) (fn ,args ,@body))))

(mac yfn (args . body)
  " Creates a coroutine which yields via 'yield, takes `args' as initial input,
    and executes `body'.
    See also [[cofn]] [[cowrap]] [[yfngen]] "
  `(cofn yield ,args ,@body))

(mac cofngen (name args . body)
  " Creates a coroutine generator which takes `args' and returns a coroutine
    which yields via `name', takes no initial input, and executes `body'.
    See also [[cofn]] [[yfngen]] "
  `(fn ,args (cofn ,name () ,@body)))

(mac yfngen (args . body)
  " Creaes a coroutine generator which takes `args' and returns a coroutine
    which yields via 'yield, takes no initial input, and executes `body'.
    See also [[yfn]] [[cofngen]] "
  `(cofngen yield ,args ,@body))

(mac coro (name args . body)
  " Defines a coroutine-generator `name' which takes `args' and returns a
    coroutine that yields via 'yield, takes no initial input, and executes
    `body'.
    See also [[yfn]] [[yfngen]] [[cowrap]] "
  `(def ,name ,args
     (yfn () ,@body)))


Update for flonums 	modified:   codegen.arc

;------------------------------------------------------------------------------

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [do1 lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count)]
     constant-todo '()
     constant-count 0
     add-constant [do1 constant-count
                       (push _ constant-todo)
                       (++ constant-count)]
     code-gen nil
     compile-all-lambdas nil
     compile-constants nil)

  (= code-gen (fn (ast stack-env)
    (let (cg-list cg-args access-var cg) nil
      (= cg-list (fn (asts vars stack-env sep k)
        (if (no asts)
          (k "" stack-env)
          (let x (code-gen (car asts) stack-env)
            (cg-list (cdr asts) (cdr vars) (cons (car vars) stack-env) sep (fn (code stack-env) (k (list x sep code) stack-env)))))))

      (= cg-args (fn (args stack-env)
        (cg-list args (range 1 (len args)) stack-env "" (fn (code stack-env) code))))

      (= access-var (fn (var stack-env)
        (if (aglobal var)
          (let i (pos var global-vars)
            (list "GLOBAL(" i "/*" var!uid "*/)"))
          (let i (- (len stack-env) (pos var stack-env) 1)
            (list "LOCAL(" i "/*" var!uid "*/)")))))

      (= cg (fn (ast)
        (if
          (alit ast)
            (let val ast!val
              (if
                (no val) (list " PUSH(NILOBJ);")
                (is val t) (list " PUSH(TOBJ);")
                (isa val 'char) (list " PUSH(CHAR2OBJ(" coerce.val!int "));")
                (isa val 'string) (list " PUSH((obj)utf82str(\"" val "\"));")
                (isa val 'num) (list " PUSH((obj)DBL2OBJ(" val "));")
                (list " PUSH(FIX2OBJ(" (coerce (num val) 'int) "));"))) ; Just be sure it is an actual int, not something like 1.0
          (aquote ast)
            (let val ast!val
              (list " PUSH(QUOTE_CONSTANTS[" (add-constant val) "]"
                    "/* '" (tostring:write val) " */);"))
          (aref ast)
            (list " PUSH(" (access-var ast!var stack-env) ");")
          (aset ast)
            (list (cg (car ast!subx)) " " (access-var ast!var stack-env) " = TOS();")
          (acnd ast)
            (let x (map cg ast!subx)
              (list (car x) "\n if (POP() != NILOBJ) {\n" (cadr x) "\n } else {\n" (car:cddr x) "\n }"))
          (aprim ast)
            (let args ast!subx
              (if
                (is ast!op '%sharedvar)
                  (list (cg-args args stack-env) " MAKE_SHAREDVAR();")
                (is ast!op '%sharedvar-read)
                  (list (cg-args args stack-env) " READ_SHAREDVAR();")
                (is ast!op '%sharedvar-write)
                  (list (cg-args args stack-env) " WRITE_SHAREDVAR();")
                (is ast!op '%sref) (list (cg-args args stack-env) " SREF();")
                (is ast!op '%cons) (list (cg-args args stack-env) " CONS();")
                (is ast!op '%car) (list (cg-args args stack-env) " CAR();")
                (is ast!op '%cdr) (list (cg-args args stack-env) " CDR();")
                (is ast!op '%len) (list (cg-args args stack-env) " LEN();")
                (is ast!op '%type) (list (cg-args args stack-env) " TYPE();")
                (is ast!op '%annotate) (list (cg-args args stack-env) " ANNOTATE();")
                (is ast!op '%rep) (list (cg-args args stack-env) " REP();")
                (is ast!op '%is) (list (cg-args args stack-env) " EQ();")
                (is ast!op '%isnt) (list (cg-args args stack-env) " NEQ();")
                (is ast!op '%<) (list (cg-args args stack-env) " LT();")
                (is ast!op '%>) (list (cg-args args stack-env) " GT();")
                (is ast!op '%<=) (list (cg-args args stack-env) " LE();")
                (is ast!op '%>=) (list (cg-args args stack-env) " GE();")
                (is ast!op '%+) (list (cg-args args stack-env) " ADD();")
                (is ast!op '%-) (list (cg-args args stack-env) " SUB();")
                (is ast!op '%*) (list (cg-args args stack-env) " MUL();")
                (is ast!op '%pr) (list (cg-args args stack-env) " PR();")
                (is ast!op '%prn) (list (cg-args args stack-env) " PRN();")
                (is ast!op '%table) (list (cg-args args stack-env) " TBL();")
                (is ast!op '%halt) (list (cg-args args stack-env) " HALT();")
                (is ast!op '%closure)
                  (withs
                    (i (add-lambda (car args))
                     n (len (cdr args))
                     s (list "CLOSURE(" i "," n ");"))
                    (list (cg-args (cdr args) stack-env) " BEGIN_" s (map [list " INICLO(" _ ");"] (rev:range 1 n)) " END_" s))
                (is ast!op '%closure-ref)
                  (let i ((cadr args) 'val)
                    (list (cg (car args)) " TOS() = CLOSURE_REF(TOS()," i ");"))
                (err "unknown primitive" ast!op)))
          (anapp ast)
            (withs
              (fun (car ast!subx)
               args (cdr ast!subx)
               n (len args))
              (if (alam fun)
                (cg-list args (properify fun!params) stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
                (cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
                  (with
                    (start (len stack-env)
                     s (list "JUMP(" n ");"))
                    (list code " BEGIN_" s (map [list " PUSH(LOCAL(" (+ _ start) "));"] (range 0 (- n 1))) " END_" s))))))
          (alam ast) ; this case is impossible after CPS-conversion
            (list " PUSH(FIX2OBJ(" (add-lambda ast) "));")
          (aseq ast) ; this case is impossible after CPS-conversion
            (map [list (cg _) "DROP();"] ast!subx)
            (err "unknown ast" ast))))

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            ; if variadic, insert variadic handling code
            (if (dotted ast!params)
              ; determine the number of required arguments
              (let num-reqs (- (len:properify ast!params) 1)
                (list " VARIADIC2LIST(" num-reqs ");\n")))
            ; <insert code to check that caller passed
            ; correct number of arguments here>
            (code-gen (car ast!subx) (rev:properify ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (= compile-constants
    (fn (cs)
      (with (i 0
             express nil)
        (= express
           (fn (e)
             (if
               (number e) (list "FIX2OBJ(" e ")")
               (no e) "SYM2OBJ(\"nil\")"
               (isa e 'sym) (list "SYM2OBJ(" (tostring:write:string e) ")")
               (acons e)
                 (list "cons_fun(" (express:car e) ", " (express:cdr e) ")")
               ;else
                 (err:string "not supported in quote form: "
                             (tostring:write e)))))
        (mapeach c cs
          (do1
            (list "QUOTE_CONSTANTS[" i "] = " (express c) ";\n")
            (++ i))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 2000 "\n" "#define NB_QUOTE_CONSTANTS " constant-count "\n")
      code-header*
      (if constant-todo
        ; constants were defined; initialize
        (list "void init_constants(void){\n"
              (compile-constants:rev constant-todo)
              "}\n")
        ; no constants; dummy initialize
        "\n#define init_constants()\n")
      code-prefix*
      code-execute*
      code
      code-suffix*))))

(def readtxtfile (name)
  (w/infile f name
    (let res ""
      (whilet line (readline f) (++ res (string line "\n")))
      res)))

(= code-header* (readtxtfile "a2c.h")  ; typedefs, function headers & macros
   code-prefix* (readtxtfile "a2c.c")) ; predefined functions

(= code-execute* "

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");
  long num_args = 0;

  jump: switch (pc) {

")

(= code-suffix* "  }
  return POP();
}
")

;------------------------------------------------------------------------------

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        ; actually, shouldn't properify the params, maybe okay since this is debug code, but...
        (list 'let (map (fn (p a) (list p!uid (source a))) (properify ((car ast!subx) 'params)) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map-improper [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (list 'quote ast!val)
      ; if unknown AST, then probably still in list form
      ; (cref driver)
      ast))

; seems currently unused -
; note that this function doesn't support varargs
(def ds (ast)
   (if
      (alit ast)
          (cons 'lit ast!val)
      (aref ast)
         (cons 'ref ((ast 'var) 'uid))
      (aset ast)
         (cons 'set (list 'set ((ast 'var) 'uid) (ds (car ast!subx))))
      (acnd ast)
         (cons 'cnd (cons 'if (map ds ast!subx)))
      (aprim ast)
         (cons 'prim (cons ast!op (map ds ast!subx)))
      (anapp ast)
      (cons 'app
         (if (alam (car ast!subx))
            (list 'let (map (fn (p a) (list p!uid (ds a))) ((car ast!subx) 'params) (cdr ast!subx)) (ds (car ((car ast!subx) 'subx))))
            (map ds ast!subx)))
      (alam ast)
         (cons 'lam (list 'fn (map [_ 'uid] ast!params) (ds (car ast!subx))))
      (aseq ast)
         (cons 'seq (cons 'do (map ds ast!subx)))
         ast))

; abstract away avoiding ' and the quoted parts of `
; body *must* return the value in 'var if it won't
; change anything
(mac code-walk (var code . body)
  (w/uniq usercode
    `(let ,usercode (fn (,var) ,@body)
       (*code-walk-internal ,usercode ,code))))

(def *code-walk-internal (usercode code)
  (let pass-to-user
       (fn (c)
         (let new-code (usercode c)
           (if (isnt new-code c)
               ; if change, rewalk the new code
               ; (don't move on unless code is stable)
               (*code-walk-internal usercode new-code)
               (if (acons new-code)
                   (map-improper [*code-walk-internal usercode _] new-code)
                   new-code))))
    (if (acons code)
        (if
          (is (car code) 'quote)
            code
          (is (car code) 'quasiquote)
            (list 'quasiquote
               ((rfn quasiwalk (code)
                   (if (acons code)
                       (if
                         (is (car code) 'unquote)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         (is (car code) 'unquote-splicing)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         ; else
                           (map-improper quasiwalk code))
                       code))
                 (cadr code)))
          ; else
            (pass-to-user code))
        (pass-to-user code))))

(def to-3-if (l)
  (code-walk code l
    (if
      (and (caris code 'if) (len> code 4))
        (let (_ c v . rest) code
          `(if ,c ,v (if ,@rest)))
      ; else
        code)))

(def symbol-syntax (l)
  (code-walk code l
    (remove-ssyntaxes code)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def remove-ssyntaxes (code)
  (if
    (and (acons code) (ssyntax:car code))
      (let (fun . args) code
        (zap ssexpand fun)
        (if (caris fun 'compose)
            ((afn ((fun . rest))
               (if rest
                   `(,fun ,(self rest))
                   `(,fun ,@args)))
             (cdr fun))
            `(,fun ,@args)))
    (ssyntax code)
      (ssexpand code)
    code))

; handles (toplevel) 'load and 'require
; inefficiency note: allocs a lot of cons cells
(def include-files (l)
  (mappend
    (fn (e)
      ; if it's a 'load or 'require, include it
      (if (and (acons e) (in (car e) 'load 'require))
          (let (_ file . oops) e
            (when oops
              (err:string "Too many parameters to: " (car e)))
            ; make sure to recursively handle including files
            (include-files
              (w/infile s file
                (readall s (list 'detect-eof)))))
          (list e)))
    l))

;------------------------------------------------------------------------------

(def strip-ext (filename)
  (cut filename 0 (pos #\. filename)))

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (cons 'do (readall s (list 'detect-eof))))
         chain
         `(
            ; --------List form
            (,include-files "FILE INCLUSION")
            ; NOTE: all the 'code-walk passes might be
            ; better off in a single pass (just use a large
            ; 'if block).  Especially with regards to macros
            ; and symbol syntax: a ssyntax might emit a macro,
            ; which might emit a ssyntax, which might emit
            ; a macro... 'code-walk can actually handle this
            ; but only if macros and ssyntax expansion are
            ; in the same 'code-walk block
            (,symbol-syntax "ssyntax TRANSFORMATION")
            (,to-3-if "3-arg-if TRANSFORMATION")
            ; --------AST form
            (,[xe _ ()] "AST TRANSFORMATION")
            (,lib-ac-insert "ac.scm LIBRARY INSERTION")
            (,in-global "GLOBAL INLINING")
            (,rm-global "UNUSED GLOBAL REMOVAL")
            (,sharedvars-convert-assert "SHARED VARIABLE CONVERSION")
            (,cps-convert "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= xe-global-cte* (make-initial-cte))
    (when debugmode
      (w/outfile stream "arc2c.log"
        nil))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d nil
                  (prn desc)
                  (= new-d (f old-d))
                  (when debugmode
                    (w/appendfile stream "arc2c.log"
                      (w/stdout stream
                        (prn "--------------------------")
                        (prn desc)
                        (prn "--------------------------")
                        (ppr-sexp (source new-d)))))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))

;------------------------------------------------------------------------------

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [do1 lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count)]
     constant-todo '()
     constant-count 0
     add-constant [do1 constant-count
                       (push _ constant-todo)
                       (++ constant-count)]
     code-gen nil
     compile-all-lambdas nil
     compile-constants nil)

  (= code-gen (fn (ast stack-env)
    (let (cg-list cg-args access-var cg) nil
      (= cg-list (fn (asts vars stack-env sep k)
        (if (no asts)
          (k "" stack-env)
          (let x (code-gen (car asts) stack-env)
            (cg-list (cdr asts) (cdr vars) (cons (car vars) stack-env) sep (fn (code stack-env) (k (list x sep code) stack-env)))))))

      (= cg-args (fn (args stack-env)
        (cg-list args (range 1 (len args)) stack-env "" (fn (code stack-env) code))))

      (= access-var (fn (var stack-env)
        (if (aglobal var)
          (let i (pos var global-vars)
            (list "GLOBAL(" i "/*" var!uid "*/)"))
          (let i (- (len stack-env) (pos var stack-env) 1)
            (list "LOCAL(" i "/*" var!uid "*/)")))))

      (= cg (fn (ast)
        (if
          (alit ast)
            (let val ast!val
              (if
                (no val) (list " PUSH(NILOBJ);")
                (is val t) (list " PUSH(TOBJ);")
                (isa val 'char) (list " PUSH(CHAR2OBJ(" coerce.val!int "));")
                (isa val 'string) (list " PUSH((obj)utf82str(\"" val "\"));")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (let val ast!val
              (list " PUSH(QUOTE_CONSTANTS[" (add-constant val) "]"
                    "/* '" (tostring:write val) " */);"))
          (aref ast)
            (list " PUSH(" (access-var ast!var stack-env) ");")
          (aset ast)
            (list (cg (car ast!subx)) " " (access-var ast!var stack-env) " = TOS();")
          (acnd ast)
            (let x (map cg ast!subx)
              (list (car x) "\n if (POP() != NILOBJ) {\n" (cadr x) "\n } else {\n" (car:cddr x) "\n }"))
          (aprim ast)
            (let args ast!subx
              (if
                (is ast!op '%sharedvar)
                  (list (cg-args args stack-env) " MAKE_SHAREDVAR();")
                (is ast!op '%sharedvar-read)
                  (list (cg-args args stack-env) " READ_SHAREDVAR();")
                (is ast!op '%sharedvar-write)
                  (list (cg-args args stack-env) " WRITE_SHAREDVAR();")
                (is ast!op '%sref) (list (cg-args args stack-env) " SREF();")
                (is ast!op '%cons) (list (cg-args args stack-env) " CONS();")
                (is ast!op '%car) (list (cg-args args stack-env) " CAR();")
                (is ast!op '%cdr) (list (cg-args args stack-env) " CDR();")
                (is ast!op '%len) (list (cg-args args stack-env) " LEN();")
                (is ast!op '%type) (list (cg-args args stack-env) " TYPE();")
                (is ast!op '%annotate) (list (cg-args args stack-env) " ANNOTATE();")
                (is ast!op '%rep) (list (cg-args args stack-env) " REP();")
                (is ast!op '%is) (list (cg-args args stack-env) " EQ();")
                (is ast!op '%isnt) (list (cg-args args stack-env) " NEQ();")
                (is ast!op '%<) (list (cg-args args stack-env) " LT();")
                (is ast!op '%>) (list (cg-args args stack-env) " GT();")
                (is ast!op '%<=) (list (cg-args args stack-env) " LE();")
                (is ast!op '%>=) (list (cg-args args stack-env) " GE();")
                (is ast!op '%+) (list (cg-args args stack-env) " ADD();")
                (is ast!op '%-) (list (cg-args args stack-env) " SUB();")
                (is ast!op '%*) (list (cg-args args stack-env) " MUL();")
                (is ast!op '%pr) (list (cg-args args stack-env) " PR();")
                (is ast!op '%prn) (list (cg-args args stack-env) " PRN();")
                (is ast!op '%table) (list (cg-args args stack-env) " TBL();")
                (is ast!op '%halt) (list (cg-args args stack-env) " HALT();")
                (is ast!op '%closure)
                  (withs
                    (i (add-lambda (car args))
                     n (len (cdr args))
                     s (list "CLOSURE(" i "," n ");"))
                    (list (cg-args (cdr args) stack-env) " BEGIN_" s (map [list " INICLO(" _ ");"] (rev:range 1 n)) " END_" s))
                (is ast!op '%closure-ref)
                  (let i ((cadr args) 'val)
                    (list (cg (car args)) " TOS() = CLOSURE_REF(TOS()," i ");"))
                (err "unknown primitive" ast!op)))
          (anapp ast)
            (withs
              (fun (car ast!subx)
               args (cdr ast!subx)
               n (len args))
              (if (alam fun)
                (cg-list args (properify fun!params) stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
                (cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
                  (with
                    (start (len stack-env)
                     s (list "JUMP(" n ");"))
                    (list code " BEGIN_" s (map [list " PUSH(LOCAL(" (+ _ start) "));"] (range 0 (- n 1))) " END_" s))))))
          (alam ast) ; this case is impossible after CPS-conversion
            (list " PUSH(FIX2OBJ(" (add-lambda ast) "));")
          (aseq ast) ; this case is impossible after CPS-conversion
            (map [list (cg _) "DROP();"] ast!subx)
            (err "unknown ast" ast))))

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            ; if variadic, insert variadic handling code
            (if (dotted ast!params)
              ; determine the number of required arguments
              (let num-reqs (- (len:properify ast!params) 1)
                (list " VARIADIC2LIST(" num-reqs ");\n")))
            ; <insert code to check that caller passed
            ; correct number of arguments here>
            (code-gen (car ast!subx) (rev:properify ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (= compile-constants
    (fn (cs)
      (with (i 0
             express nil)
        (= express
           (fn (e)
             (if
               (number e) (list "FIX2OBJ(" e ")")
               (no e) "SYM2OBJ(\"nil\")"
               (isa e 'sym) (list "SYM2OBJ(" (tostring:write:string e) ")")
               (acons e)
                 (list "cons_fun(" (express:car e) ", " (express:cdr e) ")")
               ;else
                 (err:string "not supported in quote form: "
                             (tostring:write e)))))
        (mapeach c cs
          (do1
            (list "QUOTE_CONSTANTS[" i "] = " (express c) ";\n")
            (++ i))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 2000 "\n" "#define NB_QUOTE_CONSTANTS " constant-count "\n")
      code-header*
      (if constant-todo
        ; constants were defined; initialize
        (list "void init_constants(void){\n"
              (compile-constants:rev constant-todo)
              "}\n")
        ; no constants; dummy initialize
        "\n#define init_constants()\n")
      code-prefix*
      code-execute*
      code
      code-suffix*))))

(def readtxtfile (name)
  (w/infile f name
    (let res ""
      (whilet line (readline f) (++ res (string line "\n")))
      res)))

(= code-header* (readtxtfile "a2c.h")  ; typedefs, function headers & macros
   code-prefix* (readtxtfile "a2c.c")) ; predefined functions

(= code-execute* "

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");
  long num_args = 0;

  jump: switch (pc) {

")

(= code-suffix* "  }
  return POP();
}
")

;------------------------------------------------------------------------------

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        ; actually, shouldn't properify the params, maybe okay since this is debug code, but...
        (list 'let (map (fn (p a) (list p!uid (source a))) (properify ((car ast!subx) 'params)) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map-improper [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (list 'quote ast!val)
      ; if unknown AST, then probably still in list form
      ; (cref driver)
      ast))

; seems currently unused -
; note that this function doesn't support varargs
(def ds (ast)
   (if
      (alit ast)
          (cons 'lit ast!val)
      (aref ast)
         (cons 'ref ((ast 'var) 'uid))
      (aset ast)
         (cons 'set (list 'set ((ast 'var) 'uid) (ds (car ast!subx))))
      (acnd ast)
         (cons 'cnd (cons 'if (map ds ast!subx)))
      (aprim ast)
         (cons 'prim (cons ast!op (map ds ast!subx)))
      (anapp ast)
      (cons 'app
         (if (alam (car ast!subx))
            (list 'let (map (fn (p a) (list p!uid (ds a))) ((car ast!subx) 'params) (cdr ast!subx)) (ds (car ((car ast!subx) 'subx))))
            (map ds ast!subx)))
      (alam ast)
         (cons 'lam (list 'fn (map [_ 'uid] ast!params) (ds (car ast!subx))))
      (aseq ast)
         (cons 'seq (cons 'do (map ds ast!subx)))
         ast))

; abstract away avoiding ' and the quoted parts of `
; body *must* return the value in 'var if it won't
; change anything
(mac code-walk (var code . body)
  (w/uniq usercode
    `(let ,usercode (fn (,var) ,@body)
       (*code-walk-internal ,usercode ,code))))

(def *code-walk-internal (usercode code)
  (let pass-to-user
       (fn (c)
         (let new-code (usercode c)
           (if (isnt new-code c)
               ; if change, rewalk the new code
               ; (don't move on unless code is stable)
               (*code-walk-internal usercode new-code)
               (if (acons new-code)
                   (map-improper [*code-walk-internal usercode _] new-code)
                   new-code))))
    (if (acons code)
        (if
          (is (car code) 'quote)
            code
          (is (car code) 'quasiquote)
            (list 'quasiquote
               ((rfn quasiwalk (code)
                   (if (acons code)
                       (if
                         (is (car code) 'unquote)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         (is (car code) 'unquote-splicing)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         ; else
                           (map-improper quasiwalk code))
                       code))
                 (cadr code)))
          ; else
            (pass-to-user code))
        (pass-to-user code))))

(def to-3-if (l)
  (code-walk code l
    (if
      (and (caris code 'if) (len> code 4))
        (let (_ c v . rest) code
          `(if ,c ,v (if ,@rest)))
      ; else
        code)))

(def symbol-syntax (l)
  (code-walk code l
    (remove-ssyntaxes code)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def remove-ssyntaxes (code)
  (if
    (and (acons code) (ssyntax:car code))
      (let (fun . args) code
        (zap ssexpand fun)
        (if (caris fun 'compose)
            ((afn ((fun . rest))
               (if rest
                   `(,fun ,(self rest))
                   `(,fun ,@args)))
             (cdr fun))
            `(,fun ,@args)))
    (ssyntax code)
      (ssexpand code)
    code))

; handles (toplevel) 'load and 'require
; inefficiency note: allocs a lot of cons cells
(def include-files (l)
  (mappend
    (fn (e)
      ; if it's a 'load or 'require, include it
      (if (and (acons e) (in (car e) 'load 'require))
          (let (_ file . oops) e
            (when oops
              (err:string "Too many parameters to: " (car e)))
            ; make sure to recursively handle including files
            (include-files
              (w/infile s file
                (readall s (list 'detect-eof)))))
          (list e)))
    l))

;------------------------------------------------------------------------------

(def strip-ext (filename)
  (cut filename 0 (pos #\. filename)))

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (cons 'do (readall s (list 'detect-eof))))
         chain
         `(
            ; --------List form
            (,include-files "FILE INCLUSION")
            ; NOTE: all the 'code-walk passes might be
            ; better off in a single pass (just use a large
            ; 'if block).  Especially with regards to macros
            ; and symbol syntax: a ssyntax might emit a macro,
            ; which might emit a ssyntax, which might emit
            ; a macro... 'code-walk can actually handle this
            ; but only if macros and ssyntax expansion are
            ; in the same 'code-walk block
            (,symbol-syntax "ssyntax TRANSFORMATION")
            (,to-3-if "3-arg-if TRANSFORMATION")
            ; --------AST form
            (,[xe _ ()] "AST TRANSFORMATION")
            (,lib-ac-insert "ac.scm LIBRARY INSERTION")
            (,in-global "GLOBAL INLINING")
            (,rm-global "UNUSED GLOBAL REMOVAL")
            (,sharedvars-convert-assert "SHARED VARIABLE CONVERSION")
            (,cps-convert "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= xe-global-cte* (make-initial-cte))
    (when debugmode
      (w/outfile stream "arc2c.log"
        nil))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d nil
                  (prn desc)
                  (= new-d (f old-d))
                  (when debugmode
                    (w/appendfile stream "arc2c.log"
                      (w/stdout stream
                        (prn "--------------------------")
                        (prn desc)
                        (prn "--------------------------")
                        (ppr-sexp (source new-d)))))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))


Fixed bug in ppr.arc where not all references to ppr were renamed

(= pprsyms* (fill-table (table)
			'(quote "'"
			  quasiquote "`"
			  unquote ","
			  unquote-splicing ",@")))

(def sp ((o n 1))
  " Print a number of spaces. "
  (repeat n (pr " ")))

(def print-spaced (xs)
  " Print the expressions in the list separated by spaces. "
  (when xs
    (print car.xs)
    (each x cdr.xs (sp) print.x)))

(def print (x)
  " Print an expression on one line, replacing quote, unquote,
    quasiquote, unquote-splicing, and make-br-fn with their respective symbols. "
  (do (aif (or atom.x dotted.x)
	     (do write.x nil)
	   (pprsyms* car.x)
	     (do pr.it
	       (print cadr.x)
	       nil)
	   (is car.x 'make-br-fn)
	     (do (pr "[") (print-spaced cadr.x) (pr "]") nil)
	   (do (pr "(") print-spaced.x (pr ")") nil))
      x))

(= oneline* 45)

(def len (x (o c 0))
  " Measures the length of a string, vector, table, list or dotted list. "
  (if (isa x 'string) ($.string-length x)
      (isa x 'vec) ($.vector-length x)
      (isa x 'table) ($.hash-table-count x)
      (and atom.x x) (+ c 1)
      acons.x (len cdr.x (+ c 1))
      c))

(mac indent (col . body)
  `(do (unless noindent sp.col)
       ,@body))

(mac ppr-sub body
  `(indent col
      (let whole (tostring print.x)
	(if (< len.whole oneline*)
	    (do pr.whole nil)
	    (do ,@body t)))))

(def indent-pairs (xs (o col 0))
  (let l (apply max 0 (map len:tostring:print:car (keep cdr pair.xs)))
    (on x pair.xs
        (if (~is index 0)
            (do (prn)
                (sp col)))
        (let str (tostring:print car.x)
          (if cdr.x
              (do pr.str
                  (sp:- l len.str -1)
                  (ppr-main cadr.x (+ col 1 l) t))
              ; lone tail expression
              (do (sp (+ l 1))
                  (ppr-main car.x (+ col (+ l 1)) t)))))))

(def indent-block (xs (o col 0))
  (each x xs (prn) (ppr-main x col)))

(def indent-mac (xs (o args 0) (o col 0))
  (print-spaced (firstn args xs))
  (indent-block (nthcdr args xs) (+ col 2)))

(def indent-basic (xs l (o col 0))
  (if (all [or atom._ (and (is car._ 'quote) (atom cadr._))]
	   xs)
      print-spaced.xs
      (do (ppr-main car.xs (+ col 2 l) t)
	  (indent-block cdr.xs (+ col 2 l)))))

(def indent-wave (xs (o col 0))
  (do (ppr-main car.xs col t)
      (on x cdr.xs
	  (prn)
	  (ppr-main x (+ col (* 2 (mod (+ index 1) 2)))))))

(= ifline* 20)

(def indent-if (l)
  (fn (xs (o col 0))
      (if (< len.xs 4)
	    (on x xs
		(if (~is index 0) (prn))
		(ppr-main x (+ col 2 l) (is index 0)))
	  (all [< (len:tostring print._) ifline*]
	       pair.xs)
	    (indent-pairs xs (+ col 2 l))
	  (indent-wave xs (+ col 2 l)))))

(def indent-with (l)
  (fn (xs (o col 0))
      (pr "(")
      (indent-pairs car.xs (+ col 3 l))
      (pr ")")
      (indent-block cdr.xs (+ col 3))))

(def indent-def (xs (o col 0))
  (print-spaced (firstn 2 xs))
  (if (isa xs.2 'string)
      (do (prn)
	  (sp (+ col 2))
	  (pr #\" xs.2 #\")
	  (indent-block (nthcdr 3 xs) (+ col 2)))
      (indent-block (nthcdr 2 xs) (+ col 2))))

(def indent-case (n)
  (fn (xs (o col 0))
      (print-spaced:firstn n xs)
      (prn)
      (sp (+ col 2))
      (indent-pairs (nthcdr n xs) (+ col 2))))

(= indent-rules*
   (fill-table (table)
     `(if      ,(indent-if 2)
       aif     ,(indent-if 3)
       with    ,(indent-with 4)
       withs   ,(indent-with 5)
       def     ,indent-def
       mac     ,indent-def
       do      ,[indent-basic _ 2 _2]
       and     ,[indent-basic _ 3 _2]
       or      ,[indent-basic _ 2 _2]
       nor     ,[indent-basic _ 3 _2]
       case    ,(indent-case 1)
       caselet ,(indent-case 2)
       fn      ,[indent-mac _ 1 _2])))

(def ppr-main (x (o col 0) (o noindent nil))
  " Recursive main body of the ppr function. "
  (aif (or atom.x dotted.x)		;just print the expression if it's an atom or dotted list
         (indent col
	   print.x
	   nil)
       (is car.x 'make-br-fn)		;if the expression is a br-fn, print the brackets and then the contents
         (ppr-sub
	   (pr "[")
	   (ppr-main cadr.x (+ col 1) t)
	   (pr "]"))
       (pprsyms* car.x)
         (ppr-sub
	   pr.it
	   (ppr-main cadr.x (+ col len.it) t))
       (ppr-sub
	 (pr "(")
	 (withs (proc car.x
		 args sig.proc
                 n    len.args
		 str  (tostring:print proc)
		 l    len.str
		 xs   cdr.x)
	   (if (isa proc 'cons)
	       (do (ppr-main proc (+ col 1) t)
		   (indent-block xs (+ col 1)))
	       (do pr.str
		   (when xs
		     (sp)
		     (aif indent-rules*.proc
			    (it xs col)
			  (and (isa proc 'sym) (bound proc) (isa (eval proc) 'mac))
			    (if (or dotted.args (and args (~acons args)))
				(indent-mac xs (- len.args 1) col)
				(indent-mac xs 0 col))
			  (indent-basic xs l col)))))
	   (pr ")")))))

(def ppr l
  " Pretty print. This function displays arc code with proper
    indenting and representation of syntax. "
  (each x l (ppr-main x) (prn)))

(= pprsyms* (fill-table (table)
			'(quote "'"
			  quasiquote "`"
			  unquote ","
			  unquote-splicing ",@")))

(def sp ((o n 1))
  " Print a number of spaces. "
  (repeat n (pr " ")))

(def print-spaced (xs)
  " Print the expressions in the list separated by spaces. "
  (when xs
    (print car.xs)
    (each x cdr.xs (sp) print.x)))

(def print (x)
  " Print an expression on one line, replacing quote, unquote,
    quasiquote, unquote-splicing, and make-br-fn with their respective symbols. "
  (do (aif (or atom.x dotted.x)
	     (do write.x nil)
	   (pprsyms* car.x)
	     (do pr.it
	       (print cadr.x)
	       nil)
	   (is car.x 'make-br-fn)
	     (do (pr "[") (print-spaced cadr.x) (pr "]") nil)
	   (do (pr "(") print-spaced.x (pr ")") nil))
      x))

(= oneline* 45)

(def len (x (o c 0))
  " Measures the length of a string, vector, table, list or dotted list. "
  (if (isa x 'string) ($.string-length x)
      (isa x 'vec) ($.vector-length x)
      (isa x 'table) ($.hash-table-count x)
      (and atom.x x) (+ c 1)
      acons.x (len cdr.x (+ c 1))
      c))

(mac indent (col . body)
  `(do (unless noindent sp.col)
       ,@body))

(mac ppr-sub body
  `(indent col
      (let whole (tostring print.x)
	(if (< len.whole oneline*)
	    (do pr.whole nil)
	    (do ,@body t)))))

(def indent-pairs (xs (o col 0))
  (let l (apply max 0 (map len:tostring:print:car (keep cdr pair.xs)))
    (on x pair.xs
        (if (~is index 0)
            (do (prn)
                (sp col)))
        (let str (tostring:print car.x)
          (if cdr.x
              (do pr.str
                  (sp:- l len.str -1)
                  (ppr cadr.x (+ col 1 l) t))
              ; lone tail expression
              (do (sp (+ l 1))
                  (ppr car.x (+ col (+ l 1)) t)))))))

(def indent-block (xs (o col 0))
  (each x xs (prn) (ppr x col)))

(def indent-mac (xs (o args 0) (o col 0))
  (print-spaced (firstn args xs))
  (indent-block (nthcdr args xs) (+ col 2)))

(def indent-basic (xs l (o col 0))
  (if (all [or atom._ (and (is car._ 'quote) (atom cadr._))]
	   xs)
      print-spaced.xs
      (do (ppr car.xs (+ col 2 l) t)
	  (indent-block cdr.xs (+ col 2 l)))))

(def indent-wave (xs (o col 0))
  (do (ppr car.xs col t)
      (on x cdr.xs
	  (prn)
	  (ppr x (+ col (* 2 (mod (+ index 1) 2)))))))

(= ifline* 20)

(def indent-if (l)
  (fn (xs (o col 0))
      (if (< len.xs 4)
	    (on x xs
		(if (~is index 0) (prn))
		(ppr x (+ col 2 l) (is index 0)))
	  (all [< (len:tostring print._) ifline*]
	       pair.xs)
	    (indent-pairs xs (+ col 2 l))
	  (indent-wave xs (+ col 2 l)))))

(def indent-with (l)
  (fn (xs (o col 0))
      (pr "(")
      (indent-pairs car.xs (+ col 3 l))
      (pr ")")
      (indent-block cdr.xs (+ col 3))))

(def indent-def (xs (o col 0))
  (print-spaced (firstn 2 xs))
  (if (isa xs.2 'string)
      (do (prn)
	  (sp (+ col 2))
	  (pr #\" xs.2 #\")
	  (indent-block (nthcdr 3 xs) (+ col 2)))
      (indent-block (nthcdr 2 xs) (+ col 2))))

(def indent-case (n)
  (fn (xs (o col 0))
      (print-spaced:firstn n xs)
      (prn)
      (sp (+ col 2))
      (indent-pairs (nthcdr n xs) (+ col 2))))

(= indent-rules*
   (fill-table (table)
     `(if      ,(indent-if 2)
       aif     ,(indent-if 3)
       with    ,(indent-with 4)
       withs   ,(indent-with 5)
       def     ,indent-def
       mac     ,indent-def
       do      ,[indent-basic _ 2 _2]
       and     ,[indent-basic _ 3 _2]
       or      ,[indent-basic _ 2 _2]
       nor     ,[indent-basic _ 3 _2]
       case    ,(indent-case 1)
       caselet ,(indent-case 2)
       fn      ,[indent-mac _ 1 _2])))

(def ppr-main (x (o col 0) (o noindent nil))
  " Recursive main body of the ppr function. "
  (aif (or atom.x dotted.x)		;just print the expression if it's an atom or dotted list
         (indent col
	   print.x
	   nil)
       (is car.x 'make-br-fn)		;if the expression is a br-fn, print the brackets and then the contents
         (ppr-sub
	   (pr "[")
	   (ppr-main cadr.x (+ col 1) t)
	   (pr "]"))
       (pprsyms* car.x)
         (ppr-sub
	   pr.it
	   (ppr cadr.x (+ col len.it) t))
       (ppr-sub
	 (pr "(")
	 (withs (proc car.x
		 args sig.proc
                 n    len.args
		 str  (tostring:print proc)
		 l    len.str
		 xs   cdr.x)
	   (if (isa proc 'cons)
	       (do (ppr-main proc (+ col 1) t)
		   (indent-block xs (+ col 1)))
	       (do pr.str
		   (when xs
		     (sp)
		     (aif indent-rules*.proc
			    (it xs col)
			  (and (isa proc 'sym) (bound proc) (isa (eval proc) 'mac))
			    (if (or dotted.args (and args (~acons args)))
				(indent-mac xs (- len.args 1) col)
				(indent-mac xs 0 col))
			  (indent-basic xs l col)))))
	   (pr ")")))))

(def ppr l
  " Pretty print. This function displays arc code with proper
    indenting and representation of syntax. "
  (each x l (ppr-main x) (prn)))