File psl-1983/3-1/tests/20/xxx-header.red artifact da08f7123d part of check-in 3af273af29

% XXX-HEADER.RED for DEC20
% Defines Data spaces, MAIN!. for 20 and I/O interface
%
% Revisions: MLG, 18 Feb 1983
%	     Move HEAP declarations from PT:SUB3
%            and P20T:20-TEST-GLOBAL-DATA.RED 
%	   Add dummy DATE and VersionName routines
on syslisp;
% -----Allocate the stack area

Internal WConst StackSize = 5000;
Internal WArray Stack[StackSize];

exported WVar StackLowerBound = &Stack[0],
	      StackUpperBound = &Stack[StackSize];

external WVar ST;

%--- Allocate HEAP and BPS areas

Internal Wconst HeapSize = 150000;		% Enough for PSL-TIMER
Internal Warray HEAP[HeapSize];			% Could do a Dynamic alloc

exported Wvar   HeapLowerBound = &Heap[0],	% bottom of heap
	        HeapUpperBound = &Heap[HeapSize],
		HeapLast,		        % next free slot in heap	
		HeapTrapBound,			% To catch impending HEAP full
	 	HeapPreviousLast;		% save start of new block

CommentOutcode <<                              % If Copying GC
Internal Warray OtherHeap[HeapSize];
exported WVar OldHeapLast,
	      OldHeapLowerBound = &OtherHeap[0];
	      OldHeapUpperBound = &OtherHeap[HeapSize];
>>;

% Stuff for Compacting GC

exported Wvar HeapTrapped;

internal WConst BitsInsegment=13,
	        GCArraySize = LShift(HeapSize, -BitsInSegment) + 1;

exported WArray GCArray[GCArraySize];

Internal Wconst	BPSSize  = 500;
internal Warray BPS[BPSsize];			% Could do a Dynamic alloc

exported WVar FirstBPS=&BPS[0],  		% Base of BPS, for info
	      NextBPS = &BPS[0],                % allocate CODE up
	      LastBPS = &BPS[BPSSize],          % allocate Warray down
              FinalBPS= &BPS[BPSSize]; 		% For info purposes

syslsp procedure InitHeap();
% Set up Heap base etc.
 <<HeapLast:=HeapLowerBound;
   HeapPreviousLast := 0>>;



% allocate for the "extra" arguments
% 0..MaxArgBlock are arguments (MaxRealRegs + 1)..MaxArgs

internal WConst MaxArgBlock = (MaxArgs - MaxRealRegs) - 1;
exported WArray ArgumentBlock[MaxArgBlock];

% For the ForeignFunction calling protocol
exported Wvar Arg1,Arg2,Arg3,ARg4,Arg5,Arg6,Arg7,Arg8,
              Arg9, Arg10,Arg11,Arg12,Arg13,Arg14,Arg15;


% The hashtable
exported WArray HashTable[MaxObArray/2];

%--- End of Data Definitions ----------
%--- Now do 20 Specific MAIN!. and I/O Interface:

lap '((!*entry Main!. expr 0)
      (reset)
      (move (reg st) (lit (halfword (minus (WConst StackSize))
				      (difference (WConst Stack) 1))))
      (move (reg NIL) (fluid NIL))
      (!*LINKE 0 FirstCall Expr 0)  % Call the MAINn firstroutine
);

% Define "standard" LISP equivalents for the DEC20-MACRO foreign
% functions defined in 20IO.MAC

FLAG('(
   Init20  % Initialize I/O, Timer, etc
   PutC20  % Print Ascii Character, use 10=EOL to get end of line
   GetC20  % Return Ascii Character
   Timc20  % Return CPU time (can also print time check)
   Quit20  % Terminate execution, finalize
   Err20   % Print error message
   PutI20  % print an Integer
),'ForeignFunction);


Global '(IN!* OUT!*);

Procedure Init();
 <<Init20 0;
   LispVar IN!*:=0;
   LispVar Out!*:=1;
   >>;         % Always need one dummy argument

Procedure GetC();
 If LispVar IN!* eq 0 then Getc20 0         % Always need one dummy argument
  else IndependentReadChar LispVar IN!*;

Procedure TimC();
  TimC20 0;         % Always need one dummy argument

procedure PutC x;
 If LispVar Out!* eq 1 then Putc20 x     
  else IndependentWriteChar(LispVar Out!*,x);

procedure Quit;
  Quit20 0;         % always need 1 argument

procedure ExitLisp;
  Quit20 0;

Procedure Reset();
 <<Prin2T "Should RESET here, but will QUIT";
   Quit;>>;

procedure Date;
  '"No-Date-Yet";

Procedure VersionName;
  '"DEC-20 test system";

procedure PutInt I;
  PutI20 I;

% SYMFNC storage routine:
LAP '((!*entry !%Store!-Jcall Expr 2) % CodeAddress, Storage Address
      (!*alloc 0) 
      (!*WOR (reg 1) 8#254000000000)  % Load a JRST in higher-bits
      (!*MOVE (reg 1) (memory (reg 2) (wconst 0)))
      (!*EXIT 0));

LAP '((!*entry !%copy!-function!-cell Expr 2) % from to
      (!*alloc 0) 
      (!*move (memory (reg 1) (Wconst 0)) (memory (reg 2) (wconst 0)))
      (!*exit 0));

FLUID '(UndefnCode!* UndefnNarg!*);

LAP '((!*ENTRY UndefinedFunction expr 0) % For missing Function
 % No alloc 0 ? and no LINKE because dont want to change LinkReg
      (!*MOVE (reg LinkReg) (Fluid UndefnCode!*))
      (!*Move (reg NargReg) (Fluid UndefnNarg!*))
      (!*JCALL UndefinedFunctionAux)
);

procedure LongTimes(x,y);
  x*y;

procedure LongDiv(x,y);
  x/y;

procedure LongRemainder(x,y);
  Remainder(x,y);

off syslisp;

end;