-+-+-+-+-+-+-+-+ START OF PART 2 -+-+-+-+-+-+-+-+
X                          dbg_qio_write : v_array );
X                      3 :`20
X                        ( dbg_qio_1_char_now : char );
X                      4 :
X                        ( dbg_qio_readln_characters : integer;
X                          dbg_qio_readln : v_array );
X                      6 :
X                        ( dbg_qio_1_char_timed_delay : integer;
X                          dbg_qio_1_char_timed : char );
X                  End;
X
X`5BHIDDEN`5D
XVAR
X  res : integer;
X
XVAR
X  dbg : `5Edebugger_data;
X  debugger_initialized : boolean := false;
X  debugger_alone : boolean;
X  debugger_on : boolean;
X
X`5BHIDDEN`5D
XFUNCTION  DEBUG_FLAG : boolean;
XExtern;
X
X`5BHIDDEN`5D
XPROCEDURE  DBG_Exit_Handler ( exit_reason : integer );
XBEGIN
X  dbg`5E.exit_please := true;
X  dbg`5E.request := 0;
X  $Setef ( efn := dbg_request );
XEND;
X
X
X`5BGLOBAL`5D
XPROCEDURE  DBG_init;
XVAR
X  i : integer;
X  sect_end : $defptr;
XBEGIN
X  debugger_initialized := true;
X  debugger_on := debug_flag;
X  IF debugger_on then
X    BEGIN
X      create_global_section ('INTERACT_DBG',size(debugger_data),dbg,sect_end
V);
X      IF dbg`5E.partner then
X        BEGIN
X          Setup_handler ( iaddress(DBG_Exit_handler) );
X          debugger_alone := false;
X          IF set_interlocked(dbg`5E.Initialized) then
X            ERROR ('%INTERACT_DEBUG, One process is already in debug mode.')
V;
X          Create_event_flag_cluster ('INTERACT_DBG','96-127');
X        END
X      ELSE
X        BEGIN
X          debugger_alone := true;
X          delete_global_section (dbg,sect_end);
X        END;
X    END;
XEND;
X
X`5BGLOBAL`5D
XPROCEDURE  DBG_call;
XBEGIN
X  IF debugger_alone then
X    ERROR ('%INTERACT_DEBUG, Must not call if no partner.');
X  REPEAT
X    $Setef ( efn := dbg_request );
X    $Waitfr ( efn := dbg_reply );
X    $Clref ( efn := dbg_reply );
X    IF ( dbg`5E.message_from_partner ) then
X      writeln (dbg`5E.message_reads);
X  UNTIL ( not dbg`5E.message_from_partner );
XEND;
X
X
XEND.
$ CALL UNPACK DEBUG.PAS;1 1533239163
$ create 'f'
X        .title        DEBUGFLAG - returns a boolean true if debug is on
X
X        $clidef       ; want prog arg list definitions
X        $sfdef        ; stack frame definitions
X
X        .psect        $code        exe, rd, nowrt, pic, shr
X
X;        .align        word
X        .entry        -
XDebug_Flag, `5Em<r2, r3, r4>
X
X;
X; FUNCTION  Debug_Flag
X;
X; this procedure can be called at any depth of nesting  it traces back throu
Vgh`20
X; the call frames to the mainline frame to access the mainline arg list.`20
X; mainline call frame is recognized by being the second-outermost frame.
X;
X
X        movl    fp, r1                   ; start tracing back through saved
V fp's
X        movl    sf$l_save_fp(r1), r2     ; back another frame
X        movl    sf$l_save_fp(r2), r3     ; and another
X2000$:
X        movl    sf$l_save_fp(r3), r4
X        beqlu   8000$                    ; no more => end
X        movl    r2, r1
X        movl    r3, r2
X        movl    r4, r3
X        brb     2000$
X8000$:
X        movl    sf$l_save_ap(r1), r1     ; get mainline ap
X        movl    cli$l_linkflag(r1), r2   ; and return link flags
X        movl    cli$l_cliflag(r1), r3    ; and return link flags
X
X;   r2`5B0`5D = link/deb`20
X;   r3`5B0`5D = run/`5Bno`5Ddeb
X;   r3`5B1`5D = /nodeb or /deb
X
X        bbss    #1, r3, 9000$            ; run/deb
X        bbss    #0, r3, 8500$            ; run/nodeb
X        bbss    #0, r2, 9000$            ; run     link/deb
X
X8500$:
X        clrl        r0
X        ret
X9000$:
X        movl    #1, r0
X        ret
X        .end
$ CALL UNPACK DEBUG_FLAG.MAR;1 19627217
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET'),
X  Environment
X    ('DEC.PEN')
X`5D
X
XMODULE DEC;
X
X`5BHIDDEN`5DTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION  Dec ( number    : integer;
X                pad_char  : char := ' ';
X                pad_len   : integer := 0
X              ) : v_array;
XVAR
X  Result : v_array;
XBEGIN
X  Writev (result,number:0);
X  WHILE ( result.length < abs(pad_len) ) do
X    IF ( pad_len < 0 ) then
X      result := result + pad_char
X    ELSE
X      result := pad_char + result;
X  dec := result;
XEND;
X
XEND.
$ CALL UNPACK DEC.PAS;1 303393095
$ create 'f'
X`5B
X  Inherit`20
X    ('VT100.PEN'),
X  Environment
X    ('ERROR.PEN')
X`5D
X
XMODULE ERROR ( output );
X
X`5BHIDDEN`5D
XTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XPROCEDURE  ERROR ( text : v_array );
XBEGIN
X  writeln ( VT100 + VT100_graphics_off + VT100_normal + VT100_normal_scroll
V + VT100_no_application_keypad + VT100_ESC + '`5BJ' );
X  writeln (text);
X  HALT;
XEND;
X
XEND.
$ CALL UNPACK ERROR.PAS;1 644041675
$ create 'f'
X`5B
X  Environment
X    ('EXTRACT.PEN')
X`5D
X
XMODULE EXTRACT;
X
X`5BHIDDEN`5DTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION  Extract ( str   : v_array;
X                    start : integer ) : v_array;
XBEGIN
X  Extract := substr(str,start,str.length-start+1);
XEND;
X
XEND.
$ CALL UNPACK EXTRACT.PAS;1 505566564
$ create 'f'
X`5B
X  Inherit
X    ('QIO_WRITE','QIO_READ','POSN','ERROR','FULL_CHAR','VT100'),
X  Environment
X    ('FORMATTED_READ.PEN')
X`5D
X
XMODULE FORMATTED_READ;
X
X`5BHIDDEN`5D
XTYPE
X  v_array = varying `5B256`5D of char;
X
X
X`5BGlobal`5D
XPROCEDURE  Formated_read
X (VAR return_value   : v_array;
X      picture_clause : v_array;
X      x_posn         : integer;
X      y_posn         : integer;
X      default_value  : v_array := '';
X      field_full_terminate : boolean := false;
X      begin_brace    : v_array := '';
X      end_brace      : v_array := ''
X );
XVAR
X  i : integer;
X  ch : char;
X  outline : v_array;
X
X
X    PROCEDURE  Go_left;
X    BEGIN
X      IF ( i <> 1 ) then
X        BEGIN
X          REPEAT
X            i := i - 1;
X          UNTIL ( i = 1 ) or ( picture_clause`5Bi`5D in `5B'9','X'`5D );
X          IF not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) then
X            BEGIN
X              WHILE not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) do
X                i := i + 1;
X            END;
X        END;
X    END;
X
X
X    PROCEDURE  Go_right;
X    BEGIN
X      IF ( i <> length(picture_clause) ) then
X        BEGIN
X          REPEAT
X            i := i + 1;
X          UNTIL ( i = length(picture_clause) ) or ( picture_clause`5Bi`5D in
V `5B'9','X'`5D );
X          IF not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) then
X            BEGIN
X              WHILE not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) do
X                i := i - 1;
X            END;
X        END;
X    END;
X
X
X    PROCEDURE  Escape_sequence;
X    BEGIN
X      ch := qio_1_char;
X      IF ( ch = '`5B' ) then
X        BEGIN
X          ch := qio_1_char;
X          CASE ch of
X            'C' : go_right;
X            'D' : go_left;
X            Otherwise
X             qio_write (chr(7));               `20
X          End;
X        END
X      ELSE
X        qio_write (chr(7));               `20
X    END;
X
X
X    PROCEDURE  Delete;
X    VAR
X      last : integer;
X    BEGIN
X      IF ( i <> 1 ) then
X        BEGIN
X          last := length(picture_clause)+1;
X          REPEAT
X            last := last - 1;
X          UNTIL ( last = 1 ) or ( picture_clause`5Blast`5D in `5B'9','X'`5D
V );
X
X          IF ( i <> last ) or ( return_value`5Bi`5D = ' ' ) then
X            REPEAT
X              i := i - 1;
X            UNTIL ( i = 1 ) or ( picture_clause`5Bi`5D in `5B'9','X'`5D );
X
X          IF not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) then
X            BEGIN
X              WHILE not ( picture_clause`5Bi`5D in `5B'9','X'`5D ) do
X                i := i + 1;
X            END
X          ELSE
X            BEGIN
X              posn (x_posn+i-1,y_posn);
X               qio_write (' '+VT100_bs);
X              return_value`5Bi`5D := ' ';
X            END;
X        END;
X    END;
X
X
X    PROCEDURE  Key_control;
X    BEGIN
X      IF ( ch = chr(13) ) then
X        BEGIN
X          field_full_terminate := true;
X          i := length(picture_clause) + 1;
X        END
X      ELSE
X      IF ( ch = chr(27) ) then
X        escape_sequence
X      ELSE
X      IF ( ch = chr(127) ) then
X        delete
X      ELSE
X        qio_write (chr(7));               `20
X    END;
X
X
XBEGIN
X  return_value := '';
X
X`7B get x & y if left out `7D
X
X  FOR i := 1 to length(picture_clause) do
X      CASE picture_clause`5Bi`5D of
X        '9' : IF length(default_value) < i then
X                return_value := return_value + ' '
X              ELSE
X              IF ( default_value`5Bi`5D in `5B' ','0'..'9'`5D ) then
X                return_value := return_value + default_value`5Bi`5D
X              ELSE
X                ERROR ('DEFAULT VALUE /'+default_value`5Bi`5D+'/ DOES NOT MA
VTCH PICTURE CLAUSE /'+picture_clause`5Bi`5D+'/');
X        'X' : IF length(default_value) < i then
X                return_value := return_value + ' '
X              ELSE
X              IF ( default_value`5Bi`5D in `5B' '..'`7E'`5D ) then
X                return_value := return_value + default_value`5Bi`5D
X              ELSE
X                ERROR ('%INTERACT-F-DVMM, DEFAULT VALUE /'+full_char(default
V_value`5Bi`5D)+'/ DOES NOT MATCH PICTURE CLAUSE /'+picture_clause`5Bi`5D+'/'
V);
X       otherwise`20
X          return_value := return_value + picture_clause`5Bi`5D;
X      End;
X
X  outline := '';
X
X  posn (x_posn,y_posn);
X  IF length(begin_brace) > 0 then
X    outline := outline + begin_brace;
X  outline := outline + return_value;
X  IF length(end_brace) > 0 then
X    outline := outline + end_brace;
X
X  qio_write (outline);
X
X  IF length(begin_brace) > 0 then
X    x_posn := x_posn + length(begin_brace);
X
X  i := 1;
X  REPEAT
X    WHILE ( i <= length(picture_clause) ) do
X      BEGIN
X        posn (x_posn+i-1,y_posn);
X        CASE picture_clause`5Bi`5D of
X          '9' : BEGIN
X                  ch := qio_1_char;
X                  IF ( ch in `5B' ','0'..'9'`5D ) then
X                    BEGIN
X                      return_value`5Bi`5D := ch;
X                      qio_write (ch);
X                      i := i + 1;
X                    END
X                  ELSE
X                    key_control;
X                END;
X          'X' : BEGIN
X                  ch := qio_1_char;
X                  IF ( ch in `5B' '..'`7E'`5D ) then
X                    BEGIN
X                      return_value`5Bi`5D := ch;
X                      qio_write (ch);
X                      i := i + 1;
X                    END
X                  ELSE
X                    key_control;
X                END;
X         otherwise`20
X            i := i + 1;
X        End;
X      END;
X    IF ( i > length(picture_clause) ) and ( not field_full_terminate ) then
X      i := length(picture_clause);
X  UNTIL ( i > length(picture_clause) );
XEND;
X
XEND.
$ CALL UNPACK FORMATTED_READ.PAS;1 1832506380
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET','VT100'),
X  Environment
X    ('FULL_CHAR.PEN')
X`5D
X
XMODULE FULL_CHAR;
X
X`5BHIDDEN`5DTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION  Full_char ( character : char ) : v_array;
XVAR
X  c : integer;
XBEGIN
X  c := ord(character);
X  IF ( c in `5B0..31,127`5D ) then
X    full_char := VT100_inverse + chr(64+c) + VT100_normal
X  ELSE
X  IF ( c < 128 ) then
X    full_char := character
X  ELSE
X  IF ( (c-128) in `5B0..31,127`5D ) then
X    full_char := VT100_inverse + VT100_bright + chr(c-64) + VT100_normal
X  ELSE
X    full_char := VT100_bright + character;
XEND;
X
XEND.
$ CALL UNPACK FULL_CHAR.PAS;1 1849114346
$ create 'f'
X`5B
X  Inherit`20
X    ('VT100','QIO_WRITE','CASE_CONVERT','ERROR'),
X  Environment`20
X    ('GET_CLEAR.PEN')`20
X`5D
X
XMODULE GET_CLEAR;
X
X`5BHIDDEN`5D
XTYPE
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION  Get_Clear ( portiontype : v_array := 'SCREEN';
X                   cleartype   : v_array := 'WHOLETHING' ) : v_array;
XVAR
X  outline : v_array;
XBEGIN
X  outline := VT100_ESC + '`5B';
X
X  cleartype := upper_string(cleartype);
X  IF ( cleartype = 'WHOLETHING' ) then
X    outline := outline + '2'
X  ELSE
X  IF ( cleartype = 'TO_START' ) then
X    outline := outline + '1'
X  ELSE
X  IF ( cleartype <> 'TO_END' ) then
X    ERROR ('%INTERACT-GET_CLEAR, Cleartype /'+cleartype+'/ Unknown.');
X
X  portiontype := upper_string(portiontype);
X  IF ( portiontype = 'SCREEN' ) then
X    get_clear := outline + 'J'
X  ELSE
X  IF ( portiontype = 'LINE' ) then
X    get_clear := outline + 'K'
X  ELSE
X    error ('%INTERACT-GET_CLEAR, Portiontype /'+portiontype+'/ unknown.');
XEND;
X
XEND.
$ CALL UNPACK GET_CLEAR.PAS;1 1918441650
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES'),
X  Environment
X    ('GET_JPI.PEN')
X`5D
X
XMODULE Get_jpi;
X
X`5BHIDDEN`5D
XTYPE
X  $UWORD = `5BWORD`5D 0..65535;
X  v_array = varying `5B256`5D of char;
X
X`5BGLOBAL`5D
XFUNCTION  Get_jpi ( jpicode , retlen : integer ) : v_array;
XVAR
X  itemlist    : record
X                  item : array `5B1..1`5D of`20
X                    record
X                      bufsize : $uword;
X                      code    : $uword;
X                      bufadr  : integer;
X                      lenadr  : integer
X                    end;
X                  no_more : integer;
X                end;
X  name : packed array `5B1..256`5D of char;
X  retname : v_array;
X  ret_status : integer;
XBEGIN
X  WITH itemlist do
X   BEGIN
X     WITH item`5B1`5D do
X       BEGIN
X         Bufsize := retlen;
X         Code := jpicode;
X         Bufadr := iaddress(name);
X         Lenadr := 0
X       END;
X     No_more := 0
X   END;
X  ret_status := $Getjpiw(itmlst := itemlist);
X  IF not odd(ret_status) then
X    LIB$SIGNAL(ret_status);
X  retname := name;
X  retname.length := retlen;
X  get_jpi := retname;
XEND;
XEND.
$ CALL UNPACK GET_JPI.PAS;1 2120645565
$ create 'f'
X`5B
X  Inherit
X    ('SYS$LIBRARY:STARLET','VT100'),
X  Environment
X    ('GET_POSN.PEN')
X`5D
X
XMODULE GET_POSN;
X
+-+-+-+-+-+-+-+-  END  OF PART 2 +-+-+-+-+-+-+-+-