reduce-historical/psl-1983/20-kernel/system-extras.red

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

%  <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))
      (hrli 1 8#440700)			% 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 := SymFnc;
    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;