rm-global: removed debug code

rm-global: removed debug code

; rm-global.arc
; by AmkG
; partial dead code elimination - unused global removal
;
; removes assignments to globals, if the global
; is not read.  Also removes bits of the program
; that won't return any values and have side effects,
; such as docstrings.

(def rm-global (ast)
  (with (writeset (gv-set ast)
         readset (gv-read ast)
         ; private functions
         remove-consts nil
         remove-assigns nil)
    ; removes assigments to variables in the
    ; toremove set
    (= remove-assigns
       (fn (toremove ast)
         ; if it's an assignment, and it's one of
         ; the assigments to remove, then remove the
         ; enclosing assignment: remember that we need
         ; to handle the case:
         ;   (set used-global (set unused-global value))
         ;   =>
         ;   (set used-global value)
         (if
           (and (aset ast) (some ast!var toremove))
             (car ast!subx)
           (aquote ast)
             ast
             (do
               (= ast!subx (map [remove-assigns toremove _] ast!subx))
               ast))))
    ; removes constants and other no-side-effect code
    ; from within sequences
    (= remove-consts
       (fn (ast)
         (if
           (aseq ast)
             (do
               (= ast!subx
                  ((afn ((ast . rest))
                     (if
                       rest
                       ; check if ast can't have side-effects
                       ; Note: this test is the most important
                       ; part of the dead-code elimination
                       ; If we can detect that something won't have
                       ; an effect if it isn't the return value,
                       ; then we can eliminate it
                         (if ((orf alit aref aquote alam) ast)
                             (self rest)
                             (cons (remove-consts ast) (self rest)))
                       ; tails are always useful
                       ast
                         (cons (remove-consts ast) nil)))
                   ast!subx))
               ast)
           (aquote ast)
             ast
             (do
               (= ast!subx (map remove-consts ast!subx))
               ast))))
    (aif
      ; remove any global variables written that
      ; aren't read
      (diff writeset readset)
        (rm-global:remove-consts:remove-assigns it ast)
      ; if there's anything read that isn't written,
      ; raise exception
      (diff readset writeset)
        ; allow some undefined globals: these are inserted later in
        ; the transformation
        (if (all [in _!uid 'ccc] it)
          ast
          (err:tostring:pr "Global variables read, but aren't assigned to: "
                           (map [_ 'uid] it)))
      ; else continue
        ast)))

; rm-global.arc
; by AmkG
; partial dead code elimination - unused global removal
;
; removes assignments to globals, if the global
; is not read.  Also removes bits of the program
; that won't return any values and have side effects,
; such as docstrings.

(def rm-global (ast)
  (with (writeset (gv-set ast)
         readset (gv-read ast)
         ; private functions
         remove-consts nil
         remove-assigns nil)
    ; removes assigments to variables in the
    ; toremove set
    (= remove-assigns
       (fn (toremove ast)
         ; if it's an assignment, and it's one of
         ; the assigments to remove, then remove the
         ; enclosing assignment: remember that we need
         ; to handle the case:
         ;   (set used-global (set unused-global value))
         ;   =>
         ;   (set used-global value)
         (if
           (and (aset ast) (some ast!var toremove))
             (car ast!subx)
           (aquote ast)
             ast
             (do
               (= ast!subx (map [remove-assigns toremove _] ast!subx))
               ast))))
    ; removes constants and other no-side-effect code
    ; from within sequences
    (= remove-consts
       (fn (ast)
         (prn "remove-consts " (source ast))
         (if
           (aseq ast)
             (do
               (= ast!subx
                  ((afn ((ast . rest))
                     (if
                       rest
                       ; check if ast can't have side-effects
                       ; Note: this test is the most important
                       ; part of the dead-code elimination
                       ; If we can detect that something won't have
                       ; an effect if it isn't the return value,
                       ; then we can eliminate it
                         (if ((orf alit aref aquote alam) ast)
                             (self rest)
                             (cons (remove-consts ast) (self rest)))
                       ; tails are always useful
                       ast
                         (cons (remove-consts ast) nil)))
                   ast!subx))
               ast)
           (aquote ast)
             ast
             (do
               (= ast!subx (map remove-consts ast!subx))
               ast))))
    (aif
      ; remove any global variables written that
      ; aren't read
      (diff writeset readset)
        (rm-global:remove-consts:remove-assigns it ast)
      ; if there's anything read that isn't written,
      ; raise exception
      (diff readset writeset)
        ; allow some undefined globals: these are inserted later in
        ; the transformation
        (if (all [in _!uid 'ccc] it)
          ast
          (err:tostring:pr "Global variables read, but aren't assigned to: "
                           (map [_ 'uid] it)))
      ; else continue
        ast)))


We do not use the ed driver anymore

We do not use the ed driver anymore

#	$OpenBSD: files.arc,v 1.21 1999/09/11 10:20:20 niklas Exp $
#
# maxpartitions must be first item in files.${ARCH}
#
maxpartitions 16

maxusers 2 8 64

#	Required files

file	arch/arc/arc/autoconf.c
file	arch/arc/arc/conf.c
file	arch/arc/dev/dma.c
file	arch/arc/arc/machdep.c
file	arch/arc/arc/pmap.c
file	arch/arc/arc/trap.c

file	arch/mips/mips/arcbios.c

#
# Machine-independent ATAPI drivers
#

include "../../../dev/atapiscsi/files.atapiscsi"
include "../../../dev/ata/files.ata"

#
#	System BUS types
#
define	mainbus {}
device	mainbus
attach	mainbus at root
file	arch/mips/mips/mainbus.c	mainbus

#	Our CPU configurator
device	cpu
attach	cpu at mainbus			# not optional
file arch/mips/mips/cpu.c		cpu

#
#	PICA bus autoconfiguration devices
#
device	pica {}
attach	pica at mainbus			# optional
file	arch/arc/pica/picabus.c		pica

#
#	ALGOR bus autoconfiguration devices
#
device	algor {}
attach	algor at mainbus		# optional
file	arch/arc/algor/algorbus.c	algor

#
#	ISA Bus bridge
#
device	isabr {} : isabus
attach	isabr at mainbus		# optional
file	arch/arc/isa/isabus.c		isabr

#
#	PCI Bus bridge
#
device	pbcpcibr {} : pcibus
attach	pbcpcibr at mainbus		# optional
file	arch/arc/pci/pbcpcibus.c	pbcpcibr

#	Ethernet chip on PICA bus
device	sn
attach	sn at pica: ifnet, ether
file	arch/arc/dev/if_sn.c		sn	needs-count

#	Use machine independent SCSI driver routines
include	"../../../scsi/files.scsi"
major	{sd = 0}
major	{cd = 3}

#	Symbios 53C94 SCSI interface driver on PICA bus
device	asc: scsi
attach	asc at pica
file	arch/arc/dev/asc.c		asc	needs-count

#	Floppy disk controller on PICA bus
device	fdc {drive = -1}
attach	fdc at pica
device	fd: disk
attach	fd at fdc
file	arch/arc/dev/fd.c		fdc	needs-flag
major	{fd = 7}

#
#	Stock ISA bus support
#
define  pcmcia {}			# XXX dummy decl...

include	"../../../dev/pci/files.pci"
include	"../../../dev/isa/files.isa"
major	{ wd = 4 }

#	Real time clock, must have one..
device	clock
attach	clock at pica with clock_pica
attach	clock at isa with clock_isa
attach	clock at algor with clock_algor
file	arch/arc/arc/clock_mc.c	clock & (clock_isa | clock_pica | clock_algor) needs-flag

#	Console driver on PC-style graphics
device	pc: tty
attach	pc at pica with pc_pica
attach	pc at isa with pc_isa
device	pms: tty
attach	pms at pica
file	arch/arc/dev/pccons.c		pc & (pc_pica | pc_isa)	needs-flag

# BusLogic BT-445C VLB SCSI Controller. Special on TYNE local bus.
device  btl: scsi
attach  btl at isa
file    arch/arc/dti/btl.c              btl needs-count

# 8250/16[45]50-based "com" ports
attach	com at pica with com_pica
attach	com at algor with com_algor
file	arch/arc/dev/com_lbus.c		com & (com_pica | com_algor)

# Game adapter (joystick)
device  joy
attach  joy at isa
file    arch/arc/isa/joy.c             joy needs-flag

# PC parallel ports (XXX what chip?)
attach	lpt at pica with lpt_pica
attach	lpt at algor with lpt_algor
file	arch/arc/dev/lpt_lbus.c		lpt & (lpt_pica | lpt_algor)

#
#	PCI Bus support
#

# PCI VGA display driver
device	pcivga: tty
attach	pcivga at pci
file	arch/arc/pci/pci_vga.c		pcivga

#
# ISA PnP
#

include "../../../dev/isa/files.isapnp"
file	arch/arc/isa/isapnp_machdep.c	isapnp

#
# Specials.
#
# RAM disk for boot tape
pseudo-device rd
file dev/ramdisk.c			rd needs-flag
file arch/arc/dev/rd_root.c		ramdisk_hooks
major {rd = 8}

#
#	Common files
#

file	dev/cons.c
file	dev/cninit.c
file	netinet/in_cksum.c
file	netns/ns_cksum.c			ns

file	compat/ultrix/ultrix_misc.c		compat_ultrix
file	compat/ultrix/ultrix_syscalls.c		compat_ultrix
file	compat/ultrix/ultrix_sysent.c		compat_ultrix

#	$OpenBSD: files.arc,v 1.20 1999/08/12 13:06:33 niklas Exp $
#
# maxpartitions must be first item in files.${ARCH}
#
maxpartitions 16

maxusers 2 8 64

#	Required files

file	arch/arc/arc/autoconf.c
file	arch/arc/arc/conf.c
file	arch/arc/dev/dma.c
file	arch/arc/arc/machdep.c
file	arch/arc/arc/pmap.c
file	arch/arc/arc/trap.c

file	arch/mips/mips/arcbios.c

#
# Machine-independent ATAPI drivers
#

include "../../../dev/atapiscsi/files.atapiscsi"
include "../../../dev/ata/files.ata"

#
#	System BUS types
#
define	mainbus {}
device	mainbus
attach	mainbus at root
file	arch/mips/mips/mainbus.c	mainbus

#	Our CPU configurator
device	cpu
attach	cpu at mainbus			# not optional
file arch/mips/mips/cpu.c		cpu

#
#	PICA bus autoconfiguration devices
#
device	pica {}
attach	pica at mainbus			# optional
file	arch/arc/pica/picabus.c		pica

#
#	ALGOR bus autoconfiguration devices
#
device	algor {}
attach	algor at mainbus		# optional
file	arch/arc/algor/algorbus.c	algor

#
#	ISA Bus bridge
#
device	isabr {} : isabus
attach	isabr at mainbus		# optional
file	arch/arc/isa/isabus.c		isabr

#
#	PCI Bus bridge
#
device	pbcpcibr {} : pcibus
attach	pbcpcibr at mainbus		# optional
file	arch/arc/pci/pbcpcibus.c	pbcpcibr

#	Ethernet chip on PICA bus
device	sn
attach	sn at pica: ifnet, ether
file	arch/arc/dev/if_sn.c		sn	needs-count

#	Use machine independent SCSI driver routines
include	"../../../scsi/files.scsi"
major	{sd = 0}
major	{cd = 3}

#	Symbios 53C94 SCSI interface driver on PICA bus
device	asc: scsi
attach	asc at pica
file	arch/arc/dev/asc.c		asc	needs-count

#	Floppy disk controller on PICA bus
device	fdc {drive = -1}
attach	fdc at pica
device	fd: disk
attach	fd at fdc
file	arch/arc/dev/fd.c		fdc	needs-flag
major	{fd = 7}

#
#	Stock ISA bus support
#
define  pcmcia {}			# XXX dummy decl...

include	"../../../dev/pci/files.pci"
include	"../../../dev/isa/files.isa"
major	{ wd = 4 }

#	Real time clock, must have one..
device	clock
attach	clock at pica with clock_pica
attach	clock at isa with clock_isa
attach	clock at algor with clock_algor
file	arch/arc/arc/clock_mc.c	clock & (clock_isa | clock_pica | clock_algor) needs-flag

#	Console driver on PC-style graphics
device	pc: tty
attach	pc at pica with pc_pica
attach	pc at isa with pc_isa
device	pms: tty
attach	pms at pica
file	arch/arc/dev/pccons.c		pc & (pc_pica | pc_isa)	needs-flag

# BusLogic BT-445C VLB SCSI Controller. Special on TYNE local bus.
device  btl: scsi
attach  btl at isa
file    arch/arc/dti/btl.c              btl needs-count

# 8250/16[45]50-based "com" ports
attach	com at pica with com_pica
attach	com at algor with com_algor
file	arch/arc/dev/com_lbus.c		com & (com_pica | com_algor)

# Game adapter (joystick)
device  joy
attach  joy at isa
file    arch/arc/isa/joy.c             joy needs-flag
file    dev/isa/if_ed.c                 ed & (ed_isa | ed_pcmcia) needs-flag

# PC parallel ports (XXX what chip?)
attach	lpt at pica with lpt_pica
attach	lpt at algor with lpt_algor
file	arch/arc/dev/lpt_lbus.c		lpt & (lpt_pica | lpt_algor)

#
#	PCI Bus support
#

# PCI VGA display driver
device	pcivga: tty
attach	pcivga at pci
file	arch/arc/pci/pci_vga.c		pcivga

#
# ISA PnP
#

include "../../../dev/isa/files.isapnp"
file	arch/arc/isa/isapnp_machdep.c	isapnp

#
# Specials.
#
# RAM disk for boot tape
pseudo-device rd
file dev/ramdisk.c			rd needs-flag
file arch/arc/dev/rd_root.c		ramdisk_hooks
major {rd = 8}

#
#	Common files
#

file	dev/cons.c
file	dev/cninit.c
file	netinet/in_cksum.c
file	netns/ns_cksum.c			ns

file	compat/ultrix/ultrix_misc.c		compat_ultrix
file	compat/ultrix/ultrix_syscalls.c		compat_ultrix
file	compat/ultrix/ultrix_sysent.c		compat_ultrix


another template bug: blog.arc was stale

; Blog tool example.  20 Jan 08, rev 21 May 09.

; To run:
; arc> (load "lib/blog.arc")
; arc> (bsv)
; go to http://localhost:8080/blog

(= postdir* "arc/posts/"  maxid* 0  posts* (table))

(= blogtitle* "A Blog")

(deftem post  id nil  title nil  text nil)

(def load-posts ()
  (each id (map int (dir postdir*))
    (= maxid*      (max maxid* id)
       (posts* id) (temload 'post (string postdir* id)))))

(def save-post (p) (temstore 'post p (string postdir* p!id)))

(def post (id) (posts* (errsafe:int id)))

(mac blogpage body
  `(whitepage
     (center
       (widtable 600
         (tag b (link blogtitle* "blog"))
         (br 3)
         ,@body
         (br 3)
         (w/bars (link "archive")
                 (link "new post" "newpost"))))))

(defop viewpost req (blogop post-page req))

(def blogop (f req)
  (aif (post (arg req "id"))
       (f (get-user req) it)
       (blogpage (pr "No such post."))))

(def permalink (p) (string "viewpost?id=" p!id))

(def post-page (user p) (blogpage (display-post user p)))

(def display-post (user p)
  (tag b (link p!title (permalink p)))
  (when user
    (sp)
    (link "[edit]" (string "editpost?id=" p!id)))
  (br2)
  (pr p!text))

(defopl newpost req
  (whitepage
    (aform [let u (get-user _)
             (post-page u (addpost u (arg _ "t") (arg _ "b")))]
      (tab (row "title" (input "t" "" 60))
           (row "text"  (textarea "b" 10 80))
           (row ""      (submit))))))

(def addpost (user title text)
  (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
    (save-post p)
    (= (posts* p!id) p)))

(defopl editpost req (blogop edit-page req))

(def edit-page (user p)
  (whitepage
    (vars-form user
               `((string title ,p!title t t) (text text ,p!text t t))
               (fn (name val) (= (p name) val))
               (fn () (save-post p)
                      (post-page user p)))))

(defop archive req
  (blogpage
    (tag ul
      (each p (map post (rev (range 1 maxid*)))
        (tag li (link p!title (permalink p)))))))

(defop blog req
  (let user (get-user req)
    (blogpage
      (for i 0 4
        (awhen (posts* (- maxid* i))
          (display-post user it)
          (br 3))))))

(def bsv ()
  (ensure-dir postdir*)
  (load-posts)
  (asv))

; Blog tool example.  20 Jan 08, rev 21 May 09.

; To run:
; arc> (load "lib/blog.arc")
; arc> (bsv)
; go to http://localhost:8080/blog

(= postdir* "arc/posts/"  maxid* 0  posts* (table))

(= blogtitle* "A Blog")

(deftem post  id nil  title nil  text nil)

(def load-posts ()
  (each id (map int (dir postdir*))
    (= maxid*      (max maxid* id)
       (posts* id) (temload 'post (string postdir* id)))))

(def save-post (p) (save-table p (string postdir* p!id)))

(def post (id) (posts* (errsafe:int id)))

(mac blogpage body
  `(whitepage
     (center
       (widtable 600
         (tag b (link blogtitle* "blog"))
         (br 3)
         ,@body
         (br 3)
         (w/bars (link "archive")
                 (link "new post" "newpost"))))))

(defop viewpost req (blogop post-page req))

(def blogop (f req)
  (aif (post (arg req "id"))
       (f (get-user req) it)
       (blogpage (pr "No such post."))))

(def permalink (p) (string "viewpost?id=" p!id))

(def post-page (user p) (blogpage (display-post user p)))

(def display-post (user p)
  (tag b (link p!title (permalink p)))
  (when user
    (sp)
    (link "[edit]" (string "editpost?id=" p!id)))
  (br2)
  (pr p!text))

(defopl newpost req
  (whitepage
    (aform [let u (get-user _)
             (post-page u (addpost u (arg _ "t") (arg _ "b")))]
      (tab (row "title" (input "t" "" 60))
           (row "text"  (textarea "b" 10 80))
           (row ""      (submit))))))

(def addpost (user title text)
  (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
    (save-post p)
    (= (posts* p!id) p)))

(defopl editpost req (blogop edit-page req))

(def edit-page (user p)
  (whitepage
    (vars-form user
               `((string title ,p!title t t) (text text ,p!text t t))
               (fn (name val) (= (p name) val))
               (fn () (save-post p)
                      (post-page user p)))))

(defop archive req
  (blogpage
    (tag ul
      (each p (map post (rev (range 1 maxid*)))
        (tag li (link p!title (permalink p)))))))

(defop blog req
  (let user (get-user req)
    (blogpage
      (for i 0 4
        (awhen (posts* (- maxid* i))
          (display-post user it)
          (br 3))))))

(def bsv ()
  (ensure-dir postdir*)
  (load-posts)
  (asv))


closures: closure conversion now preserves continuation-ness of functions

;------------------------------------------------------------------------------
; closure conversion

(def convert (ast self-var free-vars)
  (let cc (rfn cc (ast)
    (if
      (or (alit ast) (aquote ast))
        ast
      (aref ast)
        (aif (pos ast!var free-vars)
          (make-prim (list (make-ref '() self-var) (make-lit '() (+ it 1))) '%closure-ref)
          ast)
      (aset ast)
        (make-set (map cc ast!subx) ast!var)
      (acnd ast)
        (make-cnd (map cc ast!subx))
      (aprim ast)
        (make-prim (map cc ast!subx) ast!op)
      (anapp ast)
        (with
          (fun (car ast!subx)
           args (map cc (cdr ast!subx)))
          (if (alam fun)
            (make-app:cons
              ((if fun!continuation make-cont make-lam)
                (list:cc (car fun!subx)) fun!params) args)
            (let f (cc fun)
              (make-app:cons (make-prim (list f (make-lit '() 0)) '%closure-ref) (cons f args)))))
      (alam ast)
        (with
          (new-free-vars (keep [~aglobal _] (fv ast))
           new-self-var (new-var 'self))
          (make-prim
            (cons
              ((if ast!continuation make-cont make-lam)
                (list:convert (car ast!subx) new-self-var new-free-vars)
                (cons new-self-var ast!params))
              (map [cc (make-ref '() _)] new-free-vars))
            '%closure))
      (aseq ast) ; Impossible after CPS
        (make-seq (map cc ast!subx))
        (err "unknown ast" ast)))

    (cc ast)))

(def closure-convert (ast)
  (make-lam (list (convert ast nil '())) '()))

;------------------------------------------------------------------------------
; closure conversion

(def convert (ast self-var free-vars)
  (let cc (rfn cc (ast)
    (if
      (or (alit ast) (aquote ast))
        ast
      (aref ast)
        (aif (pos ast!var free-vars)
          (make-prim (list (make-ref '() self-var) (make-lit '() (+ it 1))) '%closure-ref)
          ast)
      (aset ast)
        (make-set (map cc ast!subx) ast!var)
      (acnd ast)
        (make-cnd (map cc ast!subx))
      (aprim ast)
        (make-prim (map cc ast!subx) ast!op)
      (anapp ast)
        (with
          (fun (car ast!subx)
           args (map cc (cdr ast!subx)))
          (if (alam fun)
            (make-app:cons (make-lam (list:cc (car fun!subx)) fun!params) args)
            (let f (cc fun)
              (make-app:cons (make-prim (list f (make-lit '() 0)) '%closure-ref) (cons f args)))))
      (alam ast)
        (with
          (new-free-vars (keep [~aglobal _] (fv ast))
           new-self-var (new-var 'self))
          (make-prim
            (cons
              (make-lam
                (list:convert (car ast!subx) new-self-var new-free-vars)
                (cons new-self-var ast!params))
              (map [cc (make-ref '() _)] new-free-vars))
            '%closure))
      (aseq ast) ; Impossible after CPS
        (make-seq (map cc ast!subx))
        (err "unknown ast" ast)))

    (cc ast)))

(def closure-convert (ast)
  (make-lam (list (convert ast nil '())) '()))


arc2b/bytecodegen: now supports t and nil literals, corrected bug in apply generation

(require "lib/proto-table.arc")

(def bytecodegen (ast (o env (table 'top 0)) (o cont-clos))
  ; (ppr-sexp:source ast)
  (withs (is-closure-ref-self
          (fn (ast)
            (and (aprim ast) (is ast!op '%closure-ref)
                 (let (s-var i) ast!subx
                   (and (aref s-var) (is 0 (env s-var!var))))))
          is-closure-ref-0
          (fn (ast)
            (and (aprim ast) (is ast!op '%closure-ref) (is ((cadr ast!subx) 'val) 0)))
          is-cont-type
          (fn (asts)
            (if (is (len asts) 2)
                (let (f r) asts
                  (and (aref f) (is 1 (env f!var))))))
          is-cont-on-closure-type
          (fn (asts)
            (if (is (len asts) 2)
                (let (f r) asts
                  (is-closure-ref-self f))))
          ; ensure that a tail call apply really is just a tail-call apply
          ; (i.e. does not nest any if's or lets)
          apply-pushall
          (fn (params)
            (mappend
              (fn (p)
                (if ((orf aprim aref aset aquote alit) p)
                    (bytecodegen p env)
                    (do (prn "----unexpected in tail-call apply")
                        (ppr-sexp:source p)
                        nil)))
              params))
          ; generates an environment for a function
          f-environment
          (fn (params)
            (let new-env (table)
              (on p params (= new-env.p index))
              (= new-env!top (len params))
              new-env))
          ; uses the specified bytecode's -local-push
          ; version if possible
          w/local-push
          (fn (param op)
            ; check if it's a local variable reference
            (aif
              (and (aref param) (~aglobal param!var) (env param!var))
                 `( (,(sym:string op '-local-push) ,it))
              (is-closure-ref-self param)
                 ; closure values in arc2c are numbered from 1->N, but
                 ; in snap are numbered 0->N-1
                 `( (,(sym:string op '-clos-push) ,(- ((cadr param!subx) 'val) 1)))
              ; else
                 `( ,@(bytecodegen param env)
                    ,op)))
          direct-compile
          (fn (params op)
            `( ,@(mappend [bytecodegen _ env] params)
               ,op))
          is-continuation
          (fn (ast)
            (if (and (aprim ast) (is '%closure ast!op))
               (let f (car ast!subx)
                  (and (alam f) f!continuation)))))
    (if
      (anapp ast)
        ; check if applied-to parameter is a function
        (let (f . params) ast!subx
          (if (alam f)
              ; let form
              ; associate parameters with variables
              ; Note! does not handle cases:
              ; ((fn (a) ...) 1 2 3)
              ; (shouldn't happen anyway, probably flag
              ; this as an error before reaching this stage)
              (withs (assoclist
                      ((afn (vars subxs)
                         (if
                           (acons vars)
                             (cons
                               (cons (car vars) (car subxs))
                               (self (cdr vars) (cdr subxs)))
                           ; rest parameter
                           ; (shouldn't normally happen...)
                           vars
                             (cons
                               (cons vars
                                 ((afn (subxs)
                                    (if subxs
                                        (make-prim
                                          `(,(car subxs) ,(self:cdr subxs))
                                          '%cons)
                                        (make-lit () nil)))
                                  subxs))
                               nil)))
                       f!params params)
                       ; create a new environment
                       ; (don't overwrite old one - we might
                       ; be on one branch of an 'if)
                       new-env (proto-table env)
                       ; push each parameter on the stack
                       pushlist
                       (mappend
                         (fn ((var . ast))
                           ; just rename it if reference to an existing
                           ; local variable
                           (aif (and
                                  (aref ast)
                                  (~aglobal ast!var)
                                  (env ast!var))
                                ; existing local
                                (do
                                  (= (new-env var) it)
                                  ; emit no code
                                  ())
                                ; emit code for it
                                (do
                                  (= (new-env var) new-env!top)
                                  (++ new-env!top)
                                  (bytecodegen ast env))))
                         assoclist))
                `(,@pushlist
                  ,@(bytecodegen (car f!subx) new-env cont-clos)))
              ; ordinary apply
              ; ignore f: the base system will handle this for us
              (if (is-closure-ref-0 f)
                  (if
                    ; check if continuation-type (first param is ref
                    ; to local[1], and two params (continuation and
                    ; return-value) only)
                    (is-cont-type params)
                      ; now check if return value is a variable reference
                      (let (k rv) params
                        (if (and (aref rv) (~aglobal rv!var))
                            `( (continue-local ,(env rv!var)))
                            `( ,@(bytecodegen rv env)
                               continue)))
                    ; check if continuation-type where continuation is a
                    ; closure-ref (first param is ref to self[N], and two
                    ; params only)
                    (is-cont-on-closure-type params)
                      (let (k rv) params
                        `( ,@(bytecodegen rv env)
                           ; arc2c counts the function code as closure.0
                           ; snap does not, so convert closure.N to
                           ; (closure (- N 1))
                           (continue-on-clos ,(- ((cadr k!subx) 'val) 1))))
                    ; check if current function is a continuation,
                    ; if we need to create a continuation for this
                    ; call, and if we can reuse this continuation's
                    ; closure structure
                    (and cont-clos (is-continuation:cadr params)
                         (>= cont-clos (- (len ((cadr params) 'subx)) 1)))
                      (withs ((f k . params) params
                              ; k-fn = the lambda for the continuation
                              ; k-closed = the closed variables of the
                              ;   continuation
                              (k-fn . k-closed) k!subx)
                        `( ,@(bytecodegen f env)
                           (local 0) ; placeholder for k
                           ,@(mappend [bytecodegen _ env] params)
                           ,@(mappend [bytecodegen _ env] k-closed)
                           (k-closure-reuse ,(len k-closed)
                             ,@(bytecodegen
                                 (car k-fn!subx)
                                 (f-environment k-fn!params)
                                 cont-clos))
                           (apply-invert-k ,(+ 2 (len params)))))
                    ; ordinary apply
                       ; NOTE! assumes that subexpressions here cannot
                       ; be 'let forms
                      `( ,@(apply-pushall params)
                         (apply ,(len params))))
                  (do (prn "----expected (%closure-ref _ 0) on apply")
                      (ppr-sexp:source ast)
                      nil))))
      (aprim ast)
        (given op      ast!op
               params  ast!subx
          (case op
            %closure-ref
              ; make sure we are referring to the
              ; self variable
              (let (s-var paramnum) params
                (if (and
                      (aref s-var)
                      (~aglobal s-var!var)
                      (is 0 (env s-var!var)))
                    ; closure numberings in arc2c count the function code
                    ; as closure.0
                    ; snap does not, so convert closure.N to (closure (- N 1))
                    `((closure-ref ,(- paramnum!val 1)))
                    (do (prn "----expected (%closure-ref self _)")
                        (ppr-sexp:source ast)
                        nil)))
            %closure
              ; make sure first parameter is a
              ; function
              (let (f . closed) params
                (if
                  (~alam f)
                    ; not a function
                    (do (prn "---- expected (%closure (fn ...) ...)")
                        (ppr-sexp:source ast)
                        nil)
                    ; create the closure
                    `( ,@(mappend [bytecodegen _ env] closed)
                       (,(if f!continuation 'k-closure 'closure)
                                ,(len closed)
                                ; add check for correct arguments here
                                ,(if (~dotted f!params)
                                     `(check-vars ,(len f!params))
                                     ; the variadic bytecode counts only
                                     ; the proper arguments
                                     `(variadic
                                        ,(- (len:properify f!params) 1)))
                                ,@(bytecodegen
                                    (car f!subx)
                                    (f-environment:properify f!params)
                                    (if f!continuation (len closed)))))))
            %car
              (w/local-push (car ast!subx) 'car)
            %cdr
              (w/local-push (car ast!subx) 'cdr)
            %cons
              (direct-compile ast!subx 'cons)
            %halt
              (w/local-push (car ast!subx) 'halt)
            %type
              (w/local-push (car ast!subx) 'type)
            %rep
              (w/local-push (car ast!subx) 'rep)
            %annotate
              (direct-compile ast!subx 'tag)
            %apply
              (direct-compile ast!subx 'apply-list)
            %sharedvar
              (w/local-push (car ast!subx) 'sv)
            %sharedvar-read
              (w/local-push (car ast!subx) 'sv-ref)
            %sharedvar-write
              (direct-compile ast!subx 'sv-set)
            ; default primitive
              (do (prn "----unsupported primitive")
                  (ppr-sexp:source ast)
                  nil)))
      (acnd ast)
        (let (c then else) ast!subx
          ; check for common case of local variable reference
          (if (and (aref c) (~aglobal c!var))
              `( (if-local ,(env c!var) ,@(bytecodegen then env))
                 ,@(bytecodegen else env))
              ; bytecode 'if pops stack top, so no need to update environment
              `( ,@(bytecodegen c env)
                 (if ,@(bytecodegen then env))
                 ,@(bytecodegen else env))))
      (alit ast)
        (let val ast!val
          (if
            (isa val 'int)
              `( (int ,val))
            (is val t)
              `( lit-t )
            (no val)
              `( lit-nil )
            ; else
              (do (prn "----unsupported literal type")
                  (ppr-sexp:source ast)
                  nil)))
      (aquote ast)
        (let val ast!val
          (if (isa val 'sym)
              `( (sym ',val))
              (do (prn "----unexpected type in quote form")
                  (ppr-sexp:source ast)
                  nil)))
      (aset ast)
        (given var   ast!var
               (val) ast!subx
          (if (aglobal var)
              `( ,@(bytecodegen val env)
                 (global-set ',var!id))
              (do (prn "----unexpected set of non-global")
                  (ppr-sexp:source ast)
                  nil)))
      (aref ast)
        (let var ast!var
          (if (aglobal var)
              `( (global ',var!id))
              `( (local ,(env var)))))
      ; shouldn't occur after closure conversion
      (alam ast)
        (do (prn "----unexpected naked function")
            (ppr-sexp:source ast)
            nil)
      ; shouldn't occur after cps conversion
      (aseq ast)
        (do (prn "----unexpected sequence")
            (ppr-sexp:source ast)
            nil)
      ; else
        (do (prn "----unsupported ast")
            (ppr-sexp:source ast)
            nil))))

(def bytecodegen-top (ast)
  (if
    ; what we expect
    (alam ast)
      `(
        ,(if (~dotted ast!params)
             `(check-vars ,(len ast!params))
             `(variadic ,(- (len:properify ast!params) 1)))
        ,@(bytecodegen (car ast!subx)
                       (with (rv (table)
                              params (properify ast!params))
                         (on e params (= rv.e index))
                         (= rv!top (len params))
                         rv)))
    ; else
      (do (prn "----expected naked function")
          (ppr-sexp:source ast)
          (err "Expected naked function"))))

(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)
      `(fn ,(map-improper [_ 'uid] ast!params)
           ,@(if ast!continuation '((t arc2b continuation)))
           ,(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))

; 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))

; compiles an expression to bytecode
(def compile-to-bytecode (e)
  (givens xe [xe _ ()]
          top-k-var (new-var 'k)
          cps-convert [cps-convert _ top-k-var]
          closure-convert [closure-convert _ top-k-var]
    ; this is stupid.... I like it!
    (bytecodegen-top:closure-convert:cps-convert:quote-lift:sharedvars-convert-assert:xe:to-3-if:symbol-syntax e)))

(require "lib/proto-table.arc")

(def bytecodegen (ast (o env (table 'top 0)) (o cont-clos))
  ; (ppr-sexp:source ast)
  (withs (is-closure-ref-self
          (fn (ast)
            (and (aprim ast) (is ast!op '%closure-ref)
                 (let (s-var i) ast!subx
                   (and (aref s-var) (is 0 (env s-var!var))))))
          is-closure-ref-0
          (fn (ast)
            (and (aprim ast) (is ast!op '%closure-ref) (is ((cadr ast!subx) 'val) 0)))
          is-cont-type
          (fn (asts)
            (if (is (len asts) 2)
                (let (f r) asts
                  (and (aref f) (is 1 (env f!var))))))
          is-cont-on-closure-type
          (fn (asts)
            (if (is (len asts) 2)
                (let (f r) asts
                  (is-closure-ref-self f))))
          ; ensure that a tail call apply really is just a tail-call apply
          ; (i.e. does not nest any if's or lets)
          apply-pushall
          (fn (params)
            (mappend
              (fn (p)
                (if ((orf aprim aref aset aquote) p)
                    (bytecodegen p env)
                    (do (prn "----unexpected in tail-call apply")
                        (ppr-sexp:source p)
                        nil)))
              params))
          ; generates an environment for a function
          f-environment
          (fn (params)
            (let new-env (table)
              (on p params (= new-env.p index))
              (= new-env!top (len params))
              new-env))
          ; uses the specified bytecode's -local-push
          ; version if possible
          w/local-push
          (fn (param op)
            ; check if it's a local variable reference
            (aif
              (and (aref param) (~aglobal param!var) (env param!var))
                 `( (,(sym:string op '-local-push) ,it))
              (is-closure-ref-self param)
                 ; closure values in arc2c are numbered from 1->N, but
                 ; in snap are numbered 0->N-1
                 `( (,(sym:string op '-clos-push) ,(- ((cadr param!subx) 'val) 1)))
              ; else
                 `( ,@(bytecodegen param env)
                    ,op)))
          direct-compile
          (fn (params op)
            `( ,@(mappend [bytecodegen _ env] params)
               ,op))
          is-continuation
          (fn (ast)
            (if (and (aprim ast) (is '%closure ast!op))
               (let f (car ast!subx)
                  (and (alam f) f!continuation)))))
    (if
      (anapp ast)
        ; check if applied-to parameter is a function
        (let (f . params) ast!subx
          (if (alam f)
              ; let form
              ; associate parameters with variables
              ; Note! does not handle cases:
              ; ((fn (a) ...) 1 2 3)
              ; (shouldn't happen anyway, probably flag
              ; this as an error before reaching this stage)
              (withs (assoclist
                      ((afn (vars subxs)
                         (if
                           (acons vars)
                             (cons
                               (cons (car vars) (car subxs))
                               (self (cdr vars) (cdr subxs)))
                           ; rest parameter
                           ; (shouldn't normally happen...)
                           vars
                             (cons
                               (cons vars
                                 ((afn (subxs)
                                    (if subxs
                                        (make-prim
                                          `(,(car subxs) ,(self:cdr subxs))
                                          '%cons)
                                        (make-lit () nil)))
                                  subxs))
                               nil)))
                       f!params params)
                       ; create a new environment
                       ; (don't overwrite old one - we might
                       ; be on one branch of an 'if)
                       new-env (proto-table env)
                       ; push each parameter on the stack
                       pushlist
                       (mappend
                         (fn ((var . ast))
                           ; just rename it if reference to an existing
                           ; local variable
                           (aif (and
                                  (aref ast)
                                  (~aglobal ast!var)
                                  (env ast!var))
                                ; existing local
                                (do
                                  (= (new-env var) it)
                                  ; emit no code
                                  ())
                                ; emit code for it
                                (do
                                  (= (new-env var) new-env!top)
                                  (++ new-env!top)
                                  (bytecodegen ast env))))
                         assoclist))
                `(,@pushlist
                  ,@(bytecodegen (car f!subx) new-env cont-clos)))
              ; ordinary apply
              ; ignore f: the base system will handle this for us
              (if (is-closure-ref-0 f)
                  (if
                    ; check if continuation-type (first param is ref
                    ; to local[1], and two params (continuation and
                    ; return-value) only)
                    (is-cont-type params)
                      ; now check if return value is a variable reference
                      (let (k rv) params
                        (if (and (aref rv) (~aglobal rv!var))
                            `( (continue-local ,(env rv!var)))
                            `( ,@(bytecodegen rv env)
                               continue)))
                    ; check if continuation-type where continuation is a
                    ; closure-ref (first param is ref to self[N], and two
                    ; params only)
                    (is-cont-on-closure-type params)
                      (let (k rv) params
                        `( ,@(bytecodegen rv env)
                           ; arc2c counts the function code as closure.0
                           ; snap does not, so convert closure.N to
                           ; (closure (- N 1))
                           (continue-on-clos ,(- ((cadr k!subx) 'val) 1))))
                    ; check if current function is a continuation,
                    ; if we need to create a continuation for this
                    ; call, and if we can reuse this continuation's
                    ; closure structure
                    (and cont-clos (is-continuation:cadr params)
                         (>= cont-clos (- (len ((cadr params) 'subx)) 1)))
                      (withs ((f k . params) params
                              ; k-fn = the lambda for the continuation
                              ; k-closed = the closed variables of the
                              ;   continuation
                              (k-fn . k-closed) k!subx)
                        `( ,@(bytecodegen f env)
                           (local 0) ; placeholder for k
                           ,@(mappend [bytecodegen _ env] params)
                           ,@(mappend [bytecodegen _ env] k-closed)
                           (k-closure-reuse ,(len k-closed)
                             ,@(bytecodegen
                                 (car k-fn!subx)
                                 (f-environment k-fn!params)
                                 cont-clos))
                           (apply-invert-k ,(+ 2 (len params)))))
                    ; ordinary apply
                       ; NOTE! assumes that subexpressions here cannot
                       ; be 'let forms
                      `( ,@(apply-pushall params)
                         (apply ,(len params))))
                  (do (prn "----expected (%closure-ref _ 0) on apply")
                      (ppr-sexp:source ast)
                      nil))))
      (aprim ast)
        (given op      ast!op
               params  ast!subx
          (case op
            %closure-ref
              ; make sure we are referring to the
              ; self variable
              (let (s-var paramnum) params
                (if (and
                      (aref s-var)
                      (~aglobal s-var!var)
                      (is 0 (env s-var!var)))
                    ; closure numberings in arc2c count the function code
                    ; as closure.0
                    ; snap does not, so convert closure.N to (closure (- N 1))
                    `((closure-ref ,(- paramnum!val 1)))
                    (do (prn "----expected (%closure-ref self _)")
                        (ppr-sexp:source ast)
                        nil)))
            %closure
              ; make sure first parameter is a
              ; function
              (let (f . closed) params
                (if
                  (~alam f)
                    ; not a function
                    (do (prn "---- expected (%closure (fn ...) ...)")
                        (ppr-sexp:source ast)
                        nil)
                    ; create the closure
                    `( ,@(mappend [bytecodegen _ env] closed)
                       (,(if f!continuation 'k-closure 'closure)
                                ,(len closed)
                                ; add check for correct arguments here
                                ,(if (~dotted f!params)
                                     `(check-vars ,(len f!params))
                                     ; the variadic bytecode counts only
                                     ; the proper arguments
                                     `(variadic
                                        ,(- (len:properify f!params) 1)))
                                ,@(bytecodegen
                                    (car f!subx)
                                    (f-environment:properify f!params)
                                    (if f!continuation (len closed)))))))
            %car
              (w/local-push (car ast!subx) 'car)
            %cdr
              (w/local-push (car ast!subx) 'cdr)
            %cons
              (direct-compile ast!subx 'cons)
            %halt
              (w/local-push (car ast!subx) 'halt)
            %type
              (w/local-push (car ast!subx) 'type)
            %rep
              (w/local-push (car ast!subx) 'rep)
            %annotate
              (direct-compile ast!subx 'tag)
            %apply
              (direct-compile ast!subx 'apply-list)
            %sharedvar
              (w/local-push (car ast!subx) 'sv)
            %sharedvar-read
              (w/local-push (car ast!subx) 'sv-ref)
            %sharedvar-write
              (direct-compile ast!subx 'sv-set)
            ; default primitive
              (do (prn "----unsupported primitive")
                  (ppr-sexp:source ast)
                  nil)))
      (acnd ast)
        (let (c then else) ast!subx
          ; check for common case of local variable reference
          (if (and (aref c) (~aglobal c!var))
              `( (if-local ,(env c!var) ,@(bytecodegen then env))
                 ,@(bytecodegen else env))
              ; bytecode 'if pops stack top, so no need to update environment
              `( ,@(bytecodegen c env)
                 (if ,@(bytecodegen then env))
                 ,@(bytecodegen else env))))
      (alit ast)
        (let val ast!val
          (if
            (isa val 'int)
              `( (int ,val))
            ; else
              (do (prn "----unsupported literal type")
                  (ppr-sexp:source ast)
                  nil)))
      (aquote ast)
        (let val ast!val
          (if (isa val 'sym)
              `( (sym ',val))
              (do (prn "----unexpected type in quote form")
                  (ppr-sexp:source ast)
                  nil)))
      (aset ast)
        (given var   ast!var
               (val) ast!subx
          (if (aglobal var)
              `( ,@(bytecodegen val env)
                 (global-set ',var!id))
              (do (prn "----unexpected set of non-global")
                  (ppr-sexp:source ast)
                  nil)))
      (aref ast)
        (let var ast!var
          (if (aglobal var)
              `( (global ',var!id))
              `( (local ,(env var)))))
      ; shouldn't occur after closure conversion
      (alam ast)
        (do (prn "----unexpected naked function")
            (ppr-sexp:source ast)
            nil)
      ; shouldn't occur after cps conversion
      (aseq ast)
        (do (prn "----unexpected sequence")
            (ppr-sexp:source ast)
            nil)
      ; else
        (do (prn "----unsupported ast")
            (ppr-sexp:source ast)
            nil))))

(def bytecodegen-top (ast)
  (if
    ; what we expect
    (alam ast)
      `(
        ,(if (~dotted ast!params)
             `(check-vars ,(len ast!params))
             `(variadic ,(- (len:properify ast!params) 1)))
        ,@(bytecodegen (car ast!subx)
                       (with (rv (table)
                              params (properify ast!params))
                         (on e params (= rv.e index))
                         (= rv!top (len params))
                         rv)))
    ; else
      (do (prn "----expected naked function")
          (ppr-sexp:source ast)
          (err "Expected naked function"))))

(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)
      `(fn ,(map-improper [_ 'uid] ast!params)
           ,@(if ast!continuation '((t arc2b continuation)))
           ,(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))

; 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))

; compiles an expression to bytecode
(def compile-to-bytecode (e)
  (givens xe [xe _ ()]
          top-k-var (new-var 'k)
          cps-convert [cps-convert _ top-k-var]
          closure-convert [closure-convert _ top-k-var]
    ; this is stupid.... I like it!
    (bytecodegen-top:closure-convert:cps-convert:quote-lift:sharedvars-convert-assert:xe:to-3-if:symbol-syntax e)))


reorg srv.arc into sections

reorg srv.arc into sections

; 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*
      (serve-socket s breaksrv*)))
  (prn "quit server"))

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

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

(= srv-noisy* nil)

; http requests currently capped to upload-limit* bytes
; see 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 serve-socket (s breaksrv)
  (if breaksrv
    (accept-request-with-deadline s)
    (errsafe (accept-request-with-deadline s))))

(def accept-request-with-deadline (s)
  (with ((in out ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (= th1 (thread
             (after (handle-request-thread in out ip)
                    (close in out)
                    (kill-thread th2))))
    (= th2 (thread
             (sleep threadlife*)
             (unless (dead th1)
               (prn "srv thread took too long for " ip))
             (kill-thread th1)
             (force-close in out)))))

(def handle-request-thread (in out ip)
  (withs (t0 (msec)
          req parse-header.in)
    (= req!cooks (only.parse-cookies (req "cookie")))
    (aif (req "x-forwarded-for")
      (= ip it))
    (after
      (unless (abusive? ip)
        (let t1 (msec)
          (if (~authorized? req)
            (request-credentials out)
            (case req!type
              get  (respond out req)
              post (handle-post in out req)
                   (respond-err out "Unknown request: " req)))
          (log-request req!type req!op req!args req!cooks ip t0 t1)))
      (close in out))
    (harvest-fnids)))

(= max-age* (table) static-max-age* nil)

(def respond (out req)
  (w/stdout out
    (iflet f (srvops* req!op)
      (if (redirector* req!op)
        (do (prrn "HTTP/1.1 302 Moved")
            (prrn "Location: " (f out req))
            (prrn))
        (do (prrn "HTTP/1.1 200 OK")
            (prrn "Content-Type: text/html; charset=utf-8")
            (prrn "Connection: close")
            (awhen (max-age* req!op)
              (prrn "Cache-Control: max-age=" it))
            (f out req)))
      (let filetype (static-filetype req!op)
        (aif (and filetype (file-exists (string staticdir* req!op)))
          (do (prrn "HTTP/1.1 200 OK")
              (prrn "Content-Type: " filetype
                   (if (litmatch "text" filetype)
                     "; charset=utf-8"
                     ""))
              (prrn "Connection: close")
              (awhen static-max-age*
                (prrn "Cache-Control: max-age=" it))
              (prrn)
              (w/infile i it
                (whilet b (readb i)
                  (writeb b out))))
          (respond-err out "Unknown."))))))

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

(def respond-err (out msg . args)
  (w/stdout out
    (prrn "HTTP/1.1 404 Not Found")
    (prrn "Content-Type: text/html; charset=utf-8")
    (prrn "Connection: close")
    (prrn)
    (apply pr msg args)))

(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)))

;; http headers

(def parse-header ((o in (stdin)))
  (let (request-line . header-lines) read-header.in
    (as table (accum yield
      (map yield parse-cmd.request-line)
      (map yield (map split-header header-lines))))))

(def read-header ((o in (stdin)))
  (with (nls 0  lines nil  line nil)
    (forever:let c readc.in
      (if no.c (break))
      (if (is c #\return) (continue))
      (if (is c #\newline)
        (++ nls)
        (= nls 0))
      (when (>= nls 2)
        (break))
      (if (is c #\newline)
        (do (push (string rev.line) lines)
            (wipe line))
        (push c line)))
    rev.lines))

(def split-header (line)
  (whenlet n (findsubseq ": " line)
    (list (downcase:cut line 0 n)  ; normalize header key
          (cut line (+ n 2)))))

(def parse-cmd (request-line)
  (accum yield
    (let (type url) tokens.request-line
      (yield `(type ,(sym downcase.type)))
      (let (base args) (tokens url #\?)
        (yield `(op ,(sym:cut base 1)))  ; skip leading slash
        (aif args
          (yield `(args ,parseargs.it)))))))

; 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 parse-cookies (s)
  (map [tokens _ #\=]
       (tokens s [or whitec._ (is _ #\;)])))

(def arg (req key)
  (acheck (alref req!args key) [~isa _ 'table]
    ; deref multipart params by default
    (it "contents")))

;; abusive ip throttling

; 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)

(def abusive? (ip)
  (++ (requests/ip* ip 0))
  (when (or (ignore-ips* ip) (abusive-core ip))
    (when (~spurned* ip)
      (prn "throttling abusive ip " ip))
    (++ (spurned* ip 0))))

(def abusive-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))))))

;; basic auth for private websites

; to enable, provide a single common user:pass in the clear for all users in this file:
(= private-credentials* (errsafe:string:fromfile (+ arcdir* "/private-credentials") (read)))

(def authorized? (req)
  (or no.private-credentials*
      (aand (req "authorization")
            (cut it (len "Basic "))
            (iso private-credentials* base64-decode.it))))

(def request-credentials (out)
  (w/stdout out
    (prrn "HTTP/1.1 401 Not Authorized")
    (prrn "WWW-Authenticate: Basic realm=\"" site-url* "\"")
    (prrn)))

($ (require net/base64))
(def base64-encode (s)
  (fromstring s
    (tostring
      ($.base64-encode-stream (stdin) (stdout)))))
(def base64-decode (s)
  (fromstring s
    (tostring
      ($.base64-decode-stream (stdin) (stdout)))))

;; multipart post requests

(def handle-post (in out req)
  (iflet clen (req "content-length")
    (do (zap [errsafe:as int _] clen)
        (= req!args
           (+ req!args
              (let ctype (req "content-type")
                (if (~begins downcase.ctype "multipart/form-data")
                  (parseargs:string:readchars clen in) ; ascii
                  (parse-multipart-args multipart-boundary.ctype in))))) ; maybe non-ascii
        (respond out req))
    (respond-err out "Post request without Content-Length.")))

(def multipart-boundary (s)
  (let delim "boundary="
    (+ "--" (cut s (+ (findsubseq delim s)
                      len.delim)))))

(def parse-multipart-args (boundary in)
  (scan-past boundary in) ; skip prelude
  (accum yield
    (until (multipart-end boundary in)
      (withs (headers   scan-headers.in
              body  (scan-body boundary in)) ; only part that may contain non-ascii
        (when headers
          (yield:parse-multipart-part headers body))))))

; "The final boundary is followed by two more hyphens to indicate that no
; further parts follow."
;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
; We've already read the boundary itself.
(def multipart-end (boundary in)
  (aif peekc.in
    (and (is #\- it) readc.in
         (or (is #\- peekc.in)
             ; "one #\- shalt thou not count,
             ; excepting that thou then proceed to two"
             (ero "malformed multipart input; boundary followed by just one '-'. Is it the final part or isn't it?")))
    (ero "malformed multipart input; request didn't have a final boundary")))

(def scan-headers (in)
  ; "The boundary must be followed immediately either by another CRLF and the
  ; header fields for the next part, or by two CRLFs, in which case there are no
  ; header fields for the next part.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (parse-mime-header:bytes-string:scan-past "\r\n\r\n" in))

(def scan-body (boundary in)
  ; "The CRLF preceding the encapsulation line is considered part of the
  ; boundary.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (scan-past (+ "\r\n" boundary) in))

(def parse-multipart-part (headers body)
  (awhen (and headers (alref headers "name"))
    (list unstring.it
          (w/table multipart-arg
            (= (multipart-arg "contents")
               (if (all-ascii? body)
                 bytes-string.body
                 body))
            (each (property val) headers
              (unless (iso "name" property)
                (= multipart-arg.property val)))))))

; parse lines of the form a=b; c=d; e=f; ..
; segments without '=' are passed through as single-elem lists
(def parse-mime-header (line)
  (map [tokens _ #\=]
       (tokens downcase.line (orf whitec (testify #\;)))))

; return list of bytes until pat is encountered
; pat is read from input but dropped from result
; all chars in pat must be 1-byte
(def scan-past (pat in)
  (= pat (map int (coerce pat 'cons)))
  (let buffer (spliceable-list len.pat)
    (until (iso pat suffix.buffer)
      (append buffer (list readb.in)))
    splice.buffer))

; convert list of bytes to string
(def bytes-string (l)
  (coerce (map [coerce _ 'char]
               l)
          'string))

(def all-ascii? (l)
  (errsafe:all [<= 0 _ 127] l))

; "\"abc\"" => "abc"
(def unstring (s)
  (if (iso #\" s.0)
    (cut s 1 -1)
    s))

(def multipart-metadata (req arg key)
  (let val (alref req!args arg)
    (if (isa val 'table)
      val.key)))

;; extending the server with new ops

(= 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 prrn 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 (prrn) ,@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))

(= 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) (prrn) (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) (prrn) (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)
                           (prrn)
                           (,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)
                                       (prrn)
                                       (,f ,ga)))))
       ,@body)))

(mac form-multi (action . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action ,action)
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prrn) (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) (prrn) (,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*
      (serve-socket s breaksrv*)))
  (prn "quit server"))

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

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

(= srv-noisy* nil)

; http requests currently capped to upload-limit* bytes
; see 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 serve-socket (s breaksrv)
  (if breaksrv
    (accept-request-with-timeout s)
    (errsafe (accept-request-with-timeout s))))

(def accept-request-with-timeout (s)
  (with ((in out ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (= th1 (thread
             (after (handle-request-thread in out ip)
                    (close in out)
                    (kill-thread th2))))
    (= th2 (thread
             (sleep threadlife*)
             (unless (dead th1)
               (prn "srv thread took too long for " ip))
             (kill-thread th1)
             (force-close in out)))))

(def handle-request-thread (in out ip)
  (withs (t0 (msec)
          req parse-header.in)
    (= req!cooks (only.parse-cookies (req "cookie")))
    (aif (req "x-forwarded-for")
      (= ip it))
    (after
      (unless (abusive ip)
        (let t1 (msec)
          (if (~authorized? req)
            (request-credentials out)
            (case req!type
              get  (respond out req)
              post (handle-post in out req)
                   (respond-err out "Unknown request: " req)))
          (log-request req!type req!op req!args req!cooks ip t0 t1)))
      (close in out))
    (harvest-fnids)))

; 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)

(def abusive (ip)
  (++ (requests/ip* ip 0))
  (when (or (ignore-ips* ip) (abusive-core ip))
    (when (~spurned* ip)
      (prn "throttling abusive ip " ip))
    (++ (spurned* ip 0))))

(def abusive-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))))))

; basic auth support for private websites
; to enable, provide a single common user:pass in the clear for all users in this file:
(= private-credentials* (errsafe:string:fromfile (+ arcdir* "/private-credentials") (read)))

(def authorized? (req)
  (or no.private-credentials*
      (aand (req "authorization")
            (cut it (len "Basic "))
            (iso private-credentials* base64-decode.it))))

(def request-credentials (out)
  (w/stdout out
    (prrn "HTTP/1.1 401 Not Authorized")
    (prrn "WWW-Authenticate: Basic realm=\"" site-url* "\"")
    (prrn)))

($ (require net/base64))
(def base64-encode (s)
  (fromstring s
    (tostring
      ($.base64-encode-stream (stdin) (stdout)))))
(def base64-decode (s)
  (fromstring s
    (tostring
      ($.base64-decode-stream (stdin) (stdout)))))

(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)))

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

(= 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 prrn 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 (prrn) ,@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))

(= max-age* (table) static-max-age* nil)

(def respond (out req)
  (w/stdout out
    (iflet f (srvops* req!op)
      (if (redirector* req!op)
        (do (prrn "HTTP/1.1 302 Moved")
            (prrn "Location: " (f out req))
            (prrn))
        (do (prrn "HTTP/1.1 200 OK")
            (prrn "Content-Type: text/html; charset=utf-8")
            (prrn "Connection: close")
            (awhen (max-age* req!op)
              (prrn "Cache-Control: max-age=" it))
            (f out req)))
      (let filetype (static-filetype req!op)
        (aif (and filetype (file-exists (string staticdir* req!op)))
          (do (prrn "HTTP/1.1 200 OK")
              (prrn "Content-Type: " filetype
                   (if (litmatch "text" filetype)
                     "; charset=utf-8"
                     ""))
              (prrn "Connection: close")
              (awhen static-max-age*
                (prrn "Cache-Control: max-age=" it))
              (prrn)
              (w/infile i it
                (whilet b (readb i)
                  (writeb b out))))
          (respond-err out "Unknown."))))))

(def handle-post (in out req)
  (iflet clen (req "content-length")
    (do (zap [errsafe:as int _] clen)
        (= req!args
           (+ req!args
              (let ctype (req "content-type")
                (if (~begins downcase.ctype "multipart/form-data")
                  (parseargs:string:readchars clen in) ; ascii
                  (parse-multipart-args multipart-boundary.ctype in))))) ; maybe non-ascii
        (respond out req))
    (respond-err out "Post request without Content-Length.")))

(def multipart-boundary (s)
  (let delim "boundary="
    (+ "--" (cut s (+ (findsubseq delim s)
                      len.delim)))))

(def parse-multipart-args (boundary in)
  (scan-past boundary in) ; skip prelude
  (accum yield
    (until (multipart-end boundary in)
      (withs (headers   scan-headers.in
              body  (scan-body boundary in)) ; only part that may contain non-ascii
        (when headers
          (yield:parse-multipart-part headers body))))))

; "The final boundary is followed by two more hyphens to indicate that no
; further parts follow."
;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
; We've already read the boundary itself.
(def multipart-end (boundary in)
  (aif peekc.in
    (and (is #\- it) readc.in
         (or (is #\- peekc.in)
             ; "one #\- shalt thou not count,
             ; excepting that thou then proceed to two"
             (ero "malformed multipart input; boundary followed by just one '-'. Is it the final part or isn't it?")))
    (ero "malformed multipart input; request didn't have a final boundary")))

(def scan-headers (in)
  ; "The boundary must be followed immediately either by another CRLF and the
  ; header fields for the next part, or by two CRLFs, in which case there are no
  ; header fields for the next part.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (parse-mime-header:bytes-string:scan-past "\r\n\r\n" in))

(def scan-body (boundary in)
  ; "The CRLF preceding the encapsulation line is considered part of the
  ; boundary.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (scan-past (+ "\r\n" boundary) in))

(def parse-multipart-part (headers body)
  (awhen (and headers (alref headers "name"))
    (list unstring.it
          (w/table multipart-arg
            (= (multipart-arg "contents")
               (if (all-ascii? body)
                 bytes-string.body
                 body))
            (each (property val) headers
              (unless (iso "name" property)
                (= multipart-arg.property val)))))))

; parse lines of the form a=b; c=d; e=f; ..
; segments without '=' are passed through as single-elem lists
(def parse-mime-header (line)
  (map [tokens _ #\=]
       (tokens downcase.line (orf whitec (testify #\;)))))

; return list of bytes until pat is encountered
; pat is read from input but dropped from result
; all chars in pat must be 1-byte
(def scan-past (pat in)
  (= pat (map int (coerce pat 'cons)))
  (let buffer (spliceable-list len.pat)
    (until (iso pat suffix.buffer)
      (append buffer (list readb.in)))
    splice.buffer))

; convert list of bytes to string
(def bytes-string (l)
  (coerce (map [coerce _ 'char]
               l)
          'string))

(def all-ascii? (l)
  (errsafe:all [<= 0 _ 127] l))

; "\"abc\"" => "abc"
(def unstring (s)
  (if (iso #\" s.0)
    (cut s 1 -1)
    s))

(def respond-err (str msg . args)
  (w/stdout str
    (prrn "HTTP/1.1 404 Not Found")
    (prrn "Content-Type: text/html; charset=utf-8")
    (prrn "Connection: close")
    (prrn)
    (apply pr msg args)))

(def parse-header ((o in (stdin)))
  (let (request-line . header-lines) read-header.in
    (as table (accum yield
      (map yield parse-cmd.request-line)
      (map yield (map split-header header-lines))))))

(def read-header ((o in (stdin)))
  (with (nls 0  lines nil  line nil)
    (forever:let c readc.in
      (if no.c (break))
      (if (is c #\return) (continue))
      (if (is c #\newline)
        (++ nls)
        (= nls 0))
      (when (>= nls 2)
        (break))
      (if (is c #\newline)
        (do (push (string rev.line) lines)
            (wipe line))
        (push c line)))
    rev.lines))

(def split-header (line)
  (whenlet n (findsubseq ": " line)
    (list (downcase:cut line 0 n)  ; normalize header key
          (cut line (+ n 2)))))

(def parse-cmd (request-line)
  (accum yield
    (let (type url) tokens.request-line
      (yield `(type ,(sym downcase.type)))
      (let (base args) (tokens url #\?)
        (yield `(op ,(sym:cut base 1)))  ; skip leading slash
        (aif args
          (yield `(args ,parseargs.it)))))))

; 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 parse-cookies (s)
  (map [tokens _ #\=]
       (tokens s [or whitec._ (is _ #\;)])))

(def arg (req key)
  (acheck (alref req!args key) [~isa _ 'table]
    ; deref multipart params by default
    (it "contents")))

(def multipart-metadata (req arg key)
  (let val (alref req!args arg)
    (if (isa val 'table)
      val.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) (prrn) (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) (prrn) (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)
                           (prrn)
                           (,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)
                                       (prrn)
                                       (,f ,ga)))))
       ,@body)))

(mac form-multi (action . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action ,action)
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prrn) (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) (prrn) (,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.