Artifact 31efd240f348fbc552696dba4a6a4f7fd7aff962d2273bb9580c6e966d126720:

• File psl-1983/3-1/tests/p-apply-lap.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: 9543) [annotate] [blame] [check-ins using] [more...]

%
% P-APPLY-LAP.RED - Inefficient, portable version of APPLY-LAP
% 
% Author:      Eric Benson and M. L. Griss
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        29 July 1982
% Copyright (c) 1982 University of Utah
%
% Modifications by M.L. Griss 25 October, 1982.
% Added J. MacDonalds Mods of 29 January (for IBM, non neg stack index)
% 	In CODEEVALAPLY
% Functions which must be written non-portably, 
%   "portable" versions defined in PT:TEST-FUNCTION-PRIMITIVES.RED

% CodePrimitive
%	Takes the code pointer stored in the fluid variable CodePtr!*
%	and jumps to its address, without distubing any of the argument
%	registers.  This can be flagged 'InternalFunction for compilation
%	before this file is compiled or done as an 'OpenCode and 'ExitOpenCode
%	property for the compiler.
% CompiledCallingInterpreted
%	Called by some convention from the function cell of an ID which
%	has an interpreted function definition.  It should store the ID
%	in the fluid variable CodeForm!* without disturbing the argument
%	registers, then finish with
%	(!*JCALL CompiledCallingInterpretedAux)
%	(CompiledCallingInterpretedAux may be flagged 'InternalFunction).
% FastApply
%	Called with a functional form in (reg t1) and argument registers
%	loaded.  If it is a code pointer or an ID, the function address
%	associated with either should be jumped to.  If it is anything else
%	except a lambda form, an error should be signaled.  If it is a lambda
%	form, store (reg t1) in the fluid variable CodeForm!* and
%	(!*JCALL FastLambdaApply)
%	(FastLambdaApply may be flagged 'InternalFunction).
% UndefinedFunction
%	Called by some convention from the function cell of an ID (probably
%	the same as CompiledCallingInterpreted) for an undefined function.
%	Should call Error with the ID as part of the error message.

Compiletime <<

fluid '(CodePtr!*		% gets code pointer used by CodePrimitive
	CodeForm!*		% gets fn to be called from code
);
>>;

on Syslisp;

external WArray CodeArgs;

syslsp procedure CodeApply(CodePtr, ArgList);
begin scalar I;
    I := 0;
    LispVar CodePtr!* := CodePtr;
    while PairP ArgList and ILessP(I, 15) do
    <<  WPutV(CodeArgs , I, first ArgList);
	I := IAdd1 I;
	ArgList := rest ArgList >>;
    if IGEQ(I, 15) 
	then return StdError List("Too many arguments to function",I,CodePtr);
    return case I of
    0:	CodePrimitive();
    1:	CodePrimitive WGetV(CodeArgs, 0);
    2:	CodePrimitive(WGetV(CodeArgs, 0), 	WGetV(CodeArgs, 1));
    3:	CodePrimitive(WGetV(CodeArgs, 0), 	WgetV(CodeArgs, 1),
      	        WGetV(CodeArgs, 2));
    4:	CodePrimitive(WGetV(CodeArgs, 0), 	WgetV(CodeArgs, 1),
	        WGetV(CodeArgs, 2), 		WgetV(CodeArgs, 3));
    5:	CodePrimitive(WGetV(CodeArgs, 0), 	WgetV(CodeArgs, 1),
	        WGetV(CodeArgs, 2),	 	WgetV(CodeArgs, 3),
	        WGetV(CodeArgs, 4));
    6:	CodePrimitive(WGetV(CodeArgs, 0), 	WgetV(CodeArgs, 1),
	        WGetV(CodeArgs, 2), 		WgetV(CodeArgs, 3),
	        WGetV(CodeArgs, 4), 		WgetV(CodeArgs, 5));
    7:	CodePrimitive(WGetV(CodeArgs, 0), 	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6));
    8:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7));
    9:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8));
    10:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8),		WgetV(CodeArgs, 9));
    11:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8),		WgetV(CodeArgs, 9),
		WgetV(CodeArgs, 10));
    12:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8),		WgetV(CodeArgs, 9),
		WgetV(CodeArgs, 10),		WgetV(CodeArgs, 11));
    13:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8),		WgetV(CodeArgs, 9),
		WgetV(CodeArgs, 10),		WgetV(CodeArgs, 11),
		WgetV(CodeArgs, 12));
    14:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8),		WgetV(CodeArgs, 9),
		WgetV(CodeArgs, 10),		WgetV(CodeArgs, 11),
		WgetV(CodeArgs, 12),		WgetV(CodeArgs, 13));
    15:	CodePrimitive(WgetV(CodeArgs, 0),	WgetV(CodeArgs, 1),
		WgetV(CodeArgs, 2),		WgetV(CodeArgs, 3),
		WgetV(CodeArgs, 4),		WgetV(CodeArgs, 5),
		WgetV(CodeArgs, 6),		WgetV(CodeArgs, 7),
		WgetV(CodeArgs, 8),		WgetV(CodeArgs, 9),
		WgetV(CodeArgs, 10),		WgetV(CodeArgs, 11),
		WgetV(CodeArgs, 12),		WgetV(CodeArgs, 13),
		WgetV(CodeArgs, 14));
    end;
