/* calculate address in user memory of a variable for PL/I symbolic debugger also figures out the length and type refer to symbol structure definition in symdef.pli for definition of our inputs & outputs note: we must not modify any of our inputs or dot won't work note: uses basing_symp symbol structure for handling based arrays and implicit basing pointers */ addrcalc: procedure(symp) recursive; dcl symp pointer /*to a symbol structure*/; %include 'scandef.pli'; %include 'workdef.pli'; /*for external_data_class*/ %include 'rundef.pli'; %include 'symdef.pli'; %include 'brksymdef.pli'; %include 'moddef.pli'; %include 'symswitch.inc'; %include 'readsym.inc'; %include 'external.inc'; %include 'prologn.inc'; %include 'overlaym.inc'; %include 'getword.inc'; dcl trim entry(char(*)) returns(char(6) varying), iand entry(fixed bin(15), fixed bin(15)) returns(fixed bin(15)); dcl (imult, ibound) fixed bin(15), parent_symp pointer, (thisfp, callerfp, this_prolog, parent_prolog) fixed bin(15) static, /*static only since generates less code*/ (i, j, x) fixed bin(15) static; /*scratch, static only since generates less code*/ /**************************************************************************************************************/ current_module_static: procedure(message) returns(fixed bin(15)/*address in user task of static area*/); dcl message char(*); if ^ overlay_mapped(current_module.overlay) then call error(message); return( getword(current_module.prolog + prolog_static) ); end; call symswitch(symp->symbol.module_fileaddr); if symp->symbol.is_label /*if procedure with returns*/ then call error('not a variable'); if symp->symbol.is_structure then call error('incomplete structure reference'); if symp->symbol.explicit_basing_pointer & (symp->symbol.addressing ^= based_addressing) then call error('not a based symbol'); /* BASED */ if symp->symbol.addressing = based_addressing then do; if ^ symp->symbol.explicit_basing_pointer then do; if symp->symbol.basing_symbol = 0 then call error('missing basing pointer for based reference'); else do; /*use declared basing symbol*/ call read_symbol(symp->symbol.basing_symbol, basing_symp); if basing_symp->symbol.is_array ! basing_symp->symbol.addressing = based_addressing then call error('basing pointer for symbol to the left must be explicitly specified'); /*set up required inputs for address calculation:*/ basing_symp->symbol.explicit_basing_pointer = false; basing_symp->symbol.subscripts = 0; basing_symp->symbol.module_fileaddr = symp->symbol.module_fileaddr; call addrcalc(basing_symp); /*recurse*/ symp->symbol.basing_address = getword(basing_symp->symbol.address); end; end; if -1 <= symbol.basing_address & symbol.basing_address <= 256 /*do at least a minimal check for illegal value*/ then call error('basing pointer for symbol to the left is not initialized'); /* note on valid pointer values: 256 (400 octal) is a nice round number. actually, a normal program cannot have any variables below 1450 octal (initial FP), but the user can adjust .SPTOP downward. the only things below that point are the task header and the stack. note that our test covers the most important cases: -1 (NULL) and 0 (what uninitialized variables usually contain). we can't test against SP since it could be corrupted, and we can't go by the initial FP since the task could be priviledged, with the stack area out at 48K and valid pointers into the executive. */ if ^ symp->symbol.is_array then symp->symbol.address = symp->symbol.basing_address + symp->symbol.offset; else do; if symp->symbol.dimensions = 0 /*if all dimensions inherited*/ then i = symp->symbol.dope; /*then dope word contains static offset*/ else do; /*otherwise it points to symbol table dope vector*/ dcl pdope pointer initial(addr(scratch_symp->symbol.nextsym)), a_word fixed bin(15) based, ipdope fixed bin(15) /*defined(pdope)*/based(ppdope); ppdope=addr(pdope); call read_symbol(symp->symbol.dope, scratch_symp); ipdope = ipdope + array_origin; /*static offset is in origin word*/ i = pdope->a_word; end; symp->symbol.address = i + current_module_static( 'based arrays in an overlay can only be accessed when the overlay is loaded'); end; /*array descriptor for based array is in static area*/ end; else /* EXTERNAL */ if symp->symbol.is_external then do; parent_symp = symp; do while(parent_symp->symbol.parent_structure ^= 0); /*must find level-1 name to look up external address*/ call read_symbol(parent_symp->symbol.parent_structure, scratch_symp); parent_symp = scratch_symp; end; symp->symbol.address = external_address(parent_symp->symbol.name, external_data_class, any_parent); if symp->symbol.address = not_found then call error('level-1 name of external symbol to the left not found'); /*because external_address only enters the first occurrence of a given external data name in the workfile, the hash record is unique, and the parent link indicates what overlay the external is actually in*/ call workgrab(external_workp->workbuf.parent, scratch_workp); /*get overlay segment record*/ if ^ overlay_mapped(scratch_workp->workbuf.value) then call error('external variable is in an overlay which is not currently loaded/mapped'); if symp->symbol.parent_structure ^= 0 /*offset not valid for non-structure*/ then symp->symbol.address = symp->symbol.address + symp->symbol.offset; end; else /* STATIC */ if symp->symbol.addressing = static_addressing then symp->symbol.address = current_module_static('overlay static variables can only be accessed when the overlay is loaded') + symp->symbol.offset; else do; /* AUTOMATIC (includes argument)*/ thisfp = userfp; do while(true); if thisfp = 0 then call error('auto variable is in block that''s not currently active'); this_prolog = getword(thisfp + dsa_prolog); call uplevel(thisfp, callerfp, parent_prolog); /*find caller & parent (enclosing external procedure)*/ if current_module.blocks(symp->symbol.actual_block_code).address = this_prolog /*match address*/ then if current_module.blocks(symp->symbol.actual_block_code).name6 = prologname(this_prolog) /*& 6 chars of name*/ then if this_prolog = parent_prolog /*if external procedure*/ then /*exit loop*/ goto autofound; /*that's it*/ else if current_module.prolog = parent_prolog /*local procedure - also match parent external address*/ then if current_module.name = prologname(parent_prolog) /*and 6 chars of name*/ then /*exit loop*/ goto autofound; thisfp = callerfp; end; /*of do while*/ autofound: symp->symbol.address = thisfp + symp->symbol.offset; if symp->symbol.addressing = argument_addressing then symp->symbol.address = getword(symp->symbol.address); end; /* subscripting */ symp->symbol.descriptor = 0; if symp->symbol.is_array then do; symp->symbol.descriptor = symp->symbol.address; /*PL/I always generates an array descriptor in memory*/ i = iand(getword(symp->symbol.descriptor+array_dimensions), array_dimension_mask); end; else i = 0; if symp->symbol.subscripts < i then call error('not enough subscripts'); if symp->symbol.subscripts > i then call error('too many subscripts'); if symp->symbol.subscripts > 0 then do; symp->symbol.address = getword(symp->symbol.descriptor+array_origin); imult = symp->symbol.descriptor + array_mult; /*address of first multiplier*/ ibound = imult + symp->symbol.subscripts*2; /*address of first bounds pair*/ do i = 1 to symp->symbol.subscripts; x = symp->symbol.subscript(i).value; j = getword(ibound+2); /*high bound*/ if x > j then do; errorp = symp->symbol.subscript(i).errp; call error('hbound for this subscript is'!!j); end; j = getword(ibound); /*low bound*/ if x < j then do; errorp = symp->symbol.subscript(i).errp; call error('lbound for this subscript is'!!j); end; symp->symbol.address = symp->symbol.address + x*getword(imult); imult = imult + 2; ibound = ibound + 4; end; if symp->symbol.addressing = based_addressing /*if based, the subscript calculation yields an offset*/ then symp->symbol.address = symp->symbol.basing_address + symp->symbol.address; end; /* decode the variable type, and calculate the address and length */ symp->symbol.type = undefined_type; symp->symbol.len = symp->symbol.ssize; if symp->symbol.is_arithmetic then if symp->symbol.is_binary_or_character then /* BINARY */ if symp->symbol.is_float_or_picture then do; /* FLOAT */ symp->symbol.type = float_type; symp->symbol.len = 4; end; else do; /* FIXED BIN */ symp->symbol.type = fixed_bin_type; x = iand(symp->symbol.ssize, precision_mask); if x < 8 then symp->symbol.len = 1; else if x < 16 then symp->symbol.len = 2; else symp->symbol.len = 4; end; else do; /* DECIMAL */ call error('access to decimal variables not implemented');/**temp*/ end; else /* not arithmetic */ if ^ symp->symbol.isnot_string then do; /* string */ if symp->symbol.is_varying /*assume no string descriptor, set default varying attribute from symbol table*/ then symp->symbol.type = char_varying_type; else symp->symbol.type = char_fixed_type; if ^ symp->symbol.is_array /*if not array */ then do; if symp->symbol.addressing ^= based_addressing /* and not based */ then do; /* then have descriptor*/ symp->symbol.descriptor = symp->symbol.address; symp->symbol.address = getword(symp->symbol.descriptor + string_addr_word); symp->symbol.len = getword(symp->symbol.descriptor + string_length_word); if iand(symp->symbol.len, string_varying_mask) ^= 0 /*get varying attribute from descriptor*/ then symp->symbol.type = char_varying_type; else symp->symbol.type = char_fixed_type; symp->symbol.len = iand( symp->symbol.len, string_length_mask ); end; end; else if symp->symbol.len = star_length /*if array of char(*)*/ then symp->symbol.len = getword(symp->symbol.descriptor+array_length); /*get length from array descriptor*/ if symp->symbol.is_binary_or_character then do; /* CHARACTER */ end; /*everything's already set up*/ else if symp->symbol.is_float_or_picture then do; /* PICTURE */ call error('access to picture variables not implemented'); /**temp*/ end; else do; /* BIT string */ symp->symbol.type = bit_type; if symp->symbol.len ^= 1 ! symp->symbol.type ^= char_fixed_type /**temp*/ then call error('access to bit variables other than BIT(1) not implemented'); if symp->symbol.descriptor ^= 0 then if iand( getword(symp->symbol.descriptor + string_align_word), string_bit_alignment) ^= 0 then call error('access to bit substrings not implemented'); end; end; else do; /*not string or arith - special*/ if symp->symbol.is_pointer then do; /* POINTER */ symp->symbol.type = pointer_type; symp->symbol.len = 2; end; else call error('not a variable'); end; readword_addr = symp->symbol.address; end addrcalc;