File psl-1983/tests/p-function-primitives.red from the latest check-in


% TEST-FUNCTION-PRIMITIVES Machine Independent for Test 5 and 6
%
% Author:      M. L. Griss
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        21 October 1982
% Copyright (c) 1982 University of Utah
%
% Based on P20:Function-Primitives.Red
%  <PSL.TESTS>P-FUNCTION-PRIMITIVES.RED.4,  2-Mar-83 11:46:30, Edit by KESSLER
%  Put in Dealloc's before jump and jcall (search rrk)

% Every ID has a "function cell".  It does not necessarily contain a legal
% Lisp item, and therefore should not be accessed directly by Lisp functions.
% In this implementation the function cell contains an instruction to be
% executed.  There are 3 possibilites for this instruction, for which the
% following predicates and updating functions exist:
%
%	FUnBoundP(ID) -- the function is not defined
%	FLambdaLinkP(ID) -- the function is interpreted
%	FCodeP(ID) -- the function is compiled
%
%	MakeFUnBound(ID) -- undefine the function
%	MakeFLambdaLink(ID) -- specify that the function is interpreted
%	MakeFCode(ID, CodePtr) -- specify that the function is compiled,
%				   and that the code resides at the address
%				   associated with CodePtr
%
%	GetFCodePointer(ID) -- returns the contents of the function cell as a
%				code pointer
%
% See the templates in XXX-ASM.RED:
%
%       DefinedFunctionCellFormat!*
%	UndefinedFunctionCellFormat!*


% These functions currently check that they have proper arguments, 
% but this may change since they are only used by functions that 
% have checked them already.

% Note that on some machines, SYMFNC(x) is entire SYMFNC cell.
%           on others it points into the cell, at the "address" part.
% 
% Fairly Portable versions, based on assumption that
%      Starts with OPCODE, probably !*JCALL
%      !*Jcall SymfncBase UndefinedFunction  in ShouldBeUndefined cell

% Needs the machine-dependent procedures in XXX-HEADER:

%    !%Store!-JCALL(CodeAddress,StoreAddress)
%        to Create a !*Jcall(CodeAddress) at StoreAddress

%    !%Copy!-Function!-Cell(From,to)
%        to copy appropriate # words or bytes of Function cell
on syslisp;

smacro procedure SymFncBase D;   % The Address of CELL, 
				 %  to which !*JCALL and !*CALL jump
  Symfnc + AddressingUnitsPerFunctionCell*D;


% Unbound Functions have a JCALL UndefinedFunction:
% in the function cell, installed by the template

