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(compiletime (load io-decls token-decls))
61
62(compiletime
63  (flag '(printf1 printf2) 'iinternalfunction))
64
65(fluid '(in* out*))
66(fluid '(formatforprintf*))
67
68% First, lambda-bind FormatForPrintF!*
69(de printf (formatforprintf* a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)
70  % scs
71
72  (printf1 formatforprintf* a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13))
73
74% scs
75% Then, push all the registers on the stack and set up a pointer to them
76(lap '((*entry printf1 expr 15)
77       (*push (reg 2))
78       (*push (reg 3))
79       (*push (reg 4))
80       (*push (reg 5))
81       (*push (reg 6))
82       (*push (reg 7))
83       (*push (reg 8))
84       (*push (reg 9))
85       (*push (reg 10))
86       (*push (reg 11))
87       (*push (reg 12))
88       (*push (reg 13))
89       (*push (reg 14))
90       %   (!*PUSH (reg 15))                     scs
91       (*loc (reg 1) (frame 13))
92       %  scs
93       (*call printf2)
94       (*exit 13)))
95
96%  scs
97% Finally, actual printf, with 1 argument, pointer to array of parameters
98(de printf2 (printfargs)
99  %. Formatted print
100  %
101  % Format is a string, either in the heap or not, whose characters will be
102  % written on the currently selected output channel.  The exception to this is
103
104  % that when a % is encountered, the following character is interpreted as a
105
106  % format character, to decide how to print one of the other arguments.  The
107
108  % following format characters are currently supported:
109  %	%b - blanks; take the next argument as integer and print that many
110  %		blanks
111  %	%c - print the next argument as a single character
112  %	%d - print the next argument as a decimal integer
113  %     %e - EVALs the next argument for side-effect -- most useful if the
114  %            thing EVALed does some printing
115  %	%f - fresh-line, print end-of-line char if not at beginning of line
116  %	%l - same as %w, except lists are printed without top level parens
117  %	%n - print end-of-line character
118  %	%o - print the next argument as an octal integer
119  %	%p - print the next argument as a Lisp item, using Prin1
120  %     %r - print the next argument as a Lisp item, using ErrPrin (`FOO')
121  %	%s - print the next argument as a string
122  %	%t - tab; take the next argument as an integer and
123  %		print spaces to that column
124  %	%w - print the next argument as a Lisp item, using Prin2
125  %	%x - print the next argument as a hexidecimal integer
126  %	%% - print a %
127  %
128  % If the character is not one of these (either upper or lower case), then an
129  % error occurs.
130  %
131  (prog (uplim i ch upch)
132
133        (setq uplim (strlen (strinf formatforprintf*)))
134        (setq i 0)
135        (while (wleq i uplim)
136          (setq ch (strbyt (strinf formatforprintf*) i))
137          (if (wneq ch (char !%))
138            (writechar ch)
139            (prog nil
140                  (setq i (wplus2 i 1))
141                  (setq ch (strbyt (strinf formatforprintf*) i))
142                  (setq upch (if (lowercasechar ch)
143                          (raisechar ch)
144                          ch))
145                  (case upch
146                        (((char !B))
147                         (progn (spaces (getmem printfargs))
148                                (setq printfargs
149                                 (loc (wgetv printfargs stackdirection)))))
150                        (((char !C))
151                         (progn (writechar (getmem printfargs))
152                                (setq printfargs
153                                 (loc (wgetv printfargs stackdirection)))))
154                        (((char !D))
155                         (progn (writesysinteger (getmem printfargs) 10)
156                                (setq printfargs
157                                 (loc (wgetv printfargs stackdirection)))))
158                        (((char !E))
159                         (progn (eval (getmem printfargs))
160                                (setq printfargs
161                                 (loc (wgetv printfargs stackdirection)))))
162                        (((char !F)) (when (wgreaterp (posn) 0)
163                           (writechar (char eol))))
164                        (((char !L))
165                         (progn (prin2l (getmem printfargs))
166                                (setq printfargs
167                                 (loc (wgetv printfargs stackdirection)))))
168                        (((char !N)) (writechar (char eol)))
169                        (((char !O))
170                         (progn (writesysinteger (getmem printfargs) 8)
171                                (setq printfargs
172                                 (loc (wgetv printfargs stackdirection)))))
173                        (((char !X))
174                         (progn (writesysinteger (getmem printfargs) 16)
175                                (setq printfargs
176                                 (loc (wgetv printfargs stackdirection)))))
177                        (((char !P))
178                         (progn (prin1 (getmem printfargs))
179                                (setq printfargs
180                                 (loc (wgetv printfargs stackdirection)))))
181                        (((char !R))
182                         (progn (errprin (getmem printfargs))
183                                (setq printfargs
184                                 (loc (wgetv printfargs stackdirection)))))
185                        (((char !S))
186                         (progn (writestring (getmem printfargs))
187                                (setq printfargs
188                                 (loc (wgetv printfargs stackdirection)))))
189                        (((char !T))
190                         (progn (tab (getmem printfargs))
191                                (setq printfargs
192                                 (loc (wgetv printfargs stackdirection)))))
193                        (((char !W))
194                         (progn (prin2 (getmem printfargs))
195                                (setq printfargs
196                                 (loc (wgetv printfargs stackdirection)))))
197                        (((char !%)) (writechar (char !%)))
198                        (nil
199                         (stderror
200                          (bldmsg '"Unknown character code for PrintF: %r"
201                           (mkid ch)))))))
202          (setq i (wplus2 i 1)))))
203
204(de errorprintf (format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)
205  (prog (savechannel)
206        (setq savechannel (wrs errout*))
207        (when (wgreaterp (wgetv lineposition (intinf errout*)) 0)
208          (terpri))
209        (printf format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)
210        (when (wgreaterp (wgetv lineposition (intinf errout*)) 0)
211          (terpri))
212        (wrs savechannel)))
213
214(de tostringwritechar (channel ch)
215  % shares TokenBuffer
216  (progn (if (wgeq (wgetv tokenbuffer 0) (wdifference maxtokensize 1))
217           (progn (setf (wgetv tokenbuffer 0) 80)
218                  % truncate to 80 chars
219                  (setf (strbyt tokenbuffer 80) (char null))
220                  (stderror
221                   (list '"Buffer overflow while constructing error message:"
222                         formatforprintf* '"The truncated result was:"
223                         (copystring (mkstr tokenbuffer)))))
224           (progn (setf (wgetv tokenbuffer 0)
225                        (wplus2 (wgetv tokenbuffer 0) 1))
226                  (setf (strbyt tokenbuffer (wgetv tokenbuffer 0)) ch)))
227))
228
229%. Print to string
230(de bldmsg
231  (format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12)
232             % arg13)  jpa
233  (prog (tempchannel out*)
234        (setf (wgetv lineposition 2) 0)
235        (setf (wgetv tokenbuffer 0) -1)
236        (setq tempchannel out*)
237        (setf out* '2)
238        (printf format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10
239                arg11 arg12) % jpa arg13)
240        (setf (strbyt tokenbuffer (wplus2 (wgetv tokenbuffer 0) 1))
241              (char null))
242        (setf out* tempchannel)
243        (return (copystring tokenbuffer))))
244
245(de errprin (u)
246  %. `Prin1 with quotes'
247  (progn (writechar (char !`))
248         (prin1 u)
249         (writechar (char !'))))
250
251(de prin2l (itm)
252  %. Prin2 without top-level parens
253  (cond ((null itm) nil)
254        % NIL is (), print nothing
255        ((not (pairp itm)) (prin2 itm))
256        (t (progn (while (progn (prin2 (car itm))
257                                (setq itm (cdr itm))
258                                (pairp itm))
259                    (channelwriteblankoreol out*))
260                  (when itm
261                    (channelwriteblankoreol out*)
262                    (prin2 itm))))))
263
264(de channelprintf (out* format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
265  %   scs
266  (printf format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12))
267
268