add regex functions to strings.arc

add regex functions to strings.arc

; Matching.  Spun off 29 Jul 06.

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

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

; names of cut, split, halve not optimal

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

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

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

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

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

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

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

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

; Fixed for utf8 by pc.

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

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

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

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

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

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

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

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

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

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

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

; not a good name

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

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

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

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

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

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

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

; English

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

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

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

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

(load "help/strings.arc")

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

; Matching.  Spun off 29 Jul 06.

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

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

; names of cut, split, halve not optimal

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

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

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

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

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

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

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

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

; Fixed for utf8 by pc.

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

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

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

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

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

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

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

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

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

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

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

; not a good name

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

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

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

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

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

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

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

; English

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

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

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

(load "help/strings.arc")

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


job #9933 - remove extra quotes around pass number

.function mc_main
  .param string arc_path
  .invoke parm_sort()
  .invoke rel_pseudoformalize()
  .//
  .// Create the unmarked, standard singletons.
  .invoke sys_singletons()
  .select any te_file from instances of TE_FILE
  .assign te_file.arc_path = arc_path
  .//
  .// marking
  .//
  .// Initialize the generator database with marking information.
  .// Note that the order of processing is important here.
  .//
  .// 2) Mark interrupt handlers.
  .include "${te_file.system_color_path}/${te_file.bridge_mark}"
  .// 3) Initiate user data type marking.
  .include "${te_file.system_color_path}/${te_file.datatype_mark}"
  .// 4) Initiate prefix marking (from system marking file).
  .include "${te_file.system_color_path}/${te_file.system_mark}"
  .//
  .invoke oal( "mark_pass(1); // Ccode" )
  .invoke sys_populate()
  .invoke oal( "mark_pass(2); // Ccode" )
  .select any te_sys from instances of TE_SYS
  .//
  .// 5) Perform domain level marking.
  .include "${te_file.domain_color_path}/${te_file.domain_mark}"
  .//
  .// 6) Perform class level marking.
  .include "${te_file.domain_color_path}/${te_file.class_mark}"
  .//
  .// 7) Perform event marking.
  .include "${te_file.domain_color_path}/${te_file.event_mark}"
  .//
  .// analyze
  .invoke sys_analyze( te_sys )
  .invoke CreateSpecialWhereClauseInstances( te_sys )
  .select many te_cs from instances of TE_C where ( selected.included_in_build )
  .for each te_c in te_cs
    .// Propagate domain information to the system level.
    .invoke te_c_CollectLimits( te_c )
    .select many te_classs related by te_c->TE_CLASS[R2064] where ( not selected.ExcludeFromGen )
    .invoke class_sort( te_classs )
  .end for
  .print "translating values/expressions"
  .invoke val_translate()
  .invoke oal_translate()
.end function

.function mc_main
  .param string arc_path
  .invoke parm_sort()
  .invoke rel_pseudoformalize()
  .//
  .// Create the unmarked, standard singletons.
  .invoke sys_singletons()
  .select any te_file from instances of TE_FILE
  .assign te_file.arc_path = arc_path
  .//
  .// marking
  .//
  .// Initialize the generator database with marking information.
  .// Note that the order of processing is important here.
  .//
  .// 2) Mark interrupt handlers.
  .include "${te_file.system_color_path}/${te_file.bridge_mark}"
  .// 3) Initiate user data type marking.
  .include "${te_file.system_color_path}/${te_file.datatype_mark}"
  .// 4) Initiate prefix marking (from system marking file).
  .include "${te_file.system_color_path}/${te_file.system_mark}"
  .//
  .invoke oal( "mark_pass("1"); // Ccode" )
  .invoke sys_populate()
  .invoke oal( "mark_pass("2"); // Ccode" )
  .select any te_sys from instances of TE_SYS
  .//
  .// 5) Perform domain level marking.
  .include "${te_file.domain_color_path}/${te_file.domain_mark}"
  .//
  .// 6) Perform class level marking.
  .include "${te_file.domain_color_path}/${te_file.class_mark}"
  .//
  .// 7) Perform event marking.
  .include "${te_file.domain_color_path}/${te_file.event_mark}"
  .//
  .// analyze
  .invoke sys_analyze( te_sys )
  .invoke CreateSpecialWhereClauseInstances( te_sys )
  .select many te_cs from instances of TE_C where ( selected.included_in_build )
  .for each te_c in te_cs
    .// Propagate domain information to the system level.
    .invoke te_c_CollectLimits( te_c )
    .select many te_classs related by te_c->TE_CLASS[R2064] where ( not selected.ExcludeFromGen )
    .invoke class_sort( te_classs )
  .end for
  .print "translating values/expressions"
  .invoke val_translate()
  .invoke oal_translate()
.end function


Remove indent mac from ppr.arc

Remove indent mac from ppr.arc

(= 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)
	     write.x
	   (pprsyms* car.x)
	     (do pr.it
	       (print cadr.x))
	   (is car.x 'make-br-fn)
	     (do (pr "[") (print-spaced cadr.x) (pr "]"))
	   (do (pr "(") print-spaced.x (pr ")")))
      x))

(= oneline* 45)

(mac ppr-sub body
  `(do (unless noindent sp.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-main cadr.x (+ col 1 l) t))
              ; lone tail expression
              (do (sp (+ l 1))
                  (ppr-main car.x (+ col (+ l 1)) t)))))))

(def indent-block (xs (o col 0))
  (each x xs (prn) (ppr-main 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-main car.xs (+ col 2 l) t)
	  (indent-block cdr.xs (+ col 2 l)))))

(def indent-wave (xs (o col 0))
  (do (ppr-main car.xs col t)
      (on x cdr.xs
	  (prn)
	  (ppr-main 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-main 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-main (x (o col 0) (o noindent nil))
  " Recursive main body of the ppr function. "
  (aif (or atom.x dotted.x)		;just print the expression if it's an atom or dotted list
       (do (unless noindent sp.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-main cadr.x (+ col 1) t)
	   (pr "]"))
       (pprsyms* car.x)
         (ppr-sub
	   pr.it
	   (ppr-main 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-main 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 ")")))))

(def ppr l
  " Pretty print. This function displays arc code with proper
    indenting and representation of syntax. "
  (each x l (ppr-main x) (prn)))

(= 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)
	     write.x
	   (pprsyms* car.x)
	     (do pr.it
	       (print cadr.x))
	   (is car.x 'make-br-fn)
	     (do (pr "[") (print-spaced cadr.x) (pr "]"))
	   (do (pr "(") print-spaced.x (pr ")")))
      x))

(= oneline* 45)

(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-main cadr.x (+ col 1 l) t))
              ; lone tail expression
              (do (sp (+ l 1))
                  (ppr-main car.x (+ col (+ l 1)) t)))))))

(def indent-block (xs (o col 0))
  (each x xs (prn) (ppr-main 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-main car.xs (+ col 2 l) t)
	  (indent-block cdr.xs (+ col 2 l)))))

(def indent-wave (xs (o col 0))
  (do (ppr-main car.xs col t)
      (on x cdr.xs
	  (prn)
	  (ppr-main 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-main 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-main (x (o col 0) (o noindent nil))
  " Recursive main body of the ppr function. "
  (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-main cadr.x (+ col 1) t)
	   (pr "]"))
       (pprsyms* car.x)
         (ppr-sub
	   pr.it
	   (ppr-main 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-main 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 ")")))))

(def ppr l
  " Pretty print. This function displays arc code with proper
    indenting and representation of syntax. "
  (each x l (ppr-main x) (prn)))