reduce-historical/psl-1983/kernel/putd-getd.red

%
% PUTD-GETD.RED - Standard Lisp function defining functions
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        18 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>PUTD-GETD.RED.3, 13-Jan-83 19:09:47, Edit by PERDUE
%  Removed obsolete code from PUTD in response to Bobbie Othmer's bug report
%  <PSL.KERNEL>PUTD-GETD.RED.2, 24-Sep-82 15:01:38, Edit by BENSON
%  Added CODE-NUMBER-OF-ARGUMENTS
%  <PSL.INTERP>PUTD-GETD.RED.3, 19-Apr-82 13:10:57, Edit by BENSON
%  Function in PutD may be an ID
%  <PSL.INTERP>PUTD-GETD.RED.4,  6-Jan-82 19:18:47, Edit by GRISS
% Add NEXPR
% DE, DF and DM are defined in EASY-SL.RED

% If the function is interpreted, the lambda form will be found by
%	GET(ID, '!*LambdaLink).

% If the type of a function is other than EXPR (i.e. FEXPR or MACRO or NEXPR),
% this will be indicated by GET(ID, 'TYPE) = 'FEXPR or 'MACRO or 'NEXPR


% PutD makes use of the fact that FLUID and GLOBAL declarations use the
% property list indicator TYPE

% Non-Standard Lisp functions used:
% function cell primitives FUnBoundP, etc. found in FUNCTION-PRIMITVES.RED
% CompD --	in COMPILER.RED
% ErrorPrintF, VerboseTypeError, BldMsg

% Error numbers:
% 1100 - ill-formed function expression
% 1300 - unknown function type
% +5 in GetD

lisp procedure GetD U;			%. Lookup function definition of U
    IDP U and not FUnBoundP U and ((get(U, 'TYPE) or 'EXPR) .
	(if FLambdaLinkP U then get(U, '!*LambdaLink) else GetFCodePointer U));

lisp procedure RemD U;			%. Remove function definition of U
begin scalar OldGetD;
    if (OldGetD := GetD U) then
    <<  MakeFUnBound U;
	RemProp(U, 'TYPE);
	RemProp(U, '!*LambdaLink) >>;
    return OldGetD;
end;

fluid '(!*RedefMSG			% controls printing of redefined
	!*UserMode);			% controls query for redefinition
LoadTime
<<  !*UserMode := NIL;			% start in system mode
    !*RedefMSG := T >>;			% message in PutD

fluid '(!*Comp				% controls automatic compilation
	PromptString!*);

lisp procedure PutD(FnName, FnType, FnExp);	%. Install function definition
%
% this differs from the SL Report in 2 ways:
% - function names flagged LOSE are not defined.
% - 	"      "   which are already fluid or global are defined anyway,
% with a warning.
%
    if not IDP FnName then
	NonIDError(FnName, 'PutD)
    else if not (FnType memq '(EXPR FEXPR MACRO NEXPR)) then
	ContError(1305,
		  "%r is not a legal function type",
		  FnType,
		  PutD(FnName, FnType, FnExp))
    else if FlagP(FnName, 'LOSE) then
    <<  ErrorPrintF("*** %r has not been defined, because it is flagged LOSE",
		    FnName);
	NIL >>
    else begin scalar VarType, PrintRedefinedMessage, OldIN, PromptString!*,
			QueryResponse;
	if not FUnBoundP FnName then
	<<  if !*RedefMSG then PrintRedefinedMessage := T;
	    if !*UserMode and not FlagP(FnName, 'USER) then
		if not YesP BldMsg(
		"Do you really want to redefine the system function %r?",
								   FnName)
		then return NIL
		else Flag1(FnName, 'USER) >>;
	if CodeP FnExp then
	<<  MakeFCode(FnName, FnExp);
	    RemProp(FnName, '!*LambdaLink) >>
	else if IDP FnExp and not FUnBoundP FnExp then return
	    PutD(FnName, FnType, cdr GetD FnExp)
	else if !*Comp then
	    return CompD(FnName, FnType, FnExp)
	else if EqCar(FnExp, 'LAMBDA) then
	<<  put(FnName, '!*LambdaLink, FnExp);
	    MakeFLambdaLink FnName >>
	else return ContError(1105,
			      "Ill-formed function expression in PutD",
			      PutD(FnName, FnType, FnExp));
	if FnType neq 'EXPR then put(FnName, 'TYPE, FnType)
	    else RemProp(FnName, 'TYPE);
	if !*UserMode then Flag1(FnName, 'USER) else RemFlag1(FnName, 'USER);
	if PrintRedefinedMessage then
	    ErrorPrintF("*** Function %r has been redefined", FnName);
	return FnName;
    end;

on Syslisp;

syslsp procedure code!-number!-of!-arguments cp;
begin scalar n;
    return if codep cp then 
    <<  n := !%code!-number!-of!-arguments CodeInf cp;
	if n >= 0 and n <= MaxArgs then n >>;
end;

END;