1 2% RLISP to LISP converter. A C Norman 2004 3 4 5%% 6%% Copyright (C) 2017, following the master REDUCE source files. * 7%% * 8%% Redistribution and use in source and binary forms, with or without * 9%% modification, are permitted provided that the following conditions are * 10%% met: * 11%% * 12%% * Redistributions of source code must retain the relevant * 13%% copyright notice, this list of conditions and the following * 14%% disclaimer. * 15%% * Redistributions in binary form must reproduce the above * 16%% copyright notice, this list of conditions and the following * 17%% disclaimer in the documentation and/or other materials provided * 18%% with the distribution. * 19%% * 20%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * 21%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * 22%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * 23%% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * 24%% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * 25%% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * 26%% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * 27%% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * 28%% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * 29%% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * 30%% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * 31%% DAMAGE. * 32%% 33 34 35% $Id: extras.lsp 5550 2020-12-27 20:34:56Z arthurcnorman $ 36 37(dm df (u !&optional env) (prog (g w) (setq g (gensym)) (setq w (list (quote 38list) (quote (quote let!*)) (list (quote list) (list (quote list) (mkquote ( 39caaddr u)) (list (quote mkquote) (list (quote cdr) g)))) (list (quote cons) ( 40quote (quote progn)) (mkquote (cdddr u))))) (return (list (quote dm) (cadr u) 41(list g (quote !&optional) (gensym)) w)))) 42 43(de oem!-supervisor nil (print (eval (read)))) 44 45(de break!-loop (a) (prog (prompt ifile ofile u v) (setq ifile (rds 46!*debug!-io!*)) (setq ofile (wrs !*debug!-io!*)) (setq prompt (setpchar 47"Break loop (:X exits)> ")) top (setq u (read)) (cond ((equal u (quote !:x)) 48(go exit)) (t (cond ((equal u (quote !:q)) (progn (enable!-backtrace nil) ( 49princ "Backtrace now disabled") (terpri))) (t (cond ((equal u (quote !:v)) ( 50progn (enable!-backtrace t) (princ "Backtrace now enabled") (terpri))) (t ( 51progn (cond ((null u) (setq v nil)) (t (setq v (errorset u nil nil)))) (cond 52((atom v) (progn (princ ":Q quietens backtrace") (terpri) (princ 53":V enables backtrace") (terpri) (princ ":X exits from break loop") ( 54terpri) (princ "else form for evaluation") (terpri))) (t (progn (prin "=> ") 55(prinl (car v)) (terpri))))))))))) (go top) exit (rds ifile) (wrs ofile) ( 56setpchar prompt) (return nil))) 57 58(global (quote (s!:gensym!-serial))) 59 60(setq s!:gensym!-serial 0) 61 62(de s!:stamp (n) (cond ((lessp n 0) (append (s!:stamp (minus n)) (quote (!-)) 63)) (t (cond ((equal n 0) nil) (t (cons (schar 64"0123456789abcdefghijklmnopqrstuvwxyz" (remainder n 36)) (s!:stamp (truncate 65n 36)))))))) 66 67(de dated!-name (base) (intern (list2string (append (explodec base) (cons ( 68quote !_) (append (reverse (s!:stamp (datestamp))) (cons (quote !_) (explodec 69(setq s!:gensym!-serial (plus s!:gensym!-serial 1)))))))))) 70 71(de hashtagged!-name (base value) (intern (list2string (append (explodec base 72) (cons (quote !_) (s!:stamp (md60 value))))))) 73 74(remflag (quote (sort sortip)) (quote lose)) 75 76(de sort (l pred) (stable!-sortip (append l nil) pred)) 77 78(de stable!-sort (l pred) (stable!-sortip (append l nil) pred)) 79 80(de sortip (l pred) (stable!-sortip l pred)) 81 82(de stable!-sortip (l pred) (prog (l1 l2 w) (cond ((null l) (return l))) ( 83setq l1 l) (setq l2 (cdr l)) (cond ((null l2) (return l))) (setq l (cdr l2)) 84(cond ((null l) (progn (cond ((apply2 pred (car l2) (car l1)) (progn (setq l 85(car l1)) (rplaca l1 (car l2)) (rplaca l2 l)))) (return l1)))) (setq l l1) ( 86prog nil lab1000 (cond ((null (and l2 (not (apply2 pred (car l2) (car l))))) 87(return nil))) (progn (setq l l2) (setq l2 (cdr l2))) (go lab1000)) (cond (( 88null l2) (return l1))) (setq l2 l1) (setq l (cddr l2)) (prog nil lab1001 ( 89cond ((null (and l (cdr l))) (return nil))) (progn (setq l2 (cdr l2)) (setq l 90(cddr l))) (go lab1001)) (setq l l2) (setq l2 (cdr l2)) (rplacd l nil) (setq 91l1 (stable!-sortip l1 pred)) (setq l2 (stable!-sortip l2 pred)) (setq l ( 92setq w (list nil))) (prog nil lab1002 (cond ((null (and l1 l2)) (return nil)) 93) (progn (cond ((apply2 pred (car l2) (car l1)) (progn (rplacd w l2) (setq w 94l2) (setq l2 (cdr l2)))) (t (progn (rplacd w l1) (setq w l1) (setq l1 (cdr l1 95)))))) (go lab1002)) (cond (l1 (setq l2 l1))) (rplacd w l2) (return (cdr l))) 96) 97 98(fluid (quote (!*prinl!-visited!-nodes!* !*prinl!-index!* !*prinl!-fn!* 99!*print!-array!* !*print!-length!* !*print!-level!*))) 100 101(setq !*print!-length!* (setq !*print!-level!* nil)) 102 103(setq !*prinl!-visited!-nodes!* (mkhash 10 0 1.5)) 104 105(de s!:prinl0 (x !*prinl!-fn!*) (prog (!*prinl!-index!*) (setq 106!*prinl!-index!* 0) (unwind!-protect (progn (s!:prinl1 x 0) (s!:prinl2 x 0)) 107(clrhash !*prinl!-visited!-nodes!*)) (return x))) 108 109(de s!:prinl1 (x depth) (prog (w length) (cond ((and (fixp !*print!-level!*) 110(greaterp depth !*print!-level!*)) (return nil))) (setq length 0) top (cond ( 111(and (atom x) (not (simple!-vector!-p x)) (not (gensymp x))) (return nil)) (t 112(cond ((setq w (gethash x !*prinl!-visited!-nodes!*)) (progn (cond ((equal w 1130) (progn (setq !*prinl!-index!* (plus !*prinl!-index!* 1)) (puthash x 114!*prinl!-visited!-nodes!* !*prinl!-index!*)))) (return nil))) (t (progn ( 115puthash x !*prinl!-visited!-nodes!* 0) (cond ((simple!-vector!-p x) (progn ( 116cond (!*print!-array!* (progn (setq length (upbv x)) (cond ((and (fixp 117!*print!-length!*) (lessp !*print!-length!* length)) (setq length 118!*print!-length!*))) (prog (i) (setq i 0) lab1003 (cond ((minusp (times 1 ( 119difference length i))) (return nil))) (s!:prinl1 (getv x i) (plus depth 1)) ( 120setq i (plus i 1)) (go lab1003))))))) (t (cond ((not (atom x)) (progn ( 121s!:prinl1 (car x) (plus depth 1)) (cond ((and (fixp !*print!-length!*) ( 122greaterp (setq length (plus length 1)) !*print!-length!*)) (return nil))) ( 123setq x (cdr x)) (go top))))))))))))) 124 125(de s!:prinl2 (x depth) (cond ((and (fixp !*print!-level!*) (greaterp depth 126!*print!-level!*)) (princ "#")) (t (cond ((and (atom x) (not ( 127simple!-vector!-p x)) (not (gensymp x))) (progn (funcall !*prinl!-fn!* x))) ( 128t (prog (w length) (setq w (gethash x !*prinl!-visited!-nodes!*)) (cond ((not 129(zerop w)) (progn (cond ((lessp w 0) (progn (princ "#") (princ (minus w)) ( 130princ "#") (return nil))) (t (progn (puthash x !*prinl!-visited!-nodes!* ( 131minus w)) (princ "#") (princ w) (princ "="))))))) (cond ((simple!-vector!-p x 132) (progn (princ "%(") (cond (!*print!-array!* (progn (setq length (upbv x)) ( 133cond ((and (fixp !*print!-length!*) (lessp !*print!-length!* length)) (setq 134length !*print!-length!*))) (prog (i) (setq i 0) lab1004 (cond ((minusp ( 135times 1 (difference length i))) (return nil))) (progn (s!:prinl2 (getv x i) ( 136plus depth 1)) (cond ((not (equal i (upbv x))) (princ " ")))) (setq i (plus i 1371)) (go lab1004)))) (t (princ "..."))) (princ ")") (return nil))) (t (cond ( 138(atom x) (return (funcall !*prinl!-fn!* x)))))) (princ "(") (setq length 0) 139loop (s!:prinl2 (car x) (plus depth 1)) (setq x (cdr x)) (cond ((atom x) ( 140progn (cond ((simple!-vector!-p x) (progn (princ " . %(") (cond ( 141!*print!-array!* (progn (setq length (upbv x)) (cond ((and (fixp 142!*print!-length!*) (lessp !*print!-length!* length)) (setq length 143!*print!-length!*))) (prog (i) (setq i 0) lab1005 (cond ((minusp (times 1 ( 144difference length i))) (return nil))) (progn (s!:prinl2 (getv x i) (plus 145depth 1)) (cond ((not (equal i (upbv x))) (princ " ")))) (setq i (plus i 1)) 146(go lab1005)))) (t (princ "..."))) (princ ")"))) (t (cond (x (progn (princ 147" . ") (funcall !*prinl!-fn!* x)))))) (return (princ ")"))))) (cond ((and ( 148fixp !*print!-length!*) (greaterp (setq length (plus length 1)) 149!*print!-length!*)) (return (princ " ...)")))) (setq w (gethash x 150!*prinl!-visited!-nodes!*)) (cond ((not (equal w 0)) (cond ((lessp w 0) ( 151progn (princ " . #") (princ (minus w)) (return (princ "#)")))) (t (progn ( 152princ " . ") (s!:prinl2 x (plus depth 1)) (return (princ ")")))))) (t (princ 153" "))) (go loop))))))) 154 155(de printl (x) (progn (prinl x) (terpri) x)) 156 157(de printcl (x) (progn (princl x) (terpri) x)) 158 159(de princl (x) (s!:prinl0 x (function princ))) 160 161(de prinl (x) (s!:prinl0 x (function prin))) 162 163(de s!:format (dest fmt args) (prog (len c a res o) (cond ((not (null dest)) 164(progn (cond ((equal dest (quote t)) (setq o (wrs nil))) (t (setq o (wrs dest 165))))))) (setq len (upbv fmt)) (prog (i) (setq i 0) lab1012 (cond ((minusp ( 166times 1 (difference len i))) (return nil))) (progn (setq c (schar fmt i)) ( 167cond ((equal c (quote !~)) (progn (setq i (plus i 1)) (setq c (char!-downcase 168(schar fmt i))) (cond ((equal c (quote !%)) (cond ((null dest) (setq res ( 169cons !$eol!$ res))) (t (terpri)))) (t (cond ((equal c (quote !~)) (cond (( 170null dest) (setq res (cons (quote !~) res))) (t (princ (quote !~))))) (t ( 171progn (cond ((null args) (setq a nil)) (t (progn (setq a (car args)) (setq 172args (cdr args))))) (cond ((equal c (quote !a)) (cond ((null dest) (prog ( 173var1007) (setq var1007 (explode2 a)) lab1006 (cond ((null var1007) (return 174nil))) (prog (k) (setq k (car var1007)) (setq res (cons k res))) (setq 175var1007 (cdr var1007)) (go lab1006))) (t (princ a)))) (t (cond ((equal c ( 176quote !s)) (cond ((null dest) (prog (var1009) (setq var1009 (explode a)) 177lab1008 (cond ((null var1009) (return nil))) (prog (k) (setq k (car var1009)) 178(setq res (cons k res))) (setq var1009 (cdr var1009)) (go lab1008))) (t ( 179prin a)))) (t (cond ((null dest) (prog (var1011) (setq var1011 (explode a)) 180lab1010 (cond ((null var1011) (return nil))) (prog (k) (setq k (car var1011)) 181(setq res (cons k res))) (setq var1011 (cdr var1011)) (go lab1010))) (t ( 182prin (list (quote !?!?!?) c a))))))))))))))) (t (progn (cond ((null dest) ( 183setq res (cons c res))) (t (princ c))))))) (setq i (plus i 1)) (go lab1012)) 184(cond ((null dest) (return (list2string (reversip res)))) (t (progn (wrs o) ( 185return nil)))))) 186 187(dm format (u !&optional env) (list (quote s!:format) (cadr u) (caddr u) ( 188cons (quote list) (cdddr u)))) 189 190(fluid (quote (s!:bn s!:bufferi s!:buffero s!:indblanks s!:indentlevel 191s!:initialblanks s!:lmar s!:pendingrpars s!:rmar s!:rparcount s!:stack))) 192 193(global (quote (!*quotes !*pretty!-symmetric thin!*))) 194 195(setq !*pretty!-symmetric t) 196 197(setq !*quotes t) 198 199(setq thin!* 5) 200 201(remflag (quote (superprinm superprintm prettyprint tprettyprint)) (quote 202lose)) 203 204(de prettyprint (x) (progn (superprinm x (posn)) (terpri) nil)) 205 206(de tprettyprint (x) (progn (cond ((greaterp (posn) 6) (terpri))) ( 207prettyprint x))) 208 209(de superprintm (x s!:lmar) (progn (superprinm x s!:lmar) (terpri) x)) 210 211(de superprinm (x s!:lmar) (prog (s!:stack s!:bufferi s!:buffero s!:bn 212s!:initialblanks s!:rmar s!:pendingrpars s!:indentlevel s!:indblanks 213s!:rparcount w) (setq s!:bufferi (setq s!:buffero (list nil))) (setq 214s!:initialblanks 0) (setq s!:rparcount 0) (setq s!:indblanks 0) (setq s!:rmar 215(linelength nil)) (linelength 500) (cond ((lessp s!:rmar 25) (error 0 (list 216s!:rmar "Linelength too short for superprinting")))) (setq s!:bn 0) (setq 217s!:indentlevel 0) (cond ((geq (plus s!:lmar 20) s!:rmar) (setq s!:lmar ( 218difference s!:rmar 21)))) (setq w (posn)) (cond ((greaterp w s!:lmar) (progn 219(terpri) (setq w 0)))) (cond ((lessp w s!:lmar) (setq s!:initialblanks ( 220difference s!:lmar w)))) (s!:prindent x (plus s!:lmar 2)) (s!:overflow (quote 221none)) (linelength s!:rmar) (return x))) 222 223(flag (quote (superprinm superprintm prettyprint tprettyprint)) (quote lose)) 224 225(dm s!:top (u !&optional v) (quote (car s!:stack))) 226 227(dm s!:depth (u !&optional v) (list (quote car) (cadr u))) 228 229(dm s!:indenting (u !&optional v) (list (quote cadr) (cadr u))) 230 231(dm s!:blankcount (u !&optional v) (list (quote caddr) (cadr u))) 232 233(dm s!:blanklist (u !&optional v) (list (quote cdddr) (cadr u))) 234 235(dm s!:setindenting (u !&optional v) (list (quote rplaca) (list (quote cdr) ( 236cadr u)) (caddr u))) 237 238(dm s!:setblankcount (u !&optional v) (list (quote rplaca) (list (quote cddr) 239(cadr u)) (caddr u))) 240 241(dm s!:setblanklist (u !&optional v) (list (quote rplacd) (list (quote cddr) 242(cadr u)) (caddr u))) 243 244(dm s!:newframe (u !&optional v) (list (quote list) (cadr u) nil 0)) 245 246(dm s!:blankp (u !&optional v) (list (quote numberp) (list (quote car) (cadr 247u)))) 248 249(de s!:prindent (x n) (cond ((atom x) (cond ((simple!-vector!-p x) ( 250s!:prvector x n)) (t (prog (var1014) (setq var1014 (cond (!*pretty!-symmetric 251(cond ((stringp x) (s!:explodes x)) (t (explode x)))) (t (explode2 x)))) 252lab1013 (cond ((null var1014) (return nil))) (prog (c) (setq c (car var1014)) 253(s!:putch c)) (setq var1014 (cdr var1014)) (go lab1013))))) (t (cond (( 254s!:quotep x) (progn (s!:putch (quote !')) (s!:prindent (cadr x) (plus n 1)))) 255(t (prog (cx) (cond ((greaterp (times 4 n) (times 3 s!:rmar)) (progn ( 256s!:overflow (quote all)) (setq n (truncate n 8)) (cond ((greaterp 257s!:initialblanks n) (progn (setq s!:lmar (plus (difference s!:lmar 258s!:initialblanks) n)) (setq s!:initialblanks n))))))) (setq s!:stack (cons ( 259s!:newframe n) s!:stack)) (s!:putch (cons (quote lpar) (s!:top))) (setq cx ( 260car x)) (s!:prindent cx (plus n 1)) (cond ((and (idp cx) (not (atom (cdr x))) 261) (setq cx (get cx (quote s!:ppformat)))) (t (setq cx nil))) (cond ((and ( 262equal cx 2) (atom (cddr x))) (setq cx nil))) (cond ((equal cx (quote prog)) ( 263progn (s!:putch (quote ! )) (s!:prindent (car (setq x (cdr x))) (plus n 2)))) 264) (setq x (cdr x)) scan (cond ((atom x) (go outt))) (s!:finishpending) (cond 265((equal cx (quote prog)) (progn (s!:putblank) (s!:overflow s!:bufferi) (cond 266((atom (car x)) (progn (setq s!:lmar (setq s!:initialblanks (max (difference 267s!:lmar 6) 0))) (s!:prindent (car x) (difference n 2)) (setq x (cdr x)) (cond 268((and (not (atom x)) (atom (car x))) (go scan))) (cond ((greaterp (plus 269s!:lmar s!:bn) n) (s!:putblank)) (t (prog (i) (setq i (plus s!:lmar s!:bn)) 270lab1015 (cond ((minusp (times 1 (difference (difference n 1) i))) (return nil 271))) (s!:putch (quote ! )) (setq i (plus i 1)) (go lab1015)))) (cond ((atom x) 272(go outt)))))))) (t (cond ((numberp cx) (progn (setq cx (difference cx 1)) ( 273cond ((equal cx 0) (setq cx nil))) (s!:putch (quote ! )))) (t (s!:putblank))) 274)) (s!:prindent (car x) (plus n 2)) (setq x (cdr x)) (go scan) outt (cond (( 275not (null x)) (progn (s!:finishpending) (s!:putblank) (s!:putch (quote !.)) ( 276s!:putch (quote ! )) (s!:prindent x (plus n 5))))) (s!:putch (cons (quote 277rpar) (difference n 2))) (cond ((and (equal (s!:indenting (s!:top)) (quote 278indent)) (not (null (s!:blanklist (s!:top))))) (s!:overflow (car ( 279s!:blanklist (s!:top))))) (t (s!:endlist (s!:top)))) (setq s!:stack (cdr 280s!:stack)))))))) 281 282(de s!:explodes (x) (explode x)) 283 284(de s!:prvector (x n) (prog (bound) (setq bound (upbv x)) (setq s!:stack ( 285cons (s!:newframe n) s!:stack)) (s!:putch (cons (quote lsquare) (s!:top))) ( 286s!:prindent (getv x 0) (plus n 2)) (prog (i) (setq i 1) lab1016 (cond (( 287minusp (times 1 (difference bound i))) (return nil))) (progn (s!:putch (quote 288!,)) (s!:putblank) (s!:prindent (getv x i) (plus n 2))) (setq i (plus i 1)) 289(go lab1016)) (s!:putch (cons (quote rsquare) (difference n 2))) (s!:endlist 290(s!:top)) (setq s!:stack (cdr s!:stack)))) 291 292(de s!:putblank nil (prog nil (s!:putch (s!:top)) (s!:setblankcount (s!:top) 293(plus (s!:blankcount (s!:top)) 1)) (s!:setblanklist (s!:top) (cons s!:bufferi 294(s!:blanklist (s!:top)))) (setq s!:indblanks (plus s!:indblanks 1)))) 295 296(de s!:endlist (l) (setq s!:pendingrpars (cons l s!:pendingrpars))) 297 298(de s!:finishpending nil (progn (prog (var1020) (setq var1020 s!:pendingrpars 299) lab1019 (cond ((null var1020) (return nil))) (prog (stackframe) (setq 300stackframe (car var1020)) (progn (cond ((neq (s!:indenting stackframe) (quote 301indent)) (prog (var1018) (setq var1018 (s!:blanklist stackframe)) lab1017 ( 302cond ((null var1018) (return nil))) (prog (b) (setq b (car var1018)) (progn ( 303rplaca b (quote ! )) (setq s!:indblanks (difference s!:indblanks 1)))) (setq 304var1018 (cdr var1018)) (go lab1017)))) (s!:setblanklist stackframe t))) (setq 305var1020 (cdr var1020)) (go lab1019)) (setq s!:pendingrpars nil))) 306 307(de s!:quotep (x) (and !*quotes (not (atom x)) (equal (car x) (quote quote)) 308(not (atom (cdr x))) (null (cddr x)))) 309 310(put (quote prog) (quote s!:ppformat) (quote prog)) 311 312(put (quote lambda) (quote s!:ppformat) 1) 313 314(put (quote lambdaq) (quote s!:ppformat) 1) 315 316(put (quote setq) (quote s!:ppformat) 1) 317 318(put (quote set) (quote s!:ppformat) 1) 319 320(put (quote while) (quote s!:ppformat) 1) 321 322(put (quote t) (quote s!:ppformat) 1) 323 324(put (quote de) (quote s!:ppformat) 2) 325 326(put (quote df) (quote s!:ppformat) 2) 327 328(put (quote dm) (quote s!:ppformat) 2) 329 330(put (quote defun) (quote s!:ppformat) 2) 331 332(put (quote defmacro) (quote s!:ppformat) 2) 333 334(put (quote foreach) (quote s!:ppformat) 4) 335 336(de s!:putch (c) (prog nil (cond ((atom c) (setq s!:rparcount 0)) (t (cond (( 337s!:blankp c) (progn (setq s!:rparcount 0) (go nocheck))) (t (cond ((equal ( 338car c) (quote rpar)) (progn (setq s!:rparcount (plus s!:rparcount 1)) (cond ( 339(greaterp s!:rparcount 4) (progn (s!:putch (quote ! )) (setq s!:rparcount 2)) 340)))) (t (setq s!:rparcount 0))))))) (prog nil lab1021 (cond ((null (geq (plus 341s!:lmar s!:bn) s!:rmar)) (return nil))) (s!:overflow (quote more)) (go 342lab1021)) nocheck (setq s!:bufferi (cdr (rplacd s!:bufferi (list c)))) (setq 343s!:bn (plus s!:bn 1)))) 344 345(de s!:overflow (flg) (prog (c blankstoskip) (cond ((and (equal s!:indblanks 3460) (greaterp s!:initialblanks 2) (equal flg (quote more))) (progn (setq 347s!:initialblanks (difference s!:initialblanks 2)) (setq s!:lmar (difference 348s!:lmar 2)) (return (quote moved!-left))))) fblank (cond ((equal s!:bn 0) ( 349progn (cond ((not (equal flg (quote more))) (return (quote empty)))) (cond (( 350atom (car s!:buffero)) (prin2 "%+"))) (terpri) (setq s!:lmar 0) (return ( 351quote continued)))) (t (progn (spaces s!:initialblanks) (setq 352s!:initialblanks 0)))) (setq s!:buffero (cdr s!:buffero)) (setq s!:bn ( 353difference s!:bn 1)) (setq s!:lmar (plus s!:lmar 1)) (setq c (car s!:buffero) 354) (cond ((atom c) (progn (prin2 c) (go fblank))) (t (cond ((s!:blankp c) ( 355cond ((not (atom blankstoskip)) (progn (prin2 (quote ! )) (setq s!:indblanks 356(difference s!:indblanks 1)) (cond ((eq c (car blankstoskip)) (progn (rplacd 357blankstoskip (difference (cdr blankstoskip) 1)) (cond ((equal (cdr 358blankstoskip) 0) (setq blankstoskip t)))))) (go fblank))) (t (go blankfound)) 359)) (t (cond ((or (equal (car c) (quote lpar)) (equal (car c) (quote lsquare)) 360) (progn (prin2 (get (car c) (quote s!:ppchar))) (cond ((equal flg (quote 361none)) (go fblank))) (setq c (cdr c)) (cond ((not (null (s!:blanklist c))) ( 362go fblank))) (cond ((greaterp (s!:depth c) s!:indentlevel) (progn (setq 363s!:indentlevel (s!:depth c)) (s!:setindenting c (quote indent))))) (go fblank 364))) (t (cond ((or (equal (car c) (quote rpar)) (equal (car c) (quote rsquare) 365)) (progn (cond ((lessp (cdr c) s!:indentlevel) (setq s!:indentlevel (cdr c)) 366)) (prin2 (get (car c) (quote s!:ppchar))) (go fblank))) (t (error 0 (list c 367"UNKNOWN TAG IN OVERFLOW")))))))))) blankfound (cond ((eqcar (s!:blanklist c) 368s!:buffero) (s!:setblanklist c nil))) (setq s!:indblanks (difference 369s!:indblanks 1)) (cond ((greaterp (s!:depth c) s!:indentlevel) (progn (cond ( 370(equal flg (quote none)) (progn (prin2 (quote ! )) (go fblank)))) (cond ( 371blankstoskip (setq blankstoskip nil)) (t (progn (setq s!:indentlevel ( 372s!:depth c)) (s!:setindenting c (quote indent)))))))) (cond ((greaterp ( 373s!:blankcount c) (difference thin!* 1)) (progn (setq blankstoskip (cons c ( 374difference (s!:blankcount c) 2))) (s!:setindenting c (quote thin)) ( 375s!:setblankcount c 1) (setq s!:indentlevel (difference (s!:depth c) 1)) ( 376prin2 (quote ! )) (go fblank)))) (s!:setblankcount c (difference ( 377s!:blankcount c) 1)) (terpri) (setq s!:lmar (setq s!:initialblanks (s!:depth 378c))) (cond ((eq s!:buffero flg) (return (quote to!-flg)))) (cond ((or 379blankstoskip (not (equal flg (quote more)))) (go fblank))) (return (quote 380more)))) 381 382(put (quote lpar) (quote s!:ppchar) (quote !()) 383 384(put (quote lsquare) (quote s!:ppchar) (quote ![)) 385 386(put (quote rpar) (quote s!:ppchar) (quote !))) 387 388(put (quote rsquare) (quote s!:ppchar) (quote !])) 389 390(de fetch!-url (url !&optional dest) (prog (a b c d e w) (setq a (open!-url 391url)) (cond ((null a) (return nil))) (cond (dest (progn (setq d (open dest ( 392quote output))) (cond ((null d) (progn (close a) (return (error 0 393"unable to open destination file"))))) (setq d (wrs d))))) (setq b (rds a)) ( 394setq w (linelength 500)) (prog nil lab1022 (cond ((null (not (equal (setq c ( 395readch)) !$eof!$))) (return nil))) (princ c) (go lab1022)) (linelength e) ( 396rds b) (close a) (cond (dest (close (wrs d)))))) 397 398(de bldmsg_temp_internal (fmt args) (prog (r a) (setq fmt (explodec fmt)) ( 399prog nil lab1025 (cond ((null fmt) (return nil))) (progn (cond ((eqcar fmt ( 400quote !%)) (progn (setq fmt (cdr fmt)) (setq a (car args)) (setq args (cdr 401args)) (cond ((or (eqcar fmt (quote !p)) (eqcar fmt (quote !P))) (setq a ( 402explode a))) (t (setq a (explodec a)))) (prog (var1024) (setq var1024 a) 403lab1023 (cond ((null var1024) (return nil))) (prog (c) (setq c (car var1024)) 404(setq r (cons c r))) (setq var1024 (cdr var1024)) (go lab1023)))) (t (setq r 405(cons (car fmt) r)))) (setq fmt (cdr fmt))) (go lab1025)) (return ( 406list2string (reversip r))))) 407 408(dm bldmsg (u) (list (quote bldmsg_temp_internal) (cadr u) (cons (quote list) 409(cddr u)))) 410 411(flag (quote (bldmsg)) (quote variadic)) 412 413 414% end of file 415