hl2b testing: interface toward tests

hl2b testing: interface toward tests

; basic functionality to test the bytecode generator
; written for hl-arc-f, should be loadable in a hl system
; after changing (using <arc>v3) with (using <hl>v0)

(in-package simple-test)
(using <arc>v3)
(interface v0 test run-tests)

; execute tests and report results
; args is a list of of three-elements lists:
; '((test-desc code-to-compile expected-bytecode) ...)
(def do-test (args)
  (with (failed 0 ; number of failed tests
         n-tests (len args))
    (when (is n-tests 0)
      (err "No tests"))
    (each x args
      (withs (name (car x)
              to-test (cadr x)
              expected (caddr x)
              res (<compiler>compile-to-bytecode to-test))
        (unless (iso res expected)
          (prn "Test " name " " to-test " failed, expected " expected
               " , got " res))
          (set failed (+ failed 1))))
    (prn "Successfully completed " (- n-tests failed) " tests")
    (prn "Failed " failed " tests")
    (prn "Summary:")
    (prn "\tPassed: " (- n-tests failed) "/" n-tests ", "
         (/ (* 100 (- n-tests failed)) n-tests) "%")
    (prn "\tFailed: " failed "/" n-tests ", "
         (/ (* 100 failed) n-tests) "%")))

; list of registered tests
(set all-tests* nil)

; add a test (last added, last executed)
(def register-test (test)
  (set all-tests* (append all-tests* (list test))))

; add a set of tests with the same name
; usage:
;   (test "Description"
;     input-program1 expected-result1
;     input-program2 expected-result2
;     ...)
(mac test (name . tests)
  (unless (is 0 (mod (len tests) 2))
    (err "Unpaired test/result"))
  `(do
     ,@(map (fn (tst)
              `(register-test (cons name ,tst)))
            (tuples ,tests 2))))

; run all the registered tests
(def run-tests ()
  (do-tests all-tests*))

; basic functionality to test the bytecode generator
; written for hl-arc-f, should be loadable in a hl system
; after changing (using <arc>v3) with (using <hl>v0)

(in-package simple-test)
(using <arc>v3)

; execute tests
; args is a list of of three-elements lists:
; '((test-desc code-to-compile expected-bytecode) ...)
(def do-test (args)
  (with (failed 0 ; number of failed tests
         n-tests (len args))
    (when (is n-tests 0)
      (err "No tests"))
    (each x args
      (withs (name (car x)
              to-test (cadr x)
              expected (caddr x)
              res (<compiler>compile-to-bytecode to-test))
        (unless (iso res expected)
          (prn "Test " name " " to-test " failed, expected " expected
               " , got " res))
          (set failed (+ failed 1))))
    (prn "Successfully completed " (- n-tests failed) " tests")
    (prn "Failed " failed " tests")
    (prn "Summary:")
    (prn "\tPassed: " (- n-tests failed) "/" n-tests ", "
         (/ (* 100 (- n-tests failed)) n-tests) "%")
    (prn "\tFailed: " failed "/" n-tests ", "
         (/ (* 100 failed) n-tests) "%")))

(set all-tests* nil)


cleanup 'help'

cleanup 'help'

Also now more careful to show example sessions like they would look at
the real repl.

