Artifact 8902b587cb569584e72cdffa1770ee1fc9497f1ed5c6762d13a4b7f1a2b6b6e1:

• File psl-1983/3-1/util/20/20-interrupt.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 8987) [annotate] [blame] [check-ins using] [more...]

%
% 20-INTERRUPT.RED  -- Crude Interrupt Handler for DEC-20
% Author:      M. L. Griss  and D. Morrison
%              Utah Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        20 May 1981
% Copyright (c) University of Utah

%
% 9-June-1983 Mark R. Swanson
%  Changes for extended addressing
%
% It is assumed that the system dependent portion of an implementation will
%supply the following 3 functions:
%
%   InitializeInterrupts
%   EnableInterrupts
%   DisableInterrupts
%   DismissInterrupt
%
% While these are machine dependent, the interrupt handlers themselves are
% are expected to generally be machine independent, simply calling
% DismissInterrupt when done.  The assignment of terminal-initiated interrupts
% to keys is machine dependent.

imports '(Addr2ID);			% for code-address-to-symbol

on Syslisp;

%internal WARRAY InterruptLevelTable[2], 
%                InterruptPCStorage[2],
%                InterruptChannelTable[35];

FLUID '(InterruptLevelTable
	LoadAverageStore
        InterruptPCStorage
	InterruptArgBlock
        InterruptChannelTable
);

compiletime << WCONST !.FHSLF=8#400000;>>;

