File psl-1983/3-1/kernel/20/system-extras.red artifact 5611c0d343 part of check-in eb17ceb7f6

%
% 20-EXTRAS.RED - System-specific functions for Dec-20 PSL
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        4 March 1982
% Copyright (c) 1982 University of Utah
%

%  21-May-83 Mark R. Swanson
%    Made local byte pointer into global byte pointer in DATE; changed 
%    ReturnAddressP to use only low halfword of value in SYMFNC table.
%  <PSL.KERNEL-20>SYSTEM-EXTRAS.RED.3,  5-Jan-83 16:46:34, Edit by PERDUE
%  Added ExitLISP, for the DEC-20 a synonym of QUIT

fluid '(system_list!*);

if_system(Tenex,
    if_system(KL10,
	system_list!* := '(Dec20 PDP10 Tenex KL10),
	system_list!* := '(Dec20 PDP10 Tenex)),
    system_list!* := '(Dec20 PDP10 Tops20 KL10));

lap '((!*entry Quit expr 0)
      (haltf)
      (!*MOVE '"Continued" (reg 1))
      (!*EXIT 0)
);

CopyD('ExitLISP, 'Quit);

lap '((!*entry Date expr 0)
      (!*MOVE (WConst 8) (reg 1))	% allocate a 9 character string
      (!*CALL GtStr)
      (!*MOVE (reg 1) (reg 4))		% save it in 4
      (!*WPLUS2 (reg 1) (WConst 1))
      (tlo 1 8#610000)			% create a byte pointer to it
      (!*MOVE (WConst -1) (reg 2))	% current date
      (hrlzi (reg 3) 2#0000000001)	% ot%ntm, don't output time
      (odtim)
      (!*MOVE (reg 4) (reg 1))
      (!*MKITEM (reg 1) (WConst STR))	% tag it as a string
      (!*EXIT 0)
);

if_system(KL10, NIL,
lap '((!*Entry StackOverflow expr 0)
      (sub (reg ST) (lit (halfword 1000 1000)))	% back up stack
      (!*MOVE '"Stack overflow" (reg 1))
      (!*JCALL StdError)
));

on SysLisp;

syslsp procedure ReturnAddressP X;
begin scalar Y, Z;
    Z := Field(&SymFnc, 18, 18); % don't want any opcode bits in Z
				 % may someday want to use 23 bits, though.
    return Field(X, 0, 18) = 2#011001000000000000	% PC flags
    and Field(@(X - 1), 0, 18) = 8#260740	% pushj 17,
    and (Y := Field(@(X - 1), 18, 18) - Z) > 0 and Y < MaxSymbols
    and MkID Y;
end;

off SysLisp;

END;