block_dcld_in.pl1 11/11/86 1122.0rew 11/11/86 0911.4 11304 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ block_dcld_in: proc (P_sp) returns (ptr); /* given P_sp, a ptr to a runtime_symbol node, return a pointer to the runtime_block node it was declared in. This can't fail, given a valid symbol table Created: 22 Feb 79 James R. Davis Modified June 83 JMAthane to replace references to "runtime_symbol"structure by calls to runtime_symbol_info_ subroutine. */ dcl P_sp ptr parameter; dcl sp ptr; /* copy of P_sp */ dcl (addrel, fixed) builtin; sp = P_sp; do while (runtime_symbol_info_$level (sp) > 1); sp = runtime_symbol_info_$father (sp); end; /* now sp pts to level 0 or level 1 entry */ return (runtime_symbol_info_$father (sp)); %include pascal_symbol_node; %include runtime_symbol; %include runtime_symbol_info_; end block_dcld_in;  decode_runtime_value.pl1 11/12/86 1736.4rew 11/12/86 1607.5 120033 /****^ ****************************************************** * * * Copyright (c) 1986 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212): Fixed bug in code 16 value decoding. END HISTORY COMMENTS */ /* procedure to decode the values stored in a PL/1 symbol table */ /* Modified: 8 December 1978 by RAB to fix PL/I bug 1790 (can't decode value from internal controlled desc) Modified: 3 Mar 79 by James R. Davis MCR 3735, and overhaull for beauty and legality Modified June 83 JMAthane to add decode_runtime_value_extended entry point and code 16 interpretation. Modified August 1983 W. Olin Sibert to use attempt_thunk Modified June 86 JMAthane. fixed bug in code 16 decoding */ decode_runtime_value: proc (v, blk, sp, lp, tp, refp, code) returns (fixed bin (35)); dcl v fixed bin (35), /* value to decode */ blk ptr, /* ptr to runtime block node */ sp ptr, /* stack frame pointer */ lp ptr, /* linkage pointer */ tp ptr, /* object pointer */ refp ptr, /* based reference pointer */ code fixed bin (35); /* completion code */ dcl arg_list_arg_count fixed bin; /* used to be in include file */ dcl attempt_thunk entry (fixed bin (35), pointer, pointer, pointer, fixed bin (35)) returns (fixed bin (35)); dcl 1 a_value aligned like encoded_value; dcl (n, n1, n2, n3) fixed bin; /* values extracted from encode_value */ dcl temp ptr; /* just a temp */ dcl (addr, addrel, baseno, bin, fixed, hbound, null, ptr, stackbaseptr, string, substr, unspec) builtin; dcl ptr_var ptr based; dcl based_fixed_bin fixed bin based; string (a_value) = unspec (v); /* convert to internal form */ if (a_value.flag = "11"b) | (a_value.flag = "00"b) then do; code = 0; return (v); end; n = fixed (a_value.code, 4); if n > 16 then go to fail; go to join; decode_runtime_value_extended: entry (v, blk, sp, lp, tp, refp, symb, code) returns (fixed bin (35)); /* This entry assumes that the value IS encoded and that code is on 6 bits */ dcl symb ptr; /* ptr to runtime symbol node */ string (a_value) = unspec (v); n = fixed (addr (a_value) -> pascal_encoded_value.code, 6); join: if n > hbound (sw, 1) then do; fail: code = 1; return (0); end; n1 = fixed (a_value.n1, 6); n2 = fixed (a_value.n2, 6); n3 = fixed (a_value.n3, 18); code = 0; goto sw (n); sw (0): /* automatic variable */ return (addrel (get_stack_ptr (sp, n1), n3) -> based_fixed_bin); sw (1): /* internal static variable */ return (addrel (get_static_ptr (), n3) -> based_fixed_bin); sw (2): /* external static */ return (addrel (addrel (get_linkage_ptr (), n3) -> ptr_var, n1) -> based_fixed_bin); sw (3): /* bit offset of reference pointer */ begin; /* used by pre-EIS compilers only */ dcl 1 an_its_ptr aligned like its; if refp = null then goto fail; string (an_its_ptr) = unspec (refp); return (fixed (an_its_ptr.bit_offset, 6) + n3); end; /* type 3 begin block */ sw (4): /* based on automatic pointer */ return (addrel (addrel (get_stack_ptr (sp, n1), n3) -> ptr_var, n2) -> based_fixed_bin); sw (5): /* based on internal static pointer */ return (addrel (addrel (get_static_ptr (), n3) -> ptr_var, n2) -> based_fixed_bin); sw (6): /* based on external static pointer */ return (addrel (addrel (addrel (get_linkage_ptr (), n3) -> ptr_var, n1) -> ptr_var, n2) -> based_fixed_bin); sw (7): /* based on reference pointer (refer) */ if refp = null then goto fail; return (addrel (refp, n2) -> based_fixed_bin); sw (8): /* value given by procedure (thunk) */ return (attempt_thunk (v, blk, sp, refp, code)); /* Do the best we can */ sw (9): /* value given by argument n2 of procedure */ temp = get_arglist_ptr (sp, n1, ("0"b)); if n2 > arg_list_arg_count then goto fail; return (addrel (convert_ptr (temp -> arg_list.arg_ptrs (n2)), n3) -> based_fixed_bin); sw (10): /* value based on argument n2 of procedure */ temp = get_arglist_ptr (sp, n1, ("0"b)); if n2 > arg_list_arg_count then goto fail; return (addrel (convert_ptr (temp -> arg_list.arg_ptrs (n2)) -> ptr_var, n3) -> based_fixed_bin); sw (11): /* value given by size field at offset n3 in descriptor n2 */ temp = addrel (get_desc_ptr (sp, n1, n2), n3); if temp -> arg_descriptor.flag then return (temp -> arg_descriptor.size); /* version II arg descriptor */ else return (fixed (substr (unspec (temp -> arg_descriptor.size), 7, 18), 18)); /* version I (kludge ) */ sw (12): /* value given by field at offset n3 in descriptor of arg n2 of block n1 steps along display chain */ return (addrel (get_desc_ptr (sp, n1, n2), n3) -> based_fixed_bin); sw (13): /* value given by size in descriptor of controlled variable */ return (fixed (get_ctl_descriptor () -> arg_descriptor.size, 24)); sw (14): /* value given by word ,offset from ctl dec */ return (get_ctl_descriptor () -> based_fixed_bin); sw (15): /* value given by word at offset n2 from ctl var */ return (addrel (get_ctl_block_ptr () -> ctl_block.data, n2) -> based_fixed_bin); sw (16): /* value given by corresponding symbol block, on n2 bits, signed if n1 =1 */ begin; dcl (symbol_ptr, block_ptr, loc) ptr; dcl block_dcld_in entry (ptr) returns (ptr); dcl display_count fixed bin; dcl get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr); dcl value fixed bin (35); dcl 1 signed_value based, 2 s bit (1) unal, 2 v bit (n2) unal; dcl unsigned_value bit (n2) unal based; dcl v_36b bit (36) based; dcl this_sp ptr; dcl this_block ptr; dcl i fixed bin; get_linkage_ptr: proc () returns (ptr); /* The same as below, but returns null when faulty ptr */ dcl ilp ptr unal; if lp ^= null then return (lp); else do; /* must find it ourselves */ ilp = stackbaseptr () -> stack_header.lot_ptr -> lot.lp (fixed (baseno (get_text_ptr ()), 18)); if faulty_ptr (ilp) then return (null); return (ilp); end; end get_linkage_ptr; symbol_ptr = addrel (symb, n3); this_block = block_dcld_in (symbol_ptr); block_ptr = blk; display_count = 0; do while (this_block ^= block_ptr); block_ptr = runtime_symbol_info_$father (block_ptr); if block_ptr = null then go to fail; display_count = display_count + 1; end; this_sp = sp; if sp ^= null then do i = 1 to display_count; this_sp = this_sp -> frame.display; end; loc = get_runtime_address (block_ptr, symbol_ptr, this_sp, get_linkage_ptr (), get_text_ptr (), null, null); if loc = null then go to fail; if n2 > 36 then go to fail; if n1 > 1 then go to fail; n2 = n2 - n1; if n1 = 1 then addr (value) -> v_36b = copy (loc -> signed_value.s, 36 - n2) || loc -> signed_value.v; if n1 = 0 then addr (value) -> v_36b = copy ("0"b, 36 - n2) || loc -> unsigned_value; return (value); end; get_stack_ptr: proc (stack, display_ct) returns (ptr); dcl stack ptr parameter; dcl display_ct fixed bin parameter; dcl q ptr; dcl i fixed bin; q = stack; if q = null then goto fail; do i = 1 to display_ct; q = q -> frame.display; end; return (q); end get_stack_ptr; get_linkage_ptr: proc () returns (ptr); /* global inputs lp */ dcl ilp ptr unal; if lp ^= null then return (lp); else do; /* must find it ourselves */ ilp = stackbaseptr () -> stack_header.lot_ptr -> lot.lp (fixed (baseno (get_text_ptr ()), 18)); if faulty_ptr (ilp) then goto fail; return (ilp); end; end get_linkage_ptr; get_text_ptr: proc () returns (ptr); /* global inputs: tp, sp, blk */ if tp ^= null then return (tp); if sp ^= null then return (sp -> frame.entry); if blk ^= null then return (ptr (blk, 0)); goto fail; end get_text_ptr; get_static_ptr: proc () returns (ptr); dcl isp ptr unal; isp = stackbaseptr () -> stack_header.isot_ptr -> isot.isp (fixed (baseno (get_text_ptr ()), 18)); if faulty_ptr (isp) then goto fail; return (isp); end get_static_ptr; get_arglist_ptr: proc (stack, display_ct, quick) returns (ptr); dcl stack ptr parameter; dcl display_ct fixed bin parameter; dcl quick bit (1) aligned parameter; /* (output) caller: pass me ("0"b) if you don't care */ dcl q ptr; q = get_stack_ptr (stack, display_ct); quick = "0"b; if blk = null then q = q -> frame.argptr; else if blk -> runtime_block.quick then do; quick = "1"b; if blk -> runtime_block.entry_info = "0"b then goto fail; q = (addrel (q, blk -> runtime_block.entry_info) -> quick_entry.argptr); end; else q = q -> frame.argptr; arg_list_arg_count = q -> arg_list.arg_count; /* set globally for our callers */ return (q); end get_arglist_ptr; get_desc_ptr: proc (stack, display_ct, narg) returns (ptr); dcl stack ptr parameter; dcl display_ct fixed bin parameter; dcl narg fixed bin parameter; dcl quick bit (1) aligned; dcl q ptr; q = get_arglist_ptr (stack, display_ct, quick); if ^quick /* don't know why, but ignore for quick */ then if q -> arg_list.header.desc_count < narg then goto fail; if q -> arg_list.header.call_type = Envptr_supplied_call_type then return (convert_ptr (q -> arg_list_with_envptr.desc_ptrs (narg))); else return (convert_ptr (q -> arg_list.desc_ptrs (narg))); end get_desc_ptr; get_ctl_block_ptr: proc () returns (ptr); /* returns ptr to the controlled variable control block - GLOBAL input n1 (0 for internal, 1 for external) n3 offset in linkage or static of the ctl block */ if n1 = 0 then return (addrel (get_static_ptr (), n3)); else return (addrel (get_linkage_ptr (), n3) -> ptr_var); end get_ctl_block_ptr; get_ctl_descriptor: proc () returns (ptr); /* Il Kludge: due to bug in PL/I, for internal controlled encoding where the descriptor is desired (Type 13 and 14)(NOT 15!!) n3 is the offset in the static section of the descriptor ptr itself, not the ctl block n2 is offset from descriptor of the field wanted n1 is 0 for internal, 1 for external */ dcl dp ptr; if n1 = 0 then dp = addrel (get_static_ptr (), n3) -> ptr_var; /* pt to descriptor */ else dp = addrel (get_linkage_ptr (), n3) -> ptr_var -> ctl_block.descriptor; return (addrel (dp, n2)); /* offset from the descriptor */ end get_ctl_descriptor; convert_ptr: proc (P_ptr) returns (ptr); /* given a ptr, which may be an ITS, ITP, or text embedded ptr, convert to ITS so we can use it For certain constructs, clever ptrs like ITP are used, and these can be eval'd only by knowing the value of a users pointer reg. */ dcl P_ptr ptr parameter; dcl 1 an_itp_ptr aligned like itp; dcl reg fixed bin; dcl basep ptr; dcl 1 text_embedded_ptr aligned, 2 offset bit (18) unal, 2 pad bit (18) unal; dcl (string, unspec) builtin; string (an_itp_ptr) = unspec (P_ptr); if an_itp_ptr.itp_mod = "43"b3 /* ITS */ then return (P_ptr); if an_itp_ptr.itp_mod = "00"b3 /* text relative to base of seg */ then do; string (text_embedded_ptr) = unspec (P_ptr); return (ptr (get_text_ptr (), text_embedded_ptr.offset)); end; if an_itp_ptr.itp_mod = "41"b3 /* ITP */ then do; reg = bin (an_itp_ptr.pr_no, 3); if reg = 6 then basep = sp; else if reg = 4 then basep = get_static_ptr (); else goto fail; return (bitrel (addrel (basep, an_itp_ptr.offset), bin (an_itp_ptr.bit_offset, 6))); end; /* ITP */ goto fail; /* fell through -no of the above */ end convert_ptr; bitrel: proc (P_ptr, P_bit_offset) returns (ptr); dcl P_ptr ptr parameter; dcl P_bit_offset fixed bin (24) parameter; dcl 1 str aligned based (P_ptr), 2 filler unal bit (P_bit_offset), 2 target unal bit (1); if P_bit_offset < 0 then goto fail; return (addr (str.target)); end bitrel; faulty_ptr: proc (P_unal_ptr) returns (bit (1) aligned); dcl P_unal_ptr ptr unal parameter; dcl baseno builtin; return (baseno (P_unal_ptr) = "0"b); end faulty_ptr; %include stu_frame; %include runtime_symbol; %include quick_entry; %include ctl_block; %include stack_header; %include lot; %include its; %include arg_descriptor; %include arg_list; %include pascal_symbol_node; %include runtime_symbol_info_; end;  find_block.pl1 05/23/73 1233.4rewa05/23/73 1233.4 19908  /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Procedure to search for a symbol block Initial Version: 15 May 1970 by BLW Modified: 25 September 1972 by BLW for std obj segments */ find_block: proc(pt,name) returns(ptr); dcl pt ptr, /* points at symbol header */ name char(*) aligned; /* name of block to look up */ dcl (hp,bp) ptr, root bit(18) aligned, (addrel,length,null) builtin; %include symbol_header; %include symbol_node; %include std_symbol_header; %include pl1_symbol_block; hp = pt; if hp -> std_symbol_header.identifier ^= "symbtree" then root = hp -> symbol_header.root; /* non-std symbol header */ else do; /* have std symbol header, look for pl1 symbol block */ if hp -> std_symbol_header.area_pointer = (18)"0"b then return(null); bp = addrel(hp,hp -> std_symbol_header.area_pointer); if bp -> pl1_symbol_block.identifier ^= "pl1info" then return(null); root = bp -> pl1_symbol_block.root; end; if root = (18)"0"b then return(null); return(search(addrel(hp,root))); search: proc(block_pt) returns(ptr); dcl (block_pt,p,bp) ptr, n fixed bin; dcl 1 acc aligned based, 2 size unal bit(9), 2 string unal char(n); bp = block_pt; check: if bp -> symbol_block.name = (18)"0"b then goto step; p = addrel(bp,bp -> symbol_block.name); n = fixed(p -> acc.size,9); if n ^= length(name) then goto step; if name = p -> acc.string then return(bp); step: if bp -> symbol_block.son then do; p = search(addrel(bp,bp -> symbol_block.son)); if p ^= null then return(p); end; if bp -> symbol_block.brother then do; bp = addrel(bp,bp -> symbol_block.brother); goto check; end; return(null); end; end;  find_containing_block.pl1 06/29/79 1618.7rew 06/29/79 1421.5 22599 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ find_containing_block: procedure (header_ptr, location) returns (pointer); /* This routine finds the block that physically contains a given location, and returns a pointer to the symbol block for that block. It needs a pointer to the symbol header for the procedure to find the root block from which to begin search. Initial Version: Unknown Person Modified: 9 Sept 78 by James R. Davis to remove assumption that blocks are in text order */ dcl header_ptr pointer, /* pointer to symbol header of procedure */ (addrel, fixed, null) builtin, location fixed bin (35), /* location of interest */ bp pointer, /* pointer to current block */ p pointer; if header_ptr = null then return (null); /* check for real symbol table */ if header_ptr -> std_symbol_header.identifier ^= "symbtree" then return (null); p = addrel (header_ptr, header_ptr -> std_symbol_header.area_pointer); if p -> pl1_symbol_block.identifier ^= "pl1info" then return (null); if p -> pl1_symbol_block.root = (18)"0"b then return (null); p = addrel (header_ptr, p -> pl1_symbol_block.root); /* get pointer to root block */ /* bp at all times points to the innermost block we KNOW we're in, p points to the block being examined */ bp = p; /* we must be in root */ do while ("1"b); if location >= fixed (addrel (p, p -> runtime_block.first) -> statement_map.location, 18) & location <= fixed (addrel (p, fixed (p -> runtime_block.last) -2) -> statement_map.location, 18) then do; /* we're inside this block */ bp = p; if bp -> runtime_block.son ^= (18) "0"b /* have we a son ? */ then p = addrel (bp, bp -> runtime_block.son); /* examine it */ else return (bp); /* can go no deeper */ end; else if p -> runtime_block.brother then p = addrel (p, p -> runtime_block.brother); else return (bp); end; /* of search */ %include std_symbol_header; %include runtime_symbol; %include statement_map; %include pl1_symbol_block; end find_containing_block;  find_header.pl1 09/08/75 1705.0rew 09/08/75 1512.4 18297 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Procedure to find symbol header of a specified program Modified: 25 September 1972 by BLW for std obj segments Modified: 11 June 1975 by JMB for version 2 object info */ find_header: proc(seg_pt,name,bc) returns(ptr); dcl seg_pt ptr, /* points at text segment */ name char(32) aligned, /* name of segment */ bc fixed bin; /* bit count */ dcl (p,q) ptr, dir char(168), ent char(32), (n,code,size) fixed bin, hcs_$make_ptr entry(ptr,char(*) aligned,char(*) aligned,ptr,fixed bin), hcs_$status_mins entry(ptr,fixed bin,fixed bin,fixed bin), object_info_$brief entry(ptr,fixed bin,ptr,fixed bin), component_info_$name entry(ptr,char(32) aligned,ptr,fixed bin); dcl (index,null,ptr,substr) builtin; dcl 1 oi structure aligned like object_info; %include object_info; %include component_info; if seg_pt ^= null then p = seg_pt; else do; n = index(name," "); if n = 0 then n = 33; call hcs_$make_ptr(null,substr(name,1,n-1),"symbol_table",p,code); if code ^= 0 then goto no; end; if bc ^= 0 then n = bc; else do; call hcs_$status_mins(p,size,n,code); if code ^= 0 then goto no; end; p = ptr(p,0); oi.version_number = object_info_version_2; call object_info_$brief(p,n,addr(oi),code); if code ^= 0 then goto no; /* if segment is not bound, there is only one symbol header and that's the one we'll use */ if ^ oi.bound then return(oi.symbp); call component_info_$name(p,name,addr(ci),code); if code ^= 0 then goto no; return(ci.symb_start); no: return(null); end;  find_runtime_symbol.pl1 11/12/86 1736.4rew 11/12/86 1607.4 103365 /****^ ****************************************************** * * * Copyright (c) 1986 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212): Fixed failure when runtime_token.dcl was "0"b. END HISTORY COMMENTS */ /* Procedure to search runtime symbol table for a specified symbol. Initial Version: 15 May 1970 by BLW Modified: 24 October 1971 by BLW for Version II Modified: 21 January 1973 by BLW to return pointer to block Modified: 21 June 1974 by J.M. Broughton to handle levels and block ptr right Modified: 21 February 1978 by R.A. Barnes to consider runtime_symbol.next to always be a backwards reference Modified: 22 December 1978 by JRDavis 1) not assume that father is frame owner, b) rewrite for elegance Modified: 22 Feb 79 by JRDavis to use new routines stu_$get_display_steps Modified June 83 JMAthane to replace references to "runtime_symbol"structure by calls to runtime_symbol_info_ subroutine. */ /* Removed Version 1 symbol table support 10/17/83 S. Herbst */ /* Fixed when runtime_token.dcl = "0"b JMAthane June85 */ find_runtime_symbol: proc (pt, name, block_pt, steps) returns (ptr); declare pt ptr parameter, /* input: to block in symbol table where search begins */ name char (*) aligned parameter, /* input: name of symbol, may be of form "a.b.c" */ block_pt ptr parameter, /* output: to block node where symbol found or null if fail */ steps fixed bin parameter; /* output: if <0, non-standard error code: -1 block pointer is null -2 more than 64 structure levels in given symbol -3 given symbol too long -4 no declaration for given symbol -5 ambiguous reference if >= 0, the number of steps on display chain between the starting frame and the found frame along the display chain. This information is used by the caller to find the proper stack frame for the symbol if needed. */ /* return arg is pointer to runtime_symbol node if symbol found, or null if failed */ dcl bp ptr; /* copy of block_pt */ dcl i fixed bin; dcl ctnum fixed bin; /* number of components in symbol's name */ dcl pos fixed bin; /* used in isolating components */ dcl a (0:64) fixed bin; /* index of all periods in struc name */ dcl (addrel, index, length, hbound, null, substr) builtin; %page; block_pt = null; steps = 0; bp = pt; if bp = null then call failure (-1); /* Fill the "a" array - which records where components begin and end in "name" a(i) is the index of the i'th delimiter - so the m'th component runs from the a(i-1)+1 char to the a(i)-1 char. */ ctnum = 0; i = 1; /* be sure we enter the loop */ do pos = 0 repeat (pos + i) while (i > 0); /* pos is index of delim */ a (ctnum) = pos; /* record delim position */ if ctnum = hbound (a, 1) /* a new ct begins here, but no room */ then call failure (-2); ctnum = ctnum + 1; i = index (substr (name, pos + 1), "."); /* is there another delim we can see? */ end; a (ctnum) = length (name) + 1; /* no, there is a "fake" delim after last char */ dcl sp ptr; /* to a symbol node */ dcl ctindex fixed bin; /* index in name of n'th component */ dcl ctlen fixed bin; /* length of component */ dcl stu_$get_display_steps entry (ptr, ptr) returns (fixed bin); dcl fsp ptr; /* to first symbol with given name */ ctindex = a (ctnum - 1) + 1; ctlen = a (ctnum) - a (ctnum - 1) - 1; /* watch those fenceposts! */ fsp = find_first_symbol (bp, substr (name, ctindex, ctlen)); call search_symbol (fsp, bp, sp); steps = stu_$get_display_steps (pt, bp); block_pt = bp; /* set return arg */ return (sp); %page; find_first_symbol: proc (P_bp, P_name) returns (ptr); /* given a block ptr and a name, return ptr to the first symbol in the table with the name call failure if there is none if the name has more than one component (i.e. a member of a structure) we are interested in the last component */ dcl P_bp ptr parameter; dcl P_name char (*) parameter; dcl tp ptr; /* to token chain */ dcl name_len fixed bin; dcl (addrel, length, null) builtin; name_len = length (P_name); tp = find_token_chain (); do while (tp ^= null); if tp -> runtime_token.size = name_len /* compare lengths first, for efficiency */ then if tp -> runtime_token.string = P_name /* 'cause char compare costs */ then if tp -> runtime_token.dcl ^= (18)"0"b then return (addrel (tp, tp -> runtime_token.dcl)); if (tp -> runtime_token.size > name_len) /* no hope */ | (tp -> runtime_token.next = (18)"0"b) /* nothing left */ then tp = null; /* cause loop to end */ else tp = addrel (tp, tp -> runtime_token.next); end; /* token loop */ call failure (-4); /* fell out - not found */ find_token_chain: proc returns (ptr); dcl i fixed bin; dcl offset bit (18); dcl lgth2 (0:6) fixed bin int static options (constant) init (1, 2, 4, 8, 16, 32, 99999); do i = 0 to (hbound (lgth2, 1) - 1); /* for every possible length range */ if (lgth2 (i) <= name_len) & (name_len < lgth2 (i + 1)) then do; /* found right range */ offset = P_bp -> runtime_block.token (i); if offset = (18)"0"b then call failure (-4); /* empty chain */ return (addrel (P_bp, offset)); end; end; /* search */ call failure (-3); /* >99999 ! */ end find_token_chain; end find_first_symbol; %page; search_symbol: proc (P_first_symbol, P_bp, P_sp); /* given ptr to first symbol of desired name (or to lowest level, if structure), and a block to begin searching in, search all blocks, from inward out, for a symbol that matches, or fail (in which case we do not return) */ /* If the runtime symbol table was produced by the Version II PL/I compiler, the given symbol need not be fully qualified. The searching algorithm used here is the same as that used by the PL/I compiler. We search for an applicable declaration for which the given symbol is a fully qualified reference. We remember any applicable declaration for which the symbol is a partially qualified reference. If two or more applicable declarations can be found and the given symbol is not a fully qualified reference to any of them, we have an ambiguous reference. If only one applicable declaration can be found, the given symbol is a valid partially qualified reference to that declaration. The search for an applicable declaration begins in the current block and continues outward until the first applicable declaration is found. After the first applicable declaration is found, all additional searching is confined to the block in which the first applicable declaration was found. */ dcl P_first_symbol ptr parameter; /* Input, Read-only, to symbol start at */ dcl P_bp ptr parameter; /* Input/Output, By-name, to starting block */ dcl P_sp ptr parameter; /* output, to symbol found */ dcl hp ptr; /* to symbol table header */ dcl sp ptr; dcl pq_ct fixed bin; /* number of partially qualified ref's found */ dcl pq_sp ptr; /* to symbol node of partially qual'd ref */ dcl matches bit (1) aligned; dcl fully bit (1) aligned; dcl stu_$block_dcld_in entry (ptr) returns (ptr); pq_ct = 0; hp = addrel (P_bp, P_bp -> runtime_block.header); do P_bp = P_bp repeat (addrel (P_bp, P_bp -> runtime_block.father)) while (P_bp ^= hp); sp = P_first_symbol; do while (sp ^= null); /* for each symbol of same name */ if stu_$block_dcld_in (sp) = P_bp then do; /* if dcl'd in current block */ call match_name (matches, fully); /* test it for match */ if matches then if fully then do; P_sp = sp; return; end; else do; /* partial -count it up */ pq_ct = pq_ct + 1; pq_sp = sp; end; end; sp = runtime_symbol_info_$next (sp); end; /* symbol loop */ /* not found in this block as a fully - but perhaps as a partial */ if pq_ct > 1 then call failure (-5); /* ambiguous */ if pq_ct = 1 then do; /* exactly one - ok */ P_sp = pq_sp; return; end; /* no partial, continue search in father block */ end; /* fell out of block loop - not found */ call failure (-4); %page; match_name: proc (P_match, P_fully); /* called when current symbol has the right name - see if the components match properly */ dcl P_match bit (1) aligned parameter; /* output "1"b if matches */ dcl P_fully bit (1) aligned parameter; /* output "1"b if match is fully qual'ed */ /* references the gloabl vars: ctnum a, name, sp */ dcl lev fixed bin; dcl cti fixed bin; /* index into name of a component */ dcl ctl fixed bin; /* length of a token */ dcl np ptr; /* to symbol node */ dcl ni fixed bin; /* index in names array */ lev = runtime_symbol_info_$level (sp); P_fully = "0"b; P_match = "0"b; if (lev = 0) | (lev = 1) /* can only be one ct in name */ then do; /* can optomize test */ if ctnum = 1 /* both names and component count match */ then do; P_fully = "1"b; P_match = "1"b; end; else ; /* too many ct's - can't match */ return; /* done in either case */ end; /* of one-component opt */ else if lev < ctnum /* more cts in name then levels to match */ then return; /* cant hope to match */ np = sp; do ni = ctnum to 1 by -1; /* from last to first component */ cti = a (ni - 1) + 1; ctl = a (ni) - a (ni - 1) - 1; do while (addrel (np, np -> runtime_symbol.name) -> acc.string ^= substr (name, cti, ctl)); if runtime_symbol_info_$level (np) > 1 then np = runtime_symbol_info_$father (np); else return; end; end; P_fully = (ctnum = lev); P_match = "1"b; return; end match_name; end search_symbol; %page; /* never should fall through */ exit: return (null); failure: proc (why); dcl why fixed bin; steps = why; goto exit; end; %page; %include runtime_symbol; %page; %include symbol_node; %page; %include pascal_symbol_node; %page; %include runtime_symbol_info_; %page; %include acc; end;  get_block.pl1 11/12/86 1736.4rew 11/12/86 1607.5 72999 /****^ ****************************************************** * * * Copyright (c) 1986 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212): Added PASCAL entry points parsing. END HISTORY COMMENTS */ /* Procedure to get a pointer to the runtime symbol block for a PL/I program given a pointer to its stack frame and optionally an execution loc modified: 06 Oct 78 by James R. Davis for separate static begin blocks, greater cleanliness and not assume ic is in frame owners block Modified: 25 Aug 79 by JRD to find symbol section header by object info, not link Modified: JMAthane, September 82 to add PASCAL entry points */ get_block: proc (stack_pt, header_pt, block_pt); dcl (stack_pt ptr, /* points at stack frame (input) */ header_pt ptr, /* set to point at symbol header */ block_pt ptr) parameter; /* set to point at symbol block */ dcl p ptr, /* into object seg */ sp ptr, /* copy of stack_pt */ ic fixed bin, /* offset of execution, or -1 if not supplied */ i fixed bin, based_ptr based ptr, based_word bit (36) based, /* for search for instructions */ rel_to_next bit (18), /* self relative offset for symbol table search */ bitcount fixed bin (24), code fixed bin (35), trans fixed bin; /* translator that produced object seg */ dcl 1 oi aligned like object_info; dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl (addr, addrel, fixed, null, pointer) builtin; dcl 1 structure aligned based, /* two words placed by PL/I in entry sequence */ 2 ignore bit (36), /* various flags we dont care about */ 2 head_offset bit (18) unal, /* offset in linkage sec of ptr to header */ 2 block_offset bit (18) unal; /* offset from header to frame owner block node */ %page; /* no location available with this entry */ ic = -1; join: sp = stack_pt; header_pt, block_pt = null; /* assume the worst */ if sp = null then return; /* cant find translator or entry ptr, give up */ trans = fixed (sp -> frame.translator_id, 18); /* who made this seg? */ if trans = 0 then do; /* PL/I version 2 */ p = addrel (sp -> frame.entry, 1); if p -> based_word ^= "000614272100"b3 /* tsp2 pr0|614 enter_begin */ & p -> based_word ^= "001376272100"b3 /* tsp2 pr0|1376 ss_enter_begin */ then p = addrel (p, 2); /* not a begin block, so skip two instructions */ end; else if trans = 2 then do; /* PL/I version 1 */ p = addrel (p, 3); /* in version 1 the header and block offsets are marked by a preceeding tra 2,ic instruction, which is anywhere from 3 to 8 words past the address pointed to by the entry pointer */ do i = 3 to 8; if p -> based_word = "000002710004"b3 then goto found_tra; p = addrel (p, 1); end; return; /* fell through, its not there ! */ found_tra: end; /* of version one */ else if trans = 8 then do; /* Grenoble University PASCAL */ p = addrel (sp -> frame.entry, 2); /* 3rd word */ if (p -> based_word ^= "000001273100"b3) /* tsp3 0|1 : old internal */ & (p -> based_word ^= "000064273100"b3) /* tsp3 0|52 : internal */ & (p -> based_word ^= "000131273100"b3) /* tsp3 0|89 : v7 int_entry */ then do; p = addrel (p, 2); /* 5th word */ if (p -> based_word ^= "500002273100"b3) /* tsp3 5|2 : old exportable */ & (p -> based_word ^= "500055273100"b3) /* tsp3 5|45 : old exportable fast */ & (p -> based_word ^= "500065273100"b3) /* tsp3 5|53 : exportable */ & (p -> based_word ^= "500067273100"b3) /* tsp3 5|55 : exportable fast */ then do; p = addrel (p, 1); /* 6th word */ if (p -> based_word ^= "200117273100"b3) /* tsp3 2|79 : v7 MAIN_entry */ & (p -> based_word ^= "200130273100"b3) /* tsp3 2|88 : v7 ext_entry */ then do; p = addrel (p, 2); /* 8th word */ if (p -> based_word ^= "500000273100"b3) /* tsp3 5|0 : old MAIN */ & (p -> based_word ^= "500054273100"b3) /* tsp3 5|44 : old MAIN_fast */ & (p -> based_word ^= "500063273100"b3) /* tsp3 5|51 : MAIN */ & (p -> based_word ^= "500066273100"b3) /* tsp3 5|54 MAIN fast */ then return; end; end; end; p = addrel (p, 1); end; else return; /* no other language is supported */ /* now p points to the two word structure where symbol table ptrs are */ if p -> structure.head_offset = (18)"0"b then return; /* no symbol table */ /* in former days, we got a pointer to the symbol section header by snapping the link *symbol, which is found at offselt {p -> structure.head_offset} in the linkage section This is not a good idea though, because a run unit may have been entered since the time that the program called out, which means that snapping links will not work. Run units work by setting up a whole new name space. */ call hcs_$status_mins (pointer (p, 0), (0), bitcount, code); if code ^= 0 then return; oi.version_number = object_info_version_2; call object_info_$brief (pointer (p, 0), bitcount, addr (oi), code); if code ^= 0 then return; header_pt = oi.symbp; /* if the seg is bound, then header_pt is to header of the whole seg. Thats OK, because the have the offset relative to the header of the block node we are interested in. From that block node we can get the ptr to the header we want. */ block_pt = addrel (header_pt, p -> structure.block_offset); if ^block_pt -> runtime_block.flag then return; /* not modern symbol table, can do no more */ if ic < 0 then return; /* cant be a quick block */ /* get pointer to the root symbol_block for this seg. The seg may be bound, we cant trust header_pt, as it may be the header for the bound seg as a whole. Find the header for the component */ p = addrel (block_pt, block_pt -> runtime_block.header); /* point to header */ block_pt = addrel (p, p -> std_symbol_header.area_pointer); /* point to pl1 symbol block */ block_pt = addrel (p, block_pt -> pl1_symbol_block.root); /* point at first block */ block_pt = addrel (block_pt, block_pt -> runtime_block.son); /* skip the root, its useless */ /* now search from the first block (root) for the smallest block that contains ic */ rel_to_next = "1"b; /* make sure we enter loop */ do p = block_pt repeat addrel (p, rel_to_next) while (rel_to_next ^= (18)"0"b); if ic >= fixed (addrel (p, p -> runtime_block.first) -> statement_map.location, 18) & ic <= fixed (addrel (p, p -> runtime_block.last) -> statement_map.location, 18) then do; block_pt = p; /* we are in this block */ rel_to_next = p -> runtime_block.son; /* search son if there is one */ end; else rel_to_next = p -> runtime_block.brother; /* else brother */ end; return; get_runtime_block: entry (stack_pt, header_pt, block_pt, loc); dcl loc fixed bin parameter; /* this entry is called when a location in the object seg is available One should not expect stu_ to do without the stack_pt, even though stu could find the symbol information without it. It is up to the caller to get it */ ic = loc; goto join; %page; %include stu_frame; %include runtime_symbol; %include std_symbol_header; %include pl1_symbol_block; %include statement_map; %include object_info; end get_block;  get_display_steps.pl1 11/02/83 1432.7rew 11/02/83 1430.9 21879 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ get_display_steps: proc (P_start, P_goal) returns (fixed bin); /* given ptrs to runtime_block nodes P_start and P_goal, where P_start is contained in P_goal, calculate the number of display frames that will exist between them. Created: 23 Feb 79 James R. Davis Modified: June 83 JMAthane to know PASCAL with blocks */ dcl P_start ptr parameter; dcl P_goal ptr parameter; dcl steps fixed bin; dcl op ptr; steps = 0; do op = owner_of (P_start) repeat (prev_frame_owner (op)) while (op ^= owner_of (P_goal)); steps = steps + 1; end; return (steps); prev_frame_owner: proc (qp) returns (ptr); /* qp pts to a runtime block node that is a frame owner - return ptr to the block node that owns the frame that the display ptr of this frame must pt to. The lexical father of this block - which, if non-quick, is the desired block, but if quick - its owner is the one we want. */ dcl qp ptr parameter; return (owner_of (father_of (qp))); end; father_of: proc (qp) returns (ptr); dcl qp ptr parameter; return (addrel (qp, qp -> symbol_block.father)); end father_of; owner_of: proc (qp) returns (ptr); /* return ptr to runtime_block of block that owns the frame we use - if non-quick this is ourself - if quick, use the owner field. Older segs don't have this, so must assume that father is owner but this need not be true. Old segs must be recompiled so this info will be available */ dcl qp ptr parameter; if qp -> symbol_block.type = PASCAL_WITH_BLOCK then return (addrel (qp, qp -> symbol_block.owner)); else if qp -> symbol_block.quick then if qp -> symbol_block.owner_flag then return (addrel (qp, qp -> symbol_block.owner)); else return (father_of (qp)); else return (qp); /* non-quicks own their own frame */ end owner_of; %include runtime_symbol_block; %include runtime_block_type; end get_display_steps;  get_implicit_qualifier.pl1 10/24/88 1642.8r w 10/24/88 1400.3 35820 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Procedure to obtain the value of the pointer used in the declaration of a based variable, i.e. given dcl foo based(p); this procedure is given a pointer to the runtime symbol node for "foo" and it attempts to locate and return the value of "p" Modified: 26 Feb 79 by James R. Davis to know about display steps Modified: June 83 JMAthane to replace references to "runtime_symbol" structure by calls to runtime_symbol_info_ subroutine */ /* Added version strings to runtime_symbol_info_ structures 10/06/83 S. Herbst */ get_implicit_qualifier: proc (block_pt, sym_pt, stack_pt, link_pt, text_pt) returns (ptr); dcl block_pt ptr, /* ptr to block in which symbol is declared */ sym_pt ptr, /* ptr to symbol node of based variable */ stack_pt ptr, /* ptr to stack frame associated with based var */ link_pt ptr, /* ptr to linkage section */ text_pt ptr; /* ptr to object segment */ dcl sp ptr; /* stack frame ptr */ dcl isym_ptr ptr; /* to symbol node of the implicit ptr */ dcl ival_ptr ptr; /* to the value of the ptr we're based on */ dcl iblk_ptr ptr; /* to the block the implicit qual was dcl'd in */ dcl bp ptr; /* to the block the based item was dcl'd in */ dcl based_ptr based ptr; dcl packed_ptr unaligned based ptr; dcl i fixed bin; dcl stu_$offset_to_pointer entry (ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), stu_$get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), stu_$block_dcld_in entry (ptr) returns (ptr), stu_$get_display_steps entry (ptr, ptr) returns (fixed bin); dcl (addrel, fixed, null) builtin; dcl 1 type_info like runtime_type_info; dcl 1 address_info like runtime_address_info; dcl code fixed bin (35); type_info.version = RUNTIME_TYPE_INFO_VERSION_1; call runtime_symbol_info_$type (sym_pt, addr (type_info), code); if code ^= 0 then return (null); address_info.version = RUNTIME_ADDRESS_INFO_VERSION_1; call runtime_symbol_info_$address (sym_pt, addr (address_info), code); if code ^= 0 then return (null); if address_info.location = 0 then return (null); /* no implicit qualifier in table */ isym_ptr = addrel (sym_pt, address_info.location);/* get ptr to symbol_node for implicit ptr */ bp = block_pt; /* get block node for symbol, if not supplied, find it */ if bp = null then bp = stu_$block_dcld_in (sym_pt); sp = stack_pt; /* find right frame for implicit ptr */ iblk_ptr = stu_$block_dcld_in (isym_ptr); do i = 1 to stu_$get_display_steps (bp, iblk_ptr); if sp ^= null then sp = sp -> frame.display; end; /* now pickup value of the pointer */ ival_ptr = stu_$get_runtime_address (iblk_ptr, isym_ptr, sp, link_pt, text_pt, null, null); if ival_ptr = null then return (null); type_info.version = RUNTIME_TYPE_INFO_VERSION_1; call runtime_symbol_info_$type (isym_ptr, addr (type_info), code); if code ^= 0 then return (null); if type_info.type = offset_dtype then return (stu_$offset_to_pointer (iblk_ptr, isym_ptr, ival_ptr, sp, link_pt, text_pt)); else if type_info.type = pointer_dtype then if type_info.packed then return (ival_ptr -> packed_ptr); else return (ival_ptr -> based_ptr); else return (null); /* what kind of data type!! */ %include stu_frame; %include runtime_symbol; %include std_descriptor_types; %include runtime_symbol_info_; end get_implicit_qualifier;  get_line_no.pl1 05/23/73 1233.4rewa05/23/73 1233.4 18918  /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Procedure to get the line number corresponding to a given location in an object segment compiled by PL/I or Fortran Modified: 25 September 1972 by BLW for std obj segment */ get_line_no: proc(block_pt,offset,start,num,line_no); dcl block_pt ptr, /* points at symbol block */ offset fixed bin(18), /* an offset in text segment (input) */ start fixed bin(18), /* set to start location of statement */ num fixed bin(18), /* set to number of words in statement */ line_no fixed bin(18); /* set to line number of statement */ dcl (p,q) ptr, std bit(1) aligned, (ln,loc,inc) fixed bin(18); dcl (addrel,fixed,null,size) builtin; dcl 1 map aligned based, 2 location unal bit(18), 2 line unal bit(18); %include runtime_symbol; %include statement_map; q = block_pt; if q = null then goto no; if q -> runtime_block.first = (18)"0"b then goto no; std = q -> runtime_block.standard; if std then inc = size(statement_map); else inc = size(map); p = addrel(q,q -> runtime_block.first); q = addrel(q,fixed(q -> runtime_block.last,18) + inc); line_no = -1; do while(p ^= q); if std then do; ln = fixed(p -> statement_map.source_id.line,14); loc = fixed(p -> statement_map.location,18); end; else do; ln = fixed(p -> map.line,18); loc = fixed(p -> map.location,18); end; if loc <= offset then if line_no ^= ln then do; start = loc; line_no = ln; end; else; else do; if line_no = ln then goto step; if line_no = -1 then goto no; num = loc - start; return; end; step: p = addrel(p,inc); end; no: start = -1; end;  get_location.pl1 05/23/73 1233.4rewa05/23/73 1233.4 14967  /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Procedure to obtain starting location of given statement in PL/I or Fortran program Modified: 25 September 1972 by BLW for std object segment */ get_location: proc(block_pt,line_no) returns(fixed bin(18)); dcl block_pt ptr, /* points at symbol block */ line_no fixed bin(18); /* line no whose loc is desired */ dcl (p,q) ptr, std bit(1) aligned, (ln,loc,inc) fixed bin; dcl (addrel,fixed,null,size) builtin; dcl 1 map aligned based, 2 location unal bit(18), 2 line unal bit(18); %include runtime_symbol; %include statement_map; q = block_pt; if q = null then goto no; if q -> runtime_block.first = (18)"0"b then goto no; std = q -> runtime_block.standard; if std then inc = size(statement_map); else inc = size(map); p = addrel(q,q -> runtime_block.first); q = addrel(q,fixed(q -> runtime_block.last,18) + inc); do while(p ^= q); if std then ln = fixed(p -> statement_map.source_id.line,14); else ln = fixed(p -> map.line,18); if ln = line_no then do; if std then loc = fixed(p -> statement_map.location,18); else loc = fixed(p -> map.location,18); return(loc); end; p = addrel(p,inc); end; no: return(-1); end;  get_map_index.pl1 11/02/83 1335.8rew 11/02/83 1237.0 32670 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ get_map_index: proc (P_header, P_location, R_index, R_ptr); /* given a pointer to the symbol header of a standard object segment, and an offset from the base of the seg finds the map entry for the source statement that generated the code, then returns the index and addr of the entry Created: 23 Feb 79 James R. Davis */ dcl P_header ptr parameter; dcl P_location fixed bin (18) unsigned parameter; dcl R_index fixed bin parameter; /* Output - index of entry in statement map array */ dcl R_ptr ptr parameter; /* Output - ptr to the entry */ dcl location fixed bin (18) unsigned; /* copy of P_location */ dcl highest fixed bin (35); /* highest location in object seg */ dcl lowest fixed bin (35); /* lowest address in object seg */ dcl number_entries fixed bin; /* number of entries in stmnt map */ dcl map_ptr ptr; /* to statement map for seg */ dcl map_end_ptr ptr; /* to last entry in map */ dcl map_size fixed bin; /* size of an entry in the map */ dcl 1 map_array (number_entries) aligned based (map_ptr) like statement_map; dcl stu_$get_statement_map entry (ptr, ptr, ptr, fixed bin); dcl (addr, bin, divide, fixed, null, rel) builtin; R_index = -1; R_ptr = null; /* assume the worst */ call stu_$get_statement_map (P_header, map_ptr, map_end_ptr, map_size); if (map_ptr = null) | (map_end_ptr = null) then return; /* no mpa for seg */ number_entries = divide (bin (rel (map_end_ptr)) - bin (rel (map_ptr)), map_size, 17, 0); location = P_location; lowest = fixed (map_array (1).location, 18); highest = fixed (map_array (number_entries).location, 18); if location < lowest | location > highest then return; /* canty be in text */ R_index = search_stmnt_map (); R_ptr = addr (map_array (R_index)); return; search_stmnt_map: proc () returns (fixed bin); /* does a binary search through statement map for a statement entry whose range of locations includes the location we want. We know the statement map is in order of object seg location. Lets hope there are no gaps in the generated code itself! */ dcl guess fixed bin; dcl low fixed bin; dcl high fixed bin; dcl first_loc_this_stmnt fixed bin (35); dcl first_loc_next_stmnt fixed bin (35); low = 1; high = number_entries; guess = divide (high + low, 2, 17, 0); /* start in the middle */ do while ("1"b); first_loc_this_stmnt = fixed (map_array (guess).location, 18); first_loc_next_stmnt = fixed (map_array (guess + 1).location, 18); if first_loc_this_stmnt <= location & location < first_loc_next_stmnt then return (guess); if (high - low = 1) /* special case to avoid infinite loop */ then if guess = high /* switch the guess */ then guess = low; else guess = high; else do; /* refine the limits and make better guess */ if first_loc_this_stmnt > location /* we were too high */ then high = guess; else low = guess; guess = divide (high + low, 2, 17, 0); end; end; end search_stmnt_map; %include statement_map; end get_map_index;  get_runtime_address.pl1 10/24/88 1642.8r w 10/24/88 1400.3 122688 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* procedure to return the address of a datum given ptr to its symbol node Initial Version: 22 January 1973 by BLW Modified: 8 December 1978 by RAB to ignore fault bits in LOT & ISOT Re-written: 14 Mar 79 BY James R. Davis for beauty and packed decimal Modified: 5 November 1982 by T Oke to add VLA 255/256 support. Modified: June 83 JMAthane to replace references to "runtime_symbol" structure by calls to runtime_symbol_info_ subroutine and use extended set of encoded values. Modified: 05 July 83 by S. Herbst, excised reference to data_ptr as instructed by JMAthane. Modified: 26 July 1983 by T Oke to delete superfluous use of arg_list_arg_count. We neither define, nor require it. Modified: 06 Oct 83 by S. Herbst, added version strings to runtime_symbol_info_ structures. */ /* Modified: 17 Oct 83 by S. Herbst, removed Version 1 symbol table support */ get_runtime_address: proc (block_pt, symbol_pt, stack_pt, link_pt, text_pt, ref_pt, subs_pt) returns (ptr); dcl block_pt ptr, /* ptr to block node */ symbol_pt ptr, /* ptr to symbol node */ stack_pt ptr, /* ptr to stack frame */ link_pt ptr, /* ptr to linkage section */ text_pt ptr, /* ptr to object segment */ ref_pt ptr, /* ref ptr for based variable */ subs_pt ptr; /* ptr to subscript vector */ dcl blk_pt ptr init (block_pt); dcl sym_pt ptr init (symbol_pt); dcl sp ptr init (stack_pt); dcl lp ptr init (link_pt); dcl tp ptr init (text_pt); dcl rp ptr init (ref_pt); dcl data_ptr ptr; /* hold address as we calculate it */ dcl bo fixed bin (35); /* bit offset of data */ dcl subscript (n_dims) fixed bin based (subs_pt); /* the subscripts supplied */ dcl 1 address_info like runtime_address_info; dcl code fixed bin (35); dcl arg_list_arg_count fixed bin; dcl sum fixed bin (35); /* holds array offset as calc'ed */ dcl subs_x fixed bin; /* index into subscripts */ dcl address fixed bin (35); /* logical address */ dcl bit_offset fixed bin (6); /* bit offset of pointer */ dcl word_offset fixed bin (35); /* word offset of pointer */ dcl segno fixed bin; /* segment number of pointer */ dcl pp ptr unaligned; /* packed pointer */ dcl 1 packed_pointer unaligned based (addr (pp)), /* packed pointer overlay */ 2 bit_offset fixed bin (6) unsigned unaligned, 2 address fixed bin (30) unsigned unaligned; dcl pl1_operators_$VLA_words_per_seg_ fixed bin (19) external; dcl (addr, addrel, baseno, bin, divide, mod, multiply, null, ptr, stackbaseptr) builtin; %page; dcl off fixed bin (35); address_info.version = RUNTIME_ADDRESS_INFO_VERSION_1; call runtime_symbol_info_$address (sym_pt, addr (address_info), code); if code ^= 0 then return (null); data_ptr = get_basic_address (); if address_info.offset_is_encoded then off = decode_value (address_info.offset); else off = address_info.offset; bo = convert_units (off, (address_info.units), (address_info.use_digit)); n_dims = runtime_symbol_info_$array_dims (sym_pt); if (n_dims > 0) & (subs_pt ^= null) then do; begin; dcl 1 array_info like runtime_array_info; array_info.version = RUNTIME_ARRAY_INFO_VERSION_1; call runtime_symbol_info_$array (sym_pt, addr (array_info), code); if code ^= 0 then return (null); sum = 0; do subs_x = 1 to n_dims; if array_info.bounds (subs_x).multiplier_is_encoded then sum = sum + (subscript (subs_x) * decode_value (array_info.bounds.multiplier (subs_x))); else sum = sum + (subscript (subs_x) * array_info.bounds.multiplier (subs_x)); end; if array_info.virtual_origin_is_encoded then sum = sum - decode_value (array_info.virtual_origin); else sum = sum - array_info.virtual_origin; bo = bo + convert_units (sum, (array_info.array_units), (array_info.use_digit)); end; end; /* subscript hacking */ /* Modification for 255 and 256K Very Large Arrays in Fortran. This uses the new CLASS type "1010"b to indicate 'VLA_based'. The address conversion factor is taken from the external 'pl1_operators_$VLA_words_per_seg_'. All address calculations will permit segment skipping. */ if address_info.class = 10 /* VLA_based */ then do; pp = data_ptr; /* pack pointer */ /* Determine bit_offset and word_offset of original pointer */ bit_offset = packed_pointer.bit_offset + bo; word_offset = divide (bit_offset, 36, 35, 0); packed_pointer.bit_offset = mod (bit_offset, 36); /* do specific 255/256K addressing */ if pl1_operators_$VLA_words_per_seg_ = 262144 then packed_pointer.address = packed_pointer.address + word_offset; else do; address = packed_pointer.address; segno = divide (address, 262144, 17, 0); address = mod (address, 262144) + segno * pl1_operators_$VLA_words_per_seg_ + word_offset; packed_pointer.address = divide (address, pl1_operators_$VLA_words_per_seg_, 17, 0) * 262144 + mod (address, pl1_operators_$VLA_words_per_seg_); end; data_ptr = pp; /* unpack */ return (data_ptr); end; return (bitrel (data_ptr, (bo))); convert_units: proc (value, unit_code, unit_msb) returns (fixed bin (35)); dcl value fixed bin (35) parameter; /* offset in raw */ dcl unit_code fixed bin (2) parameter unsigned; dcl unit_msb fixed bin (1) parameter unsigned; dcl unit_type fixed bin (3); unit_type = (unit_msb * 4) + unit_code; goto units_case (unit_type); units_case (0): return (value * bits_per_word); /* word */ units_case (1): return (value); /* bit */ units_case (2): return (value * bits_per_character); /* char */ units_case (3): return (value * bits_per_half); /* halfword */ units_case (4): return (value * bits_per_word); units_case (5): return (value); units_case (6): return (value * bits_per_character); units_case (7): return (divide (multiply (value, 9, 24, 0) + 1, 2, 24, 0)); /* digits 4.5 bits */ end convert_units; decode_value: proc (ev) returns (fixed bin (35)); dcl ev fixed bin (35) parameter; /* an encoded value */ dcl stu_$decode_runtime_value_extended entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, ptr, fixed bin) returns (fixed bin (35)); dcl drv fixed bin (35); dcl ns_code fixed bin; drv = stu_$decode_runtime_value_extended (ev, blk_pt, sp, lp, tp, data_ptr, sym_pt, ns_code); return (drv); end decode_value; no: return (null); %page; get_basic_address: proc returns (ptr); /* common work for both versions of symbol - branch depending on the storage class, each handled its own way. The parts of the symbol node used are the same for both versions, so this is OK For "non-simple" symbols an additional offset will be calculated */ dcl storage_offset fixed bin (35); dcl based_ptr ptr based; dcl based_thing fixed bin based; /* used in based addr calc */ dcl ap ptr; /* to arg list */ dcl temp ptr; dcl sw fixed bin (4); dcl 1 type_info like runtime_type_info; dcl stu_$get_implicit_qualifier entry (ptr, ptr, ptr, ptr, ptr) returns (ptr); sw = address_info.class; storage_offset = address_info.location; goto case (sw); case (0): goto no; /* unused */ case (1): /* automatic */ if sp = null then goto no; return (addrel (sp, storage_offset)); case (2): /* automatic adjustable */ if sp = null then goto no; return (addrel (sp, storage_offset) -> based_ptr); case (10): /* VLA_based */ case (3): /* based */ if ref_pt ^= null then temp = ref_pt; else do; temp = stu_$get_implicit_qualifier (blk_pt, sym_pt, sp, lp, tp); if temp = null then goto no; end; return (temp); case (4): /* internal static */ return (addrel (get_static_ptr (), storage_offset)); case (5): /* external static */ /* extra level of indirection is to snap link */ return (addr (addrel (get_lp (), storage_offset) -> based_ptr -> based_thing)); case (6): /* controlled internal */ return (addrel (get_static_ptr (), storage_offset) -> ctl_block.data); case (7): /* controlled external */ return (addrel (get_lp (), storage_offset) -> based_ptr -> ctl_block.data); case (8): /* parameter, not always in same place */ if sp = null then goto no; return (addrel (sp, storage_offset) -> based_ptr); case (9): /* parameter */ if sp = null then goto no; ap = get_arglist_ptr (); if storage_offset > bin (ap -> arg_list.arg_count, 17) then goto no; /* argrange condition ! */ temp = convert_ptr (ap -> arg_list.arg_ptrs (storage_offset)); /* check for varying string that is not a member - in which case the addr is for the string and not the length part */ if blk_pt -> runtime_block.flag then do; /* version 2 only */ type_info.version = RUNTIME_TYPE_INFO_VERSION_1; call runtime_symbol_info_$type (sym_pt, addr (type_info), code); if code ^= 0 then return (null); if type_info.type = varying_bit_dtype | type_info.type = varying_char_dtype then if runtime_symbol_info_$level (sym_pt) = 0 /* and not a member */ then temp = addrel (temp, -1); /* back it up */ end; return (temp); case (11): ; /* relative in symbol */ return (addrel (symbol_pt, storage_offset)); case (12): /* text ref */ return (ptr (get_tp (), storage_offset)); case (13): /* link reference */ return (addrel (get_lp (), storage_offset)); case (14): goto no; /* unused */ case (15): goto no; /* unused */ %page; convert_ptr: proc (P_ptr) returns (ptr); /* given a pointer which may be an ITS, ITP, or text-relative ptr, convert to ITS - This is needed because for certain quick blocks, the compiler will generate constant argument lists with ITP pointers An ITP ptr can only be evaluated using a pointer register, which we get from the proc */ dcl P_ptr ptr parameter; /* may be ITS or ITP ptr */ dcl 1 an_itp_ptr aligned like itp; dcl reg fixed bin; dcl basep ptr; /* a temp */ dcl 1 embedded_text_ptr aligned, 2 off bit (18) unal, 2 pad bit (18) unal; dcl (string, unspec) builtin; string (an_itp_ptr) = unspec (P_ptr); if an_itp_ptr.itp_mod = "43"b3 /* ITS */ then return (P_ptr); if an_itp_ptr.itp_mod = "00"b /* text ptr */ then do; string (embedded_text_ptr) = unspec (P_ptr); return (ptr (get_tp (), embedded_text_ptr.off)); end; if an_itp_ptr.itp_mod = "41"b3 /* ITP */ then do; reg = bin (an_itp_ptr.pr_no, 3); if reg = 6 then basep = sp; else if reg = 4 then basep = get_static_ptr (); else goto no; /* other pr, cant guess what value it had */ return (bitrel (addrel (basep, an_itp_ptr.offset), bin (an_itp_ptr.bit_offset, 6))); end; goto no; /* some other modification - yechh ! */ %include its; end convert_ptr; %page; get_arglist_ptr: proc () returns (ptr); dcl ap ptr; if blk_pt = null then ap = (sp -> frame.argptr); /* no block, assume frame owner's arg list */ else if blk_pt -> runtime_block.quick /* if quick, use entry info */ then do; if blk_pt -> runtime_block.entry_info = (18)"0"b then goto no; /* no entry info */ ap = (addrel (sp, blk_pt -> runtime_block.entry_info) -> quick_entry.argptr); end; else ap = (sp -> frame.argptr); arg_list_arg_count = ap -> arg_list.arg_count; return (ap); end get_arglist_ptr; get_lp: proc () returns (ptr); dcl ilp ptr unal; if lp ^= null then return (lp); ilp = stackbaseptr () -> stack_header.lot_ptr -> lot.lp (bin (baseno (get_tp ()), 18)); if faulty_ptr (ilp) then goto no; return (ilp); end get_lp; get_tp: proc () returns (ptr); /* to base of object seg */ if tp ^= null then return (tp); if sp ^= null then return (ptr (sp -> frame.entry, 0)); if blk_pt ^= null then return (ptr (blk_pt, 0)); goto no; /* nothing left to try */ end get_tp; get_static_ptr: proc () returns (ptr); dcl isp ptr unal; isp = stackbaseptr () -> stack_header.isot_ptr -> isot.isp (bin (baseno (get_tp ()), 18)); if faulty_ptr (isp) then goto no; return (isp); end get_static_ptr; faulty_ptr: proc (P_unal_ptr) returns (bit (1)); dcl P_unal_ptr ptr unal parameter; return (baseno (P_unal_ptr) = "0"b); end faulty_ptr; end get_basic_address; %page; bitrel: proc (P_ptr, P_bit_offset) returns (ptr); dcl P_ptr ptr parameter; dcl P_bit_offset fixed bin (24) parameter; dcl 1 str aligned based (P_ptr), 2 filler unal bit (P_bit_offset), 2 target unal bit (1); if P_bit_offset < 0 then goto no; return (addr (str.target)); end bitrel; %page; %include stu_frame; %page; %include symbol_node; %page; %include runtime_symbol; %include quick_entry; %include ctl_block; %page; %include stack_header; %page; %include arg_list; %page; %include std_descriptor_types; %page; %include system; %page; %include lot; %page; %include runtime_symbol_info_; %page; end get_runtime_address;  get_runtime_line_no.pl1 11/02/83 1335.8rew 11/02/83 1237.0 33444 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ get_runtime_line_no: proc (head_pt, offset, start, num, line_no); /* Procedure to get a line number corresponding to a given offset in a standard object segment. By using the symbol header, it avoids problems with internal procedures. Coded 9 March 1973 by Robert S. Coren. Modeled on stu_$get_line_no by BLW. Modified: 21 June 1974 by J.M. Broughton to fix stu_$get_line of several lines */ dcl head_pt ptr; /* pointer to standard symbol header */ dcl offset fixed bin (18); /* offset in text (input) */ dcl start fixed bin (18); /* location where code for source line starts(output) */ dcl num fixed bin (18); /* number of words in line (output) */ dcl line_no fixed bin (18); /* line number (output) */ dcl stu_$get_statement_map entry (ptr, ptr, ptr, fixed bin); dcl map_pt ptr; dcl end_pt ptr; dcl inc fixed bin; dcl extra fixed bin; dcl (ln, loc) fixed bin (18); dcl ll fixed bin; dcl lim fixed bin; dcl (addrel, fixed, null, string) builtin; %include statement_map; extra = 0; join: line_no = -1; call stu_$get_statement_map (head_pt, map_pt, end_pt, inc); if map_pt = null then go to no; /* search through the statement map for the entry nearest offset */ do while (map_pt ^= end_pt); ln = fixed (map_pt -> statement_map.source_id.line, 14); loc = fixed (map_pt -> statement_map.location, 18); if loc <= offset then do; if line_no ^= ln then do; /* first statement on line */ if extra ^= 0 then do; /* for "stu_$get_line" entry */ line_offset = fixed (map_pt -> statement_map.source_info.start, 18); file = fixed (map_pt -> statement_map.source_id.file, 8); end; else start = loc; line_no = ln; end; end; else do; if line_no = ln then go to step; /* more statements on the line */ if line_no = -1 then go to no; /* past it without finding one */ if extra = 0 then num = loc - start; else do; /* add on however many lines were requested */ lim = line_no + n_lines; do while (ln < lim); if string (map_pt -> statement_map.source_id) = (27)"1"b then go to done; /* don't use dummy entry */ map_pt = addrel (map_pt, inc); ln = fixed (map_pt -> statement_map.source_id.line, 14); end; done: map_pt = addrel (map_pt, -inc); /* look at last good one */ line_length = fixed (map_pt -> statement_map.source_info.start, 18) + fixed (map_pt -> statement_map.source_info.length, 9) - line_offset; end; return; end; step: map_pt = addrel (map_pt, inc); /* look at next statement map entry */ end; no: line_no = -1; if extra = 0 then start = -1; return; get_line: entry (head_pt, offset, n_lines, line_no, line_offset, line_length, file); /* This entry is used to return info about the line useful for printing it */ dcl line_offset fixed bin (18); dcl line_length fixed bin; dcl n_lines fixed bin; /* number of lines caller wants to print */ dcl file fixed bin; ll = 0; extra = 1; /* indicate stu_$get_line entry */ go to join; end get_runtime_line_no;  get_runtime_location.pl1 11/02/83 1335.8rew 11/02/83 1237.0 13824 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ get_runtime_location: proc (head_pt, line_no) returns (fixed bin (18)); /* Procedure to obtain starting location of a given source line in a standard object segment. Coded 12 March 1973 by R. S. Coren. Modeled on stu_$get_location by BLW. */ dcl line_no fixed bin; /* line number in source */ dcl head_pt ptr; /* pointerto standard symbol header */ dcl (map_pt, end_pt) ptr; dcl loc fixed bin (18); dcl ln fixed bin; dcl inc fixed bin; dcl stu_$get_statement_map entry (ptr, ptr, ptr, fixed bin); dcl (addrel, fixed, null) builtin; %include statement_map; call stu_$get_statement_map (head_pt, map_pt, end_pt, inc); if map_pt = null then return (-2); do while (map_pt ^= end_pt); ln = fixed (map_pt -> statement_map.source_id.line, 14); if ln = line_no then do; loc = fixed (map_pt -> statement_map.location, 18); return (loc); end; map_pt = addrel (map_pt, inc); /* that wasn't it, look at next entry */ end; no: return (-1); end get_runtime_location;  get_statement_map.pl1 11/02/83 1335.8rew 11/02/83 1237.0 15651 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ get_statement_map: proc (head_pt, map_pt, end_pt, map_size); /* Procedure used by stu_$get_runtime_location & stu_$get_runtime_line_no to get limits of a statement map, given a pointer to the symbol header Coded 12 March 1973 by Robert S. Coren */ dcl head_pt ptr; /* pointer to standard symbol header */ dcl map_pt ptr; /* pointer to beginning of statement map (output) */ dcl end_pt ptr; /* pointer to end of statement map (output) */ dcl map_size fixed bin; /* size of statement map entry in words */ dcl hpt ptr; dcl block_pt ptr; dcl (addrel, fixed, null, size) builtin; %include std_symbol_header; %include pl1_symbol_block; %include statement_map; hpt = head_pt; if hpt = null then go to no; if hpt -> std_symbol_header.identifier ^= "symbtree" then go to no; if hpt -> std_symbol_header.area_pointer = "0"b then go to no; block_pt = addrel (hpt, hpt -> std_symbol_header.area_pointer); if block_pt -> pl1_symbol_block.map.first = (18)"0"b then go to no; map_pt = addrel (hpt, block_pt -> pl1_symbol_block.map.first); map_size = size (statement_map); end_pt = addrel (hpt, block_pt -> pl1_symbol_block.map.last); return; no: map_pt, end_pt = null; return; end get_statement_map;  offset_to_pointer.pl1 10/24/88 1642.8r w 10/24/88 1400.3 23463 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* procedure to convert an offset to a pointer using the area, if any, on which the offset was declared Initial Version: 22 January 1973 by BLW Modified: 22 Feb 79 by JRDavis to do display steps right */ offset_to_pointer: proc (block_pt, symbol_pt, data_pt, stack_pt, link_pt, text_pt) returns (ptr); dcl block_pt ptr, /* ptr to block in which offset is declared */ symbol_pt ptr, /* ptr to runtime symbol node for offset variable */ data_pt ptr, /* ptr to actual offset variable storage */ stack_pt ptr, /* ptr to stack frame associated with offset */ link_pt ptr, /* ptr to linkage section */ text_pt ptr; /* ptr to object program */ dcl p ptr, /* to symbol_node of the offset */ q ptr, /* to symbol_node for area */ sp ptr, /* to stack frame for the area */ bq ptr, /* to block_node of the area */ bp ptr, /* to block_node of the offset */ ap ptr, /* to the area itself */ (addrel, fixed, null, pointer) builtin, i fixed bin, stu_$get_display_steps entry (ptr, ptr) returns (fixed bin), stu_$block_dcld_in entry (ptr) returns (ptr), stu_$get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr); dcl area area based, offset offset unaligned based; p = symbol_pt; if p = null then return (null); /* get ptr to symbol node of area, if any */ if p -> runtime_symbol.size = 0 then return (null); q = addrel (p, p -> runtime_symbol.size); if fixed (q -> runtime_symbol.type, 6) ^= area_dtype then return (null); bq = stu_$block_dcld_in (q); sp = stack_pt; bp = block_pt; do i = 1 to stu_$get_display_steps (bp, bq); if sp ^= null then sp = sp -> frame.display; end; /* get address of area and perform conversion */ ap = stu_$get_runtime_address (bq, q, sp, link_pt, text_pt, null, null); if ap = null then return (null); return (pointer (data_pt -> offset, ap -> area)); %include runtime_symbol; %include stu_frame; %include std_descriptor_types; end;  pointer_to_offset.pl1 10/24/88 1642.8r w 10/24/88 1400.3 24921 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* procedure to convert an pointer to a offset using the area, if any, on which the offset was declared Initial Version: 22 January 1973 by BLW Modified: 12 August 1973 by J.M. Broughton - changed stu_$offset_to_pointer to go in other direction modified: 26 Feb 79 by JRDavis - fix for display steps */ pointer_to_offset: proc (block_pt, symbol_pt, data_pt, stack_pt, link_pt, text_pt) returns (offset); dcl block_pt ptr, /* ptr to block in which offset is declared */ symbol_pt ptr, /* ptr to runtime symbol node for offset variable */ data_pt ptr, /* ptr to actual pointer variable storage */ stack_pt ptr, /* ptr to stack frame associated with offset */ link_pt ptr, /* ptr to linkage section */ text_pt ptr; /* ptr to object program */ dcl p ptr, /* to symbol_node for offset */ q ptr, /* to symbol_node for area */ bp ptr, /* block of offset */ bq ptr, /* block of area */ ap ptr, /* address of area */ sp ptr, /* stack frame of area */ i fixed bin, (addrel, fixed, nullo, null, offset) builtin, stu_$block_dcld_in entry (ptr) returns (ptr), stu_$get_display_steps entry (ptr, ptr) returns (fixed bin), stu_$get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr); dcl area area based, pointer pointer based; p = symbol_pt; if p = null then return (nullo); /* get ptr to symbol node of area, if any */ if p -> runtime_symbol.size = 0 then return (nullo); q = addrel (p, p -> runtime_symbol.size); if fixed (q -> runtime_symbol.type, 6) ^= area_dtype then return (nullo); /* get ptr to symbol block of area */ bq = stu_$block_dcld_in (q); /* get ptr to stack frame associated with area */ sp = stack_pt; bp = block_pt; do i = 1 to stu_$get_display_steps (bp, bq); if sp ^= null then sp = sp -> frame.display; end; /* get address of area and perform conversion */ ap = stu_$get_runtime_address (bq, q, sp, link_pt, text_pt, null, null); if ap = null then return (nullo); return (offset (data_pt -> pointer, ap -> area)); %include stu_frame; %include runtime_symbol; %include std_descriptor_types; end;  remote_format.pl1 11/05/86 1317.0r w 11/04/86 1034.0 27342 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* procedure to return remote format variable to plio */ remote_format: proc(v,sp,refp,ans) returns(fixed bin); dcl v fixed bin, /* value to decode */ sp ptr, /* stack frame pointer */ refp ptr, /* based reference pointer */ ans label; /* answer (output) */ dcl (p,q) ptr, (i,n,n1,n2,n3) fixed bin, ent_var entry(ptr,label) variable; dcl 1 value aligned based(p), 2 flag unal bit(2), 2 type unal bit(4), 2 (n1,n2) unal bit(6), 2 n3 unal bit(18); dcl 1 lab based(q), 2 p1 ptr, 2 p2 ptr; dcl fixed_bin fixed bin based, ptr_var ptr based, label_var label local variable based; dcl (addr,addrel,baseno,fixed,hbound,null,ptr,substr) builtin; dcl 1 arglist aligned based, 2 number bit(17) unal, 2 filler bit(55) unal, 2 ptr(1) ptr; %include stu_frame; %include stack_header; %include lot; p = addr(v); if flag = "00"b then do; q = addr(ans); p1 = addrel(p,value.n3); p2 = sp; ok: return(0); end; n = fixed(type,4); if n > hbound(sw,1) then goto sw(3); n1 = fixed(value.n1,6); n2 = fixed(value.n2,6); n3 = fixed(value.n3,18); /* get ptr to proper stack frame if needed */ if substr("10001000011"b,n+1,1) then do; q = sp; do i = 1 to n1; q = q -> frame.display; end; end; goto sw(n); /* automatic variable */ sw(0): q = addrel(q,n3); set: ans = q -> label_var; goto ok; /* internal static variable */ sw(1): call get_static_ptr; goto sw(0); /* external static variable */ sw(2): q = addrel(addrel(sp -> frame.linkage,n3) -> ptr_var,n1); goto set; /* illegal case */ sw(3): return(1); /* based on automatic pointer */ sw(4): q = addrel(addrel(q,n3) -> ptr_var,n2); goto set; /* based on internal static pointer */ sw(5): call get_static_ptr; goto sw(4); /* based on external static pointer */ sw(6): q = addrel(addrel(addrel(sp -> frame.linkage,n3) -> ptr_var, n1) -> ptr_var,n2); goto set; /* based on reference pointer */ sw(7): q = addrel(refp,n2); goto set; /* value given by procedure */ sw(8): q = addr(ent_var); p1 = ptr(sp -> frame.entry,n3); p2 = sp; call ent_var(refp,ans); goto ok; /* value given by (9) or based on (10) the nth arg of procedure */ sw(9): sw(10): q = q -> frame.argptr; if n2 > fixed(q -> arglist.number,17) then goto sw(3); q = q -> arglist.ptr(n2); if n = 9 then q = addrel(q,n3); else q = addrel(q -> ptr_var,n3); goto set; get_static_ptr: proc; sb = ptr(addr(sb),0); q = sb -> stack_header.isot_ptr -> isot.isp(fixed(baseno(sp -> frame.entry),18)); end; end;  attempt_thunk.pl1 11/05/86 1317.0r w 11/04/86 1042.3 69903 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ attempt_thunk: procedure (P_encoded_value, P_blockp, P_stackp, P_refp, P_code) returns (fixed bin (35)); /* ATTEMPT_THUNK -- This procedure is used by stu_ to call a thunk: a small procedure that is used to encode a value that cannot be expressed at compile time, such as the location of a value that is determined by a refer extent, or adjustable automatic. The thunk is a non-quick internal procedure with access to its parent's stack frame, and in theory must be called with an entry variable containing a pointer to that stack frame. In many cases, however (such as refer extents for based variables), the thunk never references its parent's stack frame, but only references the data itself (for which it is supplied a pointer) and makes some of its own calculations to determine the address. Thus, it is often possible to call a thunk even without a stack frame pointer, and that's what this program does: it examines the object code of the thunk to see whether it looks like it will work without a valid stack frame pointer for display chasing (linkage section references are also prohibited), and if it looks safe, calls it. Of course, if there is a valid stack frame pointer supplied by our caller, it uses that, instead, and doesn't go through all these heuristics. Well, yes: I KNOW this is a kludge, but it does seem to work. Sure would be nifty if this information were in the symbol table, though, and there is even room elsewhere in a thunk-encoded value to put it (n1 and n2). 23 Jun 83, W. Olin Sibert: Initial coding, for azm and display_data_. */ declare P_encoded_value fixed bin (35) parameter; declare P_blockp pointer parameter; declare P_stackp pointer parameter; declare P_refp pointer parameter; declare P_code fixed bin (35) parameter; declare refp pointer; declare blockp pointer; declare value fixed bin (35); declare 1 ev aligned like encoded_value; declare thunk_entry variable entry (pointer, fixed bin (35)); declare 1 entry_template aligned, 2 location pointer, 2 stack_frame pointer; declare thunk_ptr pointer; declare thunk_lth fixed bin; declare thunk (thunk_lth) bit (36) aligned based (thunk_ptr); declare (addr, binary, hbound, null, pointer) builtin; /* */ refp = P_refp; sp = P_stackp; blockp = P_blockp; unspec (ev) = unspec (P_encoded_value); /* First, see if the encoded value actually represents a thunk. If not, give up immediately, since our caller should have handled the other types. */ if (binary (ev.code, 4) ^= 8) then call punt (1); /* 8 is thunk-type */ /* Next, see if we got a valid stack pointer. If so, then we will just call the thunk entry variable and be done with it. */ if (sp ^= null ()) then do; thunk_ptr = pointer (sp -> stack_frame.entry_ptr, ev.n3); entry_template.location = thunk_ptr; entry_template.stack_frame = sp; unspec (thunk_entry) = unspec (entry_template); call thunk_entry (refp, value); P_code = 0; /* Successful */ return (value); end; /* If we have no stack frame pointer, first we find the thunk, assuming that is is in the segment that the block pointer indicates, and then we check the code to ensure that it does nothing untoward. */ if (blockp = null ()) then call punt (2); thunk_ptr = pointer (blockp, ev.n3); entry_template.location = thunk_ptr; entry_template.stack_frame = baseptr (""b); /* Guaranteed unusable */ unspec (thunk_entry) = unspec (entry_template); /* thunk_ptr may be changed after this. */ call find_thunk_bounds (); call check_thunk_code (); call thunk_entry (refp, value); P_code = 0; return (value); /* */ find_thunk_bounds: procedure (); declare idx fixed bin; /*^ This procedure verifies that the thunk entry sequence starts as follows: lxl7 stack_frame_size,dl epp2 pr7|34,* tsp2 pr2|1047 int_entry zero 2,0 zero 0,0 After doing so, it adjusts thunk_ptr to point to the beginning of the executable code for the thunk. */ thunk_lth = 5; /* To look at the beginning */ if (substr (thunk (1), 19, 18) ^= "727007"b3) then call punt (3); if (thunk (2) ^= "700034352120"b3) then call punt (3); if (thunk (3) ^= "201047272100"b3) then call punt (3); if (thunk (4) ^= "000002000000"b3) then call punt (3); if (thunk (5) ^= "000000000000"b3) then call punt (3); thunk_ptr = addrel (thunk_ptr, 5); thunk_lth = 200; /* More than 200 instructions seems unlikely */ /* Now, go looking for the end of the thunk, searching for the transfer to the return operator: tra pr0|631 return */ do idx = 1 to hbound (thunk, 1); if (thunk (idx) = "000631710100"b3) then do; thunk_lth = idx - 1; return; end; end; call punt (4); /* No return operator found */ end find_thunk_bounds; /* */ check_thunk_code: procedure (); declare idx fixed bin; declare jdx fixed bin; declare opcode bit (12) aligned; declare TRANSFERS (24) bit (12) aligned internal static options (constant) init ("7100"b3 /* tra */, "6050"b3 /* tpl */, "6040"b3 /* tmi */, "6054"b3 /* tpnz */, "6000"b3 /* tze */, "6010"b3 /* tnz */, "6070"b3 /* ttf */, "6064"b3 /* ttn */, "7000"b3 /* tsx0 */, "7010"b3 /* tsx1 */, "7020"b3 /* tsx2 */, "7030"b3 /* tsx3 */, "7040"b3 /* tsx4 */, "7050"b3 /* tsx5 */, "7060"b3 /* tsx6 */, "7070"b3 /* tsx7 */, "2700"b3 /* tsp0 */, "2710"b3 /* tsp1 */, "2720"b3 /* tsp2 */, "2730"b3 /* tsp3 */, "6700"b3 /* tsp4 */, "6710"b3 /* tsp5 */, "6720"b3 /* tsp6 */, "6730"b3 /* tsp7 */); declare 1 inst aligned, 2 offset fixed bin (18) unsigned unaligned, 2 opcode bit (10) unaligned, 2 pad bit (2) unaligned, 2 pr_flag bit (1) unaligned, 2 tag bit (6) unaligned; declare 1 pr_inst aligned, 2 pr_no fixed bin (3) unsigned unaligned, 2 offset fixed bin (14) unaligned, 2 opcode bit (10) unaligned, 2 pad bit (2) unaligned, 2 pr_flag bit (1) unaligned, 2 tag bit (6) unaligned; /* */ /* By rights, this should do more checking: it's easily confused by EIS, and I'm not sure what else could go wrong. I believe I've gotten most of the important cases, though. The other ones will just fault, I suppose. */ do idx = 1 to thunk_lth; unspec (inst) = thunk (idx); unspec (pr_inst) = thunk (idx); /* The most important check is for stack frame references: we allow only references to the argument pointer and to variables within the variable portion of the stack frame. Note that this will also disallow linkage section references, since it prohibits loading the LP from the frame. */ if inst.pr_flag then if (pr_inst.pr_no = 6) then if (pr_inst.offset < 64) then /* random variable */ if (pr_inst.offset ^= 26) then /* arg pointer */ call punt (5); /* Next, check to be sure it's not a transfer instruction. */ opcode = inst.opcode || "00"b; do jdx = 1 to hbound (TRANSFERS, 1); if (opcode = TRANSFERS (jdx)) then call punt (6); end; end; return; end check_thunk_code; /* */ PUNT: return (0); punt: procedure (why); declare why fixed bin (35) parameter; P_code = why; goto PUNT; end punt; %page; %include runtime_symbol; %page; %include stack_frame; end attempt_thunk;  stu_.alm 11/02/83 1415.6rew 11/02/83 1409.9 10179 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " " Transfer vector for stu_ entrypoints " " 23 Jun 83, W. Olin Sibert " macro xfer segdef &1 ife &2,() &1: getlp tra &1$&1 ifend ine &2,() &1: getlp tra &2 ifend &end xfer block_dcld_in xfer decode_runtime_value xfer decode_runtime_value_extended,decode_runtime_value$decode_runtime_value_extended xfer find_block xfer find_containing_block xfer find_header xfer find_runtime_symbol xfer get_block xfer get_display_steps xfer get_implicit_qualifier xfer get_line,get_runtime_line_no$get_line xfer get_line_no xfer get_location xfer get_map_index xfer get_runtime_address xfer get_runtime_block,get_block$get_runtime_block xfer get_runtime_line_no xfer get_runtime_location xfer get_statement_map xfer offset_to_pointer xfer pointer_to_offset xfer remote_format end bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved