reduce-historical/psl-1983/3-1/tests/p-apply-lap.red

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