![[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] / 43BSDReno / pgrm / lisp / lisplib|
Return to format.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / 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.