.

clearer accum calls
replace afn with loop

Still undecided on afn in 'tokens', since it's deeply non-tail.

; 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 yield
    (let f (testify test)
      (forlen i seq
        (if (f (seq i))
          (yield i))))))

(def lines (s)
  (map [rem #\return _]
       (slices s #\newline)))

(def slices (s test)
  (accum yield
    (loop (p  -1
           ps  (positions test s))
      (if no.ps
        (yield (cut s (+ p 1)))
        (do (yield (cut s (+ p 1) car.ps))
            (recur car.ps cdr.ps))))))

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

; should behave just like javascript's encodeURIComponent
; http://stackoverflow.com/questions/9635661/encodeuricomponent-algorithm-source-code
(def urlencode (s)
  (tostring
    (each code-point (utf-8-bytes s)
      (let c (coerce code-point 'char)
        (if (or (>= code-point 128)
                (~alphadig c)
                (in c #\! #\' #\( #\) #\* #\- #\. #\_ #\~))
          (urlencode-char code-point)
          (writec c))))))

(def urlencode-char (i)
  (writec #\%)
  (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)
        (up i start (len seq)
          (when (pat (seq i)) (throw i)))
        (up i start (- len.seq (- len.pat 1))
          (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)))

(defextend subst (old new seq) (isa seq 'string)
  (tostring
    (forlen i seq
      (if (and (< i (- len.seq len.old -1))
               (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))))

(def chomp (s)
  (if (iso (s (- len.s 1))
           #\newline)
    (cut s 0 (- len.s 1))
    s))

(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)
  (map [rem #\return _]
       (slices s #\newline)))

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

; should behave just like javascript's encodeURIComponent
; http://stackoverflow.com/questions/9635661/encodeuricomponent-algorithm-source-code
(def urlencode (s)
  (tostring
    (each code-point (utf-8-bytes s)
      (let c (coerce code-point 'char)
        (if (or (>= code-point 128)
                (~alphadig c)
                (in c #\! #\' #\( #\) #\* #\- #\. #\_ #\~))
          (urlencode-char code-point)
          (writec c))))))

(def urlencode-char (i)
  (writec #\%)
  (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)
        (up i start (len seq)
          (when (pat (seq i)) (throw i)))
        (up i start (- len.seq (- len.pat 1))
          (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)))

(defextend subst (old new seq) (isa seq 'string)
  (tostring
    (forlen i seq
      (if (and (< i (- len.seq len.old -1))
               (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))))

(def chomp (s)
  (if (iso (s (- len.s 1))
           #\newline)
    (cut s 0 (- len.s 1))
    s))

(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


fix bug where anchor was not being discarded in parse-url, take 2

; written by Mark Huetsch
; same license as Arc

($ (require openssl))
($ (xdef ssl-connect (lambda (host port)
		                   (ar-init-socket
		                     (lambda () (ssl-connect host port))))))

(load "lib/re.arc")
(load "lib/util.arc")

(def parse-server-cookies (s)
  (map [map trim _]
       (map [matchsplit "=" _]
	    (tokens (cut s (len "Set-Cookie:")) #\;))))

(def parse-server-header (lines)
  (withs (http-response (tokens (car lines))
	  ret
	   (list
	     (list
	       (http-response 0)
	       (http-response 1)
	       (http-response 2))
	     (some (fn (s)
		     (and (begins s "Set-Cookie:")
			  (parse-server-cookies s)))
		   (cdr lines))))
    ret))

(def args->query-string (args)
  (if args
      (let equals-list (map [joinstr _ "="] (pair (map [coerce _ 'string] args)))
	(joinstr equals-list "&"))
      ""))

(def parse-url (url)
  (withs (url (if (find #\# url)
		  (joinstr (butlast (tokens url #\#)) "")
		  url) ; throw away anchor component
	      has-trailing-slash (endmatch "/" url)
	      components (tokens url #\/)
	      first-component (pop components)
	      first-component-is-resource (endmatch ":" first-component)
	      resource (if first-component-is-resource (downcase (butlast first-component))
			   "http") ; defaults to http
	      host (if first-component-is-resource (pop components)
		       first-component)
	      host-tokens (tokens host #\:)
	      host (car host-tokens)
	      port (if (> (len host-tokens) 1) (int (last host-tokens)) (is "https" resource) 443 80)
	      components (tokens (if components
				     (+ (joinstr components "/") (if has-trailing-slash "/"))
				     "")
				 #\?)
	      filename (if (and components (isnt "" (components 0))) (components 0))
	      query (if (> (len components) 1) (components 1)))
    (obj resource resource host host port port filename filename query query)))

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

; TODO this isn't very pretty
(def get-or-post-url (url (o args) (o method "GET") (o cookie))
  (withs (method (upcase method)
		 parsed-url (parse-url url)
		 args-query-string (args->query-string args)
		 full-args (joinstr (list args-query-string (parsed-url 'query)) "&")
		 request-path (+ "/" (parsed-url 'filename)
				 (if (and (is method "GET") (> (len full-args) 0))
				     (+ "?" full-args)))
		 header-components (list (+ method " " request-path " HTTP/1.0")
					 (+ "Host: " (parsed-url 'host))
					 "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; uk; rv:1.9.1.2) Gecko/20090729 Firefox/3.5.2"))
    (when (is method "POST")
      (pushend (+ "Content-Length: " (len (utf-8-bytes full-args))) header-components)
      (pushend "Content-Type: application/x-www-form-urlencoded" header-components))
    (when cookie
      (push (encode-cookie cookie) header-components))
    (withs (header (reduce [+ _1 "\r\n" _2] header-components)
		   body (if (is method "POST") (+ full-args "\r\n"))
		   request-message (+ header "\r\n\r\n" body))
      (let (in out) (if (is "https" (parsed-url 'resource))
			(ssl-connect (parsed-url 'host) (parsed-url 'port))
			(socket-connect (parsed-url 'host) (parsed-url 'port)))
	(disp request-message out)
	(withs (result (tostring
			 (whilet line (readline in) (if line (prn line))))
		       body-start (posmatch "\r\n\r\n" result)
		       header-string (cut result 0 body-start)
		       header-lines (re-split "\r\n" header-string)
		       header (parse-server-header header-lines))
	  (close in out)
	  (list
	    header
	    (if body-start
		(cut result (+ 4 body-start))
		result)))))))

(def get-url (url)
  ((get-or-post-url url) 1))

(def post-url (url args)
  ((get-or-post-url url args "POST") 1))

(def google (q)
  (get-url (+ "www.google.com/search?q=" (urlencode q))))

; just some preliminary hacking
(mac w/browser body
  `(withs (cookies* (table)
		    get-url
		    (fn (url) (let (parsed-header html) (get-or-post-url url '() "GET" cookies*)
				(= cookies* (fill-table cookies* (flat (parsed-header 1))))
				html))
		    post-url
		    (fn (url args) (let (parsed-header html) (get-or-post-url url args "POST" cookies*)
				     (= cookies* (fill-table cookies* (flat (parsed-header 1))))
				     html)))
     (do ,@body)))

; written by Mark Huetsch
; same license as Arc

($ (require openssl))
($ (xdef ssl-connect (lambda (host port)
		                   (ar-init-socket
		                     (lambda () (ssl-connect host port))))))

(load "lib/re.arc")
(load "lib/util.arc")

(def parse-server-cookies (s)
  (map [map trim _]
       (map [matchsplit "=" _]
	    (tokens (cut s (len "Set-Cookie:")) #\;))))

(def parse-server-header (lines)
  (withs (http-response (tokens (car lines))
	  ret
	   (list
	     (list
	       (http-response 0)
	       (http-response 1)
	       (http-response 2))
	     (some (fn (s)
		     (and (begins s "Set-Cookie:")
			  (parse-server-cookies s)))
		   (cdr lines))))
    ret))

(def args->query-string (args)
  (if args
      (let equals-list (map [joinstr _ "="] (pair (map [coerce _ 'string] args)))
	(joinstr equals-list "&"))
      ""))

(def parse-url (url)
  (withs (url (joinstr (butlast (tokens url #\#)) "") ; throw away anchor component
	      has-trailing-slash (endmatch "/" url)
	      components (tokens url #\/)
	      first-component (pop components)
	      first-component-is-resource (endmatch ":" first-component)
	      resource (if first-component-is-resource (downcase (butlast first-component))
			   "http") ; defaults to http
	      host (if first-component-is-resource (pop components)
		       first-component)
	      host-tokens (tokens host #\:)
	      host (car host-tokens)
	      port (if (> (len host-tokens) 1) (int (last host-tokens)) (is "https" resource) 443 80)
	      components (tokens (if components
				     (+ (joinstr components "/") (if has-trailing-slash "/"))
				     "")
				 #\?)
	      filename (if (and components (isnt "" (components 0))) (components 0))
	      query (if (> (len components) 1) (components 1)))
    (obj resource resource host host port port filename filename query query)))

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

; TODO this isn't very pretty
(def get-or-post-url (url (o args) (o method "GET") (o cookie))
  (withs (method (upcase method)
		 parsed-url (parse-url url)
		 args-query-string (args->query-string args)
		 full-args (joinstr (list args-query-string (parsed-url 'query)) "&")
		 request-path (+ "/" (parsed-url 'filename)
				 (if (and (is method "GET") (> (len full-args) 0))
				     (+ "?" full-args)))
		 header-components (list (+ method " " request-path " HTTP/1.0")
					 (+ "Host: " (parsed-url 'host))
					 "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; uk; rv:1.9.1.2) Gecko/20090729 Firefox/3.5.2"))
    (when (is method "POST")
      (pushend (+ "Content-Length: " (len (utf-8-bytes full-args))) header-components)
      (pushend "Content-Type: application/x-www-form-urlencoded" header-components))
    (when cookie
      (push (encode-cookie cookie) header-components))
    (withs (header (reduce [+ _1 "\r\n" _2] header-components)
		   body (if (is method "POST") (+ full-args "\r\n"))
		   request-message (+ header "\r\n\r\n" body))
      (let (in out) (if (is "https" (parsed-url 'resource))
			(ssl-connect (parsed-url 'host) (parsed-url 'port))
			(socket-connect (parsed-url 'host) (parsed-url 'port)))
	(disp request-message out)
	(withs (result (tostring
			 (whilet line (readline in) (if line (prn line))))
		       body-start (posmatch "\r\n\r\n" result)
		       header-string (cut result 0 body-start)
		       header-lines (re-split "\r\n" header-string)
		       header (parse-server-header header-lines))
	  (close in out)
	  (list
	    header
	    (if body-start
		(cut result (+ 4 body-start))
		result)))))))

(def get-url (url)
  ((get-or-post-url url) 1))

(def post-url (url args)
  ((get-or-post-url url args "POST") 1))

(def google (q)
  (get-url (+ "www.google.com/search?q=" (urlencode q))))

; just some preliminary hacking
(mac w/browser body
  `(withs (cookies* (table)
		    get-url
		    (fn (url) (let (parsed-header html) (get-or-post-url url '() "GET" cookies*)
				(= cookies* (fill-table cookies* (flat (parsed-header 1))))
				html))
		    post-url
		    (fn (url args) (let (parsed-header html) (get-or-post-url url args "POST" cookies*)
				     (= cookies* (fill-table cookies* (flat (parsed-header 1))))
				     html)))
     (do ,@body)))


fix mime types; how did we not support js until now?

; HTTP Server.

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

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

(= quitsrv* nil breaksrv* nil)

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

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

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

(= srv-noisy* nil)

; http requests currently capped 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 handle-request (s breaksrv)
  (if breaksrv
    (handle-request-1 s)
    (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (with ((in out ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (let ip-wrapper (fn args
                      (if args
                        (= ip car.args)
                        ip))
      (= th1 (thread
               (after (handle-request-thread in out ip-wrapper)
                      (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))))))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

; For ops that want to add their own headers.  They must thus remember
; to 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))

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

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

(def respond (str op args cooks clen ctype in ip)
  (w/stdout str
    (iflet f (srvops* op)
      (let req (inst 'request 'args args 'cooks cooks 'ctype ctype 'clen clen 'in in 'ip ip)
        (if (redirector* op)
          (do (prrn rdheader*)
              (prrn "Location: " (f str req))
              (prrn))
          (do (prrn header*)
              (awhen (max-age* op)
                (prrn "Cache-Control: max-age=" it))
              (f str req))))
      (let filetype (static-filetype op)
        (aif (and filetype (file-exists (string staticdir* op)))
          (do (prrn "HTTP/1.0 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 str))))
          (respond-err str unknown-msg*))))))

(def handle-post (in out op args clen cooks ctype ip)
  (if (no clen)
    (respond-err out "Post request without Content-Length.")
    (respond out op (+ args
                       (if (~begins downcase.ctype "multipart/form-data")
                         (parseargs:string:readchars clen in) ; ascii
                         (parse-multipart-args multipart-boundary.ctype in))) ; maybe non-ascii
             cooks clen ctype in ip)))

(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 err-header*)
    (prrn)
    (apply pr msg args)))

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

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

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

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

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

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

(def arg (req key)
  (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.

; HTTP Server.

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

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

(= quitsrv* nil breaksrv* nil)

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

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

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

(= srv-noisy* nil)

; http requests currently capped 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 handle-request (s breaksrv)
  (if breaksrv
    (handle-request-1 s)
    (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (with ((in out ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (let ip-wrapper (fn args
                      (if args
                        (= ip car.args)
                        ip))
      (= th1 (thread
               (after (handle-request-thread in out ip-wrapper)
                      (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))))))

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

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

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

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

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

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

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

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

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

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

(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/html
           "txt"  'text/html
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/html
           ))))

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

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

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

; For ops that want to add their own headers.  They must thus remember
; to 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))

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

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

(def respond (str op args cooks clen ctype in ip)
  (w/stdout str
    (iflet f (srvops* op)
      (let req (inst 'request 'args args 'cooks cooks 'ctype ctype 'clen clen 'in in 'ip ip)
        (if (redirector* op)
          (do (prrn rdheader*)
              (prrn "Location: " (f str req))
              (prrn))
          (do (prrn header*)
              (awhen (max-age* op)
                (prrn "Cache-Control: max-age=" it))
              (f str req))))
      (let filetype (static-filetype op)
        (aif (and filetype (file-exists (string staticdir* op)))
          (do (prrn "HTTP/1.0 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 str))))
          (respond-err str unknown-msg*))))))

(def handle-post (in out op args clen cooks ctype ip)
  (if (no clen)
    (respond-err out "Post request without Content-Length.")
    (respond out op (+ args
                       (if (~begins downcase.ctype "multipart/form-data")
                         (parseargs:string:readchars clen in) ; ascii
                         (parse-multipart-args multipart-boundary.ctype in))) ; maybe non-ascii
             cooks clen ctype in ip)))

(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 err-header*)
    (prrn)
    (apply pr msg args)))

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

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

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

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

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

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

(def arg (req key)
  (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.


Improve warning message for state machines with missing poly event transtitions.  #4

.//============================================================================
.// $RCSfile: q.class.poly.arc,v $
.//
.// Description:
.// This archetype file contains the functions for generating class
.// methods associated with polymorphic event delivery.
.//
.// Notice:
.// (C) Copyright 1998-2013 Mentor Graphics Corporation
.//     All rights reserved.
.//
.// This document contains confidential and proprietary information and
.// property of Mentor Graphics Corp.  No part of this document may be
.// reproduced without the express written permission of Mentor Graphics Corp.
.//============================================================================
.//
.function GetPolymorphicRelationshipCollection
  .param inst_ref o_obj
  .//
  .select many r_supers related by o_obj->R_OIR[R201]->R_REL[R201]->R_SUBSUP[R206]->R_SUPER[R212] where ( selected.Obj_ID == o_obj.Obj_ID )
  .select many attr_result related by r_supers->R_SUBSUP[R212]->R_REL[R206]
  .if ( not_empty attr_result )
    .select one sm_ism related by o_obj->SM_ISM[R518]
    .if ( empty sm_ism )
      .// Passive supertype, we are done
      .assign attr_result = attr_result - attr_result
    .else
      .select any poly_sm_evt related by o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_PEVT[R525]->SM_EVT[R525]
      .select many non_local_event_set related by o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_SEVT[R525]->SM_NLEVT[R526]->SM_SEVT[R526]->SM_EVT[R525]
      .if ( (empty poly_sm_evt) and (empty non_local_event_set) )
        .assign attr_result = attr_result - attr_result
      .else
        .assign possible_super_rel_set = attr_result
        .// Remove any rels where all the subtypes are passive
        .for each possible_super_rel in possible_super_rel_set
          .select many subtype_o_objs related by possible_super_rel->R_SUBSUP[R206]->R_SUB[R213]
          .select any sub_sm_ism related by subtype_o_objs->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]->SM_ISM[R518]
          .if ( empty sub_sm_ism )
            .assign attr_result = attr_result - possible_super_rel
          .end if
        .end for
        .//
        .if ( empty poly_sm_evt )
          .// No explicit PE defined for this supertype. Any pass through PE?
          .assign pass_through = FALSE
          .for each non_local_event in non_local_event_set
            .select any txn related by non_local_event->SM_SEVT[R525]->SM_SEME[R503]->SM_NSTXN[R504]
            .if ( empty txn )
              .assign pass_through = TRUE
              .break for
            .end if
          .end for
          .if ( not pass_through )
            .assign attr_result = attr_result - attr_result
          .end if
        .end if
      .end if
    .end if
  .end if
.end function
.//
.//
.//
.function CreatePolymorphicEventDeliveryMethod
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref_set poly_sm_evts
  .param boolean gen_declaration
  .param boolean firsttime
  .param string i
  .param string supertype
  .//
  .select any te_instance from instances of TE_INSTANCE
  .select any te_eq from instances of TE_EQ
  .select any te_target from instances of TE_TARGET
  .select any te_typemap from instances of TE_TYPEMAP
  .select one te_class related by o_obj->TE_CLASS[R2019]
  .select one te_c related by te_class->TE_C[R2064]
  .invoke method_name = GetSuperTypePolymorphicEventMethodName( te_class, r_rel )
  .if ( gen_declaration and firsttime )
extern void ${method_name.result}( const ${te_class.GeneratedName} * const, ${te_eq.base_event_type} * );
  .else
    .if ( firsttime )
      .select many poly_sm_evts related by o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_PEVT[R525]->SM_EVT[R525]
    .end if
    .select many all_subtype_o_objs related by r_rel->R_SUBSUP[R206]->R_SUB[R213]->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
    .assign subtype_o_objs = all_subtype_o_objs
    .for each subtype_o_obj in all_subtype_o_objs
      .// Remove any passive subtypes
      .select one sm_ism related by subtype_o_obj->SM_ISM[R518]
      .if ( empty sm_ism )
        .assign subtype_o_objs = subtype_o_objs - subtype
      .end if
    .end for
    .select any any_subtype_o_obj related by r_rel->R_SUBSUP[R206]->R_SUB[R213]->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
    .invoke supertype_data_member = GetRelationshipDataMemberName( any_subtype_o_obj, r_rel, "" )
    .if ( firsttime )
/*
 * Transfer a polymorphic event down the R${r_rel.Numb} subtype hierarchy
 * to the dispatcher of the subtype that responds to the polymorphic event.
 * Modify the event to use the event constants of the receiving subtype
 * class.
 */
void
${method_name.result}( const ${te_class.GeneratedName} * const ${supertype}, ${te_eq.base_event_type} * event )
{
  ${te_typemap.event_number_name} event_number = GetOoaEventNumber( event );
      .if ( "SystemC" == te_target.language )
  ${te_c.Name} * thismodule = (${te_c.Name} *) event->thismodule;
      .end if
    .end if
${i}  if ( 0 != ${supertype}->${supertype_data_member.result} )
${i}  switch ( ${supertype}->${supertype_data_member.obj_id} ) {
    .for each subtype_o_obj in subtype_o_objs
      .assign transition = ""
      .select one subtype_te_class related by subtype_o_obj->TE_CLASS[R2019]
${i}    case ${subtype_te_class.system_class_number}:  /* ${subtype_te_class.Name} (${subtype_te_class.Key_lett}) */
${i}      switch ( event_number ) {
      .assign remaining_poly_sm_evts = poly_sm_evts
      .for each poly_sm_evt in poly_sm_evts
        .select one poly_te_evt related by poly_sm_evt->TE_EVT[R2036]
        .select any sm_nlevt related by subtype_o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_SEVT[R525]->SM_NLEVT[R526] where ( (selected.PolySMevt_ID == poly_sm_evt.SMevt_ID) and (selected.PolySM_ID == poly_sm_evt.SM_ID) )
        .assign mning = ""
        .if ( poly_sm_evt.Mning != "" )
          .assign mning = "'${poly_sm_evt.Mning}'"
        .end if
        .assign note = "  /* ${poly_sm_evt.Drv_Lbl}*${mning} */"
        .if ( not_empty sm_nlevt )
          .select one true_te_evt related by sm_nlevt->SM_SEVT[R526]->SM_EVT[R525]->TE_EVT[R2036]
          .select any txn related by sm_nlevt->SM_SEVT[R526]->SM_SEME[R503]->SM_NSTXN[R504]
          .select any cant_happen related by sm_nlevt->SM_SEVT[R526]->SM_SEME[R503]->SM_CH[R504]
          .if ( ( not_empty txn ) or ( not_empty cant_happen ) )
            .// True event results in a transition or exception in the subtype.
            .assign transition = transition + "${i}        case ${poly_te_evt.Enumerator}:${note}\n"
            .assign transition = transition + "${i}          event = ${te_instance.module}${te_eq.modify}( event, &${true_te_evt.GeneratedName}c );\n"
            .assign transition = transition + "${i}          SetEventTargetInstance( event, ${supertype}->${supertype_data_member.result} );\n"
            .if ( "SystemC" == te_target.language )
              .assign transition = transition + "${i}          event->thismodule = thismodule;\n"
            .end if
            .assign transition = transition + "${i}          ${subtype_te_class.dispatcher}( event );\n"
            .assign transition = transition + "${i}          break; /* after transition */\n"
          .else
            .select any sm_eign related by sm_nlevt->SM_SEVT[R526]->SM_SEME[R503]->SM_EIGN[R504]
            .if ( empty sm_eign )
              .print "WARNING:  no transition for non-local event - ${subtype_te_class.Name}(${subtype_te_class.Key_lett}):${poly_sm_evt.Drv_Lbl}.${poly_sm_evt.Mning}\n"
            .end if
          .end if
        .else
          .// Poly has no nonlocal event in this subtype, so must be deeper.
          .select any sub_is_super related by subtype_o_obj->R_OIR[R201]->R_REL[R201]->R_SUBSUP[R206]->R_SUPER[R212] where ( selected.Obj_ID == subtype_o_obj.Obj_ID )
          .if ( not_empty sub_is_super )
            .// No transition in the subtype for this event.
            .// Pass the event down through the next subtype in the hierarchy.
${i}        case ${poly_te_evt.Enumerator}:${note}
            .select many r_supers related by subtype_o_obj->R_OIR[R201]->R_REL[R201]->R_SUBSUP[R206]->R_SUPER[R212] where ( selected.Obj_ID == subtype_o_obj.Obj_ID )
            .select many r_rels related by r_supers->R_SUBSUP[R212]->R_REL[R206]
            .for each subtype_r_rel in r_rels
              .assign indent = i + "        "
              .assign newsupertype = "((${subtype_te_class.GeneratedName} *) ${supertype}->${supertype_data_member.result})"
              .invoke s = CreatePolymorphicEventDeliveryMethod( subtype_o_obj, subtype_r_rel, remaining_poly_sm_evts, false, false, indent, newsupertype )
${s.body}\
            .end for
          .end if
        .end if
        .// Avoid interrogating the same PE in a subtype.
        .assign remaining_poly_sm_evts = remaining_poly_sm_evts - poly_sm_evt
      .end for
      .if ( "" != transition )
${i}        /* transition (or cant happen) events in subtype */
${transition}\
      .end if
${i}      }
${i}      break;
    .end for
${i}  }
    .if ( firsttime )
}
    .end if
  .end if
.end function
.//
.//
.//
.function AddSuperTypePolymorphicEventHandlers
  .param inst_ref o_obj
  .param boolean gen_declaration
  .//
  .select one sm_ism related by o_obj->SM_ISM[R518]
  .if ( not_empty sm_ism )
    .select many empty_sm_evts from instances of SM_EVT where ( false )
    .invoke poly_rels = GetPolymorphicRelationshipCollection( o_obj )
    .assign poly_r_rels = poly_rels.result
    .for each r_rel in poly_r_rels
      .invoke method = CreatePolymorphicEventDeliveryMethod( o_obj, r_rel, empty_sm_evts, gen_declaration, true, "", "p_$l{o_obj.Key_Lett}" )
${method.body}\
    .end for
  .end if
.end function
.//

.//============================================================================
.// $RCSfile: q.class.poly.arc,v $
.//
.// Description:
.// This archetype file contains the functions for generating class
.// methods associated with polymorphic event delivery.
.//
.// Notice:
.// (C) Copyright 1998-2013 Mentor Graphics Corporation
.//     All rights reserved.
.//
.// This document contains confidential and proprietary information and
.// property of Mentor Graphics Corp.  No part of this document may be
.// reproduced without the express written permission of Mentor Graphics Corp.
.//============================================================================
.//
.function GetPolymorphicRelationshipCollection
  .param inst_ref o_obj
  .//
  .select many r_supers related by o_obj->R_OIR[R201]->R_REL[R201]->R_SUBSUP[R206]->R_SUPER[R212] where ( selected.Obj_ID == o_obj.Obj_ID )
  .select many attr_result related by r_supers->R_SUBSUP[R212]->R_REL[R206]
  .if ( not_empty attr_result )
    .select one sm_ism related by o_obj->SM_ISM[R518]
    .if ( empty sm_ism )
      .// Passive supertype, we are done
      .assign attr_result = attr_result - attr_result
    .else
      .select any poly_sm_evt related by o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_PEVT[R525]->SM_EVT[R525]
      .select many non_local_event_set related by o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_SEVT[R525]->SM_NLEVT[R526]->SM_SEVT[R526]->SM_EVT[R525]
      .if ( (empty poly_sm_evt) and (empty non_local_event_set) )
        .assign attr_result = attr_result - attr_result
      .else
        .assign possible_super_rel_set = attr_result
        .// Remove any rels where all the subtypes are passive
        .for each possible_super_rel in possible_super_rel_set
          .select many subtype_o_objs related by possible_super_rel->R_SUBSUP[R206]->R_SUB[R213]
          .select any sub_sm_ism related by subtype_o_objs->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]->SM_ISM[R518]
          .if ( empty sub_sm_ism )
            .assign attr_result = attr_result - possible_super_rel
          .end if
        .end for
        .//
        .if ( empty poly_sm_evt )
          .// No explicit PE defined for this supertype. Any pass through PE?
          .assign pass_through = FALSE
          .for each non_local_event in non_local_event_set
            .select any txn related by non_local_event->SM_SEVT[R525]->SM_SEME[R503]->SM_NSTXN[R504]
            .if ( empty txn )
              .assign pass_through = TRUE
              .break for
            .end if
          .end for
          .if ( not pass_through )
            .assign attr_result = attr_result - attr_result
          .end if
        .end if
      .end if
    .end if
  .end if
.end function
.//
.//
.//
.function CreatePolymorphicEventDeliveryMethod
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref_set poly_sm_evts
  .param boolean gen_declaration
  .param boolean firsttime
  .param string i
  .param string supertype
  .//
  .select any te_instance from instances of TE_INSTANCE
  .select any te_eq from instances of TE_EQ
  .select any te_target from instances of TE_TARGET
  .select any te_typemap from instances of TE_TYPEMAP
  .select one te_class related by o_obj->TE_CLASS[R2019]
  .select one te_c related by te_class->TE_C[R2064]
  .invoke method_name = GetSuperTypePolymorphicEventMethodName( te_class, r_rel )
  .if ( gen_declaration and firsttime )
extern void ${method_name.result}( const ${te_class.GeneratedName} * const, ${te_eq.base_event_type} * );
  .else
    .if ( firsttime )
      .select many poly_sm_evts related by o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_PEVT[R525]->SM_EVT[R525]
    .end if
    .select many all_subtype_o_objs related by r_rel->R_SUBSUP[R206]->R_SUB[R213]->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
    .assign subtype_o_objs = all_subtype_o_objs
    .for each subtype_o_obj in all_subtype_o_objs
      .// Remove any passive subtypes
      .select one sm_ism related by subtype_o_obj->SM_ISM[R518]
      .if ( empty sm_ism )
        .assign subtype_o_objs = subtype_o_objs - subtype
      .end if
    .end for
    .select any any_subtype_o_obj related by r_rel->R_SUBSUP[R206]->R_SUB[R213]->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
    .invoke supertype_data_member = GetRelationshipDataMemberName( any_subtype_o_obj, r_rel, "" )
    .if ( firsttime )
/*
 * Transfer a polymorphic event down the R${r_rel.Numb} subtype hierarchy
 * to the dispatcher of the subtype that responds to the polymorphic event.
 * Modify the event to use the event constants of the receiving subtype
 * class.
 */
void
${method_name.result}( const ${te_class.GeneratedName} * const ${supertype}, ${te_eq.base_event_type} * event )
{
  ${te_typemap.event_number_name} event_number = GetOoaEventNumber( event );
      .if ( "SystemC" == te_target.language )
  ${te_c.Name} * thismodule = (${te_c.Name} *) event->thismodule;
      .end if
    .end if
${i}  if ( 0 != ${supertype}->${supertype_data_member.result} )
${i}  switch ( ${supertype}->${supertype_data_member.obj_id} ) {
    .for each subtype_o_obj in subtype_o_objs
      .assign transition = ""
      .select one subtype_te_class related by subtype_o_obj->TE_CLASS[R2019]
${i}    case ${subtype_te_class.system_class_number}:  /* ${subtype_te_class.Name} (${subtype_te_class.Key_lett}) */
${i}      switch ( event_number ) {
      .assign remaining_poly_sm_evts = poly_sm_evts
      .for each poly_sm_evt in poly_sm_evts
        .select one poly_te_evt related by poly_sm_evt->TE_EVT[R2036]
        .select any sm_nlevt related by subtype_o_obj->SM_ISM[R518]->SM_SM[R517]->SM_EVT[R502]->SM_SEVT[R525]->SM_NLEVT[R526] where ( (selected.PolySMevt_ID == poly_sm_evt.SMevt_ID) and (selected.PolySM_ID == poly_sm_evt.SM_ID) )
        .assign mning = ""
        .if ( poly_sm_evt.Mning != "" )
          .assign mning = "'${poly_sm_evt.Mning}'"
        .end if
        .assign note = "  /* ${poly_sm_evt.Drv_Lbl}*${mning} */"
        .if ( not_empty sm_nlevt )
          .select one true_te_evt related by sm_nlevt->SM_SEVT[R526]->SM_EVT[R525]->TE_EVT[R2036]
          .select any txn related by sm_nlevt->SM_SEVT[R526]->SM_SEME[R503]->SM_NSTXN[R504]
          .select any cant_happen related by sm_nlevt->SM_SEVT[R526]->SM_SEME[R503]->SM_CH[R504]
          .if ( ( not_empty txn ) or ( not_empty cant_happen ) )
            .// True event results in a transition or exception in the subtype.
            .assign transition = transition + "${i}        case ${poly_te_evt.Enumerator}:${note}\n"
            .assign transition = transition + "${i}          event = ${te_instance.module}${te_eq.modify}( event, &${true_te_evt.GeneratedName}c );\n"
            .assign transition = transition + "${i}          SetEventTargetInstance( event, ${supertype}->${supertype_data_member.result} );\n"
            .if ( "SystemC" == te_target.language )
              .assign transition = transition + "${i}          event->thismodule = thismodule;\n"
            .end if
            .assign transition = transition + "${i}          ${subtype_te_class.dispatcher}( event );\n"
            .assign transition = transition + "${i}          break; /* after transition */\n"
          .else
            .select any sm_eign related by sm_nlevt->SM_SEVT[R526]->SM_SEME[R503]->SM_EIGN[R504]
            .if ( empty sm_eign )
              .print "error:  no transition for non-local event... this should not be.\n"
            .end if
          .end if
        .else
          .// Poly has no nonlocal event in this subtype, so must be deeper.
          .select any sub_is_super related by subtype_o_obj->R_OIR[R201]->R_REL[R201]->R_SUBSUP[R206]->R_SUPER[R212] where ( selected.Obj_ID == subtype_o_obj.Obj_ID )
          .if ( not_empty sub_is_super )
            .// No transition in the subtype for this event.
            .// Pass the event down through the next subtype in the hierarchy.
${i}        case ${poly_te_evt.Enumerator}:${note}
            .select many r_supers related by subtype_o_obj->R_OIR[R201]->R_REL[R201]->R_SUBSUP[R206]->R_SUPER[R212] where ( selected.Obj_ID == subtype_o_obj.Obj_ID )
            .select many r_rels related by r_supers->R_SUBSUP[R212]->R_REL[R206]
            .for each subtype_r_rel in r_rels
              .assign indent = i + "        "
              .assign newsupertype = "((${subtype_te_class.GeneratedName} *) ${supertype}->${supertype_data_member.result})"
              .invoke s = CreatePolymorphicEventDeliveryMethod( subtype_o_obj, subtype_r_rel, remaining_poly_sm_evts, false, false, indent, newsupertype )
${s.body}\
            .end for
          .end if
        .end if
        .// Avoid interrogating the same PE in a subtype.
        .assign remaining_poly_sm_evts = remaining_poly_sm_evts - poly_sm_evt
      .end for
      .if ( "" != transition )
${i}        /* transition (or cant happen) events in subtype */
${transition}\
      .end if
${i}      }
${i}      break;
    .end for
${i}  }
    .if ( firsttime )
}
    .end if
  .end if
.end function
.//
.//
.//
.function AddSuperTypePolymorphicEventHandlers
  .param inst_ref o_obj
  .param boolean gen_declaration
  .//
  .select one sm_ism related by o_obj->SM_ISM[R518]
  .if ( not_empty sm_ism )
    .select many empty_sm_evts from instances of SM_EVT where ( false )
    .invoke poly_rels = GetPolymorphicRelationshipCollection( o_obj )
    .assign poly_r_rels = poly_rels.result
    .for each r_rel in poly_r_rels
      .invoke method = CreatePolymorphicEventDeliveryMethod( o_obj, r_rel, empty_sm_evts, gen_declaration, true, "", "p_$l{o_obj.Key_Lett}" )
${method.body}\
    .end for
  .end if
.end function
.//


lib/ppr.arc: indent-pairs: break lines appropriately in tail position

Previously, expressions in tail position in were always printed on one line.

(= pprsyms* (fill-table (table)
			'(quote "'"
			  quasiquote "`"
			  unquote ","
			  unquote-splicing ",@")))

(def sp ((o n 1))
  " Print a number of spaces. "
  (repeat n (pr " ")))

(def print-spaced (xs)
  " Print the expressions in the list separated by spaces. "
  (when xs
    (print car.xs)
    (each x cdr.xs (sp) print.x)))

(def print (x)
  " Print an expression on one line, replacing quote, unquote,
    quasiquote, unquote-splicing, and make-br-fn with their respective symbols. "
  (do (aif (or atom.x dotted.x)
	     (do write.x nil)
	   (pprsyms* car.x)
	     (do pr.it
	       (print cadr.x)
	       nil)
	   (is car.x 'make-br-fn)
	     (do (pr "[") (print-spaced cadr.x) (pr "]") nil)
	   (do (pr "(") print-spaced.x (pr ")") nil))
      x))

(= oneline* 45)

(def len (x (o c 0))
  " Measures the length of a string, vector, table, list or dotted list. "
  (if (isa x 'string) ($.string-length x)
      (isa x 'vec) ($.vector-length x)
      (isa x 'table) ($.hash-table-count x)
      (and atom.x x) (+ c 1)
      acons.x (len cdr.x (+ c 1))
      c))

(mac indent (col . body)
  `(do (unless noindent sp.col)
       ,@body))

(mac ppr-sub body
  `(indent col
      (let whole (tostring print.x)
	(if (< len.whole oneline*)
	    (do pr.whole nil)
	    (do ,@body t)))))

(def indent-pairs (xs (o col 0))
  (let l (apply max 0 (map len:tostring:print:car (keep cdr pair.xs)))
    (on x pair.xs
        (if (~is index 0)
            (do (prn)
                (sp col)))
        (let str (tostring:print car.x)
          (if cdr.x
              (do pr.str
                  (sp:- l len.str -1)
                  (ppr cadr.x (+ col 1 l) t))
              ; lone tail expression
              (do (sp (+ l 1))
                  (ppr car.x (+ col (+ l 1)) t)))))))

(def indent-block (xs (o col 0))
  (each x xs (prn) (ppr x col)))

(def indent-mac (xs (o args 0) (o col 0))
  (print-spaced (firstn args xs))
  (indent-block (nthcdr args xs) (+ col 2)))

(def indent-basic (xs l (o col 0))
  (if (all [or atom._ (and (is car._ 'quote) (atom cadr._))]
	   xs)
      print-spaced.xs
      (do (ppr car.xs (+ col 2 l) t)
	  (indent-block cdr.xs (+ col 2 l)))))

(def indent-wave (xs (o col 0))
  (do (ppr car.xs col t)
      (on x cdr.xs
	  (prn)
	  (ppr x (+ col (* 2 (mod (+ index 1) 2)))))))

(= ifline* 20)

(def indent-if (l)
  (fn (xs (o col 0))
      (if (< len.xs 4)
	    (on x xs
		(if (~is index 0) (prn))
		(ppr x (+ col 2 l) (is index 0)))
	  (all [< (len:tostring print._) ifline*]
	       pair.xs)
	    (indent-pairs xs (+ col 2 l))
	  (indent-wave xs (+ col 2 l)))))

(def indent-with (l)
  (fn (xs (o col 0))
      (pr "(")
      (indent-pairs car.xs (+ col 3 l))
      (pr ")")
      (indent-block cdr.xs (+ col 3))))

(def indent-def (xs (o col 0))
  (print-spaced (firstn 2 xs))
  (if (isa xs.2 'string)
      (do (prn)
	  (sp (+ col 2))
	  (pr #\" xs.2 #\")
	  (indent-block (nthcdr 3 xs) (+ col 2)))
      (indent-block (nthcdr 2 xs) (+ col 2))))

(def indent-case (n)
  (fn (xs (o col 0))
      (print-spaced:firstn n xs)
      (prn)
      (sp (+ col 2))
      (indent-pairs (nthcdr n xs) (+ col 2))))

(= indent-rules*
   (fill-table (table)
     `(if      ,(indent-if 2)
       aif     ,(indent-if 3)
       with    ,(indent-with 4)
       withs   ,(indent-with 5)
       def     ,indent-def
       mac     ,indent-def
       do      ,[indent-basic _ 2 _2]
       and     ,[indent-basic _ 3 _2]
       or      ,[indent-basic _ 2 _2]
       nor     ,[indent-basic _ 3 _2]
       case    ,(indent-case 1)
       caselet ,(indent-case 2)
       fn      ,[indent-mac _ 1 _2])))

(def ppr (x (o col 0) (o noindent nil))
  " Pretty print. This function displays arc code with proper
    indenting and representation of syntax. "
  (aif (or atom.x dotted.x)		;just print the expression if it's an atom or dotted list
         (indent col
	   print.x
	   nil)
       (is car.x 'make-br-fn)		;if the expression is a br-fn, print the brackets and then the contents
         (ppr-sub
	   (pr "[")
	   (ppr cadr.x (+ col 1) t)
	   (pr "]"))
       (pprsyms* car.x)
         (ppr-sub
	   pr.it
	   (ppr cadr.x (+ col len.it) t))
       (ppr-sub
	 (pr "(")
	 (withs (proc car.x
		 args sig.proc
                 n    len.args
		 str  (tostring:print proc)
		 l    len.str
		 xs   cdr.x)
	   (if (isa proc 'cons)
	       (do (ppr proc (+ col 1) t)
		   (indent-block xs (+ col 1)))
	       (do pr.str
		   (when xs
		     (sp)
		     (aif indent-rules*.proc
			    (it xs col)
			  (and (isa proc 'sym) (bound proc) (isa (eval proc) 'mac))
			    (if (or dotted.args (and args (~acons args)))
				(indent-mac xs (- len.args 1) col)
				(indent-mac xs 0 col))
			  (indent-basic xs l col)))))
	   (pr ")")))))

(= pprsyms* (fill-table (table)
			'(quote "'"
			  quasiquote "`"
			  unquote ","
			  unquote-splicing ",@")))

(def sp ((o n 1))
  " Print a number of spaces. "
  (repeat n (pr " ")))

(def print-spaced (xs)
  " Print the expressions in the list separated by spaces. "
  (when xs
    (print car.xs)
    (each x cdr.xs (sp) print.x)))

(def print (x)
  " Print an expression on one line, replacing quote, unquote,
    quasiquote, unquote-splicing, and make-br-fn with their respective symbols. "
  (do (aif (or atom.x dotted.x)
	     (do write.x nil)
	   (pprsyms* car.x)
	     (do pr.it
	       (print cadr.x)
	       nil)
	   (is car.x 'make-br-fn)
	     (do (pr "[") (print-spaced cadr.x) (pr "]") nil)
	   (do (pr "(") print-spaced.x (pr ")") nil))
      x))

(= oneline* 45)

(def len (x (o c 0))
  " Measures the length of a string, vector, table, list or dotted list. "
  (if (isa x 'string) ($.string-length x)
      (isa x 'vec) ($.vector-length x)
      (isa x 'table) ($.hash-table-count x)
      (and atom.x x) (+ c 1)
      acons.x (len cdr.x (+ c 1))
      c))

(mac indent (col . body)
  `(do (unless noindent sp.col)
       ,@body))

(mac ppr-sub body
  `(indent col
      (let whole (tostring print.x)
	(if (< len.whole oneline*)
	    (do pr.whole nil)
	    (do ,@body t)))))

(def indent-pairs (xs (o col 0))
  (let l (apply max 0 (map len:tostring:print:car (keep cdr pair.xs)))
    (on x pair.xs
        (if (~is index 0)
            (do (prn)
                (sp col)))
        (let str (tostring:print car.x)
          (if cdr.x
              (do pr.str
                  (sp:- l len.str -1)
                  (ppr cadr.x (+ col 1 l) t))
              (do (sp (+ l 1)) ;offending expression
                  pr.str))))))

(def indent-block (xs (o col 0))
  (each x xs (prn) (ppr x col)))

(def indent-mac (xs (o args 0) (o col 0))
  (print-spaced (firstn args xs))
  (indent-block (nthcdr args xs) (+ col 2)))

(def indent-basic (xs l (o col 0))
  (if (all [or atom._ (and (is car._ 'quote) (atom cadr._))]
	   xs)
      print-spaced.xs
      (do (ppr car.xs (+ col 2 l) t)
	  (indent-block cdr.xs (+ col 2 l)))))

(def indent-wave (xs (o col 0))
  (do (ppr car.xs col t)
      (on x cdr.xs
	  (prn)
	  (ppr x (+ col (* 2 (mod (+ index 1) 2)))))))

(= ifline* 20)

(def indent-if (l)
  (fn (xs (o col 0))
      (if (< len.xs 4)
	    (on x xs
		(if (~is index 0) (prn))
		(ppr x (+ col 2 l) (is index 0)))
	  (all [< (len:tostring print._) ifline*]
	       pair.xs)
	    (indent-pairs xs (+ col 2 l))
	  (indent-wave xs (+ col 2 l)))))

(def indent-with (l)
  (fn (xs (o col 0))
      (pr "(")
      (indent-pairs car.xs (+ col 3 l))
      (pr ")")
      (indent-block cdr.xs (+ col 3))))

(def indent-def (xs (o col 0))
  (print-spaced (firstn 2 xs))
  (if (isa xs.2 'string)
      (do (prn)
	  (sp (+ col 2))
	  (pr #\" xs.2 #\")
	  (indent-block (nthcdr 3 xs) (+ col 2)))
      (indent-block (nthcdr 2 xs) (+ col 2))))

(def indent-case (n)
  (fn (xs (o col 0))
      (print-spaced:firstn n xs)
      (prn)
      (sp (+ col 2))
      (indent-pairs (nthcdr n xs) (+ col 2))))

(= indent-rules*
   (fill-table (table)
     `(if      ,(indent-if 2)
       aif     ,(indent-if 3)
       with    ,(indent-with 4)
       withs   ,(indent-with 5)
       def     ,indent-def
       mac     ,indent-def
       do      ,[indent-basic _ 2 _2]
       and     ,[indent-basic _ 3 _2]
       or      ,[indent-basic _ 2 _2]
       nor     ,[indent-basic _ 3 _2]
       case    ,(indent-case 1)
       caselet ,(indent-case 2)
       fn      ,[indent-mac _ 1 _2])))

(def ppr (x (o col 0) (o noindent nil))
  " Pretty print. This function displays arc code with proper
    indenting and representation of syntax. "
  (aif (or atom.x dotted.x)		;just print the expression if it's an atom or dotted list
         (indent col
	   print.x
	   nil)
       (is car.x 'make-br-fn)		;if the expression is a br-fn, print the brackets and then the contents
         (ppr-sub
	   (pr "[")
	   (ppr cadr.x (+ col 1) t)
	   (pr "]"))
       (pprsyms* car.x)
         (ppr-sub
	   pr.it
	   (ppr cadr.x (+ col len.it) t))
       (ppr-sub
	 (pr "(")
	 (withs (proc car.x
		 args sig.proc
                 n    len.args
		 str  (tostring:print proc)
		 l    len.str
		 xs   cdr.x)
	   (if (isa proc 'cons)
	       (do (ppr proc (+ col 1) t)
		   (indent-block xs (+ col 1)))
	       (do pr.str
		   (when xs
		     (sp)
		     (aif indent-rules*.proc
			    (it xs col)
			  (and (isa proc 'sym) (bound proc) (isa (eval proc) 'mac))
			    (if (or dotted.args (and args (~acons args)))
				(indent-mac xs (- len.args 1) col)
				(indent-mac xs 0 col))
			  (indent-basic xs l col)))))
	   (pr ")")))))