stylistic tweaks

stylistic tweaks

;;; web.arc: a web toolkit

;; Paths
; (defpath /hello (req)  (prs "hello" req!ip "you are visiting" req!path))
;   -> normal, literal path, 'defop-like
;
; (defpath /user/: (req usr)  (prs "hello" usr))
;   -> matches "/user/pal", "/user/john" but NOT "/user/pal/stuff"
;
; (defpath /user/:/file/* (req usr file)  (prs usr "requesting" file))
;   -> matches "/user/pal/file/http.arc", "/user/pal/file/web/beta/wf.arc"
;
; 'register-complexpath / 'find-complexpath not to be used directly:
; they are called by 'register-path / 'findpath when needed

(= litpaths* (table)  complexpaths* ())

(def register-path (str f)
  (if (some [in _ #\: #\*] str)
      (register-complexpath str f)
      (= litpaths*.str f)))

(def register-complexpath (str f)
  (let pstruct (list (tokens str #\/) f)
    (aif (assoc str complexpaths*)
    	 (= it.1 pstruct)  ; already exists, replace
	 (push (list str pstruct) complexpaths*))))

(def findpath (path)  ; actually "find the handler function for this path"
  (aif litpaths*.path
       it
       (find-complexpath (tokens path #\/))))

(def find-complexpath (ptoks (o cands complexpaths*))
  (whenlet (str (toks f)) (car cands)
    (aif (complexpath-match ptoks toks)
      	 (list f rev.it)
	 (find-complexpath ptoks (cdr cands)))))

(def complexpath-match (pc cc (o acc))  ; return the list of bindings if matched
  (if (and no.pc no.cc)
      acc
      (when (car cc)
      	(case cc.0.0  ; first char
      	  #\: (complexpath-match (cdr pc) (cdr cc) (cons (car pc) acc))
	  #\* (cons (string:intersperse #\/ pc) acc)
	      (when (is cc.0 (car pc))  ; literal token
	      	(complexpath-match (cdr pc) (cdr cc) acc))))))

(mac defpath-raw (path vars . body)
  `(register-path ,(string path) (fn ,vars ,@body)))

(mac defpath (path vars . body)
  `(defpath-raw ,path ,vars
     (resphead)
     ,@body))

;; Bring a taste of state to HTTP
; stealed from {srv|app}.arc but made simpler/saner:
; can't see, for instance, why /x and /r should be on different paths.
; and also, no twenty ...form ('arform 'tarform and 'onclick etc.)
; You're of course free to define 'onclick and co., if you need them:
; but we advice you to think twice about it: this stuff is good, but its
; scope is or at least should be limited.  Javascript exists, and
; client caching is cool.  It's 2k9 now, not 1999.  Be a man and code an
; Arc to JS compiler (have a look at scheme2js).  The Arc challenge
; is a joke.

(= ops*    (table)  ; todo: expires after some sensible time val (6 hours?)
   opurl*  "/x/")

(register-path (string opurl* ":")
  (fn (req id)  (aif ops*.id (it req) (resp-err))))

(def new-opid ((o leng 12))
  (check (rand-string leng) ~ops* (new-opid leng)))

(def newop (f)
  (atlet id (new-opid)
    (= ops*.id f)
    id))

(def opurl (id)  (string opurl* id))

(mac fnform (f . body)
  `(let id (newop ,f)
     (tag (form method 'post action (opurl id))
       ,@body)))

;; Misc utils

(def resp-err ((o msg "404 - Not found") (o sta http-notfound+))
  (resphead sta (copy httpd-hds* "Content-Type" "text/plain"))
  (prn msg))

(defs arg  (req argname)   (alref req!args argname)
      hd   (req hdname)    (alref req!hds hdname)
      cook (req cookname)  (alref req!cooks cookname))

; 'tag-options redefined to get opstring by default if meth is nil
; (please, we are no children), and "id" and "class" fields for every
; tag (please, we use javascript)
; maybe not the right place to redef?  'opmeth?

(def tag-options (spec options)
  (if (no options)
      '()
      (let ((opt val) . rest) options
        (let meth (if (in opt 'style 'class)
	     	       opstring
		      (is opt 'id)
		       opsym
		      (opmeth spec opt))
          (if meth
              (if val
                  (cons (if (precomputable-tagopt val)
                            (tostring (eval (meth opt val)))
                            (meth opt val))
                        (tag-options spec rest))
                  (tag-options spec rest))
              (cons (opstring opt val) (tag-options spec rest)))))))

; we use HTML5.  that means, less cruft (things like closing </html> or
; type="text/javascript" not mandatory, so skipped to save bandwidth)
; but don't worry old browsers will still be able to handle it (IE6 does!)

(def prdoctype ((o dt "html"))  (pr "<!doctype " dt ">"))

 (mac htmlpage (headers . body)
   `(do (prdoctype)
        (start-tag 'html)
	(tag head
	     (gentag meta http-equiv "content-type"
	     	  	  content "text/html; charset=utf-8")
	     ; better to specify encoding here, in the html: avoid
	     ; problems if the user locally saves and consults the page
	     ,@headers)
	(flushout)
        (start-tag 'body)
	,@body))

(defs js   (url) (tag (script src url))
      ijs  (str) (tag script (disp str))  ; inline code
      css  (url) (gentag link href url rel "stylesheet")
      icss (str) (tag style (disp str)))

(def lblinp (label name (o typ "text") (o val) (o sz 12))
  (tag (label for name) (pr label))
  (gentag input type typ  id name  name name  value val  size sz))

(def dispatch (req)
  (iflet hand (findpath req!path)
        (if (alist hand)  ; true if complex path
	    (apply hand.0 (cons req hand.1))
	    (hand req))
        (resp-err)))

; (= httpd-handler dispatch)  ; the right choice for 95% of cases, but
; for instance you might want to use a unique session cookie for each
; visitor, in this case, do some "Cookie" header parsing before to dispatch.

;;; web.arc: a web toolkit

;; Paths
; (defpath /hello (req)  (prs "hello" req!ip "you are visiting" req!path))
;   -> normal, literal path, 'defop-like
;
; (defpath /user/: (req usr)  (prs "hello" usr))
;   -> matches "/user/pal", "/user/john" but NOT "/user/pal/stuff"
;
; (defpath /user/:/file/* (req usr file)  (prs usr "requesting" file))
;   -> matches "/user/pal/file/http.arc", "/user/pal/file/web/beta/wf.arc"
;
; 'register-complexpath / 'find-complexpath not to be used directly:
; they are called by 'register-path / 'findpath when needed

(= litpaths* (table)  complexpaths* ())

(def register-path (str f)
  (if (some [in _ #\: #\*] str)
      (register-complexpath str f)
      (= litpaths*.str f)))

(def register-complexpath (str f)
  (let pstruct (list (tokens str #\/) f)
    (aif (assoc str complexpaths*)
    	 (= it.1 pstruct)  ; already exists, replace
	 (push (list str pstruct) complexpaths*))))

(def findpath (path)  ; actually "find the handler function for this path"
  (aif litpaths*.path
       it
       (find-complexpath (tokens path #\/))))

(def find-complexpath (ptoks (o cands complexpaths*))
  (whenlet (str (toks f)) (car cands)
    (aif (complexpath-match ptoks toks)
      	 (list f (rev it))
	 (find-complexpath ptoks (cdr cands)))))

(def complexpath-match (pc cc (o acc))  ; return the list of bindings if matched
  (if (and (no pc) (no cc))
      acc
      (when (car cc)
      	(case cc.0.0  ; first char
      	  #\: (complexpath-match (cdr pc) (cdr cc) (cons (car pc) acc))
	  #\* (cons (string:intersperse #\/ pc) acc)
	      (when (is cc.0 (car pc))  ; literal token
	      	(complexpath-match (cdr pc) (cdr cc) acc))))))

(mac defpath-raw (path vars . body)
  `(register-path ,(string path) (fn ,vars ,@body)))

(mac defpath (path vars . body)
  `(defpath-raw ,path ,vars
     (resphead)
     ,@body))

;; Bring a taste of state to HTTP
; stealed from {srv|app}.arc but made simpler/saner:
; can't see, for instance, why /x and /r should be on different paths.
; and also, no twenty ...form ('arform 'tarform and 'onclick etc.)
; You're of course free to define 'onclick and co., if you need them:
; but we advice you to think twice about it: this stuff is good, but its
; scope is or at least should be limited.  Javascript exists, and
; client caching is cool.  It's 2k9 now, not 1999.  Be a man and code an
; Arc to JS compiler (have a look at scheme2js).  The Arc challenge
; is a joke.

(= ops*    (table)  ; todo: expires after some sensible time val (6 hours?)
   opurl*  "/x/")

(register-path (string opurl* ":")
  (fn (req id)  (aif ops*.id (it req) (resp-err))))

(def new-opid ((o leng 12))
  (check (rand-string leng) ~ops* (new-opid leng)))

(def newop (f)
  (atlet id (new-opid)
    (= ops*.id f)
    id))

(def opurl (id)  (string opurl* id))

(mac fnform (f . body)
  `(let id (newop ,f)
     (tag (form method 'post action (opurl id))
       ,@body)))

;; Misc utils

(def resp-err ((o msg "404 - Not found") (o sta http-notfound+))
  (resphead sta (copy httpd-hds* "Content-Type" "text/plain"))
  (prn msg))

(defs arg  (req argname)   (alref req!args argname)
      hd   (req hdname)    (alref req!hds hdname)
      cook (req cookname)  (alref req!cooks cookname))

; 'tag-options redefined to get opstring by default if meth is nil
; (please, we are no children), and "id" and "class" fields for every
; tag (please, we use javascript)
; maybe not the right place to redef?  'opmeth?

(def tag-options (spec options)
  (if (no options)
      '()
      (let ((opt val) . rest) options
        (let meth (if (in opt 'style 'class)
	     	       opstring
		      (is opt 'id)
		       opsym
		      (opmeth spec opt))
          (if meth
              (if val
                  (cons (if (precomputable-tagopt val)
                            (tostring (eval (meth opt val)))
                            (meth opt val))
                        (tag-options spec rest))
                  (tag-options spec rest))
              (cons (opstring opt val) (tag-options spec rest)))))))

; we use HTML5.  that means, less cruft (things like closing </html> or
; type="text/javascript" not mandatory, so skipped to save bandwidth)
; but don't worry old browsers will still be able to handle it (IE6 does!)

(def prdoctype ((o dt "html"))  (pr "<!doctype " dt ">"))

 (mac htmlpage (headers . body)
   `(do (prdoctype)
        (start-tag 'html)
	(tag head
	     (gentag meta http-equiv "content-type"
	     	  	  content "text/html; charset=utf-8")
	     ; better to specify encoding here, in the html: avoid
	     ; problems if the user locally saves and consults the page
	     ,@headers)
	(flushout)
        (start-tag 'body)
	,@body))

(defs js   (url) (tag (script src url))
      ijs  (str) (tag script (disp str))  ; inline code
      css  (url) (gentag link href url rel "stylesheet")
      icss (str) (tag style (disp str)))

(def lblinp (label name (o typ "text") (o val) (o sz 12))
  (tag (label for name) (pr label))
  (gentag input type typ  id name  name name  value val  size sz))

(def dispatch (req)
  (iflet hand (findpath req!path)
        (if (alist hand)  ; true if complex path
	    (apply hand.0 (cons req hand.1))
	    (hand req))
        (resp-err)))

; (= httpd-handler dispatch)  ; the right choice for 95% of cases, but
; for instance you might want to use a unique session cookie for each
; visitor, in this case, do some "Cookie" header parsing before to dispatch.


codegen: modified driver to factor out chain of transformations on code

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

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [let i lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count) i]
     ; private functions
     code-gen nil
     compile-all-lambdas 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);")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (list " PUSH(SYM2OBJ(\"" (car ast!subx) "\"));")
          (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 '%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 '%type) (list (cg-args args stack-env) " TYPE();")
                (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 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"
            (code-gen (car ast!subx) (rev ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 10000 "\n" code-prefix*)
      code
      code-suffix*))))

(= code-prefix* "
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>

#define MAX_SYMS 1000000
#define T_PAIR 0
#define T_SYM  1

typedef long obj;

typedef struct {
  char type; /* T_PAIR */
  obj car;
  obj cdr;
} pair;

typedef struct {
  char type; /* T_SYM */
  char * value;
} symbol;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj * closure;
obj * sp;
symbol * syms[MAX_SYMS]; /* To be replaced by a hash table */
int nsyms;

#define AFIX(o) (((o) & 1) == 0) /* the last bit is 0 : it's a fixnum */
#define APTR(o) ((o) & 1)      /* It's not a fixnum : it's a ref to something else */
#define ASYM(o) (OBJ2PTR(o)[0] == T_SYM)
#define APAIR(o) (OBJ2PTR(o)[0] == T_PAIR)

#define FIX2OBJ(n) ((n) << 1)
#define OBJ2FIX(o) ((o) >> 1)

#define PTR2OBJ(p) ((obj)(p) + 1)
#define OBJ2PTR(o) ((obj*)((o) - 1))

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) OBJ2PTR(self)[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = TOS() == y ? TOBJ : NILOBJ; }
#define NEQ() { obj y = POP(); TOS() = TOS() != y ? TOBJ : NILOBJ; }

#define TYPE() { obj * p; obj y = TOS();\\
  if (AFIX(y))\\
    TOS() = SYM2OBJ(\"int\");\\
  else{\\
    p = OBJ2PTR(y);\\
    switch ((char) *p){\\
      case T_PAIR: TOS() = SYM2OBJ(\"cons\"); break;\\
      case T_SYM: TOS() = SYM2OBJ(\"sym\"); break;\\
    }\\
  }\\
}

#define LT() { obj y = POP(); TOS() = TOS() < y ? TOBJ : NILOBJ; }
#define GT() { obj y = POP(); TOS() = TOS() > y ? TOBJ : NILOBJ; }
#define LE() { obj y = POP(); TOS() = TOS() <= y ? TOBJ : NILOBJ; }
#define GE() { obj y = POP(); TOS() = TOS() >= y ? TOBJ : NILOBJ; }
#define ADD() { obj y = POP(); TOS() = TOS() + y; }
#define SUB() { obj y = POP(); TOS() = TOS() - y; }
#define MUL() { obj y = POP(); TOS() = OBJ2FIX(TOS()) * y; }

#define CONS() { pair * p = GC_MALLOC(sizeof(pair)); p->type = T_PAIR ; p->cdr = POP(); p->car = POP(); PUSH(PTR2OBJ(p)); }
#define CAR() { pair * p = (pair *) (OBJ2PTR(POP())); PUSH(p->car); }
#define CDR() { pair * p = (pair *) (OBJ2PTR(POP())); PUSH(p->cdr); }

#define PRN() { PR(); printf (\"\\n\");}

void PR(){
  pair * p;
  symbol * s;
  obj y = TOS();

  if (AFIX(y))
    printf (\"%ld\", OBJ2FIX(y));
  else if (ASYM(y)){
    s = (symbol *) OBJ2PTR(y);
    printf (\"%s\", s->value);
  }
  else if (APAIR(y)){
    p = (pair *) (OBJ2PTR(y));
    printf (\"( \");
    PUSH(p->car); PR(); POP();
    printf (\" . \");
    PUSH(p->cdr); PR(); POP();
    printf (\" )\");
  }
}

#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH(PTR2OBJ(closure));

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = OBJ2PTR(LOCAL(0))[0]; goto jump;

obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
  int i;

  for (i = 0 ; i < nsyms ; i++)
    if (strcmp (s, syms[i]->value) == 0) /* found it */
      return PTR2OBJ(syms[i]);

  if (nsyms == MAX_SYMS){ /* Bad luck, really... */
    fprintf (stderr, \"Sorry, we just ran out of symbols. Please come back later...\\n\");
    exit (1);
  }

  syms[nsyms]        = GC_MALLOC (sizeof(symbol));
  syms[nsyms]->type  = T_SYM;
  syms[nsyms]->value = (char *) GC_MALLOC (strlen (s) + 1);
  strcpy (syms[nsyms]->value, s);

  return PTR2OBJ(syms[nsyms++]);
}

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

  jump: switch (pc) {

")

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

int main (int argc, char * argv[]) {
  execute();
  return 0;
}
")

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

; 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))
        (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (cons 'quote ast!subx)
      ast))

(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)))
         (err "unknown ast" ast)))

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

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

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (readall s (list 'detect-eof)))
         chain
         `(
            ; --------List form
            ; --------AST form
            (,[xe _ ()]       "AST TRANSFORMATION")
            (,cps-convert     "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d (f old-d)
                  (when debugmode
                    (prn "------------------------------ " desc)
                    (prn (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 [let i lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count) i]
     ; private functions
     code-gen nil
     compile-all-lambdas 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);")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (list " PUSH(SYM2OBJ(\"" (car ast!subx) "\"));")
          (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 '%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 '%type) (list (cg-args args stack-env) " TYPE();")
                (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 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"
            (code-gen (car ast!subx) (rev ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 10000 "\n" code-prefix*)
      code
      code-suffix*))))

(= code-prefix* "
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>

#define MAX_SYMS 1000000
#define T_PAIR 0
#define T_SYM  1

typedef long obj;

typedef struct {
  char type; /* T_PAIR */
  obj car;
  obj cdr;
} pair;

typedef struct {
  char type; /* T_SYM */
  char * value;
} symbol;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj * closure;
obj * sp;
symbol * syms[MAX_SYMS]; /* To be replaced by a hash table */
int nsyms;

#define AFIX(o) (((o) & 1) == 0) /* the last bit is 0 : it's a fixnum */
#define APTR(o) ((o) & 1)      /* It's not a fixnum : it's a ref to something else */
#define ASYM(o) (OBJ2PTR(o)[0] == T_SYM)
#define APAIR(o) (OBJ2PTR(o)[0] == T_PAIR)

#define FIX2OBJ(n) ((n) << 1)
#define OBJ2FIX(o) ((o) >> 1)

#define PTR2OBJ(p) ((obj)(p) + 1)
#define OBJ2PTR(o) ((obj*)((o) - 1))

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) OBJ2PTR(self)[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = TOS() == y ? TOBJ : NILOBJ; }
#define NEQ() { obj y = POP(); TOS() = TOS() != y ? TOBJ : NILOBJ; }

#define TYPE() { obj * p; obj y = TOS();\\
  if (AFIX(y))\\
    TOS() = SYM2OBJ(\"int\");\\
  else{\\
    p = OBJ2PTR(y);\\
    switch ((char) *p){\\
      case T_PAIR: TOS() = SYM2OBJ(\"cons\"); break;\\
      case T_SYM: TOS() = SYM2OBJ(\"sym\"); break;\\
    }\\
  }\\
}

#define LT() { obj y = POP(); TOS() = TOS() < y ? TOBJ : NILOBJ; }
#define GT() { obj y = POP(); TOS() = TOS() > y ? TOBJ : NILOBJ; }
#define LE() { obj y = POP(); TOS() = TOS() <= y ? TOBJ : NILOBJ; }
#define GE() { obj y = POP(); TOS() = TOS() >= y ? TOBJ : NILOBJ; }
#define ADD() { obj y = POP(); TOS() = TOS() + y; }
#define SUB() { obj y = POP(); TOS() = TOS() - y; }
#define MUL() { obj y = POP(); TOS() = OBJ2FIX(TOS()) * y; }

#define CONS() { pair * p = GC_MALLOC(sizeof(pair)); p->type = T_PAIR ; p->cdr = POP(); p->car = POP(); PUSH(PTR2OBJ(p)); }
#define CAR() { pair * p = (pair *) (OBJ2PTR(POP())); PUSH(p->car); }
#define CDR() { pair * p = (pair *) (OBJ2PTR(POP())); PUSH(p->cdr); }

#define PRN() { PR(); printf (\"\\n\");}

void PR(){
  pair * p;
  symbol * s;
  obj y = TOS();

  if (AFIX(y))
    printf (\"%ld\", OBJ2FIX(y));
  else if (ASYM(y)){
    s = (symbol *) OBJ2PTR(y);
    printf (\"%s\", s->value);
  }
  else if (APAIR(y)){
    p = (pair *) (OBJ2PTR(y));
    printf (\"( \");
    PUSH(p->car); PR(); POP();
    printf (\" . \");
    PUSH(p->cdr); PR(); POP();
    printf (\" )\");
  }
}

#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH(PTR2OBJ(closure));

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = OBJ2PTR(LOCAL(0))[0]; goto jump;

obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
  int i;

  for (i = 0 ; i < nsyms ; i++)
    if (strcmp (s, syms[i]->value) == 0) /* found it */
      return PTR2OBJ(syms[i]);

  if (nsyms == MAX_SYMS){ /* Bad luck, really... */
    fprintf (stderr, \"Sorry, we just ran out of symbols. Please come back later...\\n\");
    exit (1);
  }

  syms[nsyms]        = GC_MALLOC (sizeof(symbol));
  syms[nsyms]->type  = T_SYM;
  syms[nsyms]->value = (char *) GC_MALLOC (strlen (s) + 1);
  strcpy (syms[nsyms]->value, s);

  return PTR2OBJ(syms[nsyms++]);
}

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

  jump: switch (pc) {

")

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

int main (int argc, char * argv[]) {
  execute();
  return 0;
}
")

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

; 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))
        (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (cons 'quote ast!subx)
      (err "unknown ast" ast)))

(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)))
         (err "unknown ast" ast)))

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

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

(def compile-file (filename)
  (let ast (parse-file filename)
    (prn "-------------------------- AST:")
    (prn (source ast))

    (let ast-after-cps (cps-convert ast)
      (prn "-------------------------- AST AFTER CPS-CONVERSION:")
      (prn (source ast-after-cps))

      (let ast-after-cc (closure-convert ast-after-cps)
        (prn "-------------------------- AST AFTER CLOSURE-CONVERSION:")
        (prn (source ast-after-cc))

        (let code (code-generate ast-after-cc)
          (prn "-------------------------- C CODE:")
          ;(prn (cadr code))
          (w/outfile f (+ (strip-ext filename) ".c")
            (w/stdout f
              (prn (liststr code)))))))))


hl2b/hl.arc: changed 'each emulation to use 'base-each

(in-package hl)
(using <arc>v3)

(mac <hl>def (spec . rest)
  (if
    (acons spec)
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,(car spec)
             ; should really be <hl>fn, but for now we use
             ; <axiom>lambda
             (<axiom>lambda ,(cdr spec)
               ,@rest))))
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,spec
             ,(car rest))))))
(mac <hl>defm (sig . rest)
  (withs (f  (rep <arc>defm)
          rv (apply f (car sig) (cdr sig) rest)
          (set-axiom var (poly-fn types (fn-axiom parms . body) old))
             rv)
    ; NOTE! differences in <arc>polymorph and
    ; <hl>polymorph:
    ;   (<arc>polymorph signature generic specific)
    ;   (<hl>polymorph generic signature specific)
    ; - the change in order was done since we might
    ;   want to overload how overloading of particular
    ;   objects as generics are done
    ; wrap in w/gvl
    `((<axiom>symeval '<common>call-w/gvl)
      (<axiom>lambda ()
        (<axiom>set ,var (<hl>polymorph ,old ,types (<axiom>lambda ,parms ,@body)))))))
; WARNING! limited 'let only, no destructuring
; for bootstrapping purposes only.  Full destructuring
; support will be added in cs/, but cs/ itself can't
; use it.
(mac <hl>let (var val . rest)
  (if (isnt (type var) 'sym)
      (err "bootstrapping 'let does not support destructuring")
      `((<axiom>lambda (,var)
          ,@rest)
        ,val)))
(mac <hl>with (var-vals . rest)
  (let verify
       (fn (var)
         (if (is (type var) 'sym)
             var
             (err "bootstrapping 'with does not support destructuring")))
    `((<axiom>lambda (,@(map verify:car (pair var-vals)))
        ,@rest)
      ,@(map cadr (pair var-vals)))))
(mac <hl>withs (var-vals . rest)
  (if
    var-vals
      (let (var val . nvars) var-vals
        `(<hl>let ,var ,val
           (<hl>withs ,nvars ,@rest)))
      `((<axiom>lambda () ,@rest))))
(mac <hl>do rest
  `((<axiom>lambda () ,@rest)))
(mac <hl>mac (spec . rest)
  `((<axiom>symeval '<common>call-w/gvl)
    (<axiom>lambda ()
      (<axiom>set ,(car spec)
                  (<axiom>tag '<hl>mac
                    (<axiom>lambda ,(cons '<hl>macro-info (cdr spec))
                      ,@rest))))))

(def <common>call-w/gvl (f) (f))

(mac <hl>afn (args . body)
  `(<hl>let <hl>self nil
     (<axiom>set <hl>self (<axiom>lambda ,args ,@body))))

(mac <hl>when (test . body)
  `(<axiom>if ,test (<hl>do ,@body)))

(mac <hl>unless (test . body)
  `(<axiom>if nil (<hl>do ,@body)))

(mac <hl>and args
  (if args
      (if (cdr args)
          `(<axiom>if ,(car args) (<hl>and ,@(cdr args)))
          (car args))
      't))

(mac <hl>or args
  (and args
       (w/uniq g
         `(<hl>let ,g ,(car args)
            (<axiom>if ,g ,g (<hl>or ,@(cdr args)))))))

(mac <hl>each (var val . body)
  (w/uniq (f l)
    `((<axiom>symeval '<hl>base-each) ,val 0
      (<axiom>lambda ()
        ,@body
        t))))

(mac <hl>while (test . body)
  (w/uniq (f v)
    `(<hl>let ,f nil
       (<axiom>set ,f (<axiom>fn ()
                        (<axiom>if ,test
                          (<hl>do
                            ,@body
                            (,f)))))
       (,f))))

(mac <hl>for ((var init last) . body)
  `(<hl>let ,var ,init
     (<hl>while (<axiom>i< ,var ,last)
       ,@body
       (<axiom>set ,var (<axiom>i+ ,var 1)))))

(mac <hl>if args
  (if (or (no args) (is (len args) 1))
    (car args)
    (with (test (car args)
           then (car (cdr args))
           rest (cdr (cdr args)))
      `(<axiom>if ,test ,then (<hl>if ,@rest)))))

(in-package hl)
(using <arc>v3)

(mac <hl>def (spec . rest)
  (if
    (acons spec)
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,(car spec)
             ; should really be <hl>fn, but for now we use
             ; <axiom>lambda
             (<axiom>lambda ,(cdr spec)
               ,@rest))))
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,spec
             ,(car rest))))))
(mac <hl>defm (sig . rest)
  (withs (f  (rep <arc>defm)
          rv (apply f (car sig) (cdr sig) rest)
          (set-axiom var (poly-fn types (fn-axiom parms . body) old))
             rv)
    ; NOTE! differences in <arc>polymorph and
    ; <hl>polymorph:
    ;   (<arc>polymorph signature generic specific)
    ;   (<hl>polymorph generic signature specific)
    ; - the change in order was done since we might
    ;   want to overload how overloading of particular
    ;   objects as generics are done
    ; wrap in w/gvl
    `((<axiom>symeval '<common>call-w/gvl)
      (<axiom>lambda ()
        (<axiom>set ,var (<hl>polymorph ,old ,types (<axiom>lambda ,parms ,@body)))))))
; WARNING! limited 'let only, no destructuring
; for bootstrapping purposes only.  Full destructuring
; support will be added in cs/, but cs/ itself can't
; use it.
(mac <hl>let (var val . rest)
  (if (isnt (type var) 'sym)
      (err "bootstrapping 'let does not support destructuring")
      `((<axiom>lambda (,var)
          ,@rest)
        ,val)))
(mac <hl>with (var-vals . rest)
  (let verify
       (fn (var)
         (if (is (type var) 'sym)
             var
             (err "bootstrapping 'with does not support destructuring")))
    `((<axiom>lambda (,@(map verify:car (pair var-vals)))
        ,@rest)
      ,@(map cadr (pair var-vals)))))
(mac <hl>withs (var-vals . rest)
  (if
    var-vals
      (let (var val . nvars) var-vals
        `(<hl>let ,var ,val
           (<hl>withs ,nvars ,@rest)))
      `((<axiom>lambda () ,@rest))))
(mac <hl>do rest
  `((<axiom>lambda () ,@rest)))
(mac <hl>mac (spec . rest)
  `((<axiom>symeval '<common>call-w/gvl)
    (<axiom>lambda ()
      (<axiom>set ,(car spec)
                  (<axiom>tag '<hl>mac
                    (<axiom>lambda ,(cons '<hl>macro-info (cdr spec))
                      ,@rest))))))

(def <common>call-w/gvl (f) (f))

(mac <hl>afn (args . body)
  `(<hl>let <hl>self nil
     (<axiom>set <hl>self (<axiom>fn ,args ,@body))))

(mac <hl>when (test . body)
  `(<axiom>if ,test (<hl>do ,@body)))

(mac <hl>unless (test . body)
  `(<axiom>if nil (<hl>do ,@body)))

(mac <hl>and args
  (if args
      (if (cdr args)
          `(<axiom>if ,(car args) (<hl>and ,@(cdr args)))
          (car args))
      't))

(mac <hl>or args
  (and args
       (w/uniq g
         `(<hl>let ,g ,(car args)
            (<axiom>if ,g ,g (<hl>or ,@(cdr args)))))))

(mac <hl>each (var val . body)
  (w/uniq (f l)
    `(<hl>let ,f nil
       (<axiom>set ,f (<axiom>fn (,l)
                        (<axiom>if ,l
                          (<hl>do
                            (<hl>let ,var (<axiom>car ,l) ,@body)
                            (,f (<axiom>cdr ,l))))))
       (,f ,val))))

(mac <hl>while (test . body)
  (w/uniq (f v)
    `(<hl>let ,f nil
       (<axiom>set ,f (<axiom>fn ()
                        (<axiom>if ,test
                          (<hl>do
                            ,@body
                            (,f)))))
       (,f))))

(mac <hl>for ((var init last) . body)
  `(<hl>let ,var ,init
     (<hl>while (<axiom>i< ,var ,last)
       ,@body
       (<axiom>set ,var (<axiom>i+ ,var 1)))))

(mac <hl>if args
  (if (or (no args) (is (len args) 1))
    (car args)
    (with (test (car args)
           then (car (cdr args))
           rest (cdr (cdr args)))
      `(<axiom>if ,test ,then (<hl>if ,@rest)))))