



		    block_dcld_in.pl1               11/02/83  1335.8rew 11/02/83  1234.3       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/02/83  1335.8rew 11/02/83  1234.4      112005



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* 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
*/

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	   i		      fixed bin;

	     symbol_ptr = addrel (symb, n3);
	     block_ptr = block_dcld_in (symbol_ptr);
	     display_count = 0;
	     do while (blk ^= 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/02/83  1335.8rew 11/02/83  1234.4       94635



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* 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 */

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, fixed, 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, fixed, 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 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     bin		 builtin;
	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/06/79  2133.2rew 11/06/79  2015.0       56151



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* 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
*/
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 */



/* 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 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;

%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      11/02/83  1335.8rew 11/02/83  1237.0       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         11/02/83  1335.8rew 11/02/83  1237.0      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           11/02/83  1335.8rew 11/02/83  1234.4       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           11/02/83  1335.8rew 11/02/83  1234.4       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               09/08/75  1705.0rew 09/08/75  1512.4       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/02/83  1414.3rew 11/02/83  1414.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