end;

%lisp procedure CodeEvalApply(CodePtr, ArgList);
%    CodeApply(CodePtr, EvLis ArgList);

lap '((!*entry CodeEvalApply expr 2)
	(!*ALLOC 15)
	(!*LOC (reg 3) (frame 15))  %/jim really wrong/
% 	(!*LOC (reg 3) (frame 1))   %/jim: for non-neg stack indices on IBM/
		                    % But must be base of a block of ascending
				    % addresses, check cmacros
	(!*CALL CodeEvalApplyAux)
	(!*EXIT 15)
);

syslsp procedure CodeEvalApplyAux(CodePtr, ArgList, P);
begin scalar N;
    N := 0;
    while PairP ArgList and ILessP(N, 15) do
 %/    <<  WPutV(P, ITimes2(StackDirection, N), Eval first ArgList); %/jim/
     <<  WPutV(P, N, Eval first ArgList);                            %/jim/
	ArgList := rest ArgList;
	N := IAdd1 N >>;
    if IGEQ(N, 15) 
	then return StdError list("Too many arguments to function",N,CodePtr);
    LispVar CodePtr!* := CodePtr;
    return case N of
    0:	CodePrimitive();
    1:	CodePrimitive(WgetV(P, 0));
    2:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1));
    3:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2));
    4:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3));
    5:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4));
    6:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5));
    7:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6));
    8:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7));
    9:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8));
    10:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8),
		WgetV(P, 9));
    11:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8),
		WgetV(P, 9),		WgetV(P, 10));
    12:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8),
		WgetV(P, 9),		WgetV(P, 10),	WgetV(P, 11));
    13:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8),
		WgetV(P, 9),		WgetV(P, 10),	WgetV(P, 11),
		WgetV(P, 12));
    14:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8),
		WgetV(P, 9),		WgetV(P, 10),	WgetV(P, 11),
		WgetV(P, 12),		WgetV(P, 13));
    15:	CodePrimitive(WgetV(P, 0),	WgetV(P, 1),	WgetV(P, 2),
		WgetV(P, 3),		WgetV(P, 4),	WgetV(P, 5),
		WgetV(P, 6),		WgetV(P, 7),	WgetV(P, 8),
		WgetV(P, 9),		WgetV(P, 10),	WgetV(P, 11),
		WgetV(P, 12),		WgetV(P, 13),	WgetV(P, 14));
    end;
end;

syslsp procedure BindEval(Formals, Args);
    BindEvalAux(Formals, Args, 0);

syslsp procedure BindEvalAux(Formals, Args, N);
begin scalar F, A;
    return if PairP Formals then
	if PairP Args then
	<<  F := first Formals;
	    A := Eval first Args;
	    N := BindEvalAux(rest Formals, rest Args, IAdd1 N);
	    if N = -1 then -1 else
	    <<  LBind1(F, A);
		N >> >>
	else -1
    else if PairP Args then -1
    else N;
end;

syslsp procedure CompiledCallingInterpretedAux();
<< %Later Use NARGS also
   % Recall that ID# in CODEFORM
    CompiledCallingInterpretedAuxAux 
	get(MkID(LispVar CodeForm!*), '!*LambdaLink)>>;

syslsp procedure FastLambdaApply();
<<  SaveRegisters();
    CompiledCallingInterpretedAuxAux LispVar CodeForm!* >>;

syslsp procedure CompiledCallingInterpretedAuxAux Fn;
    if not (PairP Fn and car Fn = 'LAMBDA) then
	StdError BldMsg("Ill-formed functional expression %r for %r",
						  Fn,  LispVar CodeForm!*)
    else begin scalar Formals, N, Result;
	Formals := cadr Fn;
	N := 0;
	while PairP Formals do
	<<  LBind1(car Formals,WgetV(CodeArgs, N));
	    Formals := cdr Formals;
	    N := IAdd1 N >>;
	Result := EvProgN cddr Fn;
	if N neq 0 then UnBindN N;
	return Result;
    end;

off Syslisp;

END;