;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 124.88 ;;; Reason: ;;; If you call FORMAT with a synonym-stream for *standard-output*, your Lambda ;;; loops in the microcode, as FORMAT binds *standard-output* to the stream. ;;; Similarly for a synonym-stream to a synonym-stream to *standard-output*, etc. ;;; Cure: create (si:follow-all-syn-streams), which is like (si:follow-syn-stream) ;;; but follows to the end of indirection. FORMAT now uses this... ;;; Written 22-Jun-88 18:05:24 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Cthulhu from band 1 ;;; with Experimental System 124.86, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1760, SDU Boot Tape 3.14, SDU ROM 8, the old ones. ; From modified file DJ: L.IO; QIO.LISP#236 at 22-Jun-88 18:05:25 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; QIO  " (defun follow-all-syn-streams (stream) "If STREAM is a synonym stream symbol, return the stream it ultimately points to. Otherwise return STREAM." (loop (cond ((not (symbolp stream)) (return stream)) ((neq (locf (fsymeval stream)) (follow-cell-forwarding (locf (fsymeval stream)) t)) (setq stream (fsymeval stream))) (t (return stream))))) )) ; From modified file DJ: L.IO; FORMAT.LISP#276 at 22-Jun-88 18:05:34 #10R FORMAT#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FORMAT  " (DEFUN FORMAT (STREAM CTL-STRING &REST ARGS) "Format arguments according to a control string and print to a stream. \(If the stream is T, *STANDARD-OUTPUT* is used; if NIL, a string is returned containing the formatted text.) The control string is copied to the stream, but ~ indicates special formatting commands. ~D ~mincol,padchar,commacharD Print number as a decimal integer. ~:D Print the comma character every three digits. ~@D Always print the sign. ~:@D Both. ~O Analogous to ~D, but prints in octal. ~X Analogous to ~D, but prints in hex. ~B Analogous to ~X, but prints in binary. ~F ~w,d,s,overflowchar,padcharF Print float in nonexponential notation. Multiplies by 10^s before printing if s is specified. Prints in w positions, with d digits after the decimal point. Pads on left with padchar if nec. If number doesn't fit in w positions, and overflowchar is specified, just fills the w positions with that character. ~E ~w,d,e,s,overflowchar,padchar,exptcharE Print float in exponential notation. Prints in w positions, with e digits of exponent. If s (default is 1) is positive, prints s digits before point, d-s+1 after. If s is zero, prints d digits after the point, and a zero before if there's room. If s is negative, prints d digits after the point, of which the first -s are zeros. If exptchar is specified, it is used to delimit the exponent (instead of \"e\" or whatever.) If overflowchar is specified, then if number doesn't fit in specified width, or if exponent doesn't fit in e positions, field is filled with overflowchar instead. ~G Like ~E, but if number fits without exponent, prints without one. ~$ ~w,x,y,z$ prints a floating-point number with exactly w (default 2) digits to right of decimal, at least x (default 1) to left of decimal, right-justified in field y wide padded with z. @ print + sign. : sign to left of padding. ~R ~R Print number as an English cardinal number. ~:R English ordinal number. ~@R Roman numeral. ~:@R Old Roman numeral. ~nR Print number in radix n. Thus ~8R = ~O, and ~10R = ~D. Extra parameters are as for ~D (~n,mincol,padchar,commacharR). ~A Ascii output (PRINC). Good for printing strings. ~mincol,colinc,minpad,padcharA. ~@A Right-justify the string. ~:A Make NIL print as (). ~:@A Both. ~S Analogous to ~A, but uses PRIN1, not PRINC. ~C Print a character. Mouse characters print in standard format. ~C Actual character, preceded by \"c-\", \"m-\", \"s-\" or \"h-\" if necessary. ~:C Format effectors print as names. Names of control bits (\"Control-\") precede. ~@C Prints the character in READ format, using #\\. ~:@C Like ~:C, but top/front/greek characters are followed by remark, e.g. \" (Top-S)\". ~* Ignore an argument. ~n* Ignore n arguments. ~:n* Back up n arguments (default 1). ~n@* Go to argument n. ~% Insert a newline. ~n% Insert n newlines. ~~ Insert a tilde. ~n~ Insert n tildes. ~| Insert a form. ~n| Insert n forms. ~:| Do :CLEAR-WINDOW if the stream supports it, otherwise insert a form. ~:n| Similar. ~ Ignore a CR and following whitespace in the control string. ~: Ignore the CR, retain the whitespace. ~@ Retain the CR, ignore the whitespace. ~& Do a :FRESH-LINE. ~n& Do a FRESH-LINE, then insert n-1 newlines. ~^ Terminate processing if no more arguments. Within ~{...~}, just terminate the loop. ~n; Terminate if n is zero. ~n,m; Terminate if n=m. ~n,m,p; Terminate if nmp. ~:^ When within ~:{...~}, ~^ terminates this iteration. Use ~:^ to exit the loop. ~T ~mincol,colincT Tab to column mincol+p*colinc, for the smallest integer p possible. ~mincol,colinc:T Same, but tabs in TV pixels rather than characters. ~n@T Insert n spaces. ~n,colinc@T Insert n spaces, then move 0 or more up to multiple of colinc. ~Q Apply next argument to no arguments. ~a,b,c,...,zQ Apply next argument to parameters a,b,c,...z. In (Q ...) form, apply argument to unevaled parameters. ~P Pluralize. Insert \"s\", unless argument is 1. ~:P Use previous argument, not next one (i.e. do ~:* first). ~@P Insert \"y\" if argument is 1, otherwise insert \"ies\". ~:@P Both. ~( ~(...~) Force lower case for the output generated within. ~:(...~) Similar but capitalize each word. ~@(...~) Similar but capitalize the first word. ~:@(...~) Similar but force all upper case. ~1(...~) Force first letter of first word to upper case, leave all else alone. ~? Indirect. Uses up two args; first is a format string, second is args for it. ~@? uses up one arg directly, as a format string, but it operates on the remaining format args and can use them up. ~< ~mincol,colinc,minpad,padchar Do formatting for all formatting strings strj; then output all strings with padding between them at the ~; points. Each padding point must have at least minpad padding characters. Subject to that, the total width must be at least mincol, and must be mincol+p*colinc for some p. If str0 is followed by ~:; instead of ~;, then str0 is not normally output, and the ~:; is not a padding point. Instead, after the total width has been determined, if the text will not fit into the current line of output, then str0 is output before outputting the rest. (Doesn't work when producing a string.) An argument n (~:n;) means that the text plus n more columns must fit to avoid outputting str0. A second argument m (~n,m:;) provides the line width to use instead of the stream's width. ~:< Also have a padding point at the left. Hence ~n: right-justifies x in n columns. ~@< Also have a padding point at the right. ~:@< Both. Hence ~n:@ centers x. ~[ ~[str0~;str1~;...~;strn~] Select. Argument selects one clause to do. If argument is not between 0 and n inclusive, then no alternative is performed. If a parameter is given, then use the parameter instead of an argument. (The only useful one is \"#\".) If the last string is preceded by ~:;, it is an \"else\" clause, and is processed if no other string is selected. One can also tag the clauses explicitly by giving arguments to ~;. In this case the first string must be null, and arguments to ~; tag the following string. The argument is matched against the list of parameters for each ~;. One can get ranges of tags by using ~:;. Pairs of parameters serve as inclusive range limits. A ~:; with no parameters is still an \"else\" clause. Example: ~[~'+,'-,'*,'/;operator~:'A,'Z,'a,'z;letter~:'0,'9;digit~:;other~] will produce \"operator\", \"letter\", \"digit\", or \"other\" as appropriate. ~:[iffalse~;iftrue~] The argument selects the first clause if nil, the second if non-nil. ~@[str~] If the argument is non-nil, then it is not swallowed, and str is processed. Otherwise, the nil is swallowed and str is ignored. Thus ~@[~S~] will PRIN1 a non-null thing. ~{ ~{str~} Use str as a format string for each element in the argument. More generally, the argument is a list of things to be used as successive arguments, and str is used repeatedly as a format string until the arguments are exhausted (or ~^ is used). Within the iteration the commands ~* and ~@* move among the iteration arguments, not among all the arguments given to FORMAT. ~n{str~} repeats the string at most n times. Terminating with ~:} forces str to be processed at least once. ~:{str} The argument is a list of lists, and each repetition sees one sublist. ~@{str} All remaining arguments are used as the list. ~:@{str} Each remaining argument is a list. If the str within a ~{ is empty, then an argument (which must be a string) is used. This argument precedes any that are iterated over as loop arguments. ~ ~str~ Successive lines within str are indented to align themselves with the column at which str began. ie all text within str will lie to the right of the beginning of str In place of a numeric parameter, one may use V, which uses an argument to supply the number; or one may use #, which represents the number of arguments remaining to be processed; or one may use 'x, which uses the ascii value of x (good for pad characters). The control string may actually be a list of intermixed strings and sublists. In that case, the strings are printed literally. The first atom in a sublist should be the name of a command, and remaining elements are parameters." (declare (unspecial ctl-string)) ;>>for recompilation (check-type ctl-string (or string cons error) "a string") (if (stringp stream) (assert (array-has-fill-pointer-p stream) (stream) "If the first argument, ~S, to ~S is a string, it must have a fill-pointer" 'stream 'format)) (let ((*ctl-string* ctl-string) (default-cons-area format-area)) (let-if (typep stream '(or null string)) ;; Only bind *FORMAT-STRING* if STREAM is NIL. This avoids lossage if ;; FORMAT with a first arg of NIL calls FORMAT recursively (e.g. if ;; printing a named structure). ((*FORMAT-STRING* (if (stringp stream) stream (make-format-string)))) (LET ((*STANDARD-OUTPUT* (COND ((OR (NULL STREAM) (STRINGP STREAM)) 'FORMAT-STRING-STREAM) ((EQ STREAM T) *STANDARD-OUTPUT*) (T (si:follow-all-syn-streams STREAM)))) (*FORMAT-ARGLIST* ARGS) (*LOOP-ARGLIST* NIL)) (CATCH 'FORMAT-\:^-POINT (CATCH 'FORMAT-^-POINT (TYPECASE CTL-STRING (STRING (FORMAT-CTL-STRING ARGS CTL-STRING)) (SYMBOL (FORMAT-CTL-STRING ARGS (SYMBOL-NAME CTL-STRING))) ;; pretty bloody marginal (ERROR (PRINC CTL-STRING)) (T (DO ((CTL-STRING CTL-STRING (CDR CTL-STRING))) ((NULL CTL-STRING)) (IF (STRINGP (CAR CTL-STRING)) (SEND *STANDARD-OUTPUT* :STRING-OUT (CAR CTL-STRING)) (SETQ ARGS (FORMAT-CTL-LIST ARGS (CAR CTL-STRING)))))))))) ;; Copy returned string out of temporary area and reclaim (WHEN (NULL STREAM) ;return string or nil ;; this should return a simple-string (ie without fill-pointer) (let* ((len (length *format-string*)) ;; consing this in format-area is the wrong thing, really. ;; Many things (eg pathname code) expect to be able to bind ;; default-cons-area and then call format, expecting to find the resulting ;; string in the area they specified. ;; On the other kettle of fish, most people who call (format nil ...) ;; tend to use the resulting string for a very brief time only, and ;; having it end up in the often-flipped format-area is just the right ;; thing in that case. ;; I (Mly) think that the following behaviour is WRONG and should probably ;; be changed, though it seems to win so much in practice that perhaps the ;; right thing is to change any callers who care to copy the result into ;; an area about which they care. (new (make-string len :area format-area))) (copy-array-portion *format-string* 0 len new 0 len) new))))) ))