structs: added comment dividing valid AST's from other structures

; structs.arc
; by sacado
; comments by AmkG
; Contains definitions for the abstract syntax trees used
; in CPS- and closure-conversions.

; a variable
(def make-var (id uid)
  (listtab `((type var) (id ,id) (uid ,uid))))

(def avar (x)
  (and (isa x 'table) (is x!type 'var)))

; a special form (not really a macro, at least not
; an Arc-style macro, since the output of the macro
; should be an AST, not a list)
(def make-macro (id expander)
  (listtab `((type macro) (id ,id) (expander ,expander))))

(def amacro (x)
  (and (isa x 'table) (is x!type 'macro)))

;----------------------------------------AST's

; a literal: number or t/nil
; (might be extended to chars someday)
(def make-lit (subx val)
  (listtab `((type lit) (subx ,subx) (val ,val))))

(def alit (x)
  (and (isa x 'table) (is x!type 'lit)))

; a variable reference
(def make-ref (subx var)
  (listtab `((type ref) (subx ,subx) (var ,var))))

(def aref (x)
  (and (isa x 'table) (is x!type 'ref)))

; a quoted form
; (currently only literals)
(def make-quote (subx)
  (listtab `((type quote) (subx ,subx))))

(def aquote (x)
  (and (isa x 'table) (is x!type 'quote)))

; a (set var val) form
(def make-set (subx var)
  (listtab `((type set) (subx ,subx) (var ,var))))

(def aset (x)
  (and (isa x 'table) (is x!type 'set)))

; an if form
; (supports only 2 or 3-arg form but code
; is preprocessed to that form anyway)
(def make-cnd (subx)
  (listtab `((type cnd) (subx ,subx))))

(def acnd (x)
  (and (isa x 'table) (is x!type 'cnd)))

; a primitive
; (possibly make these *optimized* primitives,
; since it's technically possible, in Arc, to
; redefine most primitives; basically if a
; primitive is redefined, it's no longer
; represented using this)
(def make-prim (subx op)
  (listtab `((type prim) (subx ,subx) (op ,op))))

(def aprim (x)
  (and (isa x 'table) (is x!type 'prim)))

; a function call (a function *app*lication)
(def make-app (subx)
  (listtab `((type app) (subx ,subx))))

(def anapp (x)
  (and (isa x 'table) (is x!type 'app)))

; a function form (a *lam*bda)
(def make-lam (subx params)
  (listtab `((type lam) (subx ,subx) (params ,params))))

(def alam (x)
  (and (isa x 'table) (is x!type 'lam)))

; a do form
(def make-seq (subx)
  (listtab `((type seq) (subx ,subx))))

(def aseq (x)
  (and (isa x 'table) (is x!type 'seq)))

(def extend (bindings env)
  (+ bindings env))

(def lookup (id env)
  (if (no env)
    nil
    (let head (car env)
      (if (is head!id id)
        head
        (lookup id (cdr env))))))

(= seq-num* 0)

(def new-var (id)
  (++ seq-num*)
  (make-var id (sym (string id "@" seq-num*))))

(def new-global (id)
  (make-var id id))

(def aglobal (var)
  (is var!id var!uid))

; structs.arc
; by sacado
; comments by AmkG
; Contains definitions for the abstract syntax trees used
; in CPS- and closure-conversions.

; a variable
(def make-var (id uid)
  (listtab `((type var) (id ,id) (uid ,uid))))

(def avar (x)
  (and (isa x 'table) (is x!type 'var)))

; a special form (not really a macro, at least not
; an Arc-style macro, since the output of the macro
; should be an AST, not a list)
(def make-macro (id expander)
  (listtab `((type macro) (id ,id) (expander ,expander))))

(def amacro (x)
  (and (isa x 'table) (is x!type 'macro)))

; a literal: number or t/nil
; (might be extended to chars someday)
(def make-lit (subx val)
  (listtab `((type lit) (subx ,subx) (val ,val))))

(def alit (x)
  (and (isa x 'table) (is x!type 'lit)))

; a variable reference
(def make-ref (subx var)
  (listtab `((type ref) (subx ,subx) (var ,var))))

(def aref (x)
  (and (isa x 'table) (is x!type 'ref)))

; a quoted form
; (currently only literals)
(def make-quote (subx)
  (listtab `((type quote) (subx ,subx))))

(def aquote (x)
  (and (isa x 'table) (is x!type 'quote)))

; a (set var val) form
(def make-set (subx var)
  (listtab `((type set) (subx ,subx) (var ,var))))

(def aset (x)
  (and (isa x 'table) (is x!type 'set)))

; an if form
; (supports only 2 or 3-arg form but code
; is preprocessed to that form anyway)
(def make-cnd (subx)
  (listtab `((type cnd) (subx ,subx))))

(def acnd (x)
  (and (isa x 'table) (is x!type 'cnd)))

