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