; On-line help system
(def ppr-source (name)
  " Pretty-prints the source code of the function `name'.
    Is a function, so `name' is evaluated.
    See also: [[src]] "
  ((only [prn "(from \"" _ "\")"]) source-file*.name)
  (ppr source*.name))

(mac src (name)
  " Pretty prints the source code of the function `name'.
    Is a macro, so `name' is not evaluated.
    See also: [[ppr-source]] "
  `(ppr-source ',name))

(mac help ((o name 'help))
  " Prints the documentation of the given symbol. To use, type
    (help symbol) ; you may also use (help \"string\") to search
    all documentation for that string. "
  (if (isa name 'sym) `(do (pr ,(helpstr name)) nil)
      (isa name 'string) `(helpsearch ,name)
      `(help)))

(def helpsearch (str)
  " Prints all symbols whose documentation matches or partly matches `str'. "
  (prall (helpsearch-core str) "Related symbols:\n" "\n")
  (prn)
  nil)

(def helpsearch-core (str)
  " Returns a list of symbols whose documentation matches or partly matches
    `str'. "
  (zap downcase str)
  (let part-match [posmatch str (downcase:string _)]
    (sort <
      (accum add
        (each (name doc) help*
          (when (or (part-match name) (part-match doc)
                    (only.part-match (source-file* name)))
            (add name)))))))

(def helpstr (name (o verbose t))
  " Returns a help string for the symbol `name'. "
  (tostring
    (withs (value (errsafe:eval name)
            kind  (type value)
            doc   (help* name))
      (when (or value doc)
        (pr "[" kind "]")
        (apply pr (n-of (- 4 (len:string kind)) " "))
        (write (aif sig*.name (cons name it)
                    (in kind 'fn 'mac) (list name)
                    name))
        (prn)
        (when verbose
          (prn (or doc (string name " is not documented.")))
          (awhen (examples* name)
            (w/line-length 20
              (prn)
              (prn "Examples:")
              (each (expr expected) pair.it
                (pr "  arc> ")
                (ppr-main expr 7 t)
                (prn)
                (when (~is '_ expected)
                  (if (caris expected 'valueof)
                    (print-example-session expr (eval expected.1))
                    (print-example-session expr expected)))))))))))

(def print-example-session (expr expected)
  (pr "  ")
  (print-like-repl expected)
  (if (~iso expected eval.expr)
    (pr " <-- this seems outdated"))
  (prn))

(def print-like-repl (x)
  (if (isa x 'string)
    (write x)
    (prn x)))

(def fns ((o test))
  " Print sigs for macros & functions whose names (as symbols) match `test'.
    If `test' is a function, it is used as a predicate.
    Otherwise, names of which `(string test)' is a prefix pass. "
  (let test (if (isa test 'fn) test
              (let pfx string.test [begins string._ pfx]))
    (each f (sort < (keep test keys.sig*))
      (pr (helpstr sym.f nil)))))

; On-line help system
(def ppr-source (name)
  " Pretty-prints the source code of the function `name'.
    Is a function, so `name' is evaluated.
    See also: [[src]] "
  ((only [prn "(from \"" _ "\")"]) source-file*.name)
  (ppr source*.name))

(mac src (name)
  " Pretty prints the source code of the function `name'.
    Is a macro, so `name' is not evaluated.
    See also: [[ppr-source]] "
  `(ppr-source ',name))

(mac help ((o name 'help))
  " Prints the documentation of the given symbol. To use, type
    (help symbol) ; you may also use (help \"string\") to search
    all documentation for that string. "
  (if (isa name 'sym) `(do (pr ,(helpstr name)) nil)
      (isa name 'string) `(helpsearch ,name)
      `(help)))

(def helpsearch (str)
  " Prints all symbols whose documentation matches or partly matches `str'. "
  (prall (helpsearch-core str) "Related symbols:\n" "\n")
  (prn)
  nil)

(def helpsearch-core (str)
  " Returns a list of symbols whose documentation matches or partly matches
    `str'. "
  (zap downcase str)
  (let part-match [posmatch str (downcase:string _)]
    (sort <
      (accum add
        (each (name doc) help*
          (when (or (part-match name) (part-match doc)
                    (only.part-match (source-file* name)))
            (add name)))))))

(def helpstr (name (o verbose t))
  " Returns a help string for the symbol `name'. "
  (tostring
    (withs (value (errsafe:eval name)
            kind  (type value)
            doc   (help* name))
      (when (or value doc)
        (pr "[" kind "]")
        (apply pr (n-of (- 4 (len:string kind)) " "))
        (write (aif sig*.name (cons name it)
                    (in kind 'fn 'mac) (list name)
                    name))
        (prn)
        (when verbose
          (prn (or doc (string name " is not documented.")))
          (awhen (examples* name)
            (w/line-length 20
              (prn)
              (prn "Examples:")
              (each (expr expected) pair.it
                (pr "  arc> ")
                (ppr-main expr 7 t)
                (prn)
                (when (~is '_ expected)
                  (if (caris expected 'valueof)
                    (do (pr "  " expected.1)
                        (if (~iso (eval expected.1)
                                  (eval expr))
                          (pr " <-- this seems outdated")))
                    (do (pr "  " expected)
                        (if (~iso expected eval.expr)
                          (pr " <-- this seems outdated"))))
                  (prn))))))))))

(def fns ((o test))
  " Print sigs for macros & functions whose names (as symbols) match `test'.
    If `test' is a function, it is used as a predicate.
    Otherwise, names of which `(string test)' is a prefix pass. "
  (let test (if (isa test 'fn) test
              (let pfx string.test [begins string._ pfx]))
    (each f (sort < (keep test keys.sig*))
      (pr (helpstr sym.f nil)))))


codegen: changed declaration of QUOTE_CONSTANTS to be always declared

  GC refers to QUOTE_CONSTANTS table, but this table isn't created
  if no quote constants are made.

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

; 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 '%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")
      "obj QUOTE_CONSTANTS[NB_QUOTE_CONSTANTS];\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)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def symbol-syntax (l)
  (code-walk code l
    (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))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d nil
                  (when debugmode
                    (pr "------------------------------ "))
                  (prn desc)
                  (= new-d (f old-d))
                  (when debugmode
                    (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 '%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 "obj QUOTE_CONSTANTS[NB_QUOTE_CONSTANTS];\n"
              "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)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def symbol-syntax (l)
  (code-walk code l
    (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))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d nil
                  (when debugmode
                    (pr "------------------------------ "))
                  (prn desc)
                  (= new-d (f old-d))
                  (when debugmode
                    (ppr-sexp (source new-d)))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))


lib/wills.arc: avoid one-will-per-value-per-gc problem

; Simplified interface to plt scheme's will executors. Ignores the fiddly bits
; about "will executors" and wills not being automatically executed, by using
; one global will executor and creating a thread to handle wills. Also avoids
; the problem that if multiple wills are registered for a given value, only one
; can be run per value per gc cycle, by adding another layer of indirection.

(unless (and bound!will-executor* ($:will-executor? ,will-executor*))
  (= will-executor* ($.make-will-executor)))

(unless (and bound!will-table* (isa will-table* 'table))
  (= will-table* ($.make-hash-table 'weak)))

(unless (and bound!will-executor-thread*
             (isa will-executor-thread* 'thread)
             (~dead will-executor-thread*))
  (= will-executor-thread*
     (thread (while t ($.will-execute will-executor*)))))

(def generic-will (val)
  (each f will-table*.val (f x)))

(def will-register (val will)
  ; if val is not yet registered with a generic will, do so
  ($.hash-table-get will-table* val
                    (fn () ($.will-register will-executor* val generic-will)))
  (push will will-table*.val)
  val)

(mac will (val . body)
  (w/uniq ign
    `(will-register ,val (fn (,ign) ,@body))))

; simplified interface to plt scheme's will executors. ignores the fiddly bits
; about "will executors" and wills not being automatically executed, by using
; one global will executor and creating a thread to handle wills.

(unless (and bound!will-executor* ($:will-executor? ,will-executor*))
  (= will-executor* ($.make-will-executor)))

(unless (and bound!will-executor-thread*
             (isa will-executor-thread* 'thread)
             (~dead will-executor-thread*))
  (= will-executor-thread*
     (thread (while t ($.will-execute will-executor*)))))

(def will-register (val will)
  ($.will-register will-executor* val will)
  val)

(mac will (val . body)
  (w/uniq ign
    `(will-register ,val (fn (,ign) ,@body))))