1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PNK:PUTD-GETD.SL
4% Title:        Standard Lisp function defining functions
5% Author:       Eric Benson
6% Created:      18 August 1981
7% Modified:     31-May-84 10:51:14 (Brian Beach)
8% Status:       Open Source: BSD License
9% Mode:         Lisp
10% Package:      Kernel
11% Compiletime:
12% Runtime:
13%
14% (c) Copyright 1983, Hewlett-Packard Company, see the file
15%            HP_disclaimer at the root of the PSL file tree
16%
17% (c) Copyright 1982, University of Utah
18%
19% Redistribution and use in source and binary forms, with or without
20% modification, are permitted provided that the following conditions are met:
21%
22%    * Redistributions of source code must retain the relevant copyright
23%      notice, this list of conditions and the following disclaimer.
24%    * Redistributions in binary form must reproduce the above copyright
25%      notice, this list of conditions and the following disclaimer in the
26%      documentation and/or other materials provided with the distribution.
27%
28% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
29% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
30% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
31% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
32% CONTRIBUTORS
33% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
34% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
35% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
36% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
37% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
38% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
39% POSSIBILITY OF SUCH DAMAGE.
40%
41%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
42%
43% Revisions:
44%
45% 29-Sep-91 (Herbert Melenk)
46%  DOS: compile putd calls for nonkernel and kernel functions
47% 01-Oct-88 (Tony Hearn)
48%  Replaced single use of flag1/remflag1 by flag/remflag to make module
49%  less dependent on non-SL functions.
50% 23-May-84 16:16:15 (Mike Creech)
51%  Rewrote code-number-of-arguments to deal with functions that were
52%  defined to have any number of arguments (-1 in *entry definition).
53%  Reformatted PUTD to make more readable.
54%  Rewrote remd to be more readable.
55%  Reformatted getd to be more readable (and changed u => func).
56% 01-Dec-83 14:59:44 (Brian Beach)
57%   Translated from Rlisp to Lisp.
58%
59%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
60
61(de getd (func)
62    % Lookup function definition of func.
63    (and
64	(idp func)
65	(not (funboundp func))
66	(cons (or (get func 'type)
67		  'expr)
68	      (if
69		 (or
70		    (flambdalinkp func)
71		    (and (flagp func 'planttrampoline)
72			 (get func '*lambdalink)))
73		 (get func '*lambdalink)
74		 (getfcodepointer func)))))
75
76(compiletime (flag '(getd0) 'internalfunction))
77
78(de getd0 (func)
79    % internal: Lookup function definition of func.
80    (and
81	(idp func)
82	(not (funboundp func))
83	(cons (or (get func 'type)
84		  'expr)
85	      (if
86		 (flambdalinkp func)
87		 (get func '*lambdalink)
88		 (getfcodepointer func)))))
89
90
91(de remd (func)
92
93    % Remove function definition of func.
94
95    (let
96	((oldgetd (getd func)))
97	(when (and oldgetd
98		   (codep (cdr oldgetd))
99		   (wlessp (inf (cdr oldgetd)) nonkernelupperbound*)
100			)
101		   (flag1 func 'planttrampoline)
102		 )
103
104	(when
105	     oldgetd
106	     % THEN There was an old definition.
107	     (makefunbound func)
108	     (remprop func 'type)
109	     (remprop func '*lambdalink))
110	% Return the old definition.
111	oldgetd)
112    )
113
114(fluid '(*redefmsg % controls printing of redefined
115	 *usermode % controls query for redefinition
116	 nonkernelupperbound*  % high address in bps
117	 ))
118
119(loadtime
120  (progn (setq *usermode nil)  % start in system mode
121	 (setq *redefmsg t)    % message in PutD
122	 ))
123
124(fluid '(*comp % controls automatic compilation
125	 promptstring*))
126
127(de code-number-of-arguments (code-pointer)
128
129    % Return the number of arguments within the range 0-maxargs, or
130    % "any" if function is setup to have any number of arguments, or
131    % NIL if not a code-pointer or too many arguments.
132
133    (when
134	 (codep code-pointer)
135	 % THEN We have a real codepointer.
136	 (let
137	     ((num-args (!%code-number-of-arguments (codeinf code-pointer))))
138	     (cond
139		  ((weq num-args -1) "any")
140		  ((and (wgeq num-args 0)
141			(wleq num-args maxargs)) num-args)
142		  (t NIL)
143		  )
144	     )
145	 )
146    )
147
148
149(de putd (fnname fntype fnexp)
150
151  % Install function definition
152  %
153  % this differs from the SL Report in 2 ways:
154  % - function names flagged LOSE are not defined.
155  % -   "      "   which are already fluid or global are defined anyway,
156  % with a warning.
157  %
158
159  (cond ((not (idp fnname)) (noniderror fnname 'putd))
160	((not (memq fntype '(expr fexpr macro nexpr)))
161	 (conterror 1305 "%r is not a legal function type" fntype
162		    (putd fnname fntype fnexp)))
163	((flagp fnname 'lose)
164	 (errorprintf "*** %r has not been defined, because it is flagged LOSE"
165		      fnname)
166	 nil)
167	(t (prog (vartype
168		  printredefinedmessage
169		  oldin
170		  u
171		  promptstring*
172		  queryresponse)
173		 (unless
174		       (funboundp fnname)
175		       % THEN
176		       (when
177			    *redefmsg
178			    % THEN
179			    (setq printredefinedmessage t))
180		       (when
181			    (and *usermode
182				 (not (flagp fnname 'user)))
183			    % THEN
184			    (if
185			       (not (yesp (bldmsg
186			    "Do you really want to redefine the system function %r?"
187						  fnname)))
188			       % THEN
189			       (return nil)
190			       % ELSE
191			       (flag1 fnname 'user))))
192		 (when (and (setq u (getd fnname))
193			    (codep (cdr u))
194			    (wlessp (inf (cdr u))
195				    nonkernelupperbound*)
196			)
197			(flag1 fnname 'planttrampoline)
198		 )
199
200		 (cond
201		      ((codep fnexp) (makefcode fnname fnexp)
202				     (remprop fnname '*lambdalink))
203		      ((and (idp fnexp)
204			    (not (funboundp fnexp)))
205		       (return (putd fnname fntype (cdr (getd fnexp)))))
206		      (*comp
207			    (return (compd fnname fntype fnexp)))
208		      ((and (flagp fnname 'planttrampoline)
209			    (eqcar fnexp 'lambda))
210			(planttrampoline fnname (length (cadr fnexp)))
211			(put fnname '!*lambdalink fnexp)
212		       )
213
214		      ((eqcar fnexp 'lambda)
215					    (put fnname '*lambdalink fnexp)
216					    (makeflambdalink fnname))
217		      (t
218			(return
219			       (conterror 1105
220					  "Ill-formed function expression in PutD"
221					  (putd fnname fntype fnexp)
222					  )
223			       )
224			)
225		      )
226
227		 (if
228		    (neq fntype 'expr)
229		    % THEN
230		    (put fnname 'type fntype)
231		    % ELSE
232		    (remprop fnname 'type))
233
234		 (if
235		    *usermode
236		    (flag (list fnname) 'user)
237		    (remflag (list fnname) 'user))
238
239		 (when
240		      printredefinedmessage
241		      % THEN
242		      (errorprintf "*** Function %r has been redefined"
243				   fnname))
244		 (return fnname)
245		 )
246	   )
247	)
248  )
249
250(de trampoline()(compiledcallinginterpreted))
251
252(de planttrampoline(u p)
253   % install an indirect call to compiledcallinginterpreted
254   (let ((m (gtbps 4))
255	 (n (id2int u))
256	 %  (p (getmem (wdifference (inf (cdr (getd u))) 4)))
257	 (a (inf (cdr (getd 'trampoline)))) )
258	(putmem m p)
259	(putmem (wplus2 m 4) (getmem a))
260	(putmem (wplus2 m 8) (getmem (wplus2 a 4)))
261	(putmem (wplus2 m 12) (getmem (wplus2 a 8)))
262	(putmem (wplus2 m 5) n)
263	   % now plant it
264	(setf (getmem (wplus2 symfnc (wtimes2 n 4))) (wplus2 m 4))
265	  ))
266
267(setq nonkernelupperbound!* (inf(cdr(getd 'putd))))
268