![[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.