/* PL/I symbolic debugger module handling EXAMINE, PUT, DEPOSIT commands */ symcmd: procedure; %include 'putdef.pli'; %include 'scandef.pli'; %include 'knldef.pli'; %include 'symdef.pli'; %include 'plioctal.inc'; %include 'typestr.inc'; /* subroutines from PLIUTL & PLIMMR: */ dcl min16 entry(fixed bin(15), fixed bin(15)) returns(fixed bin(15)), trim entry(char(*)) returns(char(20) varying), hexl entry(fixed bin(31)) returns(char(8) varying), oncode builtin; /* some variables not needing to be static are made static only because static references often take less code */ dcl (examine_type, deposit_type) (7) label; dcl cvi2c entry(pointer, fixed bin(15), char(*), fixed bin(15)), /*fixed bin converison*/ cvc2i entry(char(*), pointer, fixed bin(15)), cvd2c entry(pointer, fixed bin(15), char(*), fixed bin(15)), /*decimal conversion*/ cvc2d entry(char(*), pointer, pointer, fixed bin(15)), cvbuffer char(20), /*for cvi2c & cvd2c only (descriptor overwritten)*/ cvbuffer_size fixed bin(15) static initial(20), decitemp decimal(15), /*for cvc2d*/ rwbmax fixed bin(15) external; /*size of rwbbuf, defined in debasm*/ dcl (hexmode, putmode) fixed bin(1), (variablep, lastp) fixed bin(15), symbol_address fixed bin(15) static, sign char(2) varying static, constant_type fixed bin(7), constant_string char(80) varying, deposit_buffer char(10) static, pdeposit_buffer pointer initial(addr(deposit_buffer)), /*must fit biggest non-char variable*/ a_word fixed bin(15) based, a_float float based, a_bit bit(1) based, a_byte fixed bin(7) based; dcl (i, j, x) fixed bin(15) static, /*scratch variables*/ tname char(31) varying static; /*scratch*/ /**************************************************************************************************************/ /************* * Deposit * *************/ /*must be first, to handle optional deposit keyword*/ constant_string = substr(commandline,startp); /*use constant_string as a temporary*/ x = index(constant_string,'='); i = index(constant_string,''''); if i = 0 then i = length(constant_string); j = index(constant_string,';'); if j = 0 then j = length(constant_string); if (x ^= 0) & ( x < i & x < j ) /*if have equals sign before first quote or semicolon then it's deposit command*/ & ^ nxtokenis('DCL') /*unless first token is DCL (note that DCL commands can have equal signs and semicolons)*/ then do; i = nxtokenis(' DEPOSIT D '); /*keyword is optional (unless variable's first identifier is DEPOSIT or D)*/ call variable(main_symp); if ^ nxtokenis('=') then call error('missing ''='' or improper syntax for variable'); if nxtokenis(' + - ') then sign = lastchar; else sign = ''; if nxtokenis('.') then sign = sign !! '.'; /*allow leading decimal point*/ constant_type = nexttoken(constant_string); if constant_type = decimal_constant_type then constant_string = sign!!constant_string; else if constant_type ^= string_constant_type then call error('improper syntax for constant'); call endscan; symbol_address = main_symp->symbol.address; on conversion call error('illegal value for variable (would have raised CONVERSION)'); goto deposit_type(main_symp->symbol.type); deposit_type(/*fixed_bin_type*/ 1): on size call error('illegal value for variable (would have raised SIZE condition)'); (size):call cvc2i(constant_string, pdeposit_buffer, main_symp->symbol.ssize /*precision & scale factor*/); dep_arith: call putstring(symbol_address, substr(deposit_buffer,1,main_symp->symbol.len)); goto command_done; deposit_type(/*pointer_type*/ 2): pdeposit_buffer->a_word = constant_string; goto dep_arith; deposit_type(/*float_type*/ 3): pdeposit_buffer->a_float = constant_string; goto dep_arith; deposit_type(/*char_varying_type*/ 4): deposit_type(/*char_fixed_type*/ 5): if constant_type ^= string_constant_type then call error('value for a character variable must be a quoted string constant'); if length(constant_string) > main_symp->symbol.len then do; call warning('warning: string truncated to fit in variable, STRINGSIZE not raised'); constant_string = substr(constant_string,1,main_symp->symbol.len); end; x = length(constant_string); if main_symp->symbol.type = char_varying_type then do; call putword(symbol_address, x); /*set current length*/ symbol_address = symbol_address + 2; end; call putstring(symbol_address, constant_string); if main_symp->symbol.type = char_fixed_type then do while(x < main_symp->symbol.len); /*blank pad*/ call putstring(symbol_address+x, substr(' ',1,min16(main_symp->symbol.len-x,rwbmax))); x = x + rwbmax; end; goto command_done; deposit_type(/*bit_type*/ 6): pdeposit_buffer->a_bit = constant_string; /*works for BIT(1)*/ goto dep_arith; deposit_type(/*decimal_type*/ 7): on size call error('illegal value for variable (would have raised SIZE condition)'); (size):call cvc2d(constant_string, addr(decitemp), pdeposit_buffer, main_symp->symbol.ssize /*precision & scale factor*/); goto dep_arith; end; nextp = startp; /******************* * Examine / Put * *******************/ if nxtokenis(' PUT P ') then do; putmode = true; if debprocedure_define_level = 0 then call put_skip_list; goto putentrance; end; if nxtokenis(' EXAMINE E ') then do; putmode = false; putentrance: hexmode = false; if nxtokenis('/') then do; /*check qualifier*/ if ^nxtokenis(' HEX H ') then call error('Conversion to hexadecimal (/HEX) is the only current examine qualifier'); hexmode=true; end; item_loop: lastp = nextp; if nxtokenis(' ; , ') then do; /*examine successor*/ if debprocedure_define_level ^= 0 then goto item_done; /*execute only if not defining a do group*/ nextp = lastp; /*must back up to semicolon to detect end*/ if ^ dot_valid then call error('current variable not defined (there must be a prior examine or deposit)'); if main_symp->symbol.is_array & (main_symp->symbol.dimensions ^= 0) then do; /*examine next array element*/ main_symp->symbol.subscript(main_symp->symbol.subscripts).value = main_symp->symbol.subscript(main_symp->symbol.subscripts).value + 1; main_symp->symbol.subscript(main_symp->symbol.subscripts).errp = 0; call addrcalc(main_symp); if ^putmode then do; call put_skip_list(' ('); do i = 1 to main_symp->symbol.subscripts; if i ^= 1 then call put_list(','); call put_list(trim(main_symp->symbol.subscript(i).value)); end; call put_list(') = '); end; end; else do; /*examine next structure member*/ x = main_symp->symbol.parent_structure; if x = 0 then goto nomember; /*i.e., if not a structure*/ call read_symbol(main_symp->symbol.nextsym, main_symp); if x ^= main_symp->symbol.parent_structure then nomember: call error('no more members in structure'); call addrcalc(main_symp); if ^putmode then call put_skip_list(' .', main_symp->symbol.name, ' = '); end; end; else if putmode & (nexttoken(constant_string) = string_constant_type) then do; if debprocedure_define_level = 0 then call put_list(constant_string); /*execute only if not defining a do group*/ goto item_done; end; else do; nextp = lastp; variablep = nextp; call variable(main_symp); if debprocedure_define_level ^= 0 then goto item_done; /*execute only if not defining a do group*/ (nostringrange): /*nextp may be 2 beyond end*/ if ^putmode then call put_skip_list(substr(commandline,variablep,nextp-variablep), ' = '); end; symbol_address = main_symp->symbol.address; if main_symp->symbol.type = char_varying_type then do; i = getword(symbol_address); /*get current length*/ symbol_address = symbol_address + 2; if ( 0 <= i & i <= main_symp->symbol.ssize ) ! (main_symp->symbol.ssize = star_length) then main_symp->symbol.len = i; else call warning('current length of varying string exceeds declared size'); /*leave symbol.len at declared size*/ end; if hexmode=true then do; /*show hexadecimal*/ do i = 1 to main_symp->symbol.len; call getbytes(symbol_address,1); call put_list(substr(hexl(addr(rwbbuf)->a_byte),7),' '); symbol_address = symbol_address + 1; end; goto item_done; end; goto examine_type(main_symp->symbol.type); examine_type(/*fixed_bin_type*/ 1): call getbytes(symbol_address, main_symp->symbol.len); call cvi2c(addr(rwbbuf), main_symp->symbol.ssize/*precision & scale factor*/, cvbuffer, cvbuffer_size); call put_list(trim(cvbuffer)); goto item_done; examine_type(/*pointer_type*/ 2): x = getword(symbol_address); call put_list( x, ' ', pli_octal(x) ); goto item_done; examine_type(/*float_type*/ 3): call getbytes(symbol_address, main_symp->symbol.len); call put_list( addr(rwbbuf)->a_float ); goto item_done; examine_type(/*char_varying_type*/ 4): examine_type(/*char_fixed_type*/ 5): call put_list(''''); j = main_symp->symbol.len; /*remaining length*/ do while( j > 0 ); i = min16(j, rwbmax); call getbytes(symbol_address, i); call type_string(substr(rwbbuf,1,i),double_quotes); symbol_address = symbol_address + i; j = j - i; end; call put_list (''''); goto item_done; examine_type(/*bit_type*/ 6): call getbytes(symbol_address, main_symp->symbol.len); call put_list( addr(rwbbuf)->a_bit ); goto item_done; examine_type(/*decimal_type*/ 7): call getbytes(symbol_address, min16(main_symp->symbol.len,rwbmax)); deposit_buffer = rwbbuf; if main_symp->symbol.len > rwbmax /*big variable must be gotten in two pieces*/ then do; call getbytes(symbol_address+rwbmax, main_symp->symbol.len-rwbmax); substr(deposit_buffer,rwbmax+1) = rwbbuf; end; call cvd2c(addr(deposit_buffer), main_symp->symbol.ssize/*precision & scale factor*/, cvbuffer, cvbuffer_size); call put_list(trim(cvbuffer)); item_done: if nxtokenis(';') then goto command_done; i = nxtokenis(','); /*skip comma if one*/ if debprocedure_define_level = 0 then call put_list(' '); goto item_loop; end; return; command_done: signal condition(endcmd); end;