syslsp procedure FUnBoundP Fn;       
% Check If undefn or Not
 If not IDP Fn then NonIdError(Fn,'FunboundP)
  else  if (SymFnc IdLoc ShouldBeUndefined eq SymFnc IdInf Fn)
   % Instead of SYMFNCBASE Idloc UndefinedFunction, since its
   % of course DEFINED, and has to agree with the KernelTime template
    then 'T else 'NIL;

syslsp procedure MakeFUnBound(D);
% Install the correct Bit Pattern in SYMFNC cell
 If not IDP D then NonIdError(D,'MakeFUnbound)
  else !%copy!-function!-cell(symfncbase Idloc ShouldBeUndefined,
			      symfncbase IdInf D);

syslsp procedure FLambdaLinkP fn;
 If not IDP Fn then NonIdError(Fn,'FunboundP)
  else  if (SymFnc IdLoc CompiledCallingInterpreted eq SymFnc(IdInf Fn))
  % This installed by MakeFlambdaLink
     then 'T else 'NIL;

syslsp procedure MakeFlambdaLink D;
% Install the correct Bit Pattern in SYMFNC cell
 If not IDP D then NonIdError(D,'MakeFUnbound)
  else !%store!-JCALL(symfnc Idloc CompiledCallingInterpreted,
                              Symfncbase IdInf D); % SetUp as above

syslsp procedure FcodeP Fn;          
% Check if Code or Interp
 If not IDP Fn then NonIdError(Fn,'FcodeP)
  else if FUnboundP Fn or FLambdaLinkP Fn then NIL else T;

syslsp procedure MakeFCode(U, CodePtr);
%  Make U a compiled function
 if IDP U then
	if CodeP CodePtr then
	<<!%Store!-JCALL(CodeInf Codeptr,
                         SymfncBase IdInf U);
	    NIL >>
    else NonIDError(U, 'MakeFCode);


syslsp procedure GetFCodePointer U;
%  Get code pointer for U
  if IDP U then if FCodeP U then MkCODE SymFnc U % do we want Fcodep check
                 else NIL
    else NonIDError(U, 'GetFCodePointer);
   %/Check that IS codeP?


% Code Calling Primitives

% See PI: P-APPLY-LAP.RED by BENSON
% See also Pxxx:APPLY-LAP.RED

Fluid '(CodePtr!* CodeForm!* CodeNarg!*);

LAP '((!*entry CodePrimitive expr 15)
%	Takes the code pointer stored in the fluid variable CodePtr!*
%	and jumps to its address, without disturbing 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.
	(!*ALLOC 0)
	(!*MOVE (Fluid CodePtr!*) (reg t1))
        (!*FIELD (reg t1) (reg t1)    % get CodeINF
 		 (WConst InfStartingBit) (WConst InfBitLength))
% rrk - 03/02/83 If alloc did anything we need to get rid of it before the jump
        (!*Dealloc 0)
        (!*JUMP (memory (reg t1) (Wconst 0)))
	(!*EXIT 0)
);


LAP '((!*entry CompiledCallingInterpreted expr 15)
%	Called by some convention from the function cell of an ID which
%	has an interpreted function definition.  It should store the
%       Linkreg into
%       the fluid variable CodeForm!* without disturbing the argument
%	registers
%
%
      (!*ALLOC 0)
      (!*CALL SaveRegisters)     % !*CALL to avoid resetting LinkInfo
      (!*Move (reg LinkReg) (fluid CodeForm!*))
      (!*Move (reg NargReg) (fluid CodeNarg!*))
% rrk - 03/02/83 If alloc did anything we need to get rid of it before the jump
      (!*Dealloc 0)
      (!*JCALL CompiledCallingInterpretedAux)
      (!*Exit 0)
);


LAP '((!*entry FastApply expr 0)
%	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).
	(!*ALLOC 0)
	(!*MOVE (reg t1) (FLUID CodeForm!*))	% save input form
	(!*FIELD (reg t2) (reg t1)
		 (WConst TagStartingBit) (WConst TagBitLength))
	(!*FIELD (reg t1) (reg t1)
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*JUMPNOTEQ (Label NotAnID) (reg t2) (WConst ID))
        (!*MOVE  (reg t1) (reg LinkReg))    % Reset IDLOC name
                                            % NargReg is OK
   	(!*WTIMES2 (reg t1) (WConst AddressingUnitsPerFunctionCell))
% rrk 03/03/83
	(!*Dealloc 0)
	(!*JUMP (MEMORY (reg t1) (WArray SymFnc)))
NotAnID
	(!*JUMPNOTEQ (Label NotACodePointer) (reg t2) (WConst CODE))
% rrk 03/03/83
	(!*Dealloc 0)
	(!*JUMP (MEMORY (reg t1) (WConst 0)))
NotACodePointer
	(!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR))
	(!*MOVE (MEMORY (reg t1) (WConst 0)) (reg t2))
					% CAR with pair already untagged
	(!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (QUOTE LAMBDA))
% rrk 03/03/83
	(!*Dealloc 0)
    % Note that t1 is INF of the PAIR
	(!*JCALL FastLambdaApply)               % CodeForm!*
						% Already Loaded
IllegalFunctionalForm
	(!*MOVE (QUOTE "Illegal functional form in Apply") (reg 1))
	(!*MOVE (FLUID CodeForm!*) (reg 2))
	(!*CALL List2)
% rrk 03/03/83
	(!*Dealloc 0)
	(!*JCALL StdError)
%	(!*EXIT 0) --> what is this!
);

Exported Warray CodeArgs[15];

syslsp procedure SaveRegisters(A1, A2, A3, A4, A5, 
% Duplicate in P-APPLY
			       A6, A7, A8, A9, A10,
			       A11, A12, A13, A14, A15);
<<  CodeArgs[14] := A15;
    CodeArgs[13] := A14;
    CodeArgs[12] := A13;
    CodeArgs[11] := A12;
    CodeArgs[10] := A11;
    CodeArgs[9]  := A10;
    CodeArgs[8]  := A9;
    CodeArgs[7]  := A8;
    CodeArgs[6]  := A7;
    CodeArgs[5]  := A6;
    CodeArgs[4]  := A5;
    CodeArgs[3]  := A4;
    CodeArgs[2]  := A3;
    CodeArgs[1]  := A2;
    CodeArgs[0]  := A1 >>;


LAP '((!*ENTRY UndefinedFunctionAux expr 0) 
%	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.
      (!*ALLOC 0)	
      (!*CALL SaveRegisters)   % !*CALL so as not to change LinkInfo
                               % Was stored in UndefnCode!* UndefnNarg!*
% rrk 03/03/83
      (!*Dealloc 0)
      (!*JCALL UndefinedFunctionAuxAux)
%     (!*EXIT 0)
);

off syslisp;

  End;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]