![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to format.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib|
Return to format.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib |
1.1 ! root 1: (setq rcs-format- ! 2: "$Header") ! 3: ! 4: ;; ! 5: ;; format.l -[Fri Mar 4 12:20:16 1983 by jkf]- ! 6: ;; ! 7: ;; This is a function for printing or creating nicely formatted strings. ! 8: ;; This file is a modified version of the format program which runs in ! 9: ;; the mit lisps. When converting to franz, compatibility was the ! 10: ;; major goal, thus we still use the \ character as a string delimiter ! 11: ;; within a command string, even though it must be doubled in Franz. ! 12: ;; ! 13: ;; The file contains the user callable functions: ! 14: ;; format - lexpr for doing formated printed output or creating ! 15: ;; strings ! 16: ;; defformat - macro for adding a format directive ! 17: ;; ! 18: ! 19: ; FORMAT prints several arguments according to a control argument. ! 20: ; The control argument is either a string or a list of strings and lists. ! 21: ; The strings and lists are interpreted consecutively. ! 22: ; Strings are for the most part just printed, except that the character ~ ! 23: ; starts an escape sequence which directs other actions. ! 24: ; A ~ escape sequence has an (optional) numeric parameter followed by a ! 25: ; mode character. ! 26: ; These escape actions can use up one or more of the non-control arguments. ! 27: ; A list in the control-argument list is also interpreted as an escape. ! 28: ; Its first element is the mode, a symbol which may be any length, ! 29: ; and its remaining elements are parameters. The list (D 5) is equivalent ! 30: ; to the ~ escape "~5D"; similarly, each ~ escape has an equivalent list. ! 31: ; However, there are list escapes which have no ~ equivalent. ! 32: ! 33: ; Any undefined list escape is simply evaluated. ! 34: ! 35: ;These are the escape modes which are defined: ! 36: ; ~nD Takes any number and prints as a decimal integer. If no arg, ! 37: ; print without leading spaces. If arg and it fits in, put in leading ! 38: ; spaces; if it doesnt fit just print it. If second arg, use that ! 39: ; (or first char of STRING of it if not a number) instead of space ! 40: ; as a pad char. ! 41: ; ~nF Floating point ! 42: ; ~nE Exponential notation ! 43: ; ~nO Like D but octal ! 44: ; ~nA Character string. If there is an n then pad the string with spaces ! 45: ; on the right to make it n long. If it doesn't fit, ignore n. ! 46: ; ~n,m,minpad,padcharA Pad on the right to occupy at least ! 47: ; n columns, or if longer than that to begin with, pad to occupy ! 48: ; n+p*m columns for some nonnegative integer p. ! 49: ; at least minpad pad characters are produced in any case ! 50: ; (default if not supplied = 0). ! 51: ; padchar is used for padding purposes (default if not supplied = space). ! 52: ; if padchar is not a number, the first character in STRING of it is used. ! 53: ! 54: ; A mode can actually be used to PRINC anything, not just a string. ! 55: ; ~S Prin1 an object. Just like ~A (including parameters) but uses PRIN1. ! 56: ; ~C One character, in any acceptable form. ! 57: ; Control and meta bits print as alpha, beta, epsilon. ! 58: ; ~n* Ignore the next n args. n defaults to 1. ! 59: ; ~n% Insert n newlines. n defaults to 1. ! 60: ; ~n| Insert n formfeeds. n defaults to 1. ! 61: ; ~nX Insert n spaces. n defaults to 1. ! 62: ; ~n~ Insert n tildes. n defaults to 1. ! 63: ; ~& Perform the :FRESH-LINE operation on the stream. ! 64: ; ~n,mT Tab to column n+pm, for p an integer >= 0. ! 65: ; ~Q Apply the next arg to no arguments. ! 66: ; (Q ...) Apply the next arg to the (unevaluated) parameters following the Q. ! 67: ; ~P Insert an "s", unless its argument is a 1 ! 68: ; ~nG Goto the nth argument (zero based). The next command will get that ! 69: ; argument, etc. ! 70: ; ~E and ~F are not implemented. ~T is not implemented. ! 71: ! 72: ; (FORMAT <stream> <control arg> <args>) ! 73: ; If <stream> is NIL, cons up and return a symbol. ! 74: ; If <stream> is T, use STANDARD-OUTPUT (saves typing). ! 75: ! 76: ;; defformat: ! 77: ;; to add a format handler, the defformat macro is used. ! 78: ;; the form is (defformat code args type . body) ! 79: ;; where ! 80: ;; code is the code this will handle. the code can be a multi ! 81: ;; character symbol, however it will have to be called with \\code\\. ! 82: ;; args is either a one or two symbol list, depending on type ! 83: ;; type is either: none, one, or many. ! 84: ;; none means that type handler will not use any argument (it may use ! 85: ;; use parameters however) ! 86: ;; one means that it takes exactly one argument ! 87: ;; many means that it may take from zero to ?? arguments. ! 88: ;; body is the body of the function. Its return value is only important ! 89: ;; in the case of 'many' handlers since these handlers must return the ! 90: ;; list of the arguments they didn't use. ! 91: ;; ! 92: ;; 'none' handlers get passes a hunk which contains the parameters provide ! 93: ;; for this format directive. ! 94: ;; 'one' handlers are passed the argument and the parameters. ! 95: ;; 'many' handlers are passed the list of remaining arguments and the ! 96: ;; parameters. they return the arguments they don't use. ! 97: ! 98: ;to do: ! 99: ; 3) make sure the semantics follows the lisp machine defs ! 100: ; 6) do exponential (~e) floating point formats correctly. ! 101: ; 7) move ferror elsewhere (near error would be a good place). ! 102: ; 8) document it. ! 103: ; 11) fix ~a to left justify if given correct flag ! 104: ; 13) make sure that multi character directives are lower cased ! 105: ; 14) make the 'x parameter work correctly ! 106: ; 15) fix the english printer (wrt stream arg) and add ordinal ! 107: ! 108: ! 109: ;;; Kludges to make MacLISP like some of the LISPM functions ! 110: ! 111: (declare (special Format-Standard-Output roman-old ! 112: format-params-supplied format format-handlers ! 113: format-sharpsign-vars)) ! 114: ! 115: (setq format-sharpsign-vars 'franz-symbolic-character-names) ! 116: ! 117: ;; format-params-supplied : numbers of parameters to format parameter ! 118: ;; roman-old when t, the roman printer will print IIII instead of IV ! 119: ! 120: (or (boundp 'roman-old) (setq roman-old nil)) ! 121: ! 122: (declare (setq defmacro-for-compiling nil defmacro-displace-call nil )) ! 123: (defmacro nsubstring (&rest w) `(format\:nsubstring ,.w)) ! 124: (defmacro string-search-char (&rest w) `(format\:string-search-char ,.w)) ! 125: (defmacro ar-1 (ar ind) `(cxr ,ind ,ar)) ! 126: (defmacro as-1 (val ar ind) `(rplacx ,ind ,ar ,val)) ! 127: (defmacro >= (x y) `(not (< ,x ,y))) ! 128: (defmacro <= (x y) `(not (> ,x ,y))) ! 129: (defmacro neq (x y) `(not (= ,x ,y))) ! 130: (defmacro pop (stack) `(prog1 (car ,stack) (setq ,stack (cdr ,stack)))) ! 131: (declare (setq defmacro-for-compiling 't defmacro-displace-call 't)) ! 132: ! 133: ! 134: (declare ! 135: (special ctl-string ;The control string. ! 136: ctl-length ;string-length of ctl-string. ! 137: ctl-index ;Our current index into the control string. ! 138: ; Used by the conditional command. (NYI) ! 139: atsign-flag ;Modifier ! 140: colon-flag ;Modifier ! 141: format-temporary-area ;For temporary consing ! 142: format-arglist ;The original arg list, for ~G. ! 143: arglist-index ;How far we are in the current arglist ! 144: float-format ; format used when printing floats ! 145: poport ; franz's standard output ! 146: )) ! 147: ! 148: (defun format (stream ctl-string &rest args) ! 149: (let (format-string Format-Standard-Output ! 150: (format-arglist args) ! 151: (arglist-index 0)) ! 152: (setq stream (cond ((eq stream 't) poport ) ! 153: ((null stream) ! 154: (setq format-string 't) ! 155: (list nil)) ! 156: (t stream))) ! 157: (setq Format-Standard-Output stream) ! 158: (cond ((symbolp ctl-string) ! 159: (setq ctl-string (get_pname ctl-string)))) ! 160: (cond ((stringp ctl-string) ! 161: (format-ctl-string args ctl-string)) ! 162: (t (do ((ctl-string ctl-string (cdr ctl-string))) ! 163: ((null ctl-string)) ! 164: (setq args ! 165: (cond ((symbolp (car ctl-string)) ! 166: (format-ctl-string args (car ctl-string))) ! 167: (t (format-ctl-list args (car ctl-string)))))))) ! 168: (and format-string ! 169: (setq format-string (maknam (nreverse (cdr stream))))) ! 170: format-string)) ! 171: ! 172: (defun format-ctl-list (args ctl-list) ! 173: (format-ctl-op (car ctl-list) args (cdr ctl-list))) ! 174: ! 175: (defun format-ctl-string (args ctl-string) ! 176: (declare (fixnum ctl-index ctl-length)) ! 177: (do ((ctl-index 0) (ch) (tem) (str) (sym) ! 178: (ctl-length (flatc ctl-string))) ! 179: ((>= ctl-index ctl-length) args) ! 180: (setq tem (cond ((string-search-char #/~ ctl-string ctl-index)) ! 181: (t ctl-length))) ! 182: (cond ((neq tem ctl-index) ;Put out some literal string ! 183: (setq str (nsubstring ctl-string ctl-index tem)) ! 184: (format:patom str) ! 185: (and (>= (setq ctl-index tem) ctl-length) ! 186: (return args)))) ! 187: ;; (ar-1 ch ctl-index) is a tilde. ! 188: (do ((atsign-flag nil) ;Modifier ! 189: (colon-flag nil) ;Modifier ! 190: (params (makhunk 10)) ! 191: (param-leader -1) ! 192: ;PARAMS contains the list of numeric parameters ! 193: (param-flag nil) ;If T, a parameter has been started in PARAM ! 194: (param)) ;PARAM is the parameter currently ! 195: ; being constructed ! 196: ((>= (setq ctl-index (1+ ctl-index)) ctl-length)) ! 197: (setq ch (getcharn ctl-string (1+ ctl-index))) ! 198: (cond ((and (>= ch #/0) (<= ch #/9)) ; ! 199: (setq param (+ (* (or param 0) 10.) (- ch #/0)) ; ! 200: param-flag t)) ! 201: ((= ch #/@) ;ascii @ ! 202: (setq atsign-flag t)) ! 203: ((= ch #/:) ;ascii : ! 204: (setq colon-flag t)) ! 205: ((or (= ch #/v) (= ch #/V)) ;ascii v, v ! 206: (as-1 (pop args) params ! 207: (setq param-leader (1+ param-leader))) ! 208: (setq arglist-index (1+ arglist-index)) ! 209: (setq param nil param-flag nil)) ! 210: ((= ch #/#) ! 211: (as-1 (length args) params ! 212: (setq param-leader (1+ param-leader)))) ! 213: ((= ch #/,) ! 214: ;comma, begin another parameter, ascii , ! 215: (and param-flag (as-1 param params (setq param-leader ! 216: (1+ param-leader)))) ! 217: (setq param nil param-flag t)) ! 218: ;omitted arguments made manifest by the ! 219: ;presence of a comma come through as nil ! 220: (t ;must be a command character ! 221: ;upper case to lower ! 222: (and (>= ch #/A) (<= ch #/Z) (setq ch (+ ch (- #/a #/A)))) ! 223: (setq ctl-index (1+ ctl-index)) ;advance past command char ! 224: (and param-flag (as-1 param params (setq param-leader ! 225: (1+ param-leader)))) ! 226: (setq param-flag nil param nil tem nil) ! 227: ;str gets a string which is the name of the operation to do ! 228: (setq ! 229: str (cond ((= ch #/\ ) ;ascii \ ! 230: (let ((i (string-search-char ! 231: #/\ ! 232: ctl-string ! 233: (1+ ctl-index)))) ! 234: (and (null i) ! 235: (ferror nil ! 236: '|Unmatched \\ in control string.|)) ! 237: (prog1 ; don't uppercase! we are a two ! 238: ; case system ! 239: (setq tem ! 240: (nsubstring ctl-string ! 241: (1+ ctl-index) ! 242: i)) ! 243: (setq ctl-index i)))) ! 244: (t (ascii ch)))) ! 245: ;; SYM gets the symbol corresponding to STR ! 246: (cond ((setq sym str) ! 247: (setq format-params-supplied param-leader) ! 248: (setq args (format-ctl-op sym args params))) ! 249: (t (ferror nil '|~C is an unknown FORMAT op in \"~A\"| ! 250: tem ctl-string))) ! 251: (return nil)))))) ! 252: ! 253: ;Perform a single formatted output operation on specified args. ! 254: ;Return the remaining args not used up by the operation. ! 255: (defun format-ctl-op (op args params &aux tem) ! 256: (cond ((stringp op) (setq op (concat op)))) ; make into a symbol ! 257: (cond ((setq tem (assq op format-handlers)) ! 258: (cond ((eq 'one (cadr tem)) ! 259: (or args ! 260: (ferror nil "arg required for ~a, but no more args" op)) ! 261: (funcall (caddr tem) (car args) params) ! 262: (setq arglist-index (1+ arglist-index)) ! 263: (cdr args)) ! 264: ((eq 'none (cadr tem)) ! 265: (funcall (caddr tem) params) ! 266: args) ! 267: ((eq 'many (cadr tem)) ! 268: (funcall (caddr tem) args params)) ! 269: (t (ferror nil "Illegal format handler: ~s" tem)))) ! 270: (t (ferror nil '|\"~S\" is not defined as a FORMAT command.| op) ! 271: args))) ! 272: ! 273: (setq format-handlers nil) ! 274: ;; Format handlers ! 275: ;; ! 276: (defmacro defformat (name arglist type &rest body) ! 277: (let (newname) ! 278: ;; allow the name to be the fixnum rep of a character too. ! 279: (cond ((fixp name) (setq name (concat "ch" name)))) ! 280: ! 281: (cond ((not (memq type '(none one many))) ! 282: (ferror nil "The format type, \"~a\" is not: none, one or many" ! 283: type))) ! 284: (cond ((or (not (symbolp name)) ! 285: (not (dtpr arglist))) ! 286: (ferror nil "Bad form for name and/or arglist: ~a ~a" ! 287: name arglist))) ! 288: (cond ((memq type '(one many)) ! 289: (cond ((not (= (length arglist) 2)) ! 290: (ferror nil "There should be 2 arguments to ~a" name)))) ! 291: (t (cond ((not (= (length arglist) 1)) ! 292: (ferror nil "There should be 1 argument to ~a" name))))) ! 293: (setq newname (concat name ":format-handler")) ! 294: `(progn 'compile ! 295: (defun ,newname ,arglist ,@body) ! 296: (let ((handler (assq ',name format-handlers))) ! 297: (cond (handler (rplaca (cddr handler) ',newname)) ! 298: (t (setq format-handlers (cons (list ',name ! 299: ',type ! 300: ',newname) ! 301: format-handlers)))))))) ! 302: ! 303: ! 304: ! 305: (defformat d (arg params) one ! 306: (let ((width (cxr 0 params)) ! 307: (padchar (cxr 1 params))) ! 308: (cond ((and colon-flag (< arg 4000.) (> arg 0)) ! 309: (roman-step arg 0)) ! 310: (atsign-flag (english-print arg 'cardinal)) ! 311: ((let ((base 10.) (*nopoint t)) ! 312: (cond ((null padchar) (setq padchar 32.)) ! 313: ((not (numberp padchar)) ! 314: (setq padchar (getcharn padchar 1)))) ! 315: (and width (format-ctl-justify width (flatc arg) padchar)) ! 316: (format:patom arg)))))) ! 317: ! 318: (defformat f (arg params) one ! 319: (cond ((not (floatp arg)) (format:patom arg)) ! 320: (t (let ((float-format "%.16g") ! 321: (prec (cxr 0 params))) ! 322: (cond ((and prec (fixp prec) (> prec 0) (< prec 16)) ! 323: (setq float-format (concat "%" prec "g")))) ! 324: (format:patom arg))))) ! 325: ! 326: ; r format ! 327: ; no params and flags: print as cardinal (four) ! 328: ; no params and colon: print as ordinal (fourth) ! 329: ; no params and atsign: print as roman (IV) ! 330: ; no params and colon and atsign: print as old roman (IIII) ! 331: ; params: radix,mincol[0],padchar[<space>] ! 332: ; print in radix with at least mincol columns, padded on left ! 333: ; with padchar ! 334: ; ! 335: (defformat r (arg params) one ! 336: (format:anyradix-printer arg params nil)) ! 337: ! 338: ; o format - like ~8r, but params are like ~d. ! 339: ; ! 340: (defformat o (arg params) one ! 341: (format:anyradix-printer arg params 8.)) ! 342: ! 343: (defun format:anyradix-printer (arg params radix) ! 344: ; this is called by ~r and ~o. for ~r, the mincol parameter starts at ! 345: ; cxr 1, for ~o the mincol parameter starts at cxr 0. We compute ! 346: ; paramstart as either 0 or 1 ! 347: ; radix is given as third argument iff this is ~o ! 348: (let ((paramstart (cond (radix 0) ! 349: (t 1)))) ! 350: (cond ((null radix) (setq radix (cxr 0 params)))) ! 351: (cond ((null radix) ; if not to any given base ! 352: (cond ((and (null colon-flag) (null atsign-flag)) ! 353: (english-print arg 'cardinal)) ! 354: ((and colon-flag (null atsign-flag)) ! 355: (english-print arg 'ordinal)) ! 356: ((and (null colon-flag) atsign-flag) ! 357: (roman-step arg 0)) ! 358: ((and colon-flag atsign-flag) ! 359: (let ((roman-old t)) ! 360: (roman-step arg 0))))) ! 361: (t (let ((mincol (cxr paramstart params)) ! 362: (padchr (or (cxr (+ 1 paramstart) params) #\space)) ! 363: (res)) ! 364: (cond (mincol ;; if mincol specified ! 365: (let ((Format-Standard-Output (list nil))) ! 366: (format-binpr arg radix) ! 367: (setq res (cdr Format-Standard-Output))) ! 368: (format-ctl-justify mincol (length res) padchr) ! 369: (mapc 'format:tyo (nreverse res))) ! 370: (t (format-binpr arg radix)))))))) ! 371: ! 372: ! 373: (defun format-binpr (x base) ! 374: (cond ((equal x 0)(format:patom 0)) ! 375: ((or (> base 36.) (< base 2)) ! 376: (ferror nil "\"~s\" is not a base between 2 and 36" base)) ! 377: ((lessp x 0) ! 378: (format:patom '-) ! 379: (format-binpr1 (minus x) base)) ! 380: (t (format-binpr1 x base))) ! 381: x) ! 382: ! 383: ! 384: ! 385: (defun format-binpr1 (x base) ! 386: (cond ((equal x 0)) ! 387: (t (format-binpr1 (quotient x base) base) ! 388: (format-prc (remainder x base))))) ! 389: ! 390: (defun format-prc (x) ! 391: (cond ((< x 10.) (format:patom x)) ! 392: (t (format:tyo (plus (- #/a 10.) x))))) ! 393: ; works for 10.=A, 35.=Z. ! 394: ! 395: ;; must get the width stuff to work!! ! 396: (defun format-ctl-octal (arg params) ! 397: (let ((width (cxr 0 params)) (padchar (cxr 1 params))) ! 398: (let ((base 8)) ! 399: (cond ((null padchar) ! 400: (setq padchar 32.)) ! 401: ((not (numberp padchar)) ! 402: (setq padchar (getcharn padchar 1)))) ! 403: (and width (format-ctl-justify width (flatc arg) padchar)) ! 404: (format:patom arg)))) ! 405: ! 406: (defformat a (arg params) one ! 407: (format-ctl-ascii arg params nil)) ! 408: ! 409: (defun format-ctl-ascii (arg params prin1p) ! 410: (let ((edge (cxr 0 params)) ! 411: (period (cxr 1 params)) ! 412: (min (cxr 2 params)) ! 413: (padchar (cxr 3 params))) ! 414: (cond ((null padchar) ! 415: (setq padchar #\space)) ! 416: ((not (numberp padchar)) ! 417: (setq padchar (getcharn padchar 1)))) ! 418: (cond (prin1p (format:print arg)) ! 419: (t (format:patom arg))) ! 420: (cond ((not (null edge)) ! 421: (let ((width (cond (prin1p (flatsize arg)) ((flatc arg))))) ! 422: (cond ((not (null min)) ! 423: (format-ctl-repeat-char min padchar) ! 424: (setq width (+ width min)))) ! 425: (cond (period ! 426: (format-ctl-repeat-char ! 427: (- (+ edge (* (\\ (+ (- (max edge width) edge 1) ! 428: period) ! 429: period) ! 430: period)) ! 431: width) ! 432: padchar)) ! 433: (t (format-ctl-justify edge width padchar)))))))) ! 434: ! 435: (defformat s (arg params) one ! 436: (format-ctl-ascii arg params t)) ! 437: ! 438: (defformat c (arg params) one ! 439: (cond ((or (not (fixp arg)) ! 440: (< arg 0) ! 441: (> arg 127)) ! 442: (ferror nil "~s is not a legal character value" arg))) ! 443: (cond ((and (not colon-flag) (not atsign-flag)) ! 444: ; just print out the character after converting to ascii ! 445: (format:patom (ascii arg))) ! 446: (t ; it may have an extended name, check for that first ! 447: (let (name) ! 448: (cond ((setq name (car ! 449: (rassq arg (symeval format-sharpsign-vars)))) ! 450: ; it has an extended name. ! 451: ; if : flag, then print in human readable ! 452: (cond (colon-flag (format:patom name)) ! 453: (atsign-flag (format:patom "#\\") ! 454: (format:patom name)))) ! 455: ((< arg #\space) ! 456: ; convert from control to upper case ! 457: (setq arg (+ arg #/@)) ! 458: (cond (colon-flag (format:patom "^") ! 459: (format:patom (ascii arg))) ! 460: (atsign-flag (format:patom "#^") ! 461: (format:patom (ascii arg))))) ! 462: (t (cond (colon-flag (format:patom (ascii arg))) ! 463: (atsign-flag (format:patom "#/") ! 464: (format:patom (ascii arg)))))))))) ! 465: ! 466: (defformat p (args params) many ! 467: (let (arg) ! 468: (cond (colon-flag ! 469: (setq arg (nth (1- arglist-index) format-arglist))) ! 470: ((null args) ! 471: (ferror () "Argument required for p, but no more arguments")) ! 472: (t (setq arg (pop args) ! 473: arglist-index (1+ arglist-index)))) ! 474: (if (= arg 1) ! 475: (if atsign-flag (format:tyo #/y)) ! 476: (cond (atsign-flag ! 477: (format:tyo #/i) ! 478: (format:tyo #/e) ! 479: (format:tyo #/s)) ! 480: (t (format:tyo #/s)))) ! 481: args)) ! 482: ! 483: (defformat * (args params) many ! 484: (let ((count (or (cxr 0 params) 1))) ! 485: (if colon-flag (setq count (minus count))) ! 486: (setq arglist-index (+ arglist-index count)) ! 487: (nthcdr count format-arglist))) ! 488: ! 489: (defformat g (arg params) many ! 490: (let ((count (or (cxr 0 params) 1))) ! 491: (nthcdr count format-arglist))) ! 492: ! 493: (defformat % (params) none ! 494: (declare (fixnum i)) ! 495: (let ((count (or (cxr 0 params) 1))) ! 496: (do i 0 (1+ i) (= i count) ! 497: (format:terpr)))) ! 498: ! 499: ; ~ at the end of the line ! 500: ; no params: ignore newline and following whitespace ! 501: ; @ flag: leave the newline in the string but ignore whitespace ! 502: ; : flag: ignore newline but leave the whitespace ! 503: ; :@ flags: leave both newline and whitespace ! 504: ; ! 505: (defformat #\newline (params) none ! 506: (cond (atsign-flag ! 507: (format:tyo #\newline))) ! 508: (cond ((not colon-flag) ! 509: (setq ctl-index (1+ ctl-index)) ! 510: (do () ! 511: ((>= ctl-index ctl-length)) ! 512: (cond ((memq (getcharn ctl-string ctl-index) ! 513: '(#\space #\tab)) ! 514: (setq ctl-index (1+ ctl-index))) ! 515: (t (setq ctl-index (1- ctl-index)) ! 516: (return))))))) ! 517: ! 518: ! 519: (defformat & (params) none ! 520: (format:fresh-line)) ! 521: ! 522: (defformat x (params) none ! 523: (format-ctl-repeat-char (cxr 0 params) #\space)) ! 524: ! 525: (defformat \| (params) none ! 526: (format-ctl-repeat-char (cxr 0 params) #\ff)) ! 527: ! 528: (defformat ~ (params) none ! 529: (format-ctl-repeat-char (cxr 0 params) #/~)) ! 530: ! 531: (defun format-ctl-repeat-char (count char) ! 532: (declare (fixnum i)) ! 533: (cond ((null count) (setq count 1))) ! 534: (do i 0 (1+ i) (=& i count) ! 535: (format:tyo char))) ! 536: ! 537: ;; Several commands have a SIZE long object which they must print ! 538: ;; in a WIDTH wide field. If WIDTH is specified and is greater than ! 539: ;; the SIZE of the thing to be printed, this put out the right ! 540: ;; number of CHARs to fill the field. You can call this before ! 541: ;; or after printing the thing, to get leading or trailing padding. ! 542: (defun format-ctl-justify (width size &optional (char #\space)) ! 543: (and width (> width size) (format-ctl-repeat-char (- width size) char))) ! 544: ! 545: (defformat q (arg params) one ! 546: ;; convert params given to a list ! 547: (do ((ii format-params-supplied (1- ii)) ! 548: (params-given nil)) ! 549: ((< ii 0) (apply arg params-given)) ! 550: (setq params-given (cons (cxr ii params) params-given)))) ! 551: ! 552: (defun case-scan (goal &optional (lim ctl-length) (times 1)) ! 553: (declare (fixnum cnt lim times ctl-index)) ! 554: (*catch 'case-scan ! 555: (do ((cnt 0 (1+ cnt))) ! 556: ((>= cnt times) t) ! 557: (do ((ch)) ! 558: ((>= ctl-index lim) ! 559: (*throw 'case-scan nil)) ! 560: (setq ch (getcharn ctl-string (1+ ctl-index)) ! 561: ctl-index (1+ ctl-index)) ! 562: (cond ((= ch #/~) ! 563: (setq ch (getcharn ctl-string (1+ ctl-index)) ! 564: ctl-index (1+ ctl-index)) ! 565: (cond ((= ch goal) ! 566: (return t)) ! 567: ((= ch #/[) ! 568: (case-scan #/] lim))))))))) ! 569: ! 570: ; [ format ! 571: ; the case selector is the first parameter given, and if no parameter ! 572: ; is given, then it is the next argument ! 573: ; ! 574: (defformat \[ (args params) many ! 575: (let ((start ctl-index) ! 576: (num (cond ((> format-params-supplied -1) ! 577: (cxr 0 params)) ! 578: (t (cond ((null args) ! 579: (error "the [ format requires an argument"))) ! 580: (prog1 (car args) ! 581: (setq args (cdr args)) ! 582: (setq arglist-index (1+ arglist-index))))))) ! 583: (and colon-flag (setq num (cond (num 1) (t 0)))) ! 584: (and (null num) ! 585: (ferror nil ! 586: "The FORMAT \"[\" command must be given a numeric parameter")) ! 587: (cond ((>= num 0) ! 588: (or (case-scan #/]) ! 589: (ferror nil "Unbalanced conditional in FORMAT control string")) ! 590: (let ((i ctl-index)) ! 591: (setq ctl-index start) ! 592: (case-scan #/; i num)))) ! 593: args)) ! 594: ! 595: (defformat \] (params) none nil) ! 596: ! 597: (defformat \; (params) none ! 598: (case-scan #/])) ! 599: ! 600: ;; FIXTHIS: ! 601: ;; The following doesn't bind format-arglist and arglist-index properly. ! 602: (defformat \{ (args params) many ! 603: (let ((loop-times (or (cxr 0 params) -1)) ! 604: (loop-string) ! 605: (at-least-once nil)) ! 606: (do ((i (format\:string-search-char #/~ ctl-string ctl-index) ! 607: (format\:string-search-char #/~ ctl-string (1+ i)))) ! 608: ((or (null i) (= (1+ i) ctl-length)) ! 609: (ferror () "No matching \"}\" for \"{\" in format")) ! 610: (cond ((= #/} (getcharn ctl-string (+ 2 i))) ! 611: (setq loop-string ! 612: (format\:nsubstring ctl-string ctl-index i) ! 613: ctl-index (+ 2 i)) ! 614: (return t)) ! 615: ((and (= #/: (getcharn ctl-string (+ 2 i))) ! 616: (= #/} (getcharn ctl-string (+ 3 i)))) ! 617: (setq loop-string ! 618: (format\:nsubstring ctl-string ctl-index i) ! 619: ctl-index (+ 3 i) ! 620: at-least-once t) ! 621: (return t)))) ! 622: (if (= 0 (flatc loop-string)) ! 623: (setq loop-string (pop args) ! 624: arglist-index (1+ arglist-index))) ! 625: (if (null atsign-flag) (setq args (car args))) ! 626: (*catch '(loop-stop loop-abort) ! 627: (do ((i loop-times (1- i))) ! 628: ((and (null at-least-once) ! 629: (or (null args) (= i 0)))) ! 630: (setq at-least-once nil) ! 631: (cond ((null colon-flag) ! 632: (setq args (format-ctl-string args loop-string))) ! 633: (t (*catch 'loop-stop ! 634: (format-ctl-string (car args) loop-string)) ! 635: (setq args (cdr args) ! 636: arglist-index (1+ arglist-index)))))) ! 637: args)) ! 638: ! 639: (defformat \} (params) none nil) ! 640: ! 641: (defformat \^ (args params) many ! 642: (let ((terminate nil)) ! 643: (cond ((null (cxr 0 params)) ! 644: (setq terminate (null args))) ! 645: ((null (cxr 1 params)) ! 646: (setq terminate (zerop (cxr 0 params)))) ! 647: ((null (cxr 2 params)) ! 648: (setq terminate (equal (cxr 1 params) (cxr 0 params)))) ! 649: (t (setq terminate (and (< (cxr 0 params) (cxr 1 params)) ! 650: (< (cxr 1 params) (cxr 2 params)))))) ! 651: (if terminate ! 652: (if colon-flag (*throw 'loop-abort t) (*throw 'loop-stop t)) ! 653: args))) ! 654: ! 655: ! 656: (declare (special english-small english-medium english-large)) ! 657: ! 658: (defun make-list-array (list) ! 659: (let ((a (makhunk (length list)))) ! 660: (do ((i 0 (1+ i)) ! 661: (ll list (cdr ll))) ! 662: ((null ll)) ! 663: (rplacx i a (car ll))) ! 664: a)) ! 665: ! 666: (setq english-small ! 667: (make-list-array '(|one| |two| |three| |four| |five| |six| ! 668: |seven| |eight| |nine| |ten| |eleven| |twelve| ! 669: |thirteen| |fourteen| |fifteen| |sixteen| ! 670: |seventeen| |eighteen| |nineteen|))) ! 671: ! 672: (setq english-medium ! 673: (make-list-array '(|twenty| |thirty| |forty| |fifty| |sixty| |seventy| ! 674: |eighty| |ninty|))) ! 675: ! 676: (setq english-large ! 677: (make-list-array '(|thousand| |million| |billion| |trillion| |quadrillion| ! 678: |quintillion|))) ! 679: ! 680: ! 681: (defun english-print (n type) ! 682: (declare (fixnum i n limit)) ! 683: (cond ((zerop n) ! 684: (cond ((eq type 'cardinal) (format:patom "zero")) ! 685: (t (format:patom "zeroth")))) ! 686: ((< n 0) ! 687: (format:patom '|minus|) ! 688: (format:tyo #\space) ! 689: (english-print (minus n) type)) ! 690: (t ! 691: (do ((n n) ! 692: (p) ! 693: (flag) ! 694: (limit 1000000. ! 695: (quotient limit 1000.)) ! 696: (i 1 (1- i))) ! 697: ((< i 0) ! 698: (cond ((> n 0) ! 699: (and flag (format:tyo #\space)) ! 700: (english-print-thousand n)))) ! 701: (cond ((not (< n limit)) ! 702: (setq p (quotient n limit) ! 703: n (remainder n limit)) ! 704: (cond (flag (format:tyo #\space)) ! 705: (t (setq flag t))) ! 706: (english-print-thousand p) ! 707: (format:tyo #\space) ! 708: (format:patom (ar-1 english-large i)))))))) ! 709: ! 710: (defun english-print-thousand (n) ! 711: (declare (fixnum i n limit)) ! 712: (let ((n (remainder n 100.)) ! 713: (h (quotient n 100.))) ! 714: (cond ((> h 0) ! 715: (format:patom (ar-1 english-small (1- h))) ! 716: (format:tyo #\space) ! 717: (format:patom '|hundred|) ! 718: (and (> n 0) (format:tyo #\space)))) ! 719: (cond ((= n 0)) ! 720: ((< n 20.) ! 721: (format:patom (ar-1 english-small (1- n)))) ! 722: (t ! 723: (format:patom (ar-1 english-medium ! 724: (- (quotient n 10.) 2))) ! 725: (cond ((zerop (setq h (remainder n 10.)))) ! 726: (t ! 727: (format:tyo #/-) ;ascii - ! 728: (format:patom (ar-1 english-small (1- h))))))))) ! 729: ! 730: (defun roman-step (x n) ! 731: (cond ((> x 9.) ! 732: (roman-step (quotient x 10.) (1+ n)) ! 733: (setq x (remainder x 10.)))) ! 734: (cond ((and (= x 9) (not roman-old)) ! 735: (roman-char 0 n) ! 736: (roman-char 0 (1+ n))) ! 737: ((= x 5) ! 738: (roman-char 1 n)) ! 739: ((and (= x 4) (not roman-old)) ! 740: (roman-char 0 n) ! 741: (roman-char 1 n)) ! 742: (t (cond ((> x 5) ! 743: (roman-char 1 n) ! 744: (setq x (- x 5)))) ! 745: (do i 0 (1+ i) (>= i x) ! 746: (roman-char 0 n))))) ! 747: ! 748: (defun roman-char (i x) ! 749: (format:tyo (car (nthcdr (+ i x x) '(#/I #/V #/X #/L #/C #/D #/M))) ! 750: ; i v x l c d m ! 751: )) ! 752: ! 753: ;;; Kludges to make MacLISP like some of the LISPM functions ! 754: ! 755: ! 756: (defun format:tyo (char) ! 757: (cond ((dtpr Format-Standard-Output) ! 758: (rplacd Format-Standard-Output ! 759: (cons char (cdr Format-Standard-Output)))) ! 760: (t (tyo char Format-Standard-Output)))) ! 761: ! 762: (defun format:patom (arg) ! 763: (format:printorpatom arg nil)) ! 764: ! 765: (defun format:print (arg) ! 766: (format:printorpatom arg t)) ! 767: ! 768: (defun format:printorpatom (argument slashify) ! 769: (cond ((dtpr Format-Standard-Output) ! 770: (rplacd Format-Standard-Output ! 771: (nreconc (cond (slashify ! 772: (mapcar '(lambda (x) ! 773: (getcharn x 1)) ! 774: (explode argument))) ! 775: ((exploden argument))) ! 776: (cdr Format-Standard-Output)))) ! 777: (t (cond (slashify (print argument Format-Standard-Output)) ! 778: (t (patom argument Format-Standard-Output)))))) ! 779: ! 780: (defun format:terpr nil ! 781: (cond ((dtpr Format-Standard-Output) ! 782: (rplacd Format-Standard-Output ! 783: (cons #\newline (cdr Format-Standard-Output)))) ! 784: (t (terpr Format-Standard-Output)))) ! 785: ! 786: (defun format:fresh-line nil ! 787: (cond ((dtpr Format-Standard-Output) ! 788: (cond ((and (cdr Format-Standard-Output) ! 789: (not (= (cadr Format-Standard-Output) #\newline))) ! 790: (rplacd Format-Standard-Output ! 791: (cons #\newline (cdr Format-Standard-Output)))))) ! 792: (t (and (not (= 0 (nwritn Format-Standard-Output))) ! 793: (terpr Format-Standard-Output))))) ! 794: ! 795: ! 796: ! 797: ! 798: (defun format\:string-search-char (char str start-pos) ! 799: (declare (fixnum i start-pos str-len)) ! 800: (do ((i start-pos (1+ i)) ! 801: (str-len (flatc str))) ! 802: ((>& i str-len) nil) ! 803: (and (=& char (getcharn str (1+ i))) (return i)))) ! 804: ! 805: (defun format\:nsubstring (str from to) ! 806: (declare (fixnum i from to)) ! 807: (substring str (+ 1 from) (- to from))) ;substring is 1 based ! 808: ! 809: (defun ferror (&rest args) ! 810: (let (str) ! 811: ; if the first arg to ferror is a string we assume that it is the ! 812: ; format control string, otherwise we assume that it is a port ! 813: ; specification, and we ignore it since we want to build a string. ! 814: (if (stringp (car args)) ! 815: then (setq str (lexpr-funcall 'format nil args)) ! 816: else (setq str (lexpr-funcall 'format nil (cdr args)))) ! 817: (error str))) ! 818: ! 819: ! 820: (defun format-test nil ! 821: (format t "Start test, newline:~%freshline:~&") ! 822: (format t "decimal:~d, width=5:~5d~%" 10 10) ! 823: (format t "decimal pad with period:~10,vd~%" #/. 12) ! 824: (format t "char normal:~c, as # would read:~@c, human read:~:c~%" ! 825: #\space #\space #\space) ! 826: (format t "cardinal:~r, roman new:~@r, roman-old:~:@r~ ! 827: <same line I hope>~@ ! 828: new line but at beginning~: ! 829: same line, but spaced out~:@ ! 830: new line and over two tabs~%" 4 4 4)) ! 831: ! 832: (putprop 'format t 'version)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.