Return to format.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/format.l, revision 1.1

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.