Artifact f6a032b80f27d6f737949c83b860074a629b307c749ad023e226575102f69cda:

• File psl-1983/3-1/kernel/putd-getd.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4024) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/kernel/putd-getd.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4024) [annotate] [blame] [check-ins using]

%
% 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;