1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PXNK:PRINTF.SL 4% Description: Formatted print routine 5% Author: Eric Benson 6% Created: 27 August 1981 7% Modified: 29-Oct-84 09:10:42 (Vicki O'Day) 8% Package: 9% Status: Open Source: BSD License 10% 11% (c) Copyright 1982, University of Utah 12% 13% Redistribution and use in source and binary forms, with or without 14% modification, are permitted provided that the following conditions are met: 15% 16% * Redistributions of source code must retain the relevant copyright 17% notice, this list of conditions and the following disclaimer. 18% * Redistributions in binary form must reproduce the above copyright 19% notice, this list of conditions and the following disclaimer in the 20% documentation and/or other materials provided with the distribution. 21% 22% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 23% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 24% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 26% CONTRIBUTORS 27% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 28% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 29% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 30% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 31% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 32% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33% POSSIBILITY OF SUCH DAMAGE. 34% 35%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36% 37% Revisions: 38% 39% 28-May-87 (Leigh Stoller & Harold Carr) 40% Added fluid declarations of in* and out*. 41% 02-Mar-84 09:20:52 (Jim Ambras/CRC) 42% Corrected file header. 43% 24-Feb-84 15:42:09 (Nancy Kendzierski) 44% Added "format" arguments to errorprintf and bldmsg, since they were 45% supposed to be able to handle as manya arguments as PSL could pass ... 46% 06-Jan-84 17:10:01 (Tim Tillson) 47% Un-rlisp'ed Sam's D-register model version 48% 4-Nov-83 Sam Sands 49% Removed 15th parameter for D register model 50% 17-Sep-82 16:01:01, BENSON 51% Added ChannelPrintF 52% 3-May-82 10:45:11, BENSON 53% %L prints nothing for NIL 54% 23-Feb-82 21:40:31, BENSON 55% Added %x for hex 56% 1-Dec-81 16:11:11, BENSON 57% Changed to cause error for unknown character 58% 59%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 60 61(compiletime (load io-decls token-decls)) 62 63(compiletime 64 (flag '(printf1 printf2) 'iinternalfunction)) 65 66(fluid '(in* out*)) 67 68(fluid '(formatforprintf*)) 69 70% First, lambda-bind FormatForPrintF!* 71(de printf (formatforprintf* a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) 72 % scs 73 (printf1 formatforprintf* a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)) 74 75% scs 76% Then, push all the registers on the stack and set up a pointer to them 77(lap '((*entry printf1 expr 15) 78 (*push (reg 2)) 79 (*push (reg 3)) 80 (*push (reg 4)) 81 (*push (reg 5)) 82 (*push (reg 6)) 83 (*push (reg 7)) 84 (*push (reg 8)) 85 (*push (reg 9)) 86 (*push (reg 10)) 87 (*push (reg 11)) 88 (*push (reg 12)) 89 (*push (reg 13)) 90 (*push (reg 14)) 91 % (!*PUSH (reg 15)) scs 92 (*loc (reg 1) (frame 13)) 93 % scs 94 (*call printf2) 95 (*exit 13))) 96 97 98%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 99% 100% Formatted print 101% 102% Format is a string, either in the heap or not, whose characters will be 103% written on the currently selected output channel. The exception to this is 104% that when a % is encountered, the following character is interpreted as a 105% format character, to decide how to print one of the other arguments. The 106% following format characters are currently supported: 107% %b - blanks; take the next argument as integer and print that many 108% blanks 109% %c - print the next argument as a single character 110% %d - print the next argument as a decimal integer 111% %e - EVALs the next argument for side-effect -- most useful if the 112% thing EVALed does some printing 113% %f - fresh-line, print end-of-line char if not at beginning of line 114% %l - same as %w, except lists are printed without top level parens 115% %n - print end-of-line character 116% %o - print the next argument as an octal integer 117% %p - print the next argument as a Lisp item, using Prin1 118% %r - print the next argument as a Lisp item, using ErrPrin (`FOO') 119% %s - print the next argument as a string 120% %t - tab; take the next argument as an integer and 121% print spaces to that column 122% %w - print the next argument as a Lisp item, using Prin2 123% %x - print the next argument as a hexidecimal integer 124% %% - print a % 125% 126% If the character is not one of these (either upper or lower case), then an 127% error occurs. 128% 129%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 130 131% scs 132% Finally, actual printf, with 1 argument, pointer to array of parameters 133(de printf2 (printfargs) 134 (prog (uplim i ch upch) 135 (setq uplim (strlen (strinf formatforprintf*))) 136 (setq i 0) 137 (while (wleq i uplim) 138 (setq ch (strbyt (strinf formatforprintf*) i)) 139 (if (wneq ch (char !%)) 140 (writechar ch) 141 (prog nil 142 (setq i (wplus2 i 1)) 143 (setq ch (strbyt (strinf formatforprintf*) i)) 144 (setq upch (if (lowercasechar ch) 145 (raisechar ch) 146 ch)) 147 (case upch 148 (((char !B)) 149 (progn (spaces (getmem printfargs)) 150 (setq printfargs 151 (loc (wgetv printfargs stackdirection))))) 152 (((char !C)) 153 (progn (writechar (getmem printfargs)) 154 (setq printfargs 155 (loc (wgetv printfargs stackdirection))))) 156 (((char !D)) 157 (progn (writesysinteger (getmem printfargs) 10) 158 (setq printfargs 159 (loc (wgetv printfargs stackdirection))))) 160 (((char !E)) 161 (progn (eval (getmem printfargs)) 162 (setq printfargs 163 (loc (wgetv printfargs stackdirection))))) 164 (((char !F)) (when (wgreaterp (posn) 0) 165 (writechar (char eol)))) 166 (((char !L)) 167 (progn (prin2l (getmem printfargs)) 168 (setq printfargs 169 (loc (wgetv printfargs stackdirection))))) 170 (((char !N)) (writechar (char eol))) 171 (((char !O)) 172 (progn (writesysinteger (getmem printfargs) 8) 173 (setq printfargs 174 (loc (wgetv printfargs stackdirection))))) 175 (((char !X)) 176 (progn (writesysinteger (getmem printfargs) 16) 177 (setq printfargs 178 (loc (wgetv printfargs stackdirection))))) 179 (((char !P)) 180 (progn (prin1 (getmem printfargs)) 181 (setq printfargs 182 (loc (wgetv printfargs stackdirection))))) 183 (((char !R)) 184 (progn (errprin (getmem printfargs)) 185 (setq printfargs 186 (loc (wgetv printfargs stackdirection))))) 187 (((char !S)) 188 (progn (writestring (getmem printfargs)) 189 (setq printfargs 190 (loc (wgetv printfargs stackdirection))))) 191 (((char !T)) 192 (progn (tab (getmem printfargs)) 193 (setq printfargs 194 (loc (wgetv printfargs stackdirection))))) 195 (((char !W)) 196 (progn (prin2 (getmem printfargs)) 197 (setq printfargs 198 (loc (wgetv printfargs stackdirection))))) 199 (((char !%)) (writechar (char !%))) 200 (nil 201 (stderror 202 (bldmsg '"Unknown character code for PrintF: %r" 203 (mkid ch))))))) 204 (setq i (wplus2 i 1))))) 205 206(de errorprintf (format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) 207 (prog (savechannel) 208 (setq savechannel (wrs errout*)) 209 (when (wgreaterp (wgetv lineposition (intinf errout*)) 0) 210 (terpri)) 211 (printf format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) 212 (when (wgreaterp (wgetv lineposition (intinf errout*)) 0) 213 (terpri)) 214 (wrs savechannel))) 215 216(de tostringwritechar (channel ch) 217 % shares TokenBuffer 218 (progn (if (wgeq (wgetv tokenbuffer 0) (wdifference maxtokensize 1)) 219 (progn (setf (wgetv tokenbuffer 0) 80) 220 % truncate to 80 chars 221 (setf (strbyt tokenbuffer 80) (char null)) 222 (stderror 223 (list '"Buffer overflow while constructing error message:" 224 formatforprintf* '"The truncated result was:" 225 (copystring (mkstr tokenbuffer))))) 226 (progn (setf (wgetv tokenbuffer 0) 227 (wplus2 (wgetv tokenbuffer 0) 1)) 228 (setf (strbyt tokenbuffer (wgetv tokenbuffer 0)) ch))) 229)) 230 231%. Print to string 232(de bldmsg 233 (format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12) 234 % arg13) jpa 235 (prog (tempchannel out*) 236 (setf (wgetv lineposition 2) 0) 237 (setf (wgetv tokenbuffer 0) -1) 238 (setq tempchannel out*) 239 (setf out* '2) 240 (printf format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 241 arg11 arg12) % jpa arg13) 242 (setf (strbyt tokenbuffer (wplus2 (wgetv tokenbuffer 0) 1)) 243 (char null)) 244 (setf out* tempchannel) 245 (return (copystring tokenbuffer)))) 246 247(de errprin (u) 248 %. `Prin1 with quotes' 249 (progn (writechar (char !`)) 250 (prin1 u) 251 (writechar (char !')))) 252 253(de prin2l (itm) 254 %. Prin2 without top-level parens 255 (cond ((null itm) nil) 256 % NIL is (), print nothing 257 ((not (pairp itm)) (prin2 itm)) 258 (t (progn (while (progn (prin2 (car itm)) 259 (setq itm (cdr itm)) 260 (pairp itm)) 261 (channelwriteblankoreol out*)) 262 (when itm 263 (channelwriteblankoreol out*) 264 (prin2 itm)))))) 265 266(de channelprintf (out* format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) 267 % scs 268 (printf format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)) 269 270