![[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] / 43BSDTahoe / ucb / lisp / lisplib|
Return to format.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / 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 0 (pntlen 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 ! 167: args ! 168: (car ctl-string) ! 169: 0 ! 170: (pntlen (car ctl-string)))) ! 171: (t (format-ctl-list args (car ctl-string)))))))) ! 172: (and format-string ! 173: (setq format-string (maknam (nreverse (cdr stream))))) ! 174: format-string)) ! 175: ! 176: (defun format-ctl-list (args ctl-list) ! 177: (format-ctl-op (car ctl-list) args (cdr ctl-list))) ! 178: ! 179: (defun format-ctl-string (args ctl-string ctl-index ctl-length) ! 180: (declare (fixnum ctl-index ctl-length)) ! 181: (do ((ch) (tem) (str) (sym)) ! 182: ((>= ctl-index ctl-length) args) ! 183: (setq tem (cond ((string-search-char #/~ ctl-string ctl-index)) ! 184: (t ctl-length))) ! 185: (cond ((neq tem ctl-index) ;Put out some literal string ! 186: (do n ctl-index n (>= n tem) ! 187: (format:tyo (substringn ctl-string (setq n (1+ n)) 0))) ! 188: (and (>= (setq ctl-index tem) ctl-length) ! 189: (return args)))) ! 190: ;; (ar-1 ch ctl-index) is a tilde. ! 191: (do ((atsign-flag nil) ;Modifier ! 192: (colon-flag nil) ;Modifier ! 193: (params (makhunk 10)) ! 194: (param-leader -1) ! 195: ;PARAMS contains the list of numeric parameters ! 196: (param-flag nil) ;If T, a parameter has been started in PARAM ! 197: (param)) ;PARAM is the parameter currently ! 198: ; being constructed ! 199: ((>= (setq ctl-index (1+ ctl-index)) ctl-length)) ! 200: (setq ch (getcharn ctl-string (1+ ctl-index))) ! 201: (cond ((and (>= ch #/0) (<= ch #/9)) ; ! 202: (setq param (+ (* (or param 0) 10.) (- ch #/0)) ; ! 203: param-flag t)) ! 204: ((= ch #/@) ;ascii @ ! 205: (setq atsign-flag t)) ! 206: ((= ch #/:) ;ascii : ! 207: (setq colon-flag t)) ! 208: ((or (= ch #/v) (= ch #/V)) ;ascii v, v ! 209: (as-1 (pop args) params ! 210: (setq param-leader (1+ param-leader))) ! 211: (setq arglist-index (1+ arglist-index)) ! 212: (setq param nil param-flag nil)) ! 213: ((= ch #/#) ! 214: (as-1 (length args) params ! 215: (setq param-leader (1+ param-leader)))) ! 216: ((= ch #/,) ! 217: ;comma, begin another parameter, ascii , ! 218: (and param-flag (as-1 param params (setq param-leader ! 219: (1+ param-leader)))) ! 220: (setq param nil param-flag t)) ! 221: ;omitted arguments made manifest by the ! 222: ;presence of a comma come through as nil ! 223: (t ;must be a command character ! 224: ;upper case to lower ! 225: (and (>= ch #/A) (<= ch #/Z) (setq ch (+ ch (- #/a #/A)))) ! 226: (setq ctl-index (1+ ctl-index)) ;advance past command char ! 227: (and param-flag (as-1 param params (setq param-leader ! 228: (1+ param-leader)))) ! 229: (setq param-flag nil param nil tem nil) ! 230: ;str gets a string which is the name of the operation to do ! 231: (setq ! 232: str (cond ((= ch #/\ ) ;ascii \ ! 233: (let ((i (string-search-char ! 234: #/\ ! 235: ctl-string ! 236: (1+ ctl-index)))) ! 237: (and (null i) ! 238: (ferror nil ! 239: '|Unmatched \\ in control string.|)) ! 240: (prog1 ; don't uppercase! we are a two ! 241: ; case system ! 242: (setq tem ! 243: (nsubstring ctl-string ! 244: (1+ ctl-index) ! 245: i)) ! 246: (setq ctl-index i)))) ! 247: ;makes ~<newline> work! ;SMH@EMS ! 248: ((= ch #\newline) ! 249: #.(list 'quote (concat "ch" #\newline))) ! 250: (t (ascii ch)))) ! 251: ;; SYM gets the symbol corresponding to STR ! 252: (cond ((setq sym str) ! 253: (setq format-params-supplied param-leader) ! 254: (setq args (format-ctl-op sym args params))) ! 255: (t (ferror nil '|~C is an unknown FORMAT op in \"~A\"| ! 256: tem ctl-string))) ! 257: (return nil)))))) ! 258: ! 259: ;Perform a single formatted output operation on specified args. ! 260: ;Return the remaining args not used up by the operation. ! 261: (defun format-ctl-op (op args params &aux tem) ! 262: (cond ((stringp op) (setq op (concat op)))) ; make into a symbol ! 263: (cond ((setq tem (assq op format-handlers)) ! 264: (cond ((eq 'one (cadr tem)) ! 265: (or args ! 266: (ferror nil "arg required for ~a, but no more args" op)) ! 267: (funcall (caddr tem) (car args) params) ! 268: (setq arglist-index (1+ arglist-index)) ! 269: (cdr args)) ! 270: ((eq 'none (cadr tem)) ! 271: (funcall (caddr tem) params) ! 272: args) ! 273: ((eq 'many (cadr tem)) ! 274: (funcall (caddr tem) args params)) ! 275: (t (ferror nil "Illegal format handler: ~s" tem)))) ! 276: (t (ferror nil '|\"~S\" is not defined as a FORMAT command.| op) ! 277: args))) ! 278: ! 279: (setq format-handlers nil) ! 280: ;; Format handlers ! 281: ;; ! 282: (defmacro defformat (name arglist type &rest body) ! 283: (let (newname) ! 284: ;; allow the name to be the fixnum rep of a character too. ! 285: (cond ((fixp name) (setq name (concat "ch" name)))) ! 286: ! 287: (cond ((not (memq type '(none one many))) ! 288: (ferror nil "The format type, \"~a\" is not: none, one or many" ! 289: type))) ! 290: (cond ((or (not (symbolp name)) ! 291: (not (dtpr arglist))) ! 292: (ferror nil "Bad form for name and/or arglist: ~a ~a" ! 293: name arglist))) ! 294: (cond ((memq type '(one many)) ! 295: (cond ((not (= (length arglist) 2)) ! 296: (ferror nil "There should be 2 arguments to ~a" name)))) ! 297: (t (cond ((not (= (length arglist) 1)) ! 298: (ferror nil "There should be 1 argument to ~a" name))))) ! 299: (setq newname (concat name ":format-handler")) ! 300: `(progn 'compile ! 301: (defun ,newname ,arglist ,@body) ! 302: (let ((handler (assq ',name format-handlers))) ! 303: (cond (handler (rplaca (cddr handler) ',newname)) ! 304: (t (setq format-handlers (cons (list ',name ! 305: ',type ! 306: ',newname) ! 307: format-handlers)))))))) ! 308: ! 309: ! 310: ! 311: (defformat d (arg params) one ! 312: (let ((width (cxr 0 params)) ! 313: (padchar (cxr 1 params))) ! 314: (cond ((and colon-flag (< arg 4000.) (> arg 0)) ! 315: (roman-step arg 0)) ! 316: (atsign-flag (english-print arg 'cardinal)) ! 317: ((let ((base 10.) (*nopoint t)) ! 318: (cond ((null padchar) (setq padchar 32.)) ! 319: ((not (numberp padchar)) ! 320: (setq padchar (getcharn padchar 1)))) ! 321: (and width (format-ctl-justify width (flatc arg) padchar)) ! 322: (format:patom arg)))))) ! 323: ! 324: (defformat f (arg params) one ! 325: (cond ((not (floatp arg)) (format:patom arg)) ! 326: (t (let ((float-format "%.16g") ! 327: (prec (cxr 0 params))) ! 328: (cond ((and prec (fixp prec) (> prec 0) (< prec 16)) ! 329: (setq float-format (concat "%" prec "g")))) ! 330: (format:patom arg))))) ! 331: ! 332: ; r format ! 333: ; no params and flags: print as cardinal (four) ! 334: ; no params and colon: print as ordinal (fourth) ! 335: ; no params and atsign: print as roman (IV) ! 336: ; no params and colon and atsign: print as old roman (IIII) ! 337: ; params: radix,mincol[0],padchar[<space>] ! 338: ; print in radix with at least mincol columns, padded on left ! 339: ; with padchar ! 340: ; ! 341: (defformat r (arg params) one ! 342: (format:anyradix-printer arg params nil)) ! 343: ! 344: ; o format - like ~8r, but params are like ~d. ! 345: ; ! 346: (defformat o (arg params) one ! 347: (format:anyradix-printer arg params 8.)) ! 348: ! 349: (defun format:anyradix-printer (arg params radix) ! 350: ; this is called by ~r and ~o. for ~r, the mincol parameter starts at ! 351: ; cxr 1, for ~o the mincol parameter starts at cxr 0. We compute ! 352: ; paramstart as either 0 or 1 ! 353: ; radix is given as third argument iff this is ~o ! 354: (let ((paramstart (cond (radix 0) ! 355: (t 1)))) ! 356: (cond ((null radix) (setq radix (cxr 0 params)))) ! 357: (cond ((null radix) ; if not to any given base ! 358: (cond ((and (null colon-flag) (null atsign-flag)) ! 359: (english-print arg 'cardinal)) ! 360: ((and colon-flag (null atsign-flag)) ! 361: (english-print arg 'ordinal)) ! 362: ((and (null colon-flag) atsign-flag) ! 363: (roman-step arg 0)) ! 364: ((and colon-flag atsign-flag) ! 365: (let ((roman-old t)) ! 366: (roman-step arg 0))))) ! 367: (t (let ((mincol (cxr paramstart params)) ! 368: (padchr (or (cxr (+ 1 paramstart) params) #\space)) ! 369: (res)) ! 370: (cond (mincol ;; if mincol specified ! 371: (let ((Format-Standard-Output (list nil))) ! 372: (format-binpr arg radix) ! 373: (setq res (cdr Format-Standard-Output))) ! 374: (format-ctl-justify mincol (length res) padchr) ! 375: (mapc 'format:tyo (nreverse res))) ! 376: (t (format-binpr arg radix)))))))) ! 377: ! 378: ! 379: (defun format-binpr (x base) ! 380: (cond ((equal x 0)(format:patom 0)) ! 381: ((or (> base 36.) (< base 2)) ! 382: (ferror nil "\"~s\" is not a base between 2 and 36" base)) ! 383: ((lessp x 0) ! 384: (format:patom '-) ! 385: (format-binpr1 (minus x) base)) ! 386: (t (format-binpr1 x base))) ! 387: x) ! 388: ! 389: ! 390: ! 391: (defun format-binpr1 (x base) ! 392: (cond ((equal x 0)) ! 393: (t (format-binpr1 (quotient x base) base) ! 394: (format-prc (remainder x base))))) ! 395: ! 396: (defun format-prc (x) ! 397: (cond ((< x 10.) (format:patom x)) ! 398: (t (format:tyo (plus (- #/a 10.) x))))) ! 399: ; works for 10.=A, 35.=Z. ! 400: ! 401: ;; must get the width stuff to work!! ! 402: (defun format-ctl-octal (arg params) ! 403: (let ((width (cxr 0 params)) (padchar (cxr 1 params))) ! 404: (let ((base 8)) ! 405: (cond ((null padchar) ! 406: (setq padchar 32.)) ! 407: ((not (numberp padchar)) ! 408: (setq padchar (getcharn padchar 1)))) ! 409: (and width (format-ctl-justify width (flatc arg) padchar)) ! 410: (format:patom arg)))) ! 411: ! 412: (defformat a (arg params) one ! 413: (format-ctl-ascii arg params nil)) ! 414: ! 415: (defun format-ctl-ascii (arg params prin1p) ! 416: (let ((edge (cxr 0 params)) ! 417: (period (cxr 1 params)) ! 418: (min (cxr 2 params)) ! 419: (padchar (cxr 3 params))) ! 420: (cond ((null padchar) ! 421: (setq padchar #\space)) ! 422: ((not (numberp padchar)) ! 423: (setq padchar (getcharn padchar 1)))) ! 424: (cond (prin1p (format:print arg)) ! 425: (t (format:patom arg))) ! 426: (cond ((not (null edge)) ! 427: (let ((width (cond (prin1p (flatsize arg)) ((flatc arg))))) ! 428: (cond ((not (null min)) ! 429: (format-ctl-repeat-char min padchar) ! 430: (setq width (+ width min)))) ! 431: (cond (period ! 432: (format-ctl-repeat-char ! 433: (- (+ edge (* (\\ (+ (- (max edge width) edge 1) ! 434: period) ! 435: period) ! 436: period)) ! 437: width) ! 438: padchar)) ! 439: (t (format-ctl-justify edge width padchar)))))))) ! 440: ! 441: (defformat s (arg params) one ! 442: (format-ctl-ascii arg params t)) ! 443: ! 444: (defformat c (arg params) one ! 445: (cond ((or (not (fixp arg)) ! 446: (< arg 0) ! 447: (> arg 127)) ! 448: (ferror nil "~s is not a legal character value" arg))) ! 449: (cond ((and (not colon-flag) (not atsign-flag)) ! 450: ; just print out the character after converting to ascii ! 451: (format:patom (ascii arg))) ! 452: (t ; it may have an extended name, check for that first ! 453: (let (name) ! 454: (cond ((setq name (car ! 455: (rassq arg (symeval format-sharpsign-vars)))) ! 456: ; it has an extended name. ! 457: ; if : flag, then print in human readable ! 458: (cond (colon-flag (format:patom name)) ! 459: (atsign-flag (format:patom "#\\") ! 460: (format:patom name)))) ! 461: ((< arg #\space) ! 462: ; convert from control to upper case ! 463: (setq arg (+ arg #/@)) ! 464: (cond (colon-flag (format:patom "^") ! 465: (format:patom (ascii arg))) ! 466: (atsign-flag (format:patom "#^") ! 467: (format:patom (ascii arg))))) ! 468: (t (cond (colon-flag (format:patom (ascii arg))) ! 469: (atsign-flag (format:patom "#/") ! 470: (format:patom (ascii arg)))))))))) ! 471: ! 472: (defformat p (args params) many ! 473: (let (arg) ! 474: (cond (colon-flag ! 475: (setq arg (nth (1- arglist-index) format-arglist))) ! 476: ((null args) ! 477: (ferror () "Argument required for p, but no more arguments")) ! 478: (t (setq arg (pop args) ! 479: arglist-index (1+ arglist-index)))) ! 480: (if (= arg 1) ! 481: (if atsign-flag (format:tyo #/y)) ! 482: (cond (atsign-flag ! 483: (format:tyo #/i) ! 484: (format:tyo #/e) ! 485: (format:tyo #/s)) ! 486: (t (format:tyo #/s)))) ! 487: args)) ! 488: ! 489: (defformat * (args params) many ! 490: (let ((count (or (cxr 0 params) 1))) ! 491: (if colon-flag (setq count (minus count))) ! 492: (setq arglist-index (+ arglist-index count)) ! 493: ;; (nthcdr count format-arglist) ;; ??? SMH@EMS ! 494: (nthcdr arglist-index format-arglist))) ;; SMH@EMS ! 495: ! 496: (defformat g (arg params) many ! 497: (let ((count (or (cxr 0 params) 1))) ! 498: (nthcdr count format-arglist))) ! 499: ! 500: (defformat % (params) none ! 501: (declare (fixnum i)) ! 502: (let ((count (or (cxr 0 params) 1))) ! 503: (do i 0 (1+ i) (= i count) ! 504: (format:terpr)))) ! 505: ! 506: ; ~ at the end of the line ! 507: ; no params: ignore newline and following whitespace ! 508: ; @ flag: leave the newline in the string but ignore whitespace ! 509: ; : flag: ignore newline but leave the whitespace ! 510: ; :@ flags: leave both newline and whitespace ! 511: ; ! 512: (defformat #\newline (params) none ! 513: (cond (atsign-flag ! 514: (format:tyo #\newline))) ! 515: (cond ((not colon-flag) ! 516: (setq ctl-index (1+ ctl-index)) ! 517: (do () ! 518: ((>= ctl-index ctl-length)) ! 519: (cond ((memq (getcharn ctl-string ctl-index) ! 520: '(#\space #\tab)) ! 521: (setq ctl-index (1+ ctl-index))) ! 522: (t (setq ctl-index (1- ctl-index)) ! 523: (return))))))) ! 524: ! 525: ! 526: (defformat & (params) none ! 527: (format:fresh-line)) ! 528: ! 529: (defformat x (params) none ! 530: (format-ctl-repeat-char (cxr 0 params) #\space)) ! 531: ! 532: (defformat \| (params) none ! 533: (format-ctl-repeat-char (cxr 0 params) #\ff)) ! 534: ! 535: (defformat ~ (params) none ! 536: (format-ctl-repeat-char (cxr 0 params) #/~)) ! 537: ! 538: (defun format-ctl-repeat-char (count char) ! 539: (declare (fixnum i)) ! 540: (cond ((null count) (setq count 1))) ! 541: (do i 0 (1+ i) (=& i count) ! 542: (format:tyo char))) ! 543: ! 544: ;; Several commands have a SIZE long object which they must print ! 545: ;; in a WIDTH wide field. If WIDTH is specified and is greater than ! 546: ;; the SIZE of the thing to be printed, this put out the right ! 547: ;; number of CHARs to fill the field. You can call this before ! 548: ;; or after printing the thing, to get leading or trailing padding. ! 549: (defun format-ctl-justify (width size &optional (char #\space)) ! 550: (and width (> width size) (format-ctl-repeat-char (- width size) char))) ! 551: ! 552: (defformat q (arg params) one ! 553: ;; convert params given to a list ! 554: (do ((ii format-params-supplied (1- ii)) ! 555: (params-given nil)) ! 556: ((< ii 0) (apply arg params-given)) ! 557: (setq params-given (cons (cxr ii params) params-given)))) ! 558: ! 559: ;; Fixed nested ~[ ~] parser to handle ~:[ ~] and ~@:[ ~] as well. SMH@EMS ! 560: (defun case-scan (goal &optional (lim ctl-length) &aux flag) ! 561: (declare (fixnum lim ctl-index flag)) ! 562: (do ((ch)) ! 563: ((>= ctl-index lim) nil) ! 564: (setq ch (getcharn ctl-string (setq ctl-index (1+ ctl-index)))) ! 565: (cond ((= ch #/~) ! 566: (setq flag 0) ! 567: (do nil (nil) ! 568: (setq ch (getcharn ctl-string (setq ctl-index (1+ ctl-index)))) ! 569: (cond ((= ch #/:) (setq flag (+ flag 2))) ! 570: ((= ch #/@) (setq flag (+ flag 1))) ! 571: (t (return nil)))) ! 572: (cond ((= ch goal) (return flag)) ! 573: ((= ch #/[) (case-scan #/] lim))))))) ! 574: ! 575: ; [ format ! 576: ; the case selector is the first parameter given, and if no parameter ! 577: ; is given, then it is the next argument ! 578: ; ! 579: (defformat \[ (args params) many ; ] ! 580: (let ((start ctl-index) ! 581: (num (cond ((> format-params-supplied -1) ! 582: (cxr 0 params)) ! 583: (t (cond ((null args) ! 584: (error "the [ format requires an argument"))) ! 585: (prog1 (car args) ! 586: (setq args (cdr args)) ! 587: (setq arglist-index (1+ arglist-index))))))) ! 588: (and colon-flag (setq num (cond (num 1) (t 0)))) ! 589: (and (null num) ! 590: (ferror nil ! 591: "The FORMAT \"[\" command requires a numeric parameter")) ! 592: (or (case-scan ; [ ! 593: #/]) ! 594: (ferror nil "Unbalanced \"[\" in FORMAT control string")) ! 595: (let ((i ctl-index) (tmp)) ! 596: (setq ctl-index start) ! 597: (do n num (1- n) (= n 0) ! 598: (setq tmp (case-scan #/; ! 599: i)) ! 600: (cond ((null tmp) (return nil)) ! 601: ((and (numberp tmp) ! 602: (>= tmp 2)) ! 603: (return nil))))) ! 604: args)) ! 605: ! 606: (defformat \] (params) none nil) ! 607: ! 608: (defformat \; (params) none ! 609: (case-scan #/])) ! 610: ! 611: (defformat \{ (args params) many ! 612: (let ((loop-times (or (cxr 0 params) -1)) ! 613: (loop-string) (loop-start) (loop-length) ! 614: (at-least-once nil) ! 615: (return-args) ! 616: (return-format-arglist) ! 617: (return-arglist-index)) ! 618: (do ((i (format:string-search-char #/~ ctl-string ctl-index) ! 619: (format:string-search-char #/~ ctl-string (1+ i)))) ! 620: ((or (null i) (= (1+ i) ctl-length)) ! 621: (ferror () "No matching \"}\" for \"{\" in format")) ! 622: (cond ((= #/} (getcharn ctl-string (+ 2 i))) ! 623: (setq loop-start ctl-index ! 624: loop-length i ! 625: ctl-index (+ 2 i)) ! 626: (return t)) ! 627: ((and (= #/: (getcharn ctl-string (+ 2 i))) ! 628: (= #/} (getcharn ctl-string (+ 3 i)))) ! 629: (setq loop-start ctl-index ! 630: loop-length i ! 631: ctl-index (+ 3 i) ! 632: at-least-once t) ! 633: (return t)))) ! 634: (if (= 0 loop-length) ! 635: (setq loop-string (pop args) ! 636: arglist-index (1+ arglist-index) ! 637: loop-start 0 ! 638: loop-length (pntlen loop-string)) ! 639: (setq loop-string ctl-string)) ! 640: (if (null atsign-flag) ! 641: (setq return-args (cdr args) ! 642: return-arglist-index arglist-index ! 643: arglist-index 0 ! 644: return-format-arglist format-arglist ! 645: format-arglist (car args) ! 646: args format-arglist)) ! 647: (*catch '(loop-stop loop-abort) ! 648: (do ((i loop-times (1- i))) ! 649: ((and (null at-least-once) ! 650: (or (null args) (= i 0)))) ! 651: (setq at-least-once nil) ! 652: (cond ((null colon-flag) ! 653: (setq args (format-ctl-string args ! 654: loop-string ! 655: loop-start ! 656: loop-length))) ! 657: (t (*catch 'loop-stop ! 658: (format-ctl-string (car args) ! 659: loop-string ! 660: loop-start ! 661: loop-length)) ! 662: (setq args (cdr args) ! 663: arglist-index (1+ arglist-index)))))) ! 664: (cond (return-arglist-index ! 665: (setq args return-args ! 666: arglist-index (1+ return-arglist-index) ! 667: format-arglist return-format-arglist))) ! 668: args)) ! 669: ! 670: (defformat \} (params) none nil) ! 671: ! 672: (defformat \^ (args params) many ! 673: (let ((terminate nil)) ! 674: (cond ((null (cxr 0 params)) ! 675: (setq terminate (null args))) ! 676: ((null (cxr 1 params)) ! 677: (setq terminate (zerop (cxr 0 params)))) ! 678: ((null (cxr 2 params)) ! 679: (setq terminate (equal (cxr 1 params) (cxr 0 params)))) ! 680: (t (setq terminate (and (< (cxr 0 params) (cxr 1 params)) ! 681: (< (cxr 1 params) (cxr 2 params)))))) ! 682: (if terminate ! 683: (if colon-flag (*throw 'loop-abort t) (*throw 'loop-stop t)) ! 684: args))) ! 685: ! 686: ! 687: (declare (special english-small english-medium english-large)) ! 688: ! 689: (defun make-list-array (list) ! 690: (let ((a (makhunk (length list)))) ! 691: (do ((i 0 (1+ i)) ! 692: (ll list (cdr ll))) ! 693: ((null ll)) ! 694: (rplacx i a (car ll))) ! 695: a)) ! 696: ! 697: (setq english-small ! 698: (make-list-array '(|one| |two| |three| |four| |five| |six| ! 699: |seven| |eight| |nine| |ten| |eleven| |twelve| ! 700: |thirteen| |fourteen| |fifteen| |sixteen| ! 701: |seventeen| |eighteen| |nineteen|))) ! 702: ! 703: (setq english-medium ! 704: (make-list-array '(|twenty| |thirty| |forty| |fifty| |sixty| |seventy| ! 705: |eighty| |ninty|))) ! 706: ! 707: (setq english-large ! 708: (make-list-array '(|thousand| |million| |billion| |trillion| |quadrillion| ! 709: |quintillion|))) ! 710: ! 711: ! 712: (defun english-print (n type) ! 713: (declare (fixnum i n limit)) ! 714: (cond ((zerop n) ! 715: (cond ((eq type 'cardinal) (format:patom "zero")) ! 716: (t (format:patom "zeroth")))) ! 717: ((< n 0) ! 718: (format:patom '|minus|) ! 719: (format:tyo #\space) ! 720: (english-print (minus n) type)) ! 721: (t ! 722: (do ((n n) ! 723: (p) ! 724: (flag) ! 725: (limit 1000000. ! 726: (quotient limit 1000.)) ! 727: (i 1 (1- i))) ! 728: ((< i 0) ! 729: (cond ((> n 0) ! 730: (and flag (format:tyo #\space)) ! 731: (english-print-thousand n)))) ! 732: (cond ((not (< n limit)) ! 733: (setq p (quotient n limit) ! 734: n (remainder n limit)) ! 735: (cond (flag (format:tyo #\space)) ! 736: (t (setq flag t))) ! 737: (english-print-thousand p) ! 738: (format:tyo #\space) ! 739: (format:patom (ar-1 english-large i)))))))) ! 740: ! 741: (defun english-print-thousand (n) ! 742: (declare (fixnum i n limit)) ! 743: (let ((n (remainder n 100.)) ! 744: (h (quotient n 100.))) ! 745: (cond ((> h 0) ! 746: (format:patom (ar-1 english-small (1- h))) ! 747: (format:tyo #\space) ! 748: (format:patom '|hundred|) ! 749: (and (> n 0) (format:tyo #\space)))) ! 750: (cond ((= n 0)) ! 751: ((< n 20.) ! 752: (format:patom (ar-1 english-small (1- n)))) ! 753: (t ! 754: (format:patom (ar-1 english-medium ! 755: (- (quotient n 10.) 2))) ! 756: (cond ((zerop (setq h (remainder n 10.)))) ! 757: (t ! 758: (format:tyo #/-) ;ascii - ! 759: (format:patom (ar-1 english-small (1- h))))))))) ! 760: ! 761: (defun roman-step (x n) ! 762: (cond ((> x 9.) ! 763: (roman-step (quotient x 10.) (1+ n)) ! 764: (setq x (remainder x 10.)))) ! 765: (cond ((and (= x 9) (not roman-old)) ! 766: (roman-char 0 n) ! 767: (roman-char 0 (1+ n))) ! 768: ((= x 5) ! 769: (roman-char 1 n)) ! 770: ((and (= x 4) (not roman-old)) ! 771: (roman-char 0 n) ! 772: (roman-char 1 n)) ! 773: (t (cond ((> x 5) ! 774: (roman-char 1 n) ! 775: (setq x (- x 5)))) ! 776: (do i 0 (1+ i) (>= i x) ! 777: (roman-char 0 n))))) ! 778: ! 779: (defun roman-char (i x) ! 780: (format:tyo (car (nthcdr (+ i x x) '(#/I #/V #/X #/L #/C #/D #/M))) ! 781: ; i v x l c d m ! 782: )) ! 783: ! 784: ;;; Kludges to make MacLISP like some of the LISPM functions ! 785: ! 786: ! 787: (defun format:tyo (char) ! 788: (cond ((dtpr Format-Standard-Output) ! 789: (rplacd Format-Standard-Output ! 790: (cons char (cdr Format-Standard-Output)))) ! 791: (t (tyo char Format-Standard-Output)))) ! 792: ! 793: (defun format:patom (arg) ! 794: (format:printorpatom arg nil)) ! 795: ! 796: (defun format:print (arg) ! 797: (format:printorpatom arg t)) ! 798: ! 799: (defun format:printorpatom (argument slashify) ! 800: (cond ((dtpr Format-Standard-Output) ! 801: (rplacd Format-Standard-Output ! 802: (nreconc (cond (slashify ! 803: (mapcar '(lambda (x) ! 804: (getcharn x 1)) ! 805: (explode argument))) ! 806: ((exploden argument))) ! 807: (cdr Format-Standard-Output)))) ! 808: (t (cond (slashify (print argument Format-Standard-Output)) ! 809: (t (patom argument Format-Standard-Output)))))) ! 810: ! 811: (defun format:terpr nil ! 812: (cond ((dtpr Format-Standard-Output) ! 813: (rplacd Format-Standard-Output ! 814: (cons #\newline (cdr Format-Standard-Output)))) ! 815: (t (terpr Format-Standard-Output)))) ! 816: ! 817: (defun format:fresh-line nil ! 818: (cond ((dtpr Format-Standard-Output) ! 819: (cond ((and (cdr Format-Standard-Output) ! 820: (not (= (cadr Format-Standard-Output) #\newline))) ! 821: (rplacd Format-Standard-Output ! 822: (cons #\newline (cdr Format-Standard-Output)))))) ! 823: (t (and (not (= 0 (nwritn Format-Standard-Output))) ! 824: (terpr Format-Standard-Output))))) ! 825: ! 826: ! 827: ! 828: ! 829: (defun format\:string-search-char (char str start-pos) ! 830: (declare (fixnum i start-pos str-len)) ! 831: (do ((i start-pos (1+ i)) ! 832: (str-len (flatc str))) ! 833: ((>& i str-len) nil) ! 834: (and (=& char (getcharn str (1+ i))) (return i)))) ! 835: ! 836: (defun format\:nsubstring (str from to) ! 837: (declare (fixnum i from to)) ! 838: (substring str (+ 1 from) (- to from))) ;substring is 1 based ! 839: ! 840: (defun ferror (&rest args) ! 841: (let (str) ! 842: ; if the first arg to ferror is a string we assume that it is the ! 843: ; format control string, otherwise we assume that it is a port ! 844: ; specification, and we ignore it since we want to build a string. ! 845: (if (stringp (car args)) ! 846: then (setq str (lexpr-funcall 'format nil args)) ! 847: else (setq str (lexpr-funcall 'format nil (cdr args)))) ! 848: (error str))) ! 849: ! 850: ! 851: (defun format-test nil ! 852: (format t "Start test, newline:~%freshline:~&") ! 853: (format t "decimal:~d, width=5:~5d~%" 10 10) ! 854: (format t "decimal pad with period:~10,vd~%" #/. 12) ! 855: (format t "char normal:~c, as # would read:~@c, human read:~:c~%" ! 856: #\space #\space #\space) ! 857: (format t "cardinal:~r, roman new:~@r, roman-old:~:@r~ ! 858: <same line I hope>~@ ! 859: new line but at beginning~: ! 860: same line, but spaced out~:@ ! 861: new line and over two tabs~%" 4 4 4)) ! 862: ! 863: (putprop 'format t 'version)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.