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