; a primitive
; (possibly make these *optimized* primitives,
; since it's technically possible, in Arc, to
; redefine most primitives; basically if a
; primitive is redefined, it's no longer
; represented using this)
(def make-prim (subx op)
  (listtab `((type prim) (subx ,subx) (op ,op))))

(def aprim (x)
  (and (isa x 'table) (is x!type 'prim)))

; a function call (a function *app*lication)
(def make-app (subx)
  (listtab `((type app) (subx ,subx))))

(def anapp (x)
  (and (isa x 'table) (is x!type 'app)))

; a function form (a *lam*bda)
(def make-lam (subx params)
  (listtab `((type lam) (subx ,subx) (params ,params))))

(def alam (x)
  (and (isa x 'table) (is x!type 'lam)))

; a do form
(def make-seq (subx)
  (listtab `((type seq) (subx ,subx))))

(def aseq (x)
  (and (isa x 'table) (is x!type 'seq)))

(def extend (bindings env)
  (+ bindings env))

(def lookup (id env)
  (if (no env)
    nil
    (let head (car env)
      (if (is head!id id)
        head
        (lookup id (cdr env))))))

(= seq-num* 0)

(def new-var (id)
  (++ seq-num*)
  (make-var id (sym (string id "@" seq-num*))))

(def new-global (id)
  (make-var id id))

(def aglobal (var)
  (is var!id var!uid))


codegen: Added message that it is now emitting the C code

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

; 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
          ; TODO: make aquote and alit the same!
          (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 "));")
                ; NONCANONICAL!
                ; (def foo ()
                ;   "string")
                ; (sref (foo) #\x 0)
                ; (prn (foo))
                ; alit AST's should probably be stored in QUOTE_CONSTANTS
                ; too
                (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
               (isa e 'int) (list "PUSH(FIX2OBJ(" e "));\n")
               (no e)       "PUSH(SYM2OBJ(\"nil\"));\n"
               (isa e 'sym) (list "PUSH(SYM2OBJ(" (tostring:write:string e)
                                  "));\n")
               (acons e)
                 (list (express:car e) (express:cdr e) "CONS();\n")
               ;else
                 (err:string "not supported in quote form: "
                             (tostring:write e)))))
        (mapeach c cs
          (do1
            (list (express c) "QUOTE_CONSTANTS[" i "] = POP();\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){\nsp = stack;\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))
    (prn "Writing C code...")
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))
    t))

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

