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% 01-Oct-88 (Tony Hearn)
46%  Replaced single use of flag1/remflag1 by flag/remflag to make module
47%  less dependent on non-SL functions.
48% 23-May-84 16:16:15 (Mike Creech)
49%  Rewrote code-number-of-arguments to deal with functions that were
50%  defined to have any number of arguments (-1 in *entry definition).
51%  Reformatted PUTD to make more readable.
52%  Rewrote remd to be more readable.
53%  Reformatted getd to be more readable (and changed u => func).
54% 01-Dec-83 14:59:44 (Brian Beach)
55%   Translated from Rlisp to Lisp.
56%
57%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
58
59(de getd (func)
60
61    % Lookup function definition of func.
62
63    (and
64        (idp func)
65	(not (funboundp func))
66	(cons (or (get func 'type)
67		  'expr)
68	      (if
69		 (flambdalinkp func)
70		 % THEN
71		 (get func '*lambdalink)
72		 % ELSE
73		 (getfcodepointer func)))))
74
75(de remd (func)
76
77    % Remove function definition of func.
78
79    (let
80        ((oldgetd (getd func)))
81	(when
82	     oldgetd
83	     % THEN There was an old definition.
84	     (makefunbound func)
85	     (remprop func 'type)
86	     (remprop func '*lambdalink))
87	% Return the old definition.
88        oldgetd)
89    )
90
91(fluid '(*redefmsg % controls printing of redefined
92	 *usermode % controls query for redefinition
93	 ))
94
95(loadtime
96  (progn (setq *usermode nil)  % start in system mode
97         (setq *redefmsg t)    % message in PutD
98	 ))
99
100(fluid '(*comp % controls automatic compilation
101	 promptstring*))
102
103(de code-number-of-arguments (code-pointer)
104
105    % Return the number of arguments within the range 0-maxargs, or
106    % "any" if function is setup to have any number of arguments, or
107    % NIL if not a code-pointer or too many arguments.
108
109    (when
110         (codep code-pointer)
111	 % THEN We have a real codepointer.
112	 (let
113	     ((num-args (!%code-number-of-arguments (codeinf code-pointer))))
114	     (cond
115	          ((weq num-args -1) "any")
116		  ((and (wgeq num-args 0)
117			(wleq num-args maxargs)) num-args)
118		  (t NIL)
119		  )
120	     )
121	 )
122    )
123
124
125(de putd (fnname fntype fnexp)
126
127  % Install function definition
128  %
129  % this differs from the SL Report in 2 ways:
130  % - function names flagged LOSE are not defined.
131  % - 	"      "   which are already fluid or global are defined anyway,
132  % with a warning.
133  %
134
135  (cond ((not (idp fnname)) (noniderror fnname 'putd))
136        ((not (memq fntype '(expr fexpr macro nexpr)))
137         (conterror 1305 "%r is not a legal function type" fntype
138                    (putd fnname fntype fnexp)))
139        ((flagp fnname 'lose)
140         (errorprintf "*** %r has not been defined, because it is flagged LOSE"
141                      fnname)
142         nil)
143        (t (prog (vartype
144		  printredefinedmessage
145		  oldin
146		  promptstring*
147                  queryresponse)
148                 (unless
149		       (funboundp fnname)
150		       % THEN
151		       (when
152			    *redefmsg
153			    % THEN
154			    (setq printredefinedmessage t))
155		       (when
156			    (and *usermode
157				 (not (flagp fnname 'user)))
158			    % THEN
159			    (if
160			       (not (yesp (bldmsg
161                     "Do you really want to redefine the system function %r?"
162                                                  fnname)))
163			       % THEN
164			       (return nil)
165			       % ELSE
166			       (flag1 fnname 'user))))
167                 (cond
168		      ((codep fnexp) (makefcode fnname fnexp)
169		                     (remprop fnname '*lambdalink))
170		      ((and (idp fnexp)
171			    (not (funboundp fnexp)))
172		       (return (putd fnname fntype (cdr (getd fnexp)))))
173		      (*comp
174		            (return (compd fnname fntype fnexp)))
175		      ((eqcar fnexp 'lambda)
176                                            (put fnname '*lambdalink fnexp)
177					    (makeflambdalink fnname))
178		      (t
179                        (return
180                               (conterror 1105
181				  "Ill-formed function expression in PutD"
182				  (putd fnname fntype fnexp)
183				)
184			       )
185			)
186		      )
187
188                 (if
189		    (neq fntype 'expr)
190		    % THEN
191		    (put fnname 'type fntype)
192		    % ELSE
193		    (remprop fnname 'type))
194
195                 (if
196		    *usermode
197		    (flag (list fnname) 'user)
198		    (remflag (list fnname) 'user))
199
200		 (when
201		      printredefinedmessage
202		      % THEN
203		      (errorprintf "*** Function %r has been redefined"
204				   fnname))
205                 (return fnname)
206		 )
207	   )
208	)
209  )
210
211
212