if FUnBoundP 'XJsysError then <<
syslsp procedure XJsysError();		% autoloading stub
<<  Load JSYS;
    Apply(function XJsysError, '()) >>;
>>;

syslsp procedure InitializeInterrupts();
% Initializes interrupt handlers for both machine- and terminal-initiated
% interrupts.  Most cases should dispatch to machine-independent handlers.
% Leaves the interrupt system enabled.
% In this Tops-20 (machine-code) version we currently handle:
%   just playing, for now
begin
  (LispVar InterruptArgBlock):=GtWarray 3;
  (LispVar InterruptLevelTable):=GtWarray 3;
  (LispVar InterruptPCStorage):=GtWarray 6;
  (LispVar InterruptChannelTable):=GtWarray 36;
  (LispVar LoadAverageStore) := MkString(4, char BLANK);
  ClearInterrupts();

  (LispVar InterruptArgBlock)[0]:=3; % block length
  (LispVar InterruptArgBlock)[1]:=(LispVar InterruptLevelTable);
  (LispVar InterruptArgBlock)[2]:=(LispVar InterruptChannelTable);
  % set up interrupt tables -- see Monitor Calls Manual for details
  For i := 0:35 do             %/ Some bug, wiped out next one when after
    (LispVar InterruptChannelTable)[i]:=0;

  for i := 0:2 do
      (LispVar InterruptLevelTable)[i]:=(LispVar InterruptPCStorage) + 
                                               (i * 2); % each entry is 2 words

  % Terminal Interupts (Procedure on channel/level)
  % Note LEVEL is 1,2,3
  PutInterrupt(0,1,'DoControlG);
  PutInterrupt(1,1,'SaveAndCallControlT);	% control T not working yet
  PutInterrupt(2,1,'SaveAndBreak);
  % special channels
  PutInterrupt(6,1,'ArithOverflow);
  PutInterrupt(7,1,'FloatArithOverflow);
  PutInterrupt(9,1,'PushDownOverflow);

  % Now Install tables
  Xjsys0(!.FHSLF,
	 (LispVar InterruptArgBlock),0,0,const jsXSIR!%);
  EnableInterrupts();
  ActivateChannel(0);
  ActivateChannel(1);
  ActivateChannel(2);
  ActivateChannel(6);
  ActivateChannel(7);
  ActivateChannel(9);
  PutTerminalInterrupt(7,0); % Char CNTRL-G on 0
  PutTerminalInterrupt(4,0); % Char CNTRL-D on 2
  PutTerminalInterrupt(20,1); % Char cntrl-t on 1, not working yet
  PutTerminalInterrupt(0,2); % Char BREAK on 2
  PutTerminalInterrupt(2,2); % Char cntrl-B on 2
  
  ClearInterrupts(); 
end;

syslsp procedure SetContinueAddress(Level,Address);
begin scalar x;
 x:=(LispVar InterruptLevelTable)[Level-1];
 x[1]:=address; % second word is for PC
 end;

% FunctionCellLocation is used by LAP

off Syslisp;

fluid '(!*WritingFaslFile);

lisp procedure SetContinueFunction(Level,FunctionName);
begin scalar !*WritingFaslFile;
    % assume all function cells in section 1 for global addressing
    SetContinueAddress(Level, 8#1000000 + FunctionCellLocation FunctionName);
end;

lisp procedure PutInterrupt(Channel,Level,ActionId);
begin scalar !*WritingFaslFile;
    % assume all function cells in section 1 for global addressing
    WPutV(InterruptChannelTable,
	  Channel,
	  MkItem(Level,8#1000000 + FunctionCellLocation ActionId));
end;

on Syslisp;

syslsp procedure XWD(a,b);
 Lor(Lsh(a,18),b);

syslsp procedure PutTerminalInterrupt(CntrlChar,Channel);
  Xjsys0(XWD(CntrlChar,Channel),0,0,0,const jsATI);

syslsp procedure RemoveTerminalInterrupt(CntrlChar,Channel);
  Xjsys0(XWD(CntrlChar,Channel),0,0,0,const jsDTI);

syslsp procedure ReadTerminalWord;
  Xjsys1(0,0,0,0,Const jsRTIW);

syslsp procedure SetTerminalWordBit(n);
 <<XJsys0(Lor(ReadTerminalLWord(),Dec20Bit n),0,0,const jsSTIW);
   ReadTerminalWord()>>;

syslsp procedure SetTerminalWord(MSK);
 <<Xjsys0(Lor(ReadTerminalWord(),MSK),0,0,0,const jsSTIW);
   ReadTerminalWord()>>;

syslsp procedure ClearInterrupts;
  Xjsys0(0,0,0,0,const jsCIS); % clear any pending interrupts

syslsp procedure SignalChannel n; %. Test on channel n
  Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsIIC);

syslsp procedure EnableInterrupts;
 Xjsys0(!.FHSLF,0,0,0,const jsEIR);

syslsp procedure DisableInterrupts;
 Xjsys0(!.FHSLF,0,0,0,const jsDIR);

syslsp procedure ActivateChannel(n); %. Inform OS of channel
 Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsAIC);

syslsp procedure DeActivateChannel(n); %. Inform OS of channel
 Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsDIC);

syslsp procedure Dec20Bit n; %. Bits [0 to 35]
  Dec20Fld(1,35-n);

syslsp procedure Dec20Fld(x,y);
   LSH(x,y);

syslsp procedure DismissInterrupt;
% Warning: an interrupt handler should not attempt to resume if may have
% caused a garbage collection.  
Xjsys0(0,0,0,0,const jsDEBRK);


% ----- Some default handlers ----------

syslsp procedure DoControlG;
<<  ClearTerminalInputBuffer();	 % CFIBF
    ClearIO();                   % also clear internal buffer, etc.
    ChannelWriteChar(LispVAR StdOUT!*, Char BELL);
    ErrorPrintF "*** Restarting";
    SetContinueFunction(1,'Reset);
    DismissInterrupt()>>;

syslsp procedure ClearTerminalInputBuffer();
  Xjsys0(8#100,0,0,0,const jsCFIBF);

syslsp procedure ArithOverflow;
 <<SetContinueFunction(1,'ArithOverFlowError);
   DismissInterrupt()>>;

syslsp procedure ArithOverFlowError;
   StdError('"Integer overflow");

syslsp procedure FloatArithOverflow;
 <<SetContinueFunction(1,'FloatArithOverFlowError);
   DismissInterrupt()>>;

syslsp procedure FloatArithOverFlowError;
    StdError('"Floating point overflow");

lap '((!*entry PushDownOverflow expr 0)
	(sub (reg st) (lit (halfword 1000 1000)))	% move the stack back
	(!*MOVE (WConst 1) (REG 1))
	(xmovei 2 ErrorAddress)
	(!*CALL SetContinueAddress)
	(!*JCALL DismissInterrupt)
ErrorAddress
	(!*MOVE '"Stack overflow" (reg 1))
	(!*JCALL StdError)		% normal error
);

lap '((!*entry FindLoadAverage expr 0)
	(move 1 (lit (fullword 8#000014000014)))	% 1 min avg, .systa
	(getab)
	(!*EXIT 0)
	(move 2 (fluid LoadAverageStore))
	(tlz 2 8#770000)
	(tlo 2 8#660000)		% make a byte pointer
	(exch 1 2)
	(move 3 (lit (fullword 8#024037020200)))
	(flout)
	(!*EXIT 0)
	(!*EXIT 0)
);

syslsp procedure DoControlT();
begin scalar RunningFunctionID, CameFrom;
%    ClearTerminalInputBuffer();
    FindLoadAverage();
    CameFrom := LowHalfWord ((LispVar InterruptPCStorage)[1]);
    RunningFunctionID := code!-address!-to!-symbol CameFrom or 'UNKNOWN;
    ErrorPrintF("^T: in %p at %o,   load %w",
	    RunningFunctionID, CameFrom, LispVar LoadAverageStore);
end;
>>;

syslsp procedure DoBreak();
begin scalar RunningFunctionID, CameFrom, CurrentChannel;
    ClearTerminalInputBuffer();
    ClearIO();
    CameFrom := LowHalfWord ((LispVar InterruptPCStorage)[1]);
    RunningFunctionID := code!-address!-to!-symbol CameFrom or 'UNKNOWN;
    CurrentChannel := WRS NIL;
    ErrorPrintF("*** Break in %p at %o", RunningFunctionID, CameFrom);
    ErrorSet(quote Break(), NIL, NIL);
    WRS CurrentChannel;
end;


lap '((!*Entry SaveAndCallControlT expr 0) 
%
% Save all regs, call DoControlT and dismiss
%
	(adjsp (reg st) 14)		% allocate 14 slots on the stack
	(hrri (reg nil) (indexed (reg st) -13))	% set up BLT pointer
	(hrli (reg nil) 1)		% move regs 1..14 onto the stack
	(blt (reg nil) (indexed (reg st) 0))
	(move (reg nil) (fluid nil))	% fix reg nil
	(!*CALL DoControlT)		% call the function
	(hrli (reg nil) (indexed (reg st) -13))
	(hrri (reg nil) 1)
	(blt (reg nil) 14)		% move the registers back off the stack
	(move (reg nil) (fluid nil))	% restore reg nil again
	(adjsp (reg st) -14)
	(debrk)
);
>>;

lap '((!*Entry SaveAndBreak expr 0) 
%
% Save all regs, call DoBreak and dismiss
%
	(adjsp (reg st) 14)		% allocate 14 slots on the stack
	(hrri (reg nil) (indexed (reg st) -13))	% set up BLT pointer
	(hrli (reg nil) 1)		% move regs 1..14 onto the stack
	(blt (reg nil) (indexed (reg st) 0))
	(move (reg nil) (fluid nil))	% fix reg nil
	(!*CALL DoBreak)		% call the function
	(hrli (reg nil) (indexed (reg st) -13))
	(hrri (reg nil) 1)
	(blt (reg nil) 14)		% move the registers back off the stack
	(move (reg nil) (fluid nil))	% restore reg nil again
	(adjsp (reg st) -14)
	(debrk)
);

InitializeInterrupts();

off syslisp;

END;