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