/* find address of a PL/I external (a TKB psect) for PL/I symbolic debugger %include 'external.inc' for proper declaration incrementally scans the map, storing hash records in the work file along the way, so that access to already-accessed data is quick and the map is scanned at most once. also called by segment and global_address to cause scanning to the beginning or end, respectively, of an overlay segment section. all occurrences of external procedures are recorded in the workfile, allowing the task to have multiple external procedures with the same name but in different overlays (ordinarily they would be separate copies of the same procedure). only the first occurrence of external data is recorded (and thus accessible). access to multiple external variables with the same name is not implemented because it would make addrcalc's external lookup complicated and because it doesn't make much sense (separate variables should have separate names). currently does not handle FTB maps, though this would not be difficult to implement (recognize the '<' at the beginning of the line and overlay an alternate mapline structure. also set external_data_class = external_procedure_class, since FTB provides no differentiation, and set FTB_map = true) */ external_address: procedure(aname, aclass, asegment) returns(fixed bin(15)/*address in user task*/); dcl aname char(*) varying, aclass fixed bin(7), /*external_procedure_class, external_data_class, overlay_segment_class, or global_class*/ asegment fixed bin(23); /*fileaddr of overlay segment hash record for the segment the external must be in, or any_parent (take next-encountered external in any segment)*/ /*on return, if the external was found, external_workp points to the buffer containing the hash record*/ %include 'putdef.pli'; %include 'workdef.pli'; %include 'rundef.pli'; %include 'segdef.pli'; %include 'mapdef.pli'; %include 'truefalse.inc'; %include 'external.inc'; %include 'getword.inc'; dcl octbin entry(char(*)) returns(fixed bin(15)), trim entry(char(*) varying) returns(char(132) varying), ascii entry(fixed bin(7)) returns(char(1)); dcl aname6 char(6) varying, thisone_name char(6) varying, thisone_class fixed bin(7), thisone_addr fixed bin(15), this_is_root fixed bin(1), (next_segment, parent_segment) fixed bin(15); dcl 1 mapline, 2 psectname char(6), /*6-char name*/ 2 colon char(1), /*plus colon*/ 2 fill1 char(4), /*skip first attribute*/ 2 I_or_D char(1), /*instruction or data attribute*/ 2 fill2 char(18), /*skip further attributes*/ 2 psectaddr char(6), /*octal address*/ 2 fill3 char(22), /*skip sizes & title*/ 2 ident char(6), 2 fill4 char(1), /*skip blank*/ 2 filename char(10), /*beginning of filename (we're not interested in type or version)*/ 2 pad char(57); /*must add to 132*/ /**************************************************************************************************************/ on endfile(mapfile) goto return_not_found; aname6 = aname; call upcase(aname6); call trnslt(aname6, '.', '_'); /*convert underscores to dots*/ if external_address_first_call then do; external_address_first_call = false; this_is_root = true; current_segment.descriptor = root_segment_descriptor; /*from debinit*/ current_segment.name = root_segment_name; /*from debinit if it encountered 'Root segment' line*/ if root_segment_name ^= '' then goto write_segment; /*must write segment hash record if past 'Root segment' line*/ end; /*debinit may or may not have hit root segment line (FTB & TKB maps are different)*/ external_workp = scratch_workp; if workget(aname6, aclass, asegment, scratch_workp) then return(scratch_workp->workbuf.value); external_workp = put_workp; do while(true); nextone: read file(mapfile) into(mapline); if colon = ':' then do; skip_thisone: thisone_addr = octbin(mapline.psectaddr); if I_or_D = 'I' then thisone_class = external_procedure_class; else /* = 'D' */ thisone_class = external_data_class; thisone_name = trim(psectname); if ('A' <= substr(psectname,1,1)) & (substr(psectname,1,1) <= 'Z') then do; if thisone_class = external_data_class then if workget(thisone_name, external_data_class, any_parent, scratch_workp) then do; if scratch_workp->workbuf.value ^= thisone_addr ! scratch_workp->workbuf.parent ^= root_segment_fileaddr /* i.e., if the addresses are different, or if the addresses are the same but in different overlays (we only need compare with the root since we only put the first external of a given name in the workfile - if the first occurrence is not in the root, then all occurrences must be in overlays) (strictly, we should compare against all parents of current segment so we dont give superfluous warning if user has external in an overlay properly mapped to by a subsegment, but not sure it's worth the trouble) */ then do; call trnslt(psectname,'_','.'); /*convert dots to underscores*/ call put_skip_list('Note: external variable ',psectname,' in overlay segment ',current_segment.name, ' has the same name as a'); call put_skip_list(' previously defined external - Only the previous external will be accessable.'); end; /*warn user - multiple externals with the same name are almost always a bug due to failure to put the externals in the root*/ goto nextone; /*dont put the new one in workfile - leave only the first occurrence with the same name (usually from the root). note that every segment referring to the same external will have an occurrence of it (with same address), so this also saves us from filling the workfile with these duplicates*/ end; read file(mapfile) into(mapline); if substr(psectname,1,1) = ascii(12) /*if on page boundary, */ then read file(mapfile) into(mapline); /* skip page header*/ if colon = ':' then goto skip_thisone; /*no line following - it's system psect, not PL/I external*/ put_workp->workbuf.value = thisone_addr; call workput(thisone_name, thisone_class, current_segment.fileaddr); call workwrite(substr(mapline.filename,1,index(mapline.filename,'.')-1));/*file name less type and version*/ /* (since max size of name is 9 chars & TKB always includes type, index can't return 0 */ end/*of if alphabetic*/; /*following test is outside alphabetic code to handle call for '$DEB$$' by DEBINIT - not alphabetic but must match*/ if (thisone_name = aname6) & (thisone_class = aclass) /*use thisone_name - psectname may have been overwritten*/ & ( current_segment.fileaddr = asegment ! asegment = any_parent ) then return(thisone_addr); end/*of if ':'*/; else if index(string(mapline), /*S or s*/'egment:') ^= 0 then do; current_segment.name = trim( substr(string(mapline), index(string(mapline),':')+2, 6) ); this_is_root = ( index(string(mapline), 'Root segment:') ^= 0 ); if this_is_root then root_segment_name = current_segment.name; else do; /* find overlay segment descriptor address, traversing the tree: */ next_segment = getword(current_segment.descriptor + overlay_descriptor_link_down); if next_segment = 0 then do; pop: next_segment = getword(current_segment.descriptor + overlay_descriptor_link_next); parent_segment = getword(next_segment + overlay_descriptor_link_up); if next_segment = getword(parent_segment + overlay_descriptor_link_down) then do; current_segment.descriptor = parent_segment; goto pop; end; end; current_segment.descriptor = next_segment; user_is_overlaid = true; /*we've encountered a segment other than the root - task must have overlays*/ end; write_segment: put_workp->workbuf.value = current_segment.descriptor; call workput(current_segment.name, overlay_segment_class, 0); current_segment.globalsrec_fileaddr = current_fileaddr(workfile); current_segment.fileaddr = put_workp->workbuf.fileaddr; if this_is_root then root_segment_fileaddr = current_segment.fileaddr; segment_globals_base = null_fileaddr; write file(workfile) from(segment_data); /*reserve space in file for segment_data record to be filled in later*/ if aclass = overlay_segment_class then return(segment_found); end; else if index(string(mapline), 'Global symbols:') ^= 0 then do; segment_globals_base = current_fileaddr(mapfile); call workpos(globalsrec_fileaddr, scratch_workp); write file(workfile) from(segment_data); if aclass = global_class then return(segment_found); end; end/*of do while*/; return_not_found: return(not_found); end/*external_address*/;