1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PXNK:PRINTF.SL
4% Description:  Formatted print routine
5% Author:       Eric Benson
6% Created:      27 August 1981
7% Modified:     29-Aug-84 10:06:30 (Brian Beach)
8% Package:      Nonkernel
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% 27-May-87 (Harold Carr & Leigh Stoller)
40%  Added fluid declaration of in* and out*.
41% 20-Jul-84 9:00 (Brian Beach)
42%  Added compile time load of TOKEN-DECLS.
43%  Removed WARRAYS, WSTRINGS for micro-kernel.
44%  Cleaned up PRINTF2.
45% 01-Dec-83 14:58:18 (Brian Beach)
46%   Translated from Rlisp to Lisp.
47%
48%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
49
50(compiletime (load io-decls token-decls))
51
52(compiletime
53  (flag '(printf1 printf2) 'internalfunction))
54
55(fluid '(in* out*))
56
57(fluid '(formatforprintf* lineposition tokenbuffer))
58
59% First, lambda-bind FormatForPrintF!*
60(de printf (formatforprintf* a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)
61  (printf1 formatforprintf* a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13))
62
63% Then, push all the registers on the stack and set up a pointer to them
64(lap '((*entry printf1 expr 15)
65       (*alloc 13)
66       (*Move (reg 2) (frame 13))
67       (*Move (reg 3) (frame 12))
68       (*Move (reg 4) (frame 11))
69       (*Move (reg 5) (frame 10))
70       (*Move (reg 6) (frame 9))
71       (*Move (reg 7) (frame 8))
72       (*Move (reg 8) (frame 7))
73       (*Move (reg 9) (frame 6))
74       (*Move (reg 10) (frame 5))
75       (*Move (reg 11) (frame 4))
76       (*Move (reg 12) (frame 3))
77       (*Move (reg 13) (frame 2))
78       (*Move (reg 14) (frame 1))
79       (*loc (reg 1) (frame 13))	% load address of frame containing (reg 2), ie 1st arg
80       (*call printf2)
81       (*exit 13)))
82
83
84%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
85%
86%                          Formatted print
87%
88% Format is a string, either in the heap or not, whose characters will be
89% written on the currently selected output channel.  The exception to this is
90% that when a % is encountered, the following character is interpreted as a
91% format character, to decide how to print one of the other arguments.  The
92% following format characters are currently supported:
93%	%b - blanks; take the next argument as integer and print that many
94%		blanks
95%	%c - print the next argument as a single character
96%	%d - print the next argument as a decimal integer
97%       %e - EVALs the next argument for side-effect -- most useful if the
98%            thing EVALed does some printing
99%	%f - fresh-line, print end-of-line char if not at beginning of line
100%	%l - same as %w, except lists are printed without top level parens
101%	%n - print end-of-line character
102%	%o - print the next argument as an octal integer
103%	%p - print the next argument as a Lisp item, using Prin1
104%       %r - print the next argument as a Lisp item, using ErrPrin (`FOO')
105%	%s - print the next argument as a string
106%	%t - tab; take the next argument as an integer and
107%		print spaces to that column
108%	%w - print the next argument as a Lisp item, using Prin2
109%	%x - print the next argument as a hexidecimal integer
110%	%% - print a %
111%
112% If the character is not one of these (either upper or lower case), then an
113% error occurs.
114%
115%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
116
117(compiletime
118 (defmacro next-arg ()
119   '(prog1 (getmem printfargs)
120	   (setf printfargs (loc (wgetv printfargs stackdirection)))
121	   )))
122
123% Actual printf, with 1 argument: pointer to array of parameters
124(de printf2 (printfargs)
125  (prog (uplim i ch upch)
126    (setq uplim (strlen (strinf formatforprintf*)))
127    (setq i 0)
128    (while (wleq i uplim)
129      (setq ch (strbyt (strinf formatforprintf*) i))
130      (if (wneq ch (char !%))
131	(writechar ch)
132	(progn
133	 (setq i (wplus2 i 1))
134	 (setq ch (strbyt (strinf formatforprintf*) i))
135	 (setq upch (if (lowercasechar ch)
136		      (raisechar ch)
137		      ch))
138	 (case upch
139	   (((char !B))  (spaces (next-arg)))
140	   (((char !C))  (writechar (next-arg)))
141	   (((char !D))  (writesysinteger (next-arg) 10))
142	   (((char !E))  (eval (next-arg)))
143	   (((char !F))  (when (wgreaterp (posn) 0)
144			  (writechar (char eol))))
145	   (((char !L))  (prin2l (next-arg)))
146	   (((char !N))  (writechar (char eol)))
147	   (((char !O))  (writesysinteger (next-arg) 8))
148	   (((char !X))  (writesysinteger (next-arg) 16))
149	   (((char !P))  (prin1 (next-arg)))
150	   (((char !R))  (errprin (next-arg)))
151	   (((char !S))  (writestring (next-arg)))
152	   (((char !T))  (tab (next-arg)))
153	   (((char !W))  (prin2 (next-arg)))
154	   (((char !%)) (writechar (char !%)))
155	   (nil
156	    (stderror (bldmsg "Unknown character code for PrintF: %r" (mkid ch)))))))
157      (setq i (wplus2 i 1)))))
158
159(de errorprintf (format a1 a2 a3 a4)
160  % also A5..A14
161  (let ((savechannel (wrs errout*)))
162    (when (wgreaterp (wgetv lineposition (intinf errout*)) 0)
163      (terpri))
164    (printf format a1 a2 a3 a4)
165    (when (wgreaterp (wgetv lineposition (intinf errout*)) 0)
166      (terpri))
167    (wrs savechannel)))
168
169(de tostringwritechar (channel ch)
170  % shares TokenBuffer
171  (progn (if (wgeq (wgetv tokenbuffer 0) (wdifference maxtokensize 1))
172           (progn (setf (wgetv tokenbuffer 0) 80)
173                  % truncate to 80 chars
174                  (setf (strbyt tokenbuffer 80) (char null))
175                  (stderror
176                   (list '"Buffer overflow while constructing error message:"
177                         formatforprintf* '"The truncated result was:"
178                         (copystring (mkstr tokenbuffer)))))
179           (progn (setf (wgetv tokenbuffer 0)
180                        (wplus2 (wgetv tokenbuffer 0) 1))
181                  (setf (strbyt tokenbuffer (wgetv tokenbuffer 0)) ch)))
182))
183
184%. Print to string
185(de bldmsg
186  (format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12)
187             % arg13)  jpa
188  (prog (tempchannel out*)
189        (setf (wgetv lineposition 2) 0)
190        (setf (wgetv tokenbuffer 0) -1)
191        (setq tempchannel out*)
192        (setf out* '2)
193        (printf format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10
194                arg11 arg12) % jpa arg13)
195        (setf (strbyt tokenbuffer (wplus2 (wgetv tokenbuffer 0) 1))
196              (char null))
197        (setf out* tempchannel)
198        (return (copystring tokenbuffer))))
199
200(de errprin (u)
201  %. `Prin1 with quotes'
202  (progn (writechar (char !`))
203         (prin1 u)
204         (writechar (char !'))))
205
206(de prin2l (itm)
207  %. Prin2 without top-level parens
208  (cond ((null itm) nil)
209        % NIL is (), print nothing
210        ((not (pairp itm)) (prin2 itm))
211        (t (progn (while (progn (prin2 (car itm))
212                                (setq itm (cdr itm))
213                                (pairp itm))
214                    (channelwriteblankoreol out*))
215                  (when itm
216                    (channelwriteblankoreol out*)
217                    (prin2 itm))))))
218
219(de channelprintf (out* format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
220  (printf format a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12))
221
222