					       (*

 (c) Copyright Hewlett-Packard Company, 1985.
All rights are reserved.  Copying or other
reproduction of this program except for archival
purposes is prohibited without the prior
written consent of Hewlett-Packard Company.


	    RESTRICTED RIGHTS LEGEND

Use, duplication, or disclosure by the Government
is subject to restrictions as set forth in
paragraph (b) (3) (B) of the Rights in Technical
Data and Computer Software clause in
DAR 7-104.9(a).

HEWLETT-PACKARD COMPANY
Fort Collins, Colorado                         *)

$SYSPROG$
$RANGE OFF, STACKCHECK OFF, OVFLCHECK OFF$
$DEBUG OFF$
$ALLOW_PACKED ON$

program installdebugger;

$COPYRIGHT '(C) 1985 HEWLETT-PACKARD CO. 3.0'$
module sysbug;
{ this module is used by the debugger when it needs
  to call system resident code
}
IMPORT SYSGLOBALS, LOADER, SYSDEVS, ASM;
export
  procedure callsyscode(i : integer);
implement
  type
    menu1 = array[boolean] of menutype;
    menu2 = array[m_none..m_sysshift] of menu1;
  const
    mstates = menu2[
		{ no menu } menu1[m_sysnorm,m_sysshift],
		{ normal  } menu1[m_none,m_sysshift],
		{ shifted } menu1[m_sysnorm,m_none]];
    inmaxsize = 80;
    imsize    = 88;
  type
    realp = ^real;
    str80p= ^string80;
    dword = 0..65535;
    jvector = packed array[1..6] of char;       { jump vector }
    KRECORD = PACKED RECORD
		VTYPE : BYTE;
		SIZE  : BYTE;
		VALUE : INTEGER;
	      END;
    LLREC   = PACKED ARRAY[0..1] OF DWORD;
{****************************************************************************}
{** DO NOT CHANGE THIS RECORD WITHOUT CHANGEING THE DEBUGGER ASSEMBLY CODE **}
{** SEE ALSO MODULE POWERUP                                                **}
{****************************************************************************}
{ ERROR RECORDS }
  TYPE20       = PACKED RECORD
		   CASE INTEGER OF
		   0010:(ERR_PC : INTEGER);
		   1001:(ERR_PC1: INTEGER;
			 ERR_WRDS:INTEGER;
			 ERR_EA : INTEGER);
		   1010:(BE_SSW_10 : INTEGER;   {SHORT BUS ERROR}
			 BE_IPSC_10: DWORD;
			 BE_IPSB_10: DWORD;
			 BE_PAD_10 : INTEGER;
			 BE_FAULT_10:INTEGER;   {FAULT ADDRESS}
			 BE_DATA_10: INTEGER;   { DATA IN/OUT }
			 BE_PAD2_10: INTEGER);
		   1011:(BE_SSW_11 : INTEGER;{LONG BUS ERROR}
			 BE_IPSC_11: DWORD;
			 BE_IPSB_11: DWORD;
			 BE_PAD_11 : INTEGER;
			 BE_FAULT_11:INTEGER;   {FAULT ADDRESS}
			 BE_DATAOUT: INTEGER;
			 BE_PAD6   : PACKED ARRAY[1..16] OF CHAR;
			 BE_DATAI_11 : INTEGER;
			 BE_MISC20   : PACKED ARRAY[1..44] OF CHAR)
		 END;
  ERRORINFOREC = PACKED RECORD
		   CASE INTEGER OF
		   68000:(BE_SSW_00     : DWORD;
			  BE_FAULT_ADDR : INTEGER;
			  BE_INSTR      : DWORD);
		   68010:(BE_SSW_10     : DWORD;
			  BE_FAULT_ADDR10:INTEGER;
			  BE_PAD1_10    : DWORD;
			  BE_DATAO_10   : DWORD;
			  BE_PAD2_10    : DWORD;
			  BE_DATAI_10   : DWORD;
			  BE_PAD3_10    : DWORD;
			  BE_INSTR_10   : DWORD;
			  BE_MISC_10    : PACKED ARRAY[1..32] OF CHAR);
		   68020:(M68020:TYPE20)
		 END;
  DEBUGCOMTYPE = PACKED RECORD
		 ERRINFO  : ERRORINFOREC;
		 EXCP_STATUS  : DWORD;
		 EXCP_PC      : INTEGER;
		 EXCP_VOFFSET : DWORD;
		 EXCP_LINE    : INTEGER;
		 LASTLINE     : ^LLREC;

		 ESCAPEV      : JVECTOR;
		 PCTEMP       : INTEGER;
		 SRTEMP       : DWORD;
		 INITSTACK    : INTEGER;
		 INITPC       : INTEGER;
		 INITRECOVER  : INTEGER;
		 G_DOLLAR     : INTEGER;
		 CTL_RESETV   : JVECTOR;
		 DEBUGESCAPE  : JVECTOR;
		 BESPTEMP     : INTEGER;
		 AONOFF       : BYTE;
		 GONOFF       : BYTE;
		 GRAPHICSBASE : INTEGER;
		 INITSR       : DWORD;
		 M68KTYPE     : BYTE;
		 MSYSFLAGS    : BYTE;
		 FLTPTHDW     : BYTE;
		 FILLER       : BYTE;

		 SAVEBUS      : JVECTOR;
		 SAVEESC      : JVECTOR;

		 CTRL_FLAGS   : PACKED ARRAY[1..4] OF CHAR;

		 QSTART       : INTEGER;
		 QEND         : INTEGER;
		 QLAST        : INTEGER;

		 TCOUNT       : INTEGER;
		 OLDA6        : INTEGER;
		 SFA6         : INTEGER;

		 IMFIRST      : INTEGER;
		 IMLAST       : INTEGER;

		 KDATAP       : INTEGER;  { K0..K9 DATA AREA POINTER }
		 KVECTOR      : ARRAY[0..9] OF KRECORD;

		 REGPC        : INTEGER;
		 REGSR        : DWORD;
		 REGUS        : INTEGER;  { USER STACK POINTER }
		 DREGS        : ARRAY[0..7] OF INTEGER;
		 AREGS        : ARRAY[0..7] OF INTEGER;
		 { CRT STUFF }
		 CRTOPCODE    : BYTE;
		 CRTCHAR      : CHAR;
		 CRTPADDING1  : BYTE;
		 CRTPROMPTSIZE: BYTE;
		 CRTPROMPT    : PACKED ARRAY[1..4] OF CHAR;
		 CRTPADDING2  : INTEGER;
		 LASTLINEOP   : BYTE;
		 STAT0CHAR    : CHAR;
		 CRTPADDING3  : DWORD;
		 { KEYBOARD STUFF }
		 KBDSTATREG   : BYTE;
		 KBDCHAR      : CHAR;
		 KBDDUMMY     : CHAR;   { NOT USED }
		 KBDTRANSCODE : BYTE;   { 0 = ALPHA, 1= SPECIAL,3= NON_ADV }
		 { OTHER STUFF }
		 UEXCPI       : INTEGER; { ERROR TRAP IMPLANT ADDR }
		 SYMBOLHOOK   : JVECTOR; { HOOK INTO SYMBOL LOOKUP }
		 ACCUMV       : KRECORD;
		 DATAV        : KRECORD;
		 BASE         : DWORD;
		 SSIZE        : INTEGER;
		 RCOUNT       : INTEGER;
		 ETCODES      : ARRAY[0..1] OF INTEGER;
		 NUMET        : BYTE;
		 SCODE        : BYTE;
		 DSCODE       : BYTE;
		 TEMPD        : CHAR;   { DEBUG CI RUNLIGHT }
		 TEMPR        : CHAR;   { TEMP RUNLIGHT }
		 OUTFLAGS     : BYTE;
		 LINECOUNT    : DWORD;
		 RECALLV      : STR80P;
		 TEMPS        : ARRAY[1..4] OF INTEGER;
		 SAVEHOOK     : JVECTOR;
		 INSTACK      : ARRAY[1..4] OF INTEGER;
		 OPSTACK      : ARRAY[1..12] OF INTEGER;
		 INBUF        : STRING80;
	       END;
  VAR
    OUTS     : STR80P;
    DEBUGCRT : ^DBCINFO;
    DERR_INFO['ERR_INFO'] : INTEGER;
    DEBUGCOM : ^DEBUGCOMTYPE;

  function value(symbol: string255): integer;
  var
    modp: moddescptr;
    ptr, valueptr: addrec;
    found: boolean;
  begin {value}
    value := 0;
    found := false;
    modp := sysdefs;
    while (modp<>nil) and not found do
      with modp^ do
	begin
	  ptr := defaddr;
	  while (ptr.a<defaddr.a+defsize) and not found do
	    begin
	      found := ptr.syp^=symbol;
	      ptr.a := ptr.a+strlen(ptr.syp^)+1;
	      ptr.a := ptr.a+ord(odd(ptr.a));
	      valueptr.a := ptr.a+2;
	      if found then value := valueptr.vep^.value;
	      ptr.a := ptr.a+ptr.gvp^.short;
	    end; {while}
	  modp := link;
	end; {with modp^}
  end; {value}

  PROCEDURE UNITTOMSUS;
  {
	UNITTOMSUS DETERMINES THE MSUS THAT APPLIES TO THE
	GIVEN FILE SYSTEM UNIT NUMBER.  ON INPUT, THE UNIT NUMBER
	IS REQUIRED AND ON OUTPUT THE MSUS AND RESULT CODE
	ARE RETURNED.

	INPUT:  UNIT NUMBER IS IN TEMPL.
	OUTPUT: MSUS IS IN TEMPL2.
		RESULT CODE IS IN TEMPL3.

	RESULT CODE CONTENTS ARE:

		0 = OK RETURN
		1 = COULDN'T MAKE A DEFINITE CONVERSION.
		    MSUS IS INVALID.
  }
      TYPE
	msus_type = packed record
		      case integer of
		      1:(df       : 0..7;         { directory format }
			 dt       : 0..31;        { device type }
			 unum     : byte;         { unit number }
			 scode    : byte;         { select code }
			 baddr    : byte);        { bus address }
		      2:(pad1     : byte;
			 vol      : 0..15;    { volume number }
			 un       : 0..15);   { unit number }
		      3:(bytes    : packed array [1..4] of char);
		    end;

      PROCEDURE FSUNIT_MSUS(FSUNIT : unitnum; ANYVAR MSUS : msus_type);
	VAR
	  f : fib;
	BEGIN
	  if (fsunit<0) or (fsunit>maxunit) then escape(2);
	  with unitable^[fsunit] do
	  begin
	    msus.df    := 0;
	    msus.scode := sc;
	    msus.baddr := ba;
	    msus.unum  := du;
	    case letter of
	      'B':begin { BUBBLE }
		    msus.dt := 22;
		  end;
	      'E':begin { EPROM }
		    msus.dt := 20;
		    msus.unum := dv;
		  { bootrom uses unit, table uses volume }
		  end;
	      'F':begin { 9885 }
		    msus.dt := 6;
		  end;
	      'G':begin { SRM }
		    msus.df := 7; msus.dt := 1;
		  end;
	      'H':begin { 9895 }
		    msus.dt := 4;
		  end;
	      'J',{ PRINTER }
	      'R':{ RAM }
		  escape(2);
	      'M':begin { internal mini }
		    msus.dt := 0;
		  end;
	      'N':begin { 8290X }
		    msus.dt := 5;
		  end;
	      'Q':begin { C280 }
		    msus.vol := dv; msus.un := du;
		    if intlevel > 2 then escape(2);
		    call(dam, uvid, fsunit, getvolumename);
		    if (ioresult <> ord(inoerror)) or (strlen(uvid) = 0)
		       or (dvrtemp2 < 8)
		      then escape(2)
		    else
		    if dvrtemp2=8 then msus.dt := 16
				  else msus.dt := 17;
		  end;
	      'S':begin { SCSI }
		    msus.dt := 14;
		  end;
	      'U':begin { 913X_A }
		    msus.dt := 7;
		  end;
	      'V':begin { 913X_B }
		    msus.dt := 8;
		  end;
	      'W':begin { 913X_C }
		    msus.dt := 9;
		  end;
	      otherwise
		escape(2);
	    end; { case }
	  end;
	END; { FSUNIT_MSUS }

  BEGIN
    WITH DEBUGCOM^ DO
    BEGIN
      TRY
	TEMPS[3] := 0;
	FSUNIT_MSUS(TEMPS[1],TEMPS[2]);
      RECOVER
	TEMPS[3] := 1;
    END;
  END;

  { DUMMY REVASM }
  PROCEDURE DUMREVASM(ANYVAR INSP: INTEGER; ANYVAR SP:STR80P;
		      ANYVAR FTYPE:INTEGER);
  TYPE
    REVPROC = PROCEDURE (ANYVAR INSP: INTEGER; VAR S:STRING;
			 ANYVAR NXTP,FTYPE:INTEGER);
    PREC = RECORD
	     CASE BOOLEAN OF
	     TRUE :(RPROC : REVPROC);
	     FALSE:(I2 : PACKED ARRAY[1..2] OF INTEGER);
	   END;
  VAR
    TPROC:PREC;
    NXTP : INTEGER;
  BEGIN
    SP:= OUTS;
    TPROC.I2[1]:=VALUE('REVASM_MOD_REVASM');    { TRY TO FIND THE REAL REVASM }
    IF TPROC.I2[1]=0 THEN
    BEGIN SETSTRLEN(SP^,0); NXTP:=INSP; END     { SIGNAL NO DECODE }
    ELSE
    BEGIN
      TPROC.I2[2]:=0;   { CLEAR STATIC LINK }
      CALL(TPROC.RPROC,INSP,SP^,NXTP,FTYPE);    { CALL THE REVERSE ASSEMBLER }
      INSP:=NXTP;                               { OLD POINTER BECOMES NEW }
    END;
  END;

  PROCEDURE REALTOSTRING(ANYVAR RP:REALP; ANYVAR SP:STR80P);
  TYPE
    RSPROC = PROCEDURE(VAR R:STRING; VAR P2:INTEGER;X :REAL; W,D:SHORTINT);
    PREC = RECORD
	     CASE BOOLEAN OF
	     TRUE :(REALPR : RSPROC);
	     FALSE:(I2 : PACKED ARRAY[1..2] OF INTEGER);
	   END;
  VAR
    I : INTEGER;
    RPROC : PREC;
  BEGIN
    SP:= OUTS;
    RPROC.I2[1]:=VALUE('MFS_FWRITESTRREAL');    { FIND THE ROUTINE }
    IF RPROC.I2[1]=0 THEN SP^ :='no R formatter'
    ELSE
    BEGIN
      TRY
	RPROC.I2[2]:=0;         { CLEAR STATIC LINK }
	SETSTRLEN(SP^,0);       { CLEAR THE STRING }
	I:=1;           { SET START POSITION }
	CALL(RPROC.REALPR,SP^,I,RP^,-1,-1); { CALL THE ROUTINE }
      RECOVER
	SP^ := 'not real';
    END;
  END;

  procedure readkey;
  var
    oldkbdisr : kbdhooktype;
    oldrpgisr : kbdhooktype;
    alldone   : boolean;
    oldcaps   : boolean;
    oldnonchar: char;

    procedure debugrpg(var kbdstatus, kbddata: byte;
			 var dokey: boolean);
    var key: char;
    begin
      if dokey then
      with debugcom^ do
      begin
	kbdstatreg:= kbdstatus;
	kbdtranscode:= 1;       { special }
	alldone:= true;
	case  not odd(kbdstatus div 16) of
	  true: {shifted} { down arrow, up arrow }
	      if kbddata >= 128 then kbdchar:= #34 else kbdchar:= #35;
	  false: {unshifted}{ right arrow, left arrow }
	      if kbddata >= 128 then kbdchar:= #39 else kbdchar:= #38;
	end;
      end;
    end; { rpghandler }

    procedure debugkeys(var kbdstatus, kbddata: byte;
			var dokey: boolean);
    var
      i : integer;
      c : char;
    begin   { debugkeys }
      if dokey then
      with langcom do
	begin
	status  := kbdstatus;
	data    := kbddata;
	extension:= not odd(kbdstatus div 8);
	shift   := not odd(kbdstatus div 16);
	control := not odd(kbdstatus div 32);
	call(langtable[langindex]^.semantics);
	debugcom^.kbdstatreg:= status;
	debugcom^.kbdtranscode:= 0;     { 3.0 BUG FIX }
	alldone := true;
	CASE result OF
	nonadv_key, { have non advancing key }
	alpha_key,
	NONA_ALPHA_KEY  {3.1 BUGFIX SFB--5/30/85} :
	  begin
	    debugcom^.kbdchar:= key;
	    if (result=nonadv_key) OR   {3.1 BUGFIX SFB--5/30/85}
	      ((RESULT = NONA_ALPHA_KEY) AND NOT SHIFT) then
	    begin keybuffer^.non_char:= key; alldone:=false; end;
	  end;
	special_key: { have special function key }
	  begin
	    case data of        { fix itf keycodes }
	    5: data:=56;        { break=>pause }
	    6: data:=55;        { stop }
	    7: data:=59;        { select=>execute}
	    8: data:=57;        { np enter=>enter}
	    17: { enter/print }
	       if shift and control then { dump graphics }
	       begin data:=50; debugcom^.kbdstatreg:=175; end
	       else
		 if shift then data:=49 { dump alpha }
			  else data:=57; { enter }
	    20:begin {system/user}
		 if shift then key:='U' else key:='S';
		 kbdsysmode:=not shift;
		 setstatus(6,key);
		 if key='U' then
		   if (menustate=m_sysnorm) or (menustate=m_sysshift) then
		   begin
		     menustate:=m_none;
		     keybuffer^.echo:=true;
		     keybufops(kdisplay,c);
		   end;
		 alldone:=false;
	       end;
	    21:begin {menu}
		 alldone := false;
		 if kbdsysmode and not control then
		 begin
		   call(crtllhook,cllclear,i,c);
		   if menustate<=m_sysshift
		   then menustate:=mstates[menustate,shift]
		   else menustate:=m_none;

		   keybuffer^.echo:=(menustate=m_none);
		   case menustate of
		     m_none    : keybufops(kdisplay,c);
		     m_sysnorm : call(crtllhook,clldisplay,sysmenu^,c);
		     m_sysshift: call(crtllhook,clldisplay,sysmenushift^,c);
		     otherwise
		   end;
		 end;
	       end;

	    22:begin data:=52; debugcom^.kbdstatreg:=191; end;  { clr line }
	    23:begin data:=52; debugcom^.kbdstatreg:=175; end;  { clr screen }
	    otherwise
	    end; { case data }
	    debugcom^.kbdchar:= chr(data);
	    debugcom^.kbdtranscode:= 1; { special }
	  end;
	ignored_key: alldone:=false;
	OTHERWISE {TO MAKE ISR MORE ROBUST- THE "BITBUCKET". SFB--5/30/85}
	end;

      end;  { with langcom }
    end;    { debugkeys }

  begin { readkey }
    alldone:= false;
    with langtable[langindex]^ do
    begin
      oldcaps:= kbdcapslock; kbdcapslock:= true;  { force capslock }
      oldkbdisr:= kbdisrhook; kbdisrhook:= debugkeys;
      oldrpgisr:= rpgisrhook; rpgisrhook:= debugrpg;
      oldnonchar:= keybuffer^.non_char; keybuffer^.non_char:= ' ';

      repeat call(kbdpollhook,true) until alldone;

      kbdcapslock:= oldcaps;
    end;
    kbdisrhook:= oldkbdisr; rpgisrhook:= oldrpgisr;
    keybuffer^.non_char:= oldnonchar;
  end; { readkey }

  procedure dolastlineop;
  var
    tempc : char;
    i     : integer;
  begin
    with debugcom^ do
    case lastlineop of
    0: begin tempc:= runlight; setrunlight(tempr); tempr:= tempc; end;
    1: setrunlight(tempr);
    2: begin tempd:= runlight; setrunlight('d'); end;
    3: begin for i:=1 to 5 do setstatus(i,' '); setrunlight(tempd); end;
    4: for i:=0 to 5 do setstatus(i,' ');       { clear status line }
    5: setstatus(0,stat0char);
    6: begin    { display last line }
	 setstrlen(inbuf,0); strwrite(inbuf,1,i,lastline^[1]:5);
	 setstatus(0,' ');
	 for i:=1 to 5 do setstatus(i,inbuf[i]);
       end;
    otherwise
    end;
  end;{ dolastlineop }

  procedure docrtops;
  var i : integer;
    procedure putcursor;
    begin
      with debugcrt^ do
      begin
	if cursx>xmax then
	begin cursx:=xmin; cursy:=cursy+1; end;
	if cursy>ymax then
	begin
	  cursy:=ymax; call(dbcrthook,dbscrollup,debugcrt^);
	end;
	call(dbcrthook,dbgotoxy,debugcrt^);
      end;
    end; { putcursor }
  begin
    with debugcom^, debugcrt^ do
    if savesize>0 then
    case crtopcode of
    0: call(dbcrthook,dbexcg,debugcrt^);        { exchange display }
    1: begin    { putchr & advance cursor }
	 c:=crtchar; call(dbcrthook,dbput,debugcrt^);
	 cursx:=cursx+1; putcursor;
       end;
    2: begin    { write prompt }
	 for i:=1 to crtpromptsize do
	 begin
	   c:=crtprompt[i]; call(dbcrthook,dbput,debugcrt^);
	   cursx:=cursx+1; putcursor;
	 end;
       end;
    3: begin cursx:=xmin; cursy:=cursy+1; putcursor; end;
    4: call(dbcrthook,dbinit,debugcrt^);
    5: begin    { clear crt & homecursor }
	 call(dbcrthook,dbclear,debugcrt^);
	 cursx:=xmin; cursy:=ymin; putcursor;
       end;
    6: call(dbcrthook,dbcline,debugcrt^);       { clear to end of line }
    7: begin cursx:=xmin; putcursor; end;
    8: begin cursx:=cursx-1; putcursor; end;
    9: begin cursx:=cursx+1; putcursor; end;
    otherwise
    end;
  end;  { docrtops }

  PROCEDURE DOINIT;
  VAR DONE: BOOLEAN;
  BEGIN    { initialize }
    IF OUTS=NIL THEN NEW(OUTS);
    DEBUGCOM := ADDR(DERR_INFO);
    { allocate debugger crt window }
    NEW(DEBUGCRT);
    WITH DEBUGCRT^ DO
    BEGIN
      XMIN:=0; YMIN:=0;
      XMAX:=SYSCOM^.CRTINFO.WIDTH-1;
      YMAX:=SYSCOM^.CRTINFO.HEIGHT-1;
      SAVESIZE:=-1;
      CALL(DBCRTHOOK,DBINFO,DEBUGCRT^);
      DONE:= SAVESIZE<=0;
      WHILE NOT DONE DO { ALLOCATE SPACE TO SWAP WINDOW }
      BEGIN
	IF SAVESIZE<4000 THEN DONE:=TRUE
	ELSE
	IF (XMAX-XMIN)>50 THEN XMIN:=XMAX-49
	ELSE
	IF (YMAX-YMIN)>24 THEN YMIN:=YMAX-22
	ELSE DONE:=TRUE;

	IF DONE THEN
	BEGIN
	  NEWBYTES(SAVEAREA,SAVESIZE);
	  CALL(DBCRTHOOK,DBINIT,DEBUGCRT^);
	END
	ELSE CALL(DBCRTHOOK,DBINFO,DEBUGCRT^);
      END;      { WHILE }
    END;        { WITH }
  END;  { DOINIT }

  procedure callsyscode(i : integer);
  begin
    case i of
    -1: DOINIT;
    0 : DOCRTOPS;
    1 : call(togglegraphicshook);
    2 : call(dumpalphahook);
    3 : call(dumpgraphicshook);
    4 : WITH DEBUGCOM^ DO REALTOSTRING(TEMPS[1],TEMPS[2]);
    5 : WITH DEBUGCOM^ DO DUMREVASM(TEMPS[1],TEMPS[2],TEMPS[3]);
    6 : BEEP;
    7 : READKEY;
    8 : call(togglealphahook);
    9 : dolastlineop;
    10: UNITTOMSUS;
    otherwise
    end; { case }
  end;  { callsyscode }
end;    { module sysbug }

import sysglobals,loader,sysbug;

procedure realdebugger(p1,p2,p3: integer); external;
{****** PROGRAM INSTALLDEBUGGER **************}
begin
  callsyscode(-1);              { initialize sysbug }
  if realdebugger<>debugger then
  begin
    debugger:=realdebugger;
    realdebugger(0,0,0);        { initialize debugger }
    markuser;
  end;
end.


