Expanded the regexp wrappers to accept all of the

optional arguments accepted by their corresponding racket functions.

; Matching.  Spun off 29 Jul 06.

; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"

(def tokens (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs toks tok)
               (if (no cs)         (consif tok toks)
                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
                                   (self (cdr cs) toks (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (map rev (rec (coerce s 'cons) nil nil)))))))

; names of cut, split, halve not optimal

(def halve (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs tok)
               (if (no cs)         (list (rev tok))
                   (test (car cs)) (list cs (rev tok))
                                   (self (cdr cs) (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (rec (coerce s 'cons) nil))))))

; maybe promote to arc.arc, but if so include a list clause

(def positions (test seq)
  (accum a
    (let f (testify test)
      (forlen i seq
        (if (f (seq i)) (a i))))))

(def lines (s)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (rem #\return (cut s (+ p 1) (car ps))))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions #\newline s)))))

(def slices (s test)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (cut s (+ p 1) (car ps)))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions test s)))))

(def nonascii (s)
  (isnt (len s) (len (utf-8-bytes s))))

; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"

; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.

; Fixed for utf8 by pc.

(def urldecode (s)
 (tostring
  (forlen i s
    (caselet c (s i)
      #\+ (writec #\space)
      #\% (do (when (> (- (len s) i) 2)
                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
              (++ i 2))
          (writec c)))))

(def urlencode (s)
  (tostring
    (each c (utf-8-bytes s)
      (writec #\%)
      (let i (int c)
        (if (< i 16) (writec #\0))
        (pr (coerce i 'string 16))))))

(mac litmatch (pat string (o start 0))
  (w/uniq (gstring gstart)
    `(with (,gstring ,string ,gstart ,start)
       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
                           acc))
                  (rev acc)))))))

; litmatch would be cleaner if map worked for string and integer args:

;             ,@(map (fn (n c)
;                      `(is ,c (,gstring (+ ,gstart ,n))))
;                    (len pat)
;                    pat)

(mac endmatch (pat string)
  (w/uniq (gstring glen)
    `(withs (,gstring ,string ,glen (len ,gstring))
       (unless (> ,(len pat) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat (- (len pat) 1 i))
                               (,gstring (- ,glen 1 ,i)))
                           acc))
                  (rev acc)))))))

(def posmatch (pat seq (o start 0))
  (catch
    (if (isa pat 'fn)
        (for i start (- (len seq) 1)
          (when (pat (seq i)) (throw i)))
        (for i start (- (len seq) (len pat))
          (when (headmatch pat seq i) (throw i))))
    nil))

(def headmatch (pat seq (o start 0))
  (let p (len pat)
    ((afn (i)
       (or (is i p)
           (and (is (pat i) (seq (+ i start)))
                (self (+ i 1)))))
     0)))

(def begins (seq pat (o start 0))
  (unless (len> pat (- (len seq) start))
    (headmatch pat seq start)))

(def subst (new old seq)
  (let boundary (+ (- (len seq) (len old)) 1)
    (tostring
      (forlen i seq
        (if (and (< i boundary) (headmatch old seq i))
            (do (++ i (- (len old) 1))
                (pr new))
            (pr (seq i)))))))

(def multisubst (pairs seq)
  (tostring
    (forlen i seq
      (iflet (old new) (find [begins seq (car _) i] pairs)
        (do (++ i (- (len old) 1))
            (pr new))
        (pr (seq i))))))

; not a good name

(def findsubseq (pat seq (o start 0))
  (if (< (- (len seq) start) (len pat))
       nil
      (if (headmatch pat seq start)
          start
          (findsubseq pat seq (+ start 1)))))

(def blank (s) (~find ~whitec s))

(def nonblank (s) (unless (blank s) s))

(def trim (s (o where 'both) (o test whitec))
  (withs (f   (testify test)
           p1 (pos ~f s))
    (if p1
        (cut s
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (let i (- (len s) 1)
                 (while (and (> i p1) (f (s i)))
                   (-- i))
                 (+ i 1))))
        "")))

(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
  (withs (comma
          (fn (i)
            (tostring
              (map [apply pr (rev _)]
                   (rev (intersperse '(#\,)
                                     (tuples (rev (coerce (string i) 'cons))
                                             3))))))
          abrep
          (let a (abs n)
            (if (< digits 1)
                 (comma (roundup a))
                (exact a)
                 (string (comma a)
                         (when (and trail-zeros (> digits 0))
                           (string "." (newstring digits #\0))))
                 (withs (d (expt 10 digits)
                         m (/ (roundup (* a d)) d)
                         i (trunc m)
                         r (abs (trunc (- (* m d) (* i d)))))
                   (+ (if (is i 0)
                          (if (or init-zero (is r 0)) "0" "")
                          (comma i))
                      (withs (rest   (string r)
                              padded (+ (newstring (- digits (len rest)) #\0)
                                        rest)
                              final  (if trail-zeros
                                         padded
                                         (trim padded 'end [is _ #\0])))
                        (string (unless (empty final) ".")
                                final)))))))
    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
        (+ "-" abrep)
        abrep)))

(def joinstr (lst (o glue " "))
  (string (intersperse glue lst)))

; by Andrew Wilcox
(def begins-rest (pattern s)
  (if (begins s pattern)
      (cut s (len pattern))))

; English

(def pluralize (n str)
  (if (or (is n 1) (single n))
      str
      (string str "s")))

; Import Scheme's regular expressions
(= re $.regexp)
(def re-match (rx s (o start 0) (o end nil) (o output-port $.#f) (o input-prefix ($.bytes)))
     ($.regexp-match
       rx
       s
       start
       (if end end
	       (len s))
       output-port
       input-prefix))
(def pre-match (px s (o start 0) (o end nil) (o output-port $.#f) (o input-prefix ($.bytes)))
     ($.regexp-match
       (if $.string?.px $.pregexp.px
	   $.bytes?.px	$.byte-pregexp.px
	   		px)
       s
       start
       (if end end
	       (len s))
       output-port
       input-prefix))
(= re-match? [no:no:re-match _1 _2])
(= re-pos $.regexp-match-positions)
(= re-subst $.regexp-replace)

(def plural (n x)
  (string n #\  (pluralize n x)))

(def capitalize (str)
  (if (empty str) str
      (+ (upcase (str 0)) (cut str 1))))

(load "help/strings.arc")

; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html

; Matching.  Spun off 29 Jul 06.

; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"

(def tokens (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs toks tok)
               (if (no cs)         (consif tok toks)
                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
                                   (self (cdr cs) toks (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (map rev (rec (coerce s 'cons) nil nil)))))))

; names of cut, split, halve not optimal

(def halve (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs tok)
               (if (no cs)         (list (rev tok))
                   (test (car cs)) (list cs (rev tok))
                                   (self (cdr cs) (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (rec (coerce s 'cons) nil))))))

; maybe promote to arc.arc, but if so include a list clause

(def positions (test seq)
  (accum a
    (let f (testify test)
      (forlen i seq
        (if (f (seq i)) (a i))))))

(def lines (s)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (rem #\return (cut s (+ p 1) (car ps))))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions #\newline s)))))

(def slices (s test)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (cut s (+ p 1) (car ps)))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions test s)))))

(def nonascii (s)
  (isnt (len s) (len (utf-8-bytes s))))

; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"

; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.

; Fixed for utf8 by pc.

(def urldecode (s)
 (tostring
  (forlen i s
    (caselet c (s i)
      #\+ (writec #\space)
      #\% (do (when (> (- (len s) i) 2)
                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
              (++ i 2))
          (writec c)))))

(def urlencode (s)
  (tostring
    (each c (utf-8-bytes s)
      (writec #\%)
      (let i (int c)
        (if (< i 16) (writec #\0))
        (pr (coerce i 'string 16))))))

(mac litmatch (pat string (o start 0))
  (w/uniq (gstring gstart)
    `(with (,gstring ,string ,gstart ,start)
       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
                           acc))
                  (rev acc)))))))

; litmatch would be cleaner if map worked for string and integer args:

;             ,@(map (fn (n c)
;                      `(is ,c (,gstring (+ ,gstart ,n))))
;                    (len pat)
;                    pat)

(mac endmatch (pat string)
  (w/uniq (gstring glen)
    `(withs (,gstring ,string ,glen (len ,gstring))
       (unless (> ,(len pat) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat (- (len pat) 1 i))
                               (,gstring (- ,glen 1 ,i)))
                           acc))
                  (rev acc)))))))

(def posmatch (pat seq (o start 0))
  (catch
    (if (isa pat 'fn)
        (for i start (- (len seq) 1)
          (when (pat (seq i)) (throw i)))
        (for i start (- (len seq) (len pat))
          (when (headmatch pat seq i) (throw i))))
    nil))

(def headmatch (pat seq (o start 0))
  (let p (len pat)
    ((afn (i)
       (or (is i p)
           (and (is (pat i) (seq (+ i start)))
                (self (+ i 1)))))
     0)))

(def begins (seq pat (o start 0))
  (unless (len> pat (- (len seq) start))
    (headmatch pat seq start)))

(def subst (new old seq)
  (let boundary (+ (- (len seq) (len old)) 1)
    (tostring
      (forlen i seq
        (if (and (< i boundary) (headmatch old seq i))
            (do (++ i (- (len old) 1))
                (pr new))
            (pr (seq i)))))))

(def multisubst (pairs seq)
  (tostring
    (forlen i seq
      (iflet (old new) (find [begins seq (car _) i] pairs)
        (do (++ i (- (len old) 1))
            (pr new))
        (pr (seq i))))))

; not a good name

(def findsubseq (pat seq (o start 0))
  (if (< (- (len seq) start) (len pat))
       nil
      (if (headmatch pat seq start)
          start
          (findsubseq pat seq (+ start 1)))))

(def blank (s) (~find ~whitec s))

(def nonblank (s) (unless (blank s) s))

(def trim (s (o where 'both) (o test whitec))
  (withs (f   (testify test)
           p1 (pos ~f s))
    (if p1
        (cut s
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (let i (- (len s) 1)
                 (while (and (> i p1) (f (s i)))
                   (-- i))
                 (+ i 1))))
        "")))

(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
  (withs (comma
          (fn (i)
            (tostring
              (map [apply pr (rev _)]
                   (rev (intersperse '(#\,)
                                     (tuples (rev (coerce (string i) 'cons))
                                             3))))))
          abrep
          (let a (abs n)
            (if (< digits 1)
                 (comma (roundup a))
                (exact a)
                 (string (comma a)
                         (when (and trail-zeros (> digits 0))
                           (string "." (newstring digits #\0))))
                 (withs (d (expt 10 digits)
                         m (/ (roundup (* a d)) d)
                         i (trunc m)
                         r (abs (trunc (- (* m d) (* i d)))))
                   (+ (if (is i 0)
                          (if (or init-zero (is r 0)) "0" "")
                          (comma i))
                      (withs (rest   (string r)
                              padded (+ (newstring (- digits (len rest)) #\0)
                                        rest)
                              final  (if trail-zeros
                                         padded
                                         (trim padded 'end [is _ #\0])))
                        (string (unless (empty final) ".")
                                final)))))))
    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
        (+ "-" abrep)
        abrep)))

(def joinstr (lst (o glue " "))
  (string (intersperse glue lst)))

; by Andrew Wilcox
(def begins-rest (pattern s)
  (if (begins s pattern)
      (cut s (len pattern))))

; English

(def pluralize (n str)
  (if (or (is n 1) (single n))
      str
      (string str "s")))

; Import Scheme's regular expressions
(= re $.regexp)
(def re-match (rx s) ($.regexp-match rx s))
(def pre-match (px s)
     ($.regexp-match
       (if $.string?.px $.pregexp.px
	   $.bytes?.px	$.byte-pregexp.px
	   		px)
       s))
(= re-match? [no:no:re-match _1 _2])
(= re-pos $.regexp-match-positions)
(= re-subst $.regexp-replace)

(def plural (n x)
  (string n #\  (pluralize n x)))

(def capitalize (str)
  (if (empty str) str
      (+ (upcase (str 0)) (cut str 1))))

(load "help/strings.arc")

; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html


Demo picture: increase resolution

Demo picture: increase resolution


refactor zeros and ones

refactor zeros and ones

(def init-matrix(dims initval)
  (zap flat dims)
  (if cdr.dims
    (n-of car.dims (init-matrix cdr.dims initval))
    (n-of car.dims initval)))

(def zeros dims
  (init-matrix dims 0))

(def ones dims
  (init-matrix dims 1))

(def square (x)
  (* x x))

(def floor (n) (trunc n))
(def ceiling (n) (int ($.ceiling n)))
(def highbyte (n) (floor (/ n 256)))
(def lowbyte (n) (mod n 256))

;calculus fns

(def deriv (f)
  "provides differential of a function of a single vairable"
  (fn (x)
    (let dx (max 1d-9 (abs:* x 1d-9))
       (/ (- (f (+ x dx))
	     (f x))
          dx))))

(mac partial-diff (f n arity)
  "returns deriv function of f (w/ num args ARITY) wrt Nth variable(from 0) "
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
      (let dx (max 1d-9 (abs:* ,x 1d-9)
	(/ (- (,f ,@a-lis (+ ,x dx) ,@b-lis)
	      (,f ,@a-lis    ,x     ,@b-lis))
	   dx))))))

(mac partial-diff-vec (f n arity)
  "returns vector with each element differentiated with respect to Nth argument"
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
	(let dx (max 1d-9 (abs:* ,x 1d-9)
	   (vec-scale (vec- (,f ,@a-lis	(+ ,x dx) ,@b-lis)
			    (,f ,@a-lis    ,x     ,@b-lis))
		      (/ 1 dx)))))))

(def grad (f)
  "gradient of 3D scalar field given by F"
  (fn (x y z)
    (list ((partial-diff f 0 3) x y z)
	  ((partial-diff f 1 3) x y z)
	  ((partial-diff f 2 3) x y z))))

(def div (f)
  "divergence of 3D vector field given by F"
  (fn (x y z)
      (+ (((partial-diff-vec f 0 3) x y z) 0)
	 (((partial-diff-vec f 1 3) x y z) 1)
	 (((partial-diff-vec f 2 3) x y z) 2))))

(def curl (f)
  "curl of 3D vector field given by F"
  (with (d/dx (partial-diff-vec f 0 3)
	 d/dy (partial-diff-vec f 1 3)
	 d/dz (partial-diff-vec f 2 3))
  (fn (x y z)
    (list (- ((d/dy x y z) 2)
	     ((d/dz x y z) 1))
	  (- ((d/dz x y z) 0)
	     ((d/dx x y z) 2))
	  (- ((d/dx x y z) 1)
	     ((d/dy x y z) 0))))))

(def integral (f)
  "returns the integral of a single argument function"
  (fn (lower upper (o its 10000))
    (withs (dx      (/ (- upper lower) its)
	    x       lower
	    current (f x)
	    next    (f (+ x dx))
	    accum   0)
      (while (<= x (- upper dx))
	     (++ accum (* (/ (+ current next) 2) dx))
	     (++ x dx)
	     (= current next)
	     (= next (f:+ x dx)))
      accum)))

; vector fns

(def vec-dot (v1 v2)
  (apply + (map (fn (x y) (* x y)) v1 v2)))

(def vec-cross (v1 v2 . args)
  (if (car args)
      (vec-cross (vec-cross v1 v2) (car args) (cdr args))
      (list (- (* v1.1 v2.2) (* v2.1 v1.2))
	    (- (* v1.2 v2.0) (* v2.2 v1.0))
	    (- (* v1.0 v2.1) (* v2.0 v1.1)))))

(with (v+ (fn (v1 v2)
	     (map (fn (x y) (+ x y)) v1 v2))
       v- (fn (v1 v2)
	     (map (fn (x y) (- x y)) v1 v2)))

  (def vec+ (v1 . args)
    (if no.args v1
	(reduce v+ (cons v1 args))))

  (def vec- (v1 . args)
    (if no.args (map [- _] v1)
	(v- v1 (apply vec+ args))))

)

(def vec-scale (vec . scalars)
  (let c (apply * scalars)
    (map [* _ c] vec)))

(def quad-add args
  ((afn (tot xs)
     (if no.xs (sqrt tot)
	 (self (+ tot (expt (car xs) 2)) (cdr xs))))
   0 args))

(def vec-norm (vec)
  (vec-scale vec (/ (apply quad-add vec))))

;others

(def fact (num)
  "factorial of num (num must be a fixnum)"
  (if (or (< num 0)(no:isa num 'int)) (err "num must be a positive integer")
      ((afn (n x)
	 (if (<= n 1)
	     x
	     (self (- n 1) (* n x))))
       num 1)))

(def n-bessel (n (o terms 100))
  "gives a fn for the nth bessel function of the first kind evaluated at x"
  (fn (x)
    (with (i 0
	   tot 0)
      (while (< i terms)
	     (++ tot (/ (* (expt -1 i) (expt (/ x 2) (+ n i i)))
			(* (fact i) (fact (+ n i)))))
	     (++ i 1))
      tot)))

(def mean lis
  ((afn (tot i x . xs)
     (if no.xs (/ (+ tot x) (+ i 1))
	 (self (+ tot x) (+ i 1) car.xs cdr.xs)))
   0 0 car.lis cdr.lis))

(def std-dev lis
  (let m mean.lis
    (sqrt:/ (apply + (map [expt (- _ m) 2] lis))
	    len.lis)))

(def choose (n x)
  "number of ways of picking n elements from x (ie no. of ways of mixing 2 different sets of identical objects of size n and (- x n))"
  (if (> n x)
      (do (prn "")(pr n)(pr " is greater than ")(prn x))
      (/ (fact x) (* (fact n) (fact (- x n))))))

(def gauss-random (sigma (o middle 0))
  "aproximation to a gausian distributed random with width sigma around middle, max possible deviation +/- 1000sigma"
  (let tot 0
    (for i 0 999
      (++ tot  (- (* (rand) 2.0) 1)))
    (+ (* tot (/ sigma 25)) middle)))

(def quad-roots (a b c)
  "returns roots of the equation ax²+bx+c=0"
  (let sqroot (sqrt (- (* b b) (* 4 a c)))
    (rem-dups
     (list (/ (- sqroot b) 2 a)
	   (/ (- 0 sqroot b) 2 a)))))

(def zeros dims
  (= dims (flat dims))
  (if
    (no (cdr dims))
     (n-of (car dims) 0)
    (cdr dims)
     (n-of (car dims) (zeros (cdr dims))))
)

(def ones dims
  (= dims (flat dims))
  (if
    (no (cdr dims))
     (n-of (car dims) 1)
    (cdr dims)
     (n-of (car dims) (ones (cdr dims))))
)

(def square (x)
  (* x x))

(def floor (n) (trunc n))
(def ceiling (n) (int ($.ceiling n)))
(def highbyte (n) (floor (/ n 256)))
(def lowbyte (n) (mod n 256))

;calculus fns

(def deriv (f)
  "provides differential of a function of a single vairable"
  (fn (x)
    (let dx (max 1d-9 (abs:* x 1d-9))
       (/ (- (f (+ x dx))
	     (f x))
          dx))))

(mac partial-diff (f n arity)
  "returns deriv function of f (w/ num args ARITY) wrt Nth variable(from 0) "
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
      (let dx (max 1d-9 (abs:* ,x 1d-9)
	(/ (- (,f ,@a-lis (+ ,x dx) ,@b-lis)
	      (,f ,@a-lis    ,x     ,@b-lis))
	   dx))))))

(mac partial-diff-vec (f n arity)
  "returns vector with each element differentiated with respect to Nth argument"
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
	(let dx (max 1d-9 (abs:* ,x 1d-9)
	   (vec-scale (vec- (,f ,@a-lis	(+ ,x dx) ,@b-lis)
			    (,f ,@a-lis    ,x     ,@b-lis))
		      (/ 1 dx)))))))

(def grad (f)
  "gradient of 3D scalar field given by F"
  (fn (x y z)
    (list ((partial-diff f 0 3) x y z)
	  ((partial-diff f 1 3) x y z)
	  ((partial-diff f 2 3) x y z))))

(def div (f)
  "divergence of 3D vector field given by F"
  (fn (x y z)
      (+ (((partial-diff-vec f 0 3) x y z) 0)
	 (((partial-diff-vec f 1 3) x y z) 1)
	 (((partial-diff-vec f 2 3) x y z) 2))))

(def curl (f)
  "curl of 3D vector field given by F"
  (with (d/dx (partial-diff-vec f 0 3)
	 d/dy (partial-diff-vec f 1 3)
	 d/dz (partial-diff-vec f 2 3))
  (fn (x y z)
    (list (- ((d/dy x y z) 2)
	     ((d/dz x y z) 1))
	  (- ((d/dz x y z) 0)
	     ((d/dx x y z) 2))
	  (- ((d/dx x y z) 1)
	     ((d/dy x y z) 0))))))

(def integral (f)
  "returns the integral of a single argument function"
  (fn (lower upper (o its 10000))
    (withs (dx      (/ (- upper lower) its)
	    x       lower
	    current (f x)
	    next    (f (+ x dx))
	    accum   0)
      (while (<= x (- upper dx))
	     (++ accum (* (/ (+ current next) 2) dx))
	     (++ x dx)
	     (= current next)
	     (= next (f:+ x dx)))
      accum)))

; vector fns

(def vec-dot (v1 v2)
  (apply + (map (fn (x y) (* x y)) v1 v2)))

(def vec-cross (v1 v2 . args)
  (if (car args)
      (vec-cross (vec-cross v1 v2) (car args) (cdr args))
      (list (- (* v1.1 v2.2) (* v2.1 v1.2))
	    (- (* v1.2 v2.0) (* v2.2 v1.0))
	    (- (* v1.0 v2.1) (* v2.0 v1.1)))))

(with (v+ (fn (v1 v2)
	     (map (fn (x y) (+ x y)) v1 v2))
       v- (fn (v1 v2)
	     (map (fn (x y) (- x y)) v1 v2)))

  (def vec+ (v1 . args)
    (if no.args v1
	(reduce v+ (cons v1 args))))

  (def vec- (v1 . args)
    (if no.args (map [- _] v1)
	(v- v1 (apply vec+ args))))

)

(def vec-scale (vec . scalars)
  (let c (apply * scalars)
    (map [* _ c] vec)))

(def quad-add args
  ((afn (tot xs)
     (if no.xs (sqrt tot)
	 (self (+ tot (expt (car xs) 2)) (cdr xs))))
   0 args))

(def vec-norm (vec)
  (vec-scale vec (/ (apply quad-add vec))))

;others

(def fact (num)
  "factorial of num (num must be a fixnum)"
  (if (or (< num 0)(no:isa num 'int)) (err "num must be a positive integer")
      ((afn (n x)
	 (if (<= n 1)
	     x
	     (self (- n 1) (* n x))))
       num 1)))

(def n-bessel (n (o terms 100))
  "gives a fn for the nth bessel function of the first kind evaluated at x"
  (fn (x)
    (with (i 0
	   tot 0)
      (while (< i terms)
	     (++ tot (/ (* (expt -1 i) (expt (/ x 2) (+ n i i)))
			(* (fact i) (fact (+ n i)))))
	     (++ i 1))
      tot)))

(def mean lis
  ((afn (tot i x . xs)
     (if no.xs (/ (+ tot x) (+ i 1))
	 (self (+ tot x) (+ i 1) car.xs cdr.xs)))
   0 0 car.lis cdr.lis))

(def std-dev lis
  (let m mean.lis
    (sqrt:/ (apply + (map [expt (- _ m) 2] lis))
	    len.lis)))

(def choose (n x)
  "number of ways of picking n elements from x (ie no. of ways of mixing 2 different sets of identical objects of size n and (- x n))"
  (if (> n x)
      (do (prn "")(pr n)(pr " is greater than ")(prn x))
      (/ (fact x) (* (fact n) (fact (- x n))))))

(def gauss-random (sigma (o middle 0))
  "aproximation to a gausian distributed random with width sigma around middle, max possible deviation +/- 1000sigma"
  (let tot 0
    (for i 0 999
      (++ tot  (- (* (rand) 2.0) 1)))
    (+ (* tot (/ sigma 25)) middle)))

(def quad-roots (a b c)
  "returns roots of the equation ax²+bx+c=0"
  (let sqroot (sqrt (- (* b b) (* 4 a c)))
    (rem-dups
     (list (/ (- sqroot b) 2 a)
	   (/ (- 0 sqroot b) 2 a)))))


codegen: minor syntactic change

codegen: minor syntactic change

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

; code generation

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

  ; make sure global-vars includes call*
  (unless (some [is _!id _!uid 'call*]
                global-vars)
    (push (new-global 'call*) global-vars))

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

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

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

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

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (let (x . ast) (pop lambda-todo)
          (list
            "case " x ":\n\n"
            ; determine the number of required arguments
            (let num-reqs (len:properify ast!params)
              ; if variadic, use variadic handling code
              (if (dotted ast!params)
                  ; the second argument is the arc-side expected number of
                  ; arguments (arguments include the function to execute as
                  ; well as the continuation, which the arc-side programmer
                  ; doesn't care about)
                  (list " VARIADIC2LIST(" (- num-reqs 1) "," (- num-reqs 3) ");\n")
                  (list " CHECK_PARAMS(" num-reqs "," (- num-reqs 2) ");\n")))
            (code-gen (car ast!subx) (rev:properify ast!params))
            "\n\n"
            (compile-all-lambdas))))))

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

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"
            "#define MAX_STACK " 2000 "\n"
            "#define NB_QUOTE_CONSTANTS " constant-count "\n"
            "#define CALL_STAR GLOBAL("
              (pos [is _!uid _!id 'call*] global-vars)
            ")\n")
      code-header*
      (if constant-todo
        ; constants were defined; initialize
        (list "void init_constants(void){\nsp = stack;\n"
              (compile-constants:rev constant-todo)
              "}\n")
        ; no constants; dummy initialize
        "\n#define init_constants()\n")
      code-prefix*
      code-execute*
      code
      code-suffix*))))

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

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

(= code-execute* "

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");
  obj errhandler; /*TODO: make this thread-local*/
  long num_args = 0;

  jump: switch (pc) {

")

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

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

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        ; actually, shouldn't properify the params, maybe okay since this is debug code, but...
        (list 'let (map (fn (p a) (list p!uid (source a))) (properify ((car ast!subx) 'params)) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      `(fn ,(map-improper [_ 'uid] ast!params)
         ,@(if ast!continuation `((t arc2c 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))

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

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

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

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

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

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

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

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

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

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

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

; code generation

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

  ; make sure global-vars includes call*
  (unless (some [is _!id _!uid 'call*]
                global-vars)
    (push (new-global 'call*) global-vars))

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

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

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

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

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            ; determine the number of required arguments
            (let num-reqs (len:properify ast!params)
              ; if variadic, use variadic handling code
              (if (dotted ast!params)
                  ; the second argument is the arc-side expected number of
                  ; arguments (arguments include the function to execute as
                  ; well as the continuation, which the arc-side programmer
                  ; doesn't care about)
                  (list " VARIADIC2LIST(" (- num-reqs 1) "," (- num-reqs 3) ");\n")
                  (list " CHECK_PARAMS(" num-reqs "," (- num-reqs 2) ");\n")))
            (code-gen (car ast!subx) (rev:properify ast!params))
            "\n\n"
            (compile-all-lambdas))))))

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

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"
            "#define MAX_STACK " 2000 "\n"
            "#define NB_QUOTE_CONSTANTS " constant-count "\n"
            "#define CALL_STAR GLOBAL("
              (pos [is _!uid _!id 'call*] global-vars)
            ")\n")
      code-header*
      (if constant-todo
        ; constants were defined; initialize
        (list "void init_constants(void){\nsp = stack;\n"
              (compile-constants:rev constant-todo)
              "}\n")
        ; no constants; dummy initialize
        "\n#define init_constants()\n")
      code-prefix*
      code-execute*
      code
      code-suffix*))))

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

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

(= code-execute* "

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");
  obj errhandler; /*TODO: make this thread-local*/
  long num_args = 0;

  jump: switch (pc) {

")

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

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

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        ; actually, shouldn't properify the params, maybe okay since this is debug code, but...
        (list 'let (map (fn (p a) (list p!uid (source a))) (properify ((car ast!subx) 'params)) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      `(fn ,(map-improper [_ 'uid] ast!params)
         ,@(if ast!continuation `((t arc2c 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))

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

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

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

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

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

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

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

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

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

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


Added third interface feature -- mkuri. Needed by oauth library.

; written by Mark Huetsch and Brian J Rubinton
; same license as Arc
;
; Primary interface:
;   1)  mkreq - Build request, send request, receive response as (list header body).
;   2) defreq - Create named function wrappers for mkreq.
;             - Intended for multi-use http requests.
;             - Url query parameters can be passed into wrapper for each request.
;             - example: see (defreq google '(q "bagels new york city"))
;   3)  mkuri - Construct a uri from url and query list.
;             - Only compatible with GET requests.

(require "lib/re.arc")

(= protocol* "HTTP/1.0"
   useragent* "Web.arc/1.0"
   content-type* "Content-Type: application/x-www-form-urlencoded")

(mac w/io (io request func)
  (w/uniq (i o response)
    `(let (,i ,o) ,io
      (disp ,request ,o)
      (let ,response (,func ,i)
        (close ,i ,o)
        ,response))))

(def mkreq (url (o querylist) (o method "GET") (o cookies))
  (let url (parse-url url)
    (w/io (get-io   url!resource url!host url!port)
          (buildreq url!host
                    url!path
                    (build-query url!query querylist)
                    (upcase method)
                    cookies)
          receive-response)))

(mac defreq (name url (o querylist) (o method "GET") (o cookies))
  `(def ,name ((o param))
    (mkreq ,url (join ,querylist param) ,method ,cookies)))

(def mkuri (url (o querylist))
  (let url (parse-url url)
    (+ url!resource "://"
       url!host ":"
       url!port
       (build-uri url!path "GET" (build-query url!query querylist)))))

(def parse-url (url)
  (withs ((resource url) (split-at "://" (ensure-resource (strip-after "#" url)))
          (hp pq)        (split-at "/" url)
          (host port)    (split-at ":" hp)
          (path query)   (split-at "?" pq))
    (obj resource resource
         host     host
         port     (select-port port resource)
         path     path
         query    query)))

(def ensure-resource (url)
  (if (posmatch "://" url) url (+ "http://" url)))

(def strip-after (delim s)
  (car (split-at delim s)))

(def split-at (delim s)
  " Split string s at first instance of delimeter.
    Return split list. "
  (iflet i (posmatch delim s)
    (list (cut s 0 i) (cut s (+ i (len delim))))
    (list s)))

(def select-port (portstr resource)
  (if (nonblank portstr)
    (int portstr)
    (default-port resource)))

(def default-port (resource)
  (if (is resource "https") 443 80))

(def build-query (querystr querylist)
  (string querystr
          (and (nonblank querystr)
               querylist
               '&)
          (to-query-str querylist)))

(def to-query-str (querylist)
  (if querylist
    (joinstr (map [joinstr _ "="] (pair (map [coerce _ 'string] querylist)))
             "&")))

(def build-header (host path query method cookies)
  (reduce +
    (intersperse (str-rn)
                 (flat:list
                   (first-req-line method path query)
                   (request-header host)
                   (entity-header  method query)
                   (cookie-header  cookies)))))

(def first-req-line (method path query)
  (+ method " " (build-uri path method query) " " protocol*))

(def build-uri (path method (o query ""))
  (+ "/" path (and (is method "GET")
                   (nonblank query)
                   (+ "?" query))))

(def request-header (host)
  (list (+ "Host: " host) useragent*))

(def entity-header (method query)
  (if (is method "POST")
    (list (+ "Content-Length: " (len (utf-8-bytes query))) content-type*)))

(def cookie-header (cookies)
  (if cookies (encode-cookies cookies)))

(def encode-cookies (cookielist)
  (let joined-list (map [joinstr _ #\=] (pair cookielist))
    (+ "Cookie: "
       (if (len> joined-list 1)
         (reduce [+ _1 "; " _2] joined-list)
         (car joined-list))
       ";")))

(def build-body (query method)
  (if (and (is method "POST") (nonblank query))
    (+ query (str-rn))
    nil))

(def buildreq (host path query method cookies)
  (+ (build-header host path query method cookies)
     (str-rn 2)
     (build-body query method)))

(def str-rn ((o n 1))
  (if (<= n 1)
    (string #\return #\newline)
    (string (str-rn) (str-rn (- n 1)))))

(def get-io (resource host port)
  (if (is resource "https")
    (ssl-connect host port)
    (socket-connect host port)))

(def receive-response ((o s (stdin)))
  (list (read-header s) (read-body s)))

(def read-header ((o s (stdin)))
  " Read each line from port until a blank line is reached. "
  (accum a
    (whiler line (readline s) blank
      (a line))))

(def read-body ((o s (stdin)))
  " Read remaining lines from port. "
  (tostring
    (whilet line (readline s)
      (pr line))))

; Convenience functions.
; Note: these ignore the response header: (car (mkreq url))
(def get-url (url)
  (cdr (mkreq url)))

(def post-url (url args)
  (cdr (mkreq url args "POST")))

; TODO write functions to parse/tokenize header lines
; TODO refactor google func to use defreq macro
(def google (q)
  (get-url (+ "www.google.com/search?q=" (urlencode q))))

; written by Mark Huetsch and Brian J Rubinton
; same license as Arc
;
; Primary interface:
;   1)  mkreq - Build request, send request, receive response as (list header body).
;   2) defreq - Create named function wrappers for mkreq.
;             - Intended for multi-use http requests.
;             - Url query parameters can be passed into wrapper for each request.
;             - example: see (defreq google '(q "bagels new york city"))

(require "lib/re.arc")

(= protocol* "HTTP/1.0"
   useragent* "Web.arc/1.0"
   content-type* "Content-Type: application/x-www-form-urlencoded")

(mac w/io (io request func)
  (w/uniq (i o response)
    `(let (,i ,o) ,io
      (disp ,request ,o)
      (let ,response (,func ,i)
        (close ,i ,o)
        ,response))))

(def mkreq (url (o querylist) (o method "GET") (o cookies))
  (let url (parse-url url)
    (w/io (get-io   url!resource url!host url!port)
          (buildreq url!host
                    url!path
                    (build-query url!query querylist)
                    (upcase method)
                    cookies)
          receive-response)))

(mac defreq (name url (o querylist) (o method "GET") (o cookies))
  `(def ,name ((o param))
    (mkreq ,url (join ,querylist param) ,method ,cookies)))

(def parse-url (url)
  (withs ((resource url) (split-at "://" (ensure-resource (strip-after "#" url)))
          (hp pq)        (split-at "/" url)
          (host port)    (split-at ":" hp)
          (path query)   (split-at "?" pq))
    (obj resource resource
         host     host
         port     (select-port port resource)
         path     path
         query    query)))

(def ensure-resource (url)
  (if (posmatch "://" url) url (+ "http://" url)))

(def strip-after (delim s)
  (car (split-at delim s)))

(def split-at (delim s)
  " Split string s at first instance of delimeter.
    Return split list. "
  (iflet i (posmatch delim s)
    (list (cut s 0 i) (cut s (+ i (len delim))))
    (list s)))

(def select-port (portstr resource)
  (if (nonblank portstr)
    (int portstr)
    (default-port resource)))

(def default-port (resource)
  (if (is resource "https") 443 80))

(def build-query (querystr querylist)
  (string querystr
          (and (nonblank querystr)
               querylist
               '&)
          (to-query-str querylist)))

(def to-query-str (querylist)
  (if querylist
    (joinstr (map [joinstr _ "="] (pair (map [coerce _ 'string] querylist)))
             "&")))

(def build-header (host path query method cookies)
  (reduce +
    (intersperse (str-rn)
                 (flat:list
                   (first-req-line method path query)
                   (request-header host)
                   (entity-header  method query)
                   (cookie-header  cookies)))))

(def first-req-line (method path query)
  (+ method " " (build-uri path method query) " " protocol*))

(def build-uri (path method (o query ""))
  (+ "/" path (and (is method "GET")
                   (nonblank query)
                   (+ "?" query))))

(def request-header (host)
  (list (+ "Host: " host) useragent*))

(def entity-header (method query)
  (if (is method "POST")
    (list (+ "Content-Length: " (len (utf-8-bytes query))) content-type*)))

(def cookie-header (cookies)
  (if cookies (encode-cookies cookies)))

(def encode-cookies (cookielist)
  (let joined-list (map [joinstr _ #\=] (pair cookielist))
    (+ "Cookie: "
       (if (len> joined-list 1)
         (reduce [+ _1 "; " _2] joined-list)
         (car joined-list))
       ";")))

(def build-body (query method)
  (if (and (is method "POST") (nonblank query))
    (+ query (str-rn))
    nil))

(def buildreq (host path query method cookies)
  (+ (build-header host path query method cookies)
     (str-rn 2)
     (build-body query method)))

(def str-rn ((o n 1))
  (if (<= n 1)
    (string #\return #\newline)
    (string (str-rn) (str-rn (- n 1)))))

(def get-io (resource host port)
  (if (is resource "https")
    (ssl-connect host port)
    (socket-connect host port)))

(def receive-response ((o s (stdin)))
  (list (read-header s) (read-body s)))

(def read-header ((o s (stdin)))
  " Read each line from port until a blank line is reached. "
  (accum a
    (whiler line (readline s) blank
      (a line))))

(def read-body ((o s (stdin)))
  " Read remaining lines from port. "
  (tostring
    (whilet line (readline s)
      (pr line))))

; Convenience functions.
; Note: these ignore the response header: (car (mkreq url))
(def get-url (url)
  (cdr (mkreq url)))

(def post-url (url args)
  (cdr (mkreq url args "POST")))

; TODO write functions to parse/tokenize header lines
; TODO refactor google func to use defreq macro
(def google (q)
  (get-url (+ "www.google.com/search?q=" (urlencode q))))