; 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
          ; TODO: make aquote and alit the same!
          (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 "));")
                ; NONCANONICAL!
                ; (def foo ()
                ;   "string")
                ; (sref (foo) #\x 0)
                ; (prn (foo))
                ; alit AST's should probably be stored in QUOTE_CONSTANTS
                ; too
                (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
               (isa e 'int) (list "PUSH(FIX2OBJ(" e "));\n")
               (no e)       "PUSH(SYM2OBJ(\"nil\"));\n"
               (isa e 'sym) (list "PUSH(SYM2OBJ(" (tostring:write:string e)
                                  "));\n")
               (acons e)
                 (list (express:car e) (express:cdr e) "CONS();\n")
               ;else
                 (err:string "not supported in quote form: "
                             (tostring:write e)))))
        (mapeach c cs
          (do1
            (list (express c) "QUOTE_CONSTANTS[" i "] = POP();\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){\nsp = stack;\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)))))


better error message on fnid-less POST

better error message on fnid-less POST

; HTTP Server.

; To improve performance with static files, set static-max-age*.

(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")

(= quitsrv* nil breaksrv* nil)

(def serve ((o port 8080))
  (wipe quitsrv*)
  (ensure-srvdirs)
  (map [apply new-bgthread _] pending-bgthreads*)
  (w/socket s port
    (setuid 2) ; XXX switch from root to pg
    (prn "ready to serve port " port)
    (flushout)
    (= currsock* s)
    (until quitsrv*
      (handle-request s breaksrv*)))
  (prn "quit server"))

(def serve1 ((o port 8080))
  (w/socket s port (handle-request s t)))

(def ensure-srvdirs ()
  (map ensure-dir (list arcdir* logdir* staticdir*)))

(= srv-noisy* nil)

; http requests currently capped at 2 meg by socket-accept

; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.

; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.

(= threadlife* 30  requests* 0  requests/ip* (table)
   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))

(def handle-request (s breaksrv)
  (if breaksrv
      (handle-request-1 s)
      (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (with ((i o ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (let ip-wrapper (fn args
                      (if args
                        (= ip car.args)
                        ip))
      (= th1 (thread
               (after (handle-request-thread i o ip-wrapper)
                      (close i o)
                      (kill-thread th2))))
      (= th2 (thread
               (sleep threadlife*)
               (unless (dead th1)
                 (prn "srv thread took too long for " ip))
               (kill-thread th1)
               (force-close i o))))))

; Returns true if ip has made req-limit* requests in less than
; req-window* seconds.  If an ip is throttled, only 1 request is
; allowed per req-window* seconds.  If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).

; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.

(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)

(wipe show-abuse*)
(def abusive-ip (ip)
  (++ (requests/ip* ip 0))
  (if show-abuse*
    (if (ignore-ips* ip)
      (prn ip " ignored")
      (prn ip " " (if (abusive-ip-core ip) "" "not ") "abusive (" requests/ip*.ip ")")))
  (and (or (ignore-ips* ip) (abusive-ip-core ip))
       (++ (spurned* ip 0))))

(def abusive-ip-core (ip)
  (and (only.> (requests/ip* ip) 250)
       (let now (seconds)
         (do1 (if (req-times* ip)
                  (and (>= (qlen (req-times* ip))
                           (if (throttle-ips* ip) 1 req-limit*))
                       (let dt (- now (deq (req-times* ip)))
                         (if (< dt dos-window*) (set (ignore-ips* ip)))
                         (< dt req-window*)))
                  (do (= (req-times* ip) (queue))
                      nil))
              (enq now (req-times* ip))))))

(let proxy-header "X-Forwarded-For: "
  (def strip-header(s)
    (subst "" proxy-header s))
  (def proxy-ip(ip-wrapper lines)
    (aif (only.strip-header (car:keep [headmatch proxy-header _] lines))
        (ip-wrapper it)
        (ip-wrapper))))

(wipe show-requests*)
(def handle-request-thread (i o ip-wrapper)
  (with (nls 0 lines nil line nil responded nil t0 (msec))
    (after
      (whilet c (unless responded (readc i))
        (if srv-noisy* (pr c))
        (if (is c #\newline)
            (if (is (++ nls) 2)
                (let (type op args n cooks ctype) (parseheader (rev lines))
                  (if show-requests* (prn lines))
                  (unless (abusive-ip (proxy-ip ip-wrapper lines))
                    (let t1 (msec)
                      (case type
                        get  (respond o op args cooks 0 i "" (ip-wrapper))
                        post (handle-post i o op args n cooks ctype (ip-wrapper))
                             (respond-err o "Unknown request: " (car lines)))
                      (log-request type op args cooks (ip-wrapper) t0 t1)))
                  (set responded))
                (do (push (string (rev line)) lines)
                    (wipe line)))
            (unless (is c #\return)
              (push c line)
              (= nls 0))))
      (close i o)))
  (harvest-fnids))

(def log-request (type op args cooks ip t0 t1)
  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
    (srvlog 'srv ip
                 parsetime
                 respondtime
                 (if (> (+ parsetime respondtime) 1000) "***" "")
                 type
                 op
                 (let arg1 (car args)
                   (if (caris arg1 "fnid") "" arg1))
                 cooks)))

; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))

(def handle-post (i o op args n cooks ctype ip)
  (if srv-noisy* (pr "Post Contents: "))
  (if (no n)
      (respond-err o "Post request without Content-Length.")
      (let line nil
        (unless (begins downcase.ctype "multipart/form-data")
          (whilet c (and (> n 0) (readc i))
            (if srv-noisy* (pr c))
            (-- n)
            (push c line)))
        (if srv-noisy* (pr "\r\n\r\n"))
        (respond o op (+ (parseargs (string (rev line))) args) cooks n ctype i ip))))

(= header* "HTTP/1.1 200 OK\r
Content-Type: text/html; charset=utf-8\r
Connection: close")

(= err-header* "HTTP/1.1 404 Not Found\r
Content-Type: text/html; charset=utf-8\r
Connection: close")

(= type-header* (table))

(def gen-type-header (ctype)
  (+ "HTTP/1.0 200 OK\r
Content-Type: "
     ctype
     "\r
Connection: close"))

(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
     '((gif       "image/gif")
       (jpg       "image/jpeg")
       (png       "image/png")
       (text/html "text/html; charset=utf-8")))

(= rdheader* "HTTP/1.0 302 Moved")

(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))

(def save-optime (name elapsed)
  ; this is the place to put a/b testing
  ; toggle a flag and push elapsed into one of two lists
  (++ (opcounts* name 0))
  (unless (optimes* name) (= (optimes* name) (queue)))
  (enq-limit elapsed (optimes* name) 1000))

; For ops that want to add their own headers.  They must thus remember
; to prn a blank line before anything meant to be part of the page.

(mac defop-raw (name parms . body)
  (w/uniq t1
    `(= (srvops* ',name)
        (fn ,parms
          (let ,t1 (msec)
            (do1 (do ,@body)
                 (save-optime ',name (- (msec) ,t1))))))))

(mac defopr-raw (name parms . body)
  `(= (redirector* ',name) t
      (srvops* ',name)     (fn ,parms ,@body)))

(mac defop (name parm . body)
  (w/uniq gs
    `(do (wipe (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           (w/stdout ,gs (prn) ,@body)))))

; Defines op as a redirector.  Its retval is new location.

(mac defopr (name parm . body)
  (w/uniq gs
    `(do (set (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           ,@body))))

;(mac testop (name . args) `((srvops* ',name) ,@args))

(deftem request
  args  nil
  cooks nil
  ctype nil
  clen  0
  in    nil
  ip    nil)

(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)

(def respond (str op args cooks clen ctype in ip)
  (w/stdout str
    (iflet f (srvops* op)
      (let req (inst 'request 'args args 'cooks cooks 'ctype ctype 'clen clen 'in in 'ip ip)
        (if (redirector* op)
            (do (prn rdheader*)
                (prn "Location: " (f str req))
                (prn))
            (do (prn header*)
                (awhen (max-age* op)
                  (prn "Cache-Control: max-age=" it))
                (f str req))))
      (let filetype (static-filetype op)
        (aif (and filetype (file-exists (string staticdir* op)))
             (do (prn (type-header* filetype))
                 (awhen static-max-age*
                   (prn "Cache-Control: max-age=" it))
                 (prn)
                 (w/infile i it
                   (whilet b (readb i)
                     (writeb b str))))
             (respond-err str unknown-msg*))))))

(def static-filetype (sym)
  (let fname (coerce sym 'string)
    (and (~findsubseq ".." fname) ; for security
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "gif"  'gif
           "jpg"  'jpg
           "jpeg" 'jpg
           "png"  'png
           "css"  'text/html
           "txt"  'text/html
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/html
           ))))

(def respond-err (str msg . args)
  (w/stdout str
    (prn err-header*)
    (prn)
    (apply pr msg args)))

(def parseheader (lines)
  (let (type op args) (parseurl (car lines))
    (list type
          op
          args
          (and (is type 'post)
               (some (fn (s)
                       (and (begins downcase.s "content-length:")
                            (errsafe:coerce (cadr (tokens s)) 'int)))
                     (cdr lines)))
          (some (fn (s)
                  (and (begins downcase.s "cookie:")
                       (parsecookies s)))
                (cdr lines))
          (and (is type 'post)
               (some (fn (s)
                       (and (begins downcase.s "content-type: ")
                            (cut s (len "content-type: "))))
                     (cdr lines))))))

; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))

(def parseurl (s)
  (let (type url) (tokens s)
    (let (base args) (tokens url #\?)
      (list (sym (downcase type))
            (sym (cut base 1))
            (if args
                (parseargs args)
                nil)))))

; I don't urldecode field names or anything in cookies; correct?

(def parseargs (s)
  (map (fn ((k v)) (list k (urldecode v)))
       (map [tokens _ #\=] (tokens s #\&))))

(def parsecookies (s)
  (map [tokens _ #\=]
       (cdr (tokens s [or (whitec _) (is _ #\;)]))))

(def arg (req key) (alref req!args key))

; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).

(def reassemble-args (req)
  (aif req!args
       (apply string "?" (intersperse '&
                                      (map (fn ((k v))
                                             (string k '= v))
                                           it)))
       ""))

(= fns* (table) fnids* nil timed-fnids* nil)

; count on huge (expt 64 10) size of fnid space to avoid clashes

(def new-fnid ()
  (check (sym (rand-string 10)) ~fns* (new-fnid)))

(def fnid (f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push key fnids*)
    key))

(def timed-fnid (lasts f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push (list key (seconds) lasts) timed-fnids*)
    key))

; Within f, it will be bound to the fn's own fnid.  Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.

(mac afnid (f)
  `(atlet it (new-fnid)
     (= (fns* it) ,f)
     (push it fnids*)
     it))

;(defop test-afnid req
;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
;    (pr "click here")))

; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called.  But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.

(def harvest-fnids ((o n 50000))  ; was 20000
  (when (len> fns* n)
    (pull (fn ((id created lasts))
            (when (> (since created) lasts)
              (wipe (fns* id))
              t))
          timed-fnids*)
    (atlet nharvest (trunc (/ n 10))
      (let (kill keep) (split (rev fnids*) nharvest)
        (= fnids* (rev keep))
        (each id kill
          (wipe (fns* id)))))))

(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")

(= dead-msg* "\nUnknown or expired link.")

(defop-raw x (str req)
  (w/stdout str
    (aif (arg req "fnid")
      (aif (fns* sym.it)
        (it req)
        (pr dead-msg*))
      (pr "\nno fnid"))))

(defopr-raw y (str req)
  (aif (fns* (sym (arg req "fnid")))
       (w/stdout str (it req))
       "deadlink"))

; For asynchronous calls; discards the page.  Would be better to tell
; the fn not to generate it.

(defop-raw a (str req)
  (aif (fns* (sym (arg req "fnid")))
       (tostring (it req))))

(defopr r req
  (aif (fns* (sym (arg req "fnid")))
       (it req)
       "deadlink"))

(defop deadlink req
  (pr dead-msg*))

(def url-for (fnid)
  (string fnurl* "?fnid=" fnid))

(def flink (f)
  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))

(def rflink (f)
  (string rfnurl* "?fnid=" (fnid f)))

; Since it's just an expr, gensym a parm for (ignored) args.

(mac w/link (expr . body)
  `(tag (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(mac w/rlink (expr . body)
  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
     ,@body))

(mac onlink (text . body)
  `(w/link (do ,@body) (pr ,text)))

(mac onrlink (text . body)
  `(w/rlink (do ,@body) (pr ,text)))

; bad to have both flink and linkf; rename flink something like fnid-link

(mac linkf (text parms . body)
  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))

(mac rlinkf (text parms . body)
  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))

;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))

;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))

(mac w/link-if (test expr . body)
  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(def fnid-field (id)
  (gentag input type 'hidden name 'fnid value id))

; f should be a fn of one arg, which will be http request args.

(def fnform (f bodyfn (o redir))
  (tag (form method 'post action (if redir rfnurl2* fnurl*))
    (fnid-field (fnid f))
    (bodyfn)))

; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?

(mac aform (f . body)
  (w/uniq ga
    `(tag (form method 'post action fnurl*)
       (fnid-field (fnid (fn (,ga)
                           (prn)
                           (,f ,ga))))
       ,@body)))

(mac aform-multi (f . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action (string fnurl* "?fnid="
                               (fnid (fn (,ga)
                                       (prn)
                                       (,f ,ga)))))
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prn) (pr req))
;          (fn () (single-input "" 'foo 20 "submit"))))

;(defop test2 req
;  (aform (fn (req) (pr req))
;    (single-input "" 'foo 20 "submit")))

; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).

(mac taform (lasts f . body)
  (w/uniq (gl gf gi ga)
    `(withs (,gl ,lasts
             ,gf (fn (,ga) (prn) (,f ,ga)))
       (tag (form method 'post action fnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac arform (f . body)
  `(tag (form method 'post action rfnurl*)
     (fnid-field (fnid ,f))
     ,@body))

; overlong

(mac tarform (lasts f . body)
  (w/uniq (gl gf)
    `(withs (,gl ,lasts ,gf ,f)
       (tag (form method 'post action rfnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac aformh (f . body)
  `(tag (form method 'post action fnurl*)
     (fnid-field (fnid ,f))
     ,@body))

(mac arformh (f . body)
  `(tag (form method 'post action rfnurl2*)
     (fnid-field (fnid ,f))
     ,@body))

; only unique per server invocation

(= unique-ids* (table))

(def unique-id ((o len 8))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
        (unique-id)
        (= (unique-ids* id) id))))

(def srvlog (type . args)
  (ontofile (logfile-name type)
            (atomic (apply prs (seconds) args) (prn))))

(def logfile-name (type)
  (string logdir* type "-" (memodate)))

(with (lastasked nil lastval nil)

(def memodate ()
  (let now (seconds)
    (if (or (no lastasked) (> (- now lastasked) 60))
        (= lastasked now lastval (datestring))
        lastval)))

)

(defop || req (pr "It's alive."))

(defop topips req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (each ip (let leaders nil
                   (maptable (fn (ip n)
                               (when (> n 100)
                                 (insort (compare > requests/ip*)
                                         ip
                                         leaders)))
                             requests/ip*)
                   leaders)
          (let n (requests/ip* ip)
            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))

(defop spurned req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (map (fn ((ip n)) (row ip n))
             (sortable spurned*))))))

; eventually promote to general util

(def sortable (ht (o f >))
  (let res nil
    (maptable (fn kv
                (insort (compare f cadr) kv res))
              ht)
    res))

; Background Threads

(= bgthreads* (table) pending-bgthreads* nil)

(def new-bgthread (id f sec)
  (aif (bgthreads* id) (break-thread it))
  (= (bgthreads* id) (new-thread (fn ()
                                   (while t
                                     (sleep sec)
                                     (f))))))

; should be a macro for this?

(mac defbg (id sec . body)
  `(do (pull [caris _ ',id] pending-bgthreads*)
       (push (list ',id (fn () ,@body) ,sec)
             pending-bgthreads*)))

; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.

; HTTP Server.

; To improve performance with static files, set static-max-age*.

(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")

(= quitsrv* nil breaksrv* nil)

(def serve ((o port 8080))
  (wipe quitsrv*)
  (ensure-srvdirs)
  (map [apply new-bgthread _] pending-bgthreads*)
  (w/socket s port
    (setuid 2) ; XXX switch from root to pg
    (prn "ready to serve port " port)
    (flushout)
    (= currsock* s)
    (until quitsrv*
      (handle-request s breaksrv*)))
  (prn "quit server"))

(def serve1 ((o port 8080))
  (w/socket s port (handle-request s t)))

(def ensure-srvdirs ()
  (map ensure-dir (list arcdir* logdir* staticdir*)))

(= srv-noisy* nil)

; http requests currently capped at 2 meg by socket-accept

; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.

; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.

(= threadlife* 30  requests* 0  requests/ip* (table)
   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))

(def handle-request (s breaksrv)
  (if breaksrv
      (handle-request-1 s)
      (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (with ((i o ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (let ip-wrapper (fn args
                      (if args
                        (= ip car.args)
                        ip))
      (= th1 (thread
               (after (handle-request-thread i o ip-wrapper)
                      (close i o)
                      (kill-thread th2))))
      (= th2 (thread
               (sleep threadlife*)
               (unless (dead th1)
                 (prn "srv thread took too long for " ip))
               (kill-thread th1)
               (force-close i o))))))

; Returns true if ip has made req-limit* requests in less than
; req-window* seconds.  If an ip is throttled, only 1 request is
; allowed per req-window* seconds.  If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).

; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.

(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)

(wipe show-abuse*)
(def abusive-ip (ip)
  (++ (requests/ip* ip 0))
  (if show-abuse*
    (if (ignore-ips* ip)
      (prn ip " ignored")
      (prn ip " " (if (abusive-ip-core ip) "" "not ") "abusive (" requests/ip*.ip ")")))
  (and (or (ignore-ips* ip) (abusive-ip-core ip))
       (++ (spurned* ip 0))))

(def abusive-ip-core (ip)
  (and (only.> (requests/ip* ip) 250)
       (let now (seconds)
         (do1 (if (req-times* ip)
                  (and (>= (qlen (req-times* ip))
                           (if (throttle-ips* ip) 1 req-limit*))
                       (let dt (- now (deq (req-times* ip)))
                         (if (< dt dos-window*) (set (ignore-ips* ip)))
                         (< dt req-window*)))
                  (do (= (req-times* ip) (queue))
                      nil))
              (enq now (req-times* ip))))))

(let proxy-header "X-Forwarded-For: "
  (def strip-header(s)
    (subst "" proxy-header s))
  (def proxy-ip(ip-wrapper lines)
    (aif (only.strip-header (car:keep [headmatch proxy-header _] lines))
        (ip-wrapper it)
        (ip-wrapper))))

(wipe show-requests*)
(def handle-request-thread (i o ip-wrapper)
  (with (nls 0 lines nil line nil responded nil t0 (msec))
    (after
      (whilet c (unless responded (readc i))
        (if srv-noisy* (pr c))
        (if (is c #\newline)
            (if (is (++ nls) 2)
                (let (type op args n cooks ctype) (parseheader (rev lines))
                  (if show-requests* (prn lines))
                  (unless (abusive-ip (proxy-ip ip-wrapper lines))
                    (let t1 (msec)
                      (case type
                        get  (respond o op args cooks 0 i "" (ip-wrapper))
                        post (handle-post i o op args n cooks ctype (ip-wrapper))
                             (respond-err o "Unknown request: " (car lines)))
                      (log-request type op args cooks (ip-wrapper) t0 t1)))
                  (set responded))
                (do (push (string (rev line)) lines)
                    (wipe line)))
            (unless (is c #\return)
              (push c line)
              (= nls 0))))
      (close i o)))
  (harvest-fnids))

(def log-request (type op args cooks ip t0 t1)
  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
    (srvlog 'srv ip
                 parsetime
                 respondtime
                 (if (> (+ parsetime respondtime) 1000) "***" "")
                 type
                 op
                 (let arg1 (car args)
                   (if (caris arg1 "fnid") "" arg1))
                 cooks)))

; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))

(def handle-post (i o op args n cooks ctype ip)
  (if srv-noisy* (pr "Post Contents: "))
  (if (no n)
      (respond-err o "Post request without Content-Length.")
      (let line nil
        (unless (begins downcase.ctype "multipart/form-data")
          (whilet c (and (> n 0) (readc i))
            (if srv-noisy* (pr c))
            (-- n)
            (push c line)))
        (if srv-noisy* (pr "\r\n\r\n"))
        (respond o op (+ (parseargs (string (rev line))) args) cooks n ctype i ip))))

(= header* "HTTP/1.1 200 OK\r
Content-Type: text/html; charset=utf-8\r
Connection: close")

(= err-header* "HTTP/1.1 404 Not Found\r
Content-Type: text/html; charset=utf-8\r
Connection: close")

(= type-header* (table))

(def gen-type-header (ctype)
  (+ "HTTP/1.0 200 OK\r
Content-Type: "
     ctype
     "\r
Connection: close"))

(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
     '((gif       "image/gif")
       (jpg       "image/jpeg")
       (png       "image/png")
       (text/html "text/html; charset=utf-8")))

(= rdheader* "HTTP/1.0 302 Moved")

(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))

(def save-optime (name elapsed)
  ; this is the place to put a/b testing
  ; toggle a flag and push elapsed into one of two lists
  (++ (opcounts* name 0))
  (unless (optimes* name) (= (optimes* name) (queue)))
  (enq-limit elapsed (optimes* name) 1000))

; For ops that want to add their own headers.  They must thus remember
; to prn a blank line before anything meant to be part of the page.

(mac defop-raw (name parms . body)
  (w/uniq t1
    `(= (srvops* ',name)
        (fn ,parms
          (let ,t1 (msec)
            (do1 (do ,@body)
                 (save-optime ',name (- (msec) ,t1))))))))

(mac defopr-raw (name parms . body)
  `(= (redirector* ',name) t
      (srvops* ',name)     (fn ,parms ,@body)))

(mac defop (name parm . body)
  (w/uniq gs
    `(do (wipe (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           (w/stdout ,gs (prn) ,@body)))))

; Defines op as a redirector.  Its retval is new location.

(mac defopr (name parm . body)
  (w/uniq gs
    `(do (set (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           ,@body))))

;(mac testop (name . args) `((srvops* ',name) ,@args))

(deftem request
  args  nil
  cooks nil
  ctype nil
  clen  0
  in    nil
  ip    nil)

(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)

(def respond (str op args cooks clen ctype in ip)
  (w/stdout str
    (iflet f (srvops* op)
      (let req (inst 'request 'args args 'cooks cooks 'ctype ctype 'clen clen 'in in 'ip ip)
        (if (redirector* op)
            (do (prn rdheader*)
                (prn "Location: " (f str req))
                (prn))
            (do (prn header*)
                (awhen (max-age* op)
                  (prn "Cache-Control: max-age=" it))
                (f str req))))
      (let filetype (static-filetype op)
        (aif (and filetype (file-exists (string staticdir* op)))
             (do (prn (type-header* filetype))
                 (awhen static-max-age*
                   (prn "Cache-Control: max-age=" it))
                 (prn)
                 (w/infile i it
                   (whilet b (readb i)
                     (writeb b str))))
             (respond-err str unknown-msg*))))))

(def static-filetype (sym)
  (let fname (coerce sym 'string)
    (and (~findsubseq ".." fname) ; for security
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "gif"  'gif
           "jpg"  'jpg
           "jpeg" 'jpg
           "png"  'png
           "css"  'text/html
           "txt"  'text/html
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/html
           ))))

(def respond-err (str msg . args)
  (w/stdout str
    (prn err-header*)
    (prn)
    (apply pr msg args)))

(def parseheader (lines)
  (let (type op args) (parseurl (car lines))
    (list type
          op
          args
          (and (is type 'post)
               (some (fn (s)
                       (and (begins downcase.s "content-length:")
                            (errsafe:coerce (cadr (tokens s)) 'int)))
                     (cdr lines)))
          (some (fn (s)
                  (and (begins downcase.s "cookie:")
                       (parsecookies s)))
                (cdr lines))
          (and (is type 'post)
               (some (fn (s)
                       (and (begins downcase.s "content-type: ")
                            (cut s (len "content-type: "))))
                     (cdr lines))))))

; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))

(def parseurl (s)
  (let (type url) (tokens s)
    (let (base args) (tokens url #\?)
      (list (sym (downcase type))
            (sym (cut base 1))
            (if args
                (parseargs args)
                nil)))))

; I don't urldecode field names or anything in cookies; correct?

(def parseargs (s)
  (map (fn ((k v)) (list k (urldecode v)))
       (map [tokens _ #\=] (tokens s #\&))))

(def parsecookies (s)
  (map [tokens _ #\=]
       (cdr (tokens s [or (whitec _) (is _ #\;)]))))

(def arg (req key) (alref req!args key))

; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).

(def reassemble-args (req)
  (aif req!args
       (apply string "?" (intersperse '&
                                      (map (fn ((k v))
                                             (string k '= v))
                                           it)))
       ""))

(= fns* (table) fnids* nil timed-fnids* nil)

; count on huge (expt 64 10) size of fnid space to avoid clashes

(def new-fnid ()
  (check (sym (rand-string 10)) ~fns* (new-fnid)))

(def fnid (f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push key fnids*)
    key))

(def timed-fnid (lasts f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push (list key (seconds) lasts) timed-fnids*)
    key))

; Within f, it will be bound to the fn's own fnid.  Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.

(mac afnid (f)
  `(atlet it (new-fnid)
     (= (fns* it) ,f)
     (push it fnids*)
     it))

;(defop test-afnid req
;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
;    (pr "click here")))

; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called.  But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.

(def harvest-fnids ((o n 50000))  ; was 20000
  (when (len> fns* n)
    (pull (fn ((id created lasts))
            (when (> (since created) lasts)
              (wipe (fns* id))
              t))
          timed-fnids*)
    (atlet nharvest (trunc (/ n 10))
      (let (kill keep) (split (rev fnids*) nharvest)
        (= fnids* (rev keep))
        (each id kill
          (wipe (fns* id)))))))

(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")

(= dead-msg* "\nUnknown or expired link.")

(defop-raw x (str req)
  (w/stdout str
    (aif (fns* (sym (arg req "fnid")))
         (it req)
         (pr dead-msg*))))

(defopr-raw y (str req)
  (aif (fns* (sym (arg req "fnid")))
       (w/stdout str (it req))
       "deadlink"))

; For asynchronous calls; discards the page.  Would be better to tell
; the fn not to generate it.

(defop-raw a (str req)
  (aif (fns* (sym (arg req "fnid")))
       (tostring (it req))))

(defopr r req
  (aif (fns* (sym (arg req "fnid")))
       (it req)
       "deadlink"))

(defop deadlink req
  (pr dead-msg*))

(def url-for (fnid)
  (string fnurl* "?fnid=" fnid))

(def flink (f)
  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))

(def rflink (f)
  (string rfnurl* "?fnid=" (fnid f)))

; Since it's just an expr, gensym a parm for (ignored) args.

(mac w/link (expr . body)
  `(tag (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(mac w/rlink (expr . body)
  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
     ,@body))

(mac onlink (text . body)
  `(w/link (do ,@body) (pr ,text)))

(mac onrlink (text . body)
  `(w/rlink (do ,@body) (pr ,text)))

; bad to have both flink and linkf; rename flink something like fnid-link

(mac linkf (text parms . body)
  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))

(mac rlinkf (text parms . body)
  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))

;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))

;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))

(mac w/link-if (test expr . body)
  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(def fnid-field (id)
  (gentag input type 'hidden name 'fnid value id))

; f should be a fn of one arg, which will be http request args.

(def fnform (f bodyfn (o redir))
  (tag (form method 'post action (if redir rfnurl2* fnurl*))
    (fnid-field (fnid f))
    (bodyfn)))

; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?

(mac aform (f . body)
  (w/uniq ga
    `(tag (form method 'post action fnurl*)
       (fnid-field (fnid (fn (,ga)
                           (prn)
                           (,f ,ga))))
       ,@body)))

(mac aform-multi (f . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action (string fnurl* "?fnid="
                               (fnid (fn (,ga)
                                       (prn)
                                       (,f ,ga)))))
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prn) (pr req))
;          (fn () (single-input "" 'foo 20 "submit"))))

;(defop test2 req
;  (aform (fn (req) (pr req))
;    (single-input "" 'foo 20 "submit")))

; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).

(mac taform (lasts f . body)
  (w/uniq (gl gf gi ga)
    `(withs (,gl ,lasts
             ,gf (fn (,ga) (prn) (,f ,ga)))
       (tag (form method 'post action fnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac arform (f . body)
  `(tag (form method 'post action rfnurl*)
     (fnid-field (fnid ,f))
     ,@body))

; overlong

(mac tarform (lasts f . body)
  (w/uniq (gl gf)
    `(withs (,gl ,lasts ,gf ,f)
       (tag (form method 'post action rfnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac aformh (f . body)
  `(tag (form method 'post action fnurl*)
     (fnid-field (fnid ,f))
     ,@body))

(mac arformh (f . body)
  `(tag (form method 'post action rfnurl2*)
     (fnid-field (fnid ,f))
     ,@body))

; only unique per server invocation

(= unique-ids* (table))

(def unique-id ((o len 8))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
        (unique-id)
        (= (unique-ids* id) id))))

(def srvlog (type . args)
  (ontofile (logfile-name type)
            (atomic (apply prs (seconds) args) (prn))))

(def logfile-name (type)
  (string logdir* type "-" (memodate)))

(with (lastasked nil lastval nil)

(def memodate ()
  (let now (seconds)
    (if (or (no lastasked) (> (- now lastasked) 60))
        (= lastasked now lastval (datestring))
        lastval)))

)

(defop || req (pr "It's alive."))

(defop topips req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (each ip (let leaders nil
                   (maptable (fn (ip n)
                               (when (> n 100)
                                 (insort (compare > requests/ip*)
                                         ip
                                         leaders)))
                             requests/ip*)
                   leaders)
          (let n (requests/ip* ip)
            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))

(defop spurned req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (map (fn ((ip n)) (row ip n))
             (sortable spurned*))))))

; eventually promote to general util

(def sortable (ht (o f >))
  (let res nil
    (maptable (fn kv
                (insort (compare f cadr) kv res))
              ht)
    res))

; Background Threads

(= bgthreads* (table) pending-bgthreads* nil)

(def new-bgthread (id f sec)
  (aif (bgthreads* id) (break-thread it))
  (= (bgthreads* id) (new-thread (fn ()
                                   (while t
                                     (sleep sec)
                                     (f))))))

; should be a macro for this?

(mac defbg (id sec . body)
  `(do (pull [caris _ ',id] pending-bgthreads*)
       (push (list ',id (fn () ,@body) ,sec)
             pending-bgthreads*)))

; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.