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