



		    access_operations_.alm          11/11/89  1145.7rew 11/11/89  0804.2      118314



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(85-07-10,EJSharpe), approve(86-02-20,MCR7304),
"     audit(86-03-27,CLJones), install(86-04-23,MR12.0-1044):
"      Add attach_lv and detach_lv.
"  2) change(85-07-16,CLJones), approve(86-01-26,MCR7330),
"     audit(86-01-15,Tague), install(86-04-23,MR12.0-1044):
"      Add DM journal operations.
"  3) change(85-07-28,EJSharpe), approve(86-02-20,MCR7303),
"     audit(85-11-07,Coren), install(86-04-23,MR12.0-1044):
"      Add install_table.
"  4) change(86-01-09,Fawcett), approve(86-03-28,MCR7359),
"     audit(86-05-05,Lippard), install(86-09-16,MR12.0-1159):
"     Add operations lock_mca,unlock_mca.
"  5) change(86-03-28,Fawcett), approve(86-03-28,MCR7374),
"     audit(86-05-05,Lippard), install(86-09-16,MR12.0-1159):
"     Add invalid_mca.
"  6) change(86-06-19,Lippard), approve(85-12-30,MCR7326),
"     audit(86-10-24,GDixon), install(86-10-28,MR12.0-1200):
"      Add abs_command_cancel and abs_command_login.
"  7) change(87-06-02,Lippard), approve(87-02-09,MCR7616),
"     audit(87-08-06,Fawcett), install(87-08-06,MR12.1-1063):
"      Add set_procs_required.
"  8) change(87-06-11,GDixon), approve(87-07-15,MCR7741),
"     audit(87-07-15,Brunelle), install(87-08-04,MR12.1-1055):
"      Add dialin, dialout and dial_system.
"  9) change(87-07-15,GDixon), approve(87-07-15,MCR7741),
"     audit(87-08-06,Brunelle), install(87-08-06,MR12.1-1063):
"      Add process_terminate.
" 10) change(87-08-07,Lippard), approve(87-02-09,PBF7616),
"     audit(87-08-11,Farley), install(87-08-18,MR12.1-1090):
"      Add get_procs_required.
"                                                      END HISTORY COMMENTS

name	access_operations_
	segdef	version
	segdef	num_codes
	segdef	code_table
	segdef	text_offset_table
	segdef	text_area

" ----------------------------------------------------------------------
" ACCESS_OPERATIONS_
"
" The access audit codes and textual description for all security related
" events.  This table is used by access_audit_, all its callers, and any
" audit log message manipulation routines.
"
" Usage:
" 	dcl access_operations_$ENTRY ext bit (36) aligned;
" or:	dcl 1 access_operations_$ENTRY ext aligned like encoded_access_op;
"	    ("encoded_access_op" defined in access_audit_encoded_op.incl.pl1)
"
" See Also:
"	"access_operations_.incl.pl1" for pl1 definition of this data structure
"
" NOTES:
" 1) THE POSITION OF ENTRIES CANNOT BE CHANGED.  OTHERWISE THE LOG
"	MANIPULATION TOOLS WILL FAIL.
" 2) ANY CHANGE TO EXISTING MESSAGE TEXT MUST ALSO BE REFLECTED IN THE
"	MESSAGE DOCUMENTATION IN THE SOURCE OF ALL REFERENCING MODULES.
" 3) THE TEXT SHOULD BE NEUTRAL IN RESPECT TO TENSE AND SUCCESSFULNESS.
"	(e.g. "modified the..." should be "modification of the...")
" 4) IF YOU MODIFY ANY OF THE ENTRIES WHOSE NAME INCLUDES "mseg_", YOU MUST
"	ALSO RECOMPILE mseg_access_operations_.cds IN bound_mseg_.
"
" Last Modified:
" 85-05-01 by BIM and GMP to cleanup message segment operations
" 85-04-14 by MM Pozzo to say rcp assign resource instead of assign device
" 85-03-15 by Chris Jones to add rcp_list, fix rcp_unload and rcp_unassign
" 85-02-27 by C. Marker to io_daemon_set_page_labels.
" 85-02-26 by M. Pandolf to add mseg operations.
" 85-02-25 by MM Pozzo to add rcp operations
" 85-01-28 by Keith Loepere for log_vol_full.
" 85-01-25 by EJ Sharpe for ipc_wakeup
" 85-01-24 by E. Swenson for pnt operations.
" 85-01-23 by E. Swenson for channel and dialid operations.
" 85-01-18 by E. Swenson for login and process related operations.
" 85-01-09 by Keith Loepere for excessive_seg_state_chg.
" 84-12-26, BIM: Added message coordinator operations.
" 84-12-06 by EJ Sharpe to add system_privilege_modify and mseg_add_entry
" 84-12-05 by EJ Sharpe to add header comments and fs_obj_reclassify
" 84-12-04 by EJ Sharpe to add fs_obj_set_soos
" 84-11-29 by EJ Sharpe to add system_audit_thresh_modify and process_audit_flags_modify
" 84-11-?? by EJ Sharpe to add ipr and acv fault operations
" Written Keith Loepere, October 1984. */


	set	code_count,0
	use	codes
code_table:

	use	text_table
text_offset_table:

	use	text
text_area:

	macro	operation
	maclist	off
	set	code_count,code_count+1
	use	codes
	segdef	&1
	maclist	object
&1:	vfd	4/&2,2/&3,12/code_count,18/0
	maclist	off
	use	text
	maclist	object
&U:	aci	"&4"
	maclist	off
	use	text_table
	maclist	object
	zero	&U-text_area,&l4
	&end
"
" The format of each of the following lines, whose order cannot change once
" they exist, is:
"
"	operation	operation_name,object_type,object_access,(operation_desc)
"
" where	object_type = FS_OBJ, FS_OBJ_ATTR, RCP, ADMIN, SPECIAL
"	access_type = READ, MODIFY, MODIFY_ACCESS
"
" (Note that the detailed_operation field within the encoded_op
" is substituted by the caller of access_audit_.)

	equ	UNKNOWN,0		" can't know what the operation was
	equ	MODIFY_ACCESS,1
	equ	MODIFY,2
	equ	READ,3

	equ	NONE,0		" no object associated with the event
	equ	FS_OBJ,1
	equ	FS_OBJ_ATTR,2
	equ	RCP,3
	equ	ADMIN,4
	equ	SPECIAL,5
	equ	OTHER,6
"
	operation	fs_obj_create,FS_OBJ_ATTR,MODIFY,(creation of fs_obj)
	operation	fs_obj_delete,FS_OBJ_ATTR,MODIFY,(deletion of fs_obj)
	operation	fs_obj_initiate,FS_OBJ_ATTR,READ,(initiation of fs_obj)
	operation	fs_obj_terminate,FS_OBJ_ATTR,READ,(termination of fs_obj)
	operation	fs_obj_contents_read,FS_OBJ,READ,(read of fs_obj)
	operation	fs_obj_contents_mod,FS_OBJ,MODIFY,(modification of fs_obj)
	operation	fs_obj_prop_read,FS_OBJ_ATTR,READ,(read of fs_obj prop)
	operation	fs_obj_attr_mod,FS_OBJ_ATTR,MODIFY,(modification of fs_obj attribute prop)
	operation	fs_obj_status_mod,FS_OBJ_ATTR,MODIFY,(modification of fs_obj status prop)
	operation	fs_obj_access_mod,FS_OBJ_ATTR,MODIFY_ACCESS,(modification of fs_obj access)
	operation	fault_ipr,NONE,UNKNOWN,(illegal procedure fault)
	operation	fault_acv_ring,FS_OBJ,UNKNOWN,(access violation fault - ring)
	operation	fault_acv_mode,FS_OBJ,UNKNOWN,(access violation fault - mode)
	operation system_audit_thresh_modify,NONE,UNKNOWN,(modification of system audit flags and thresholds)
	operation	process_audit_flags_modify,NONE,UNKNOWN,(modification of process audit flags)
	operation	fs_obj_set_soos,FS_OBJ_ATTR,MODIFY_ACCESS,(modification of security out-of-service)
	operation	fs_obj_reclassify,FS_OBJ_ATTR,MODIFY_ACCESS,(modification of fs_obj access class)
	operation	system_privilege_modify,NONE,UNKNOWN,(modification of system AIM privilege)
	operation mseg_add_message,OTHER,MODIFY,(addition of a message to a message segment)

	operation daemon_reply,OTHER,MODIFY,(sending a reply to daemon)
	operation	daemon_quit,OTHER,MODIFY,(sending a quit to a daemon)
	operation daemon_login,OTHER,MODIFY,(logging in a daemon)
	operation daemon_logout,OTHER,MODIFY,(logging out a daemon)
	operation daemon_new_proc,OTHER,MODIFY,(sending a new_proc to a daemon)
	operation daemon_daemon_login,OTHER,MODIFY,(logging in as a daemon)
	operation	excessive_seg_state_chg,FS_OBJ_ATTR,UNKNOWN,(excessive segment state changes)
" Note that page_fault knows the text of excessive_seg_state_chg
	operation user_login,SPECIAL,UNKNOWN,(logging in)
	operation user_logout,SPECIAL,UNKNOWN,(logging out)
	operation process_create,SPECIAL,UNKNOWN,(creating process)
	operation process_destroy,SPECIAL,UNKNOWN,(destroying process)
	operation process_connect,SPECIAL,UNKNOWN,(connecting process)
	operation process_disconnect,SPECIAL,UNKNOWN,(disconnecting process)
	operation channel_attach,SPECIAL,MODIFY,(attaching channel)
	operation channel_detach,SPECIAL,MODIFY,(detaching channel)
	operation dialid_start,SPECIAL,MODIFY,(dial service begin)
	operation dialid_stop,SPECIAL,MODIFY,(dial service end)
	operation pnt_entry_add,ADMIN,MODIFY,(addition of pnt entry)
	operation pnt_entry_delete,ADMIN,MODIFY,(deletion of pnt entry)
	operation pnt_entry_modify,ADMIN,MODIFY,(modification of pnt entry)
	operation ipc_wakeup,SPECIAL,MODIFY,(interprocess wakeup)
	operation	log_vol_full,NONE,UNKNOWN,(overflow of logical volume)
	operation pnt_entry_admin_read,ADMIN,READ,(admin read of pnt entry)
	operation pnt_entry_priv_read,ADMIN,READ,(priv read of pnt entry)
	operation pnt_entry_network_read,ADMIN,READ,(network read of pnt entry)
	operation pnt_entry_login_read,ADMIN,READ,(login read of pnt entry)
          operation rcp_register,RCP,MODIFY,(creation of rcp object)
	operation rcp_deregister,RCP,MODIFY,(deletion of rcp object)
	operation rcp_register_acquire,RCP,MODIFY_ACCESS,(creation and acquisition of rcp object)
	operation rcp_acquire,RCP,MODIFY_ACCESS,(acquisition of rcp object)
	operation rcp_release,RCP,MODIFY_ACCESS,(release rcp object acquisition)
	operation rcp_reserve,RCP,READ,(reservation of rcp object)
	operation rcp_cancel,RCP,READ,(cancel rcp object reservation)
	operation rcp_preload,RCP,READ,(preload of rcp object)
	operation rcp_unload,RCP,READ,(unload of resource)
	operation rcp_assign_read,RCP,READ,(assign resource for reading)
	operation rcp_assign_write,RCP,MODIFY,(assign resource for writing)
	operation rcp_unassign,RCP,READ,(unassignment of rcp object)
	operation rcp_status,RCP,READ,(status of rcp object)
	operation rcp_set,RCP,MODIFY,(modify rcp object atributes)
	operation rcp_set_access,RCP,MODIFY_ACCESS,(modify rcp object access attributes)
	operation rcp_clear,RCP,MODIFY,(manual clear rcp object contents)
	operation rcp_add_device,RCP,MODIFY,(creation of rcp object)
	operation rcp_delete_device,RCP,MODIFY,(deletion of rcp object)
	operation rcp_copy_registry,RCP,MODIFY,(creation of rcp registry)
	operation rcp_delete_registry,RCP,MODIFY,(deletion of registry)
	operation rcp_reconstruct_registry,RCP,MODIFY,(reconstruction of rcp registry)
	operation rcp_update_registry_header,RCP,MODIFY,(modification of rcp registry)
	operation rcp_copy_info,RCP,READ,(copy rcp meters or rcp data)
	operation rcp_error_count,RCP,READ,(read the rcp error count)
	operation rcp_account,RCP,READ,(read rcp accounting info)
	operation	mseg_create,OTHER,MODIFY,(creating a message segment)
	operation	mseg_delete,OTHER,MODIFY,(deleting a message segment)
	operation	mseg_open,OTHER,READ,(opening a message segment)
	operation	mseg_close,OTHER,READ,(closing a message segment)
	operation	mseg_attr_read,OTHER,READ,(reading message segment attributes)
	operation	mseg_attr_mod,OTHER,MODIFY,(modifying message segment attributes)
	operation	mseg_access_read,OTHER,READ,(reading message segment access information)
	operation	mseg_access_mod,OTHER,MODIFY_ACCESS,(modifying message segment access information)
	operation	mseg_compact,OTHER,MODIFY,(compacting a message segment)
	operation	mseg_get_count,OTHER,READ,(counting messages in a message segment)
	operation	mseg_read_message,OTHER,READ,(reading a message in a message segment)
	operation	mseg_delete_message,OTHER,MODIFY,(deleting a message from a message segment)
	operation	mseg_read_delete_message,OTHER,MODIFY,(reading and deleting a message from a message segment)
	operation	mseg_update_message,OTHER,MODIFY,(updating a message in a message segment)
	operation	mseg_accept_wakeups,OTHER,MODIFY_ACCESS,(accepting wakeups over a message segment)
	operation	mseg_wakeup_send,OTHER,MODIFY,(sending a wakeup over a message segment)
	operation io_daemon_set_page_labels,FS_OBJ_ATTR,MODIFY_ACCESS,(modification of printed access labels)
	operation rcp_list,RCP,READ,(listing of rcp resources)
	operation attach_lv,SPECIAL,MODIFY_ACCESS,(attachment of logical volume)
	operation detach_lv,SPECIAL,MODIFY_ACCESS,(detachment of logical volume)
	operation dm_journal_allocate,OTHER,MODIFY_ACCESS,(allocation of DM journal)
	operation dm_journal_free,OTHER,MODIFY_ACCESS,(freeing of DM journal)
	operation dm_journal_read_attr,OTHER,READ,(reading of DM journal attributes)
	operation dm_journal_write_attr,OTHER,MODIFY,(writing of DM journal attributes)
	operation install_table,SPECIAL,MODIFY,(installation of a system table)
	operation lock_mca,OTHER,MODIFY_ACCESS,(lock of MCAs)
	operation unlock_mca,OTHER,MODIFY_ACCESS,(unlock of MCA)
	operation invalid_mca,OTHER,READ,(invalid online MCA request)
	operation abs_command_cancel,OTHER,MODIFY,(cancellation of absentee job)
	operation abs_command_login,OTHER,MODIFY,(request of login of absentee job)
	operation dialin,SPECIAL,MODIFY,(dial channel into process)
	operation dialout,SPECIAL,MODIFY,(dial out from process through channel)
	operation dial_system,SPECIAL,MODIFY,(dial channel into Initializer message coordinator)
	operation process_terminate,SPECIAL,UNKNOWN,(terminating process)
	operation set_procs_required,OTHER,MODIFY,(set processors required)
	operation get_procs_required,OTHER,READ,(get processors required)
"
	use	.text
version:
	aci	"acc_op_1",8
num_codes:
	zero	0,code_count

	join	/text/codes,text_table,text
	end




		    aim_check_.alm                  11/11/89  1145.7rew 11/11/89  0803.8       42939



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(85-06-03,Pandolf), approve(86-08-13,MCR7511),
"     audit(86-08-13,EJSharpe), install(86-08-19,MR12.0-1120):
"      Fix $greater operation.
"                                                      END HISTORY COMMENTS

" This procedure is the centralized interpreter of the access isolation mechanism.
" Entries are segdef'ed since we don't make calls or need lp.

	name	aim_check_

"	7/74	A. Kobziar
"	Modified  84-03-26 BIM to add $in_range
"	Modified  85-01-16 Chris Jones to add $range_in_range
"
" ----------------------------------------------------------------
"
" Given the authorization of the subject and the access class of the object,
" return a bit(1) answer as to whether read, write, or read-write is permitted.
"
" dcl aim_check_$xxx entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
" 	if aim_check_$xxx (subject, object) then ...
"
	segdef	write_allowed_
	segdef	read_allowed_
	segdef	read_write_allowed_
	segdef	equal
	segdef	greater
	segdef	greater_or_equal
"
" dcl aim_check_$in_range entry (bit (72) aligned,(2) bit (72) aligned) returns bit (1) aligned;
"      if aim_check_$in_range (subject, object_range) then ...
"
	segdef	in_range
"
" dcl aim_check_$range_in_range entry ((2) bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
"      if aim_check_$range_in_range (range1, range2) then ...
"
	segdef	range_in_range
"
	include	aim_template

" This code depends on the fact that aim_template.categories = 0!

write_allowed_:
	eax1	aim_template.level  "offset for IR mod
	ldx2	pr0|4,*x1		"pick up level of object
	cmpx2	pr0|2,*x1		"compare to subject
	tmi	no		"object must be >= subject
	lda	pr0|2,*		"pick up category (no IR, offset is 0)
	ana	pr0|4,*		"and with object category
	cmpa	pr0|2,*		"compare with subject category
	tze	yes		"subject is in subset of object category
	tra	no		"otherwize fail

read_allowed_:
greater_or_equal:
	eax1	aim_template.level  
	ldx2	pr0|2,*x1		"pick up subject level
	cmpx2	pr0|4,*x1		"compare to object level
	tmi	no		"subject must be >= object
	lda	pr0|2,*		"get subject category
	ana	pr0|4,*		"and with object
	cmpa	pr0|4,*		"compare to object
	tze	yes		"object must be subset of subject
	tra	no		"else fail

equal:
read_write_allowed_:
	eax1	aim_template.level
	ldx2	pr0|2,*1		"get subject level
	cmpx2	pr0|4,*1		"compare to object level
	tnz	no		"must be equal
	lda	pr0|2,*		"get subject category
	cmpa	pr0|4,*		"compare with object category
	tze	yes		"must match
	tra	no		"else fail

greater:
	lda	pr0|2,*		"subject category
	ana	pr0|4,*		"object category
	cmpa	pr0|4,*		"is object in subject subset?
	tnz	no		"must be in subject subset
	eax1	aim_template.level
	ldx2	pr0|2,*1		"subject level
	cmpx2	pr0|4,*1		"compare to object's level
	tmi	no		"can't be less
	tpnz	yes		"subject level greater than object
	cmpa	pr0|2,*		"object still in a reg
	tze	no		"must be unequal for true subset
	tra	yes		"else pass

" This entrypoint is equivalent to a pair of greater_or_equals.

in_range:
	epp1	pr0|2,*		"point to subject
	epp2	pr0|4,*		"point to object (min)
				"pr1 -> subject, pr2 -> min
	tsx3      range_one_compare
	epp3	pr1|0		"save it.
	epp1	pr2|2		"pr1 -> object (max)
	epp2	pr3|0		"pr2 -> subject
	tsx3	range_one_compare
	tra	yes

" This entrypoint ensures that its first arg's range is a subset of its second

range_in_range:
	epp1	pr0|2,*		" point to first range
	epp2	pr0|4,*		" point to second range
	tsx3	range_one_compare	" doesn't return if answer is no
	epp3	pr2|2		" point to high end of second range
	epp2	pr1|2		" point to high end of first range
	epp1	pr3|0		" set up correct comparison
	tsx3	range_one_compare
	tra	yes		" passed both tests

" pr1 -> ACC >=? pr2 -> ACC

range_one_compare:
	ldx2	pr1|aim_template.level " first level (DU!)
	cmpx2	pr2|aim_template.level " bigger than second?
	tmi	no		   " fails (subject must be >= min)
	lda	pr1|aim_template.categories
	ana	pr2|aim_template.categories
	cmpa	pr2|aim_template.categories "second subset of first?
	tnz	no
	tra	0,x3	"return for another test (YES)
	
yes:
	ldq	=o400000,du
	stq	pr0|6,*
	short_return

no:
	stz	pr0|6,*
	short_return


	end




		    aim_util_.alm                   11/11/89  1145.7r w 11/11/89  0804.7       17658



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************

" aim_util_ -- utilities that construct and deconstruct access classes
"              and authorizations.
"
"  BIM 84-04-26
"  Modified 1985-05-02, BIM: don't assume double-word alignment.
"
	name	aim_util_
	entry	get_access_class
	entry	get_level
	entry	get_categories
	entry	get_privileges
	entry	make_access_class

	include	aim_template

" 

"	CONVENTIONS
"
"	ap	pr0 (argument list)


" GET_ACCESS_CLASS

	set	auth,2	" arg offset
	set	acc,4	" arg offset

get_access_class:
	epp1	ap|auth,*
	lda	pr1|0		" get the access class
	ldq	pr1|1
         	anaq	access_class_mask   " remove privileges
	epp1	ap|acc,*
	sta	pr1|0
	stq	pr1|1
	short_return

" GET_LEVEL

	set	acc,2		" arguments are different
	set	level,4

get_level:
	epp1	ap|acc,*
	lda	pr1|0		" get the access class
	ldq	pr1|1
	qrl	18		" level DU in Q
	stq	ap|level,*
	short_return

" GET_CATEGORIES

	set	acc,2	" access class
	set	cats,4 	" categories

get_categories:
	lda	ap|acc,*	" First word is categories
	sta	ap|cats,* " simple, no?
	short_return

" GET_PRIVILEGES

	set	auth,2
	set	privs,4

get_privileges:
	epp1	ap|auth,*
	ldq	pr1|1		" just this word
	anq	=o777777,dl	" privs are low half of second word
	qls	18                  " return bit (36) aligned
	stq	ap|privs,*
	short_return

" MAKE_ACCESS_CLASS

	set	level,2
	set	cats,4
	set	acc,6

make_access_class:
	lda	ap|cats,*
	ldq	ap|level,*
	qls	18		" DU
	anaq	access_class_mask	" in case of junk
	epp1	ap|acc,*
	sta	pr1|0
	stq	pr1|1
	short_return

	even
access_class_mask:
	vfd	18/-1,18/0,15/0,3/7,18/0
	end




		    buddy_alloc_.pl1                11/11/89  1145.7rew 11/11/89  0804.2       63243



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* buddy_alloc_ is called to allocate space in an area. the calling sequence is:
   call buddy_alloc_(size,area_ptr,return_ptr), where size is fixed bin(26) and is size of block desired,
   area_ptr is the pointer to the area and return_ptr is a pointer to the allocated space.
   area_ptr must be pointing to a legitimate base or unpredictable errors will occur.  if the area pointed to by area_ptr
   is not initialized, area_ will be called to initialize it.
   coded 8.16.72 by Alan Downing.
   */
/* modified by A. Downing 08/73 to put in loop checks */

/* Last modified: (date and reason)
   11/6/75	by S.Webber to rename it buddy_alloc_ from alloc_
*/

buddy_alloc_: procedure (size, area_ptr, return_ptr);
%include area_header_v2pl1;
%include block_header_v2pl1;
dcl  return_ptr ptr,
    (rel, addrel, ptr, fixed, null) builtin,
     bit1 bit (1) init ("0"b),			/* tells if entering at top */
     alloc_ ext entry (fixed bin (26), ptr, ptr),
     area_ ext entry (fixed bin (26), ptr),
    (count, stop, i, j, k, ind, save_offset, size, place, indx) fixed bin (26),
     sys_info$max_seg_size ext static fixed bin (35),
    (area, storage, bad_area_format) condition;
	bit1 = "1"b;				/* flag to signal the area condition if insufficient area for allocate statement */
buddy_storage_: entry (size, area_ptr, return_ptr);	/* for signaling storage condition instead of area */
	if area_ptr -> area_header (1) ^= 0 then do;	/* Not buddy system area */
	     call alloc_ (size, area_ptr, return_ptr);
	     return;
	end;
restart:						/* come here if area has been made right size */
	front = fixed (rel (area_ptr), 18);		/* point to front end of area */
	stop = 70000;				/* used to stop infinite loopking when bad area exists */
	i = area_ptr -> area_header (3);
	if area_ptr -> area_header (4) = 0 then do;

/* The following code will convert the area to a new style area and then allocate
   the block therein with the new area management code. */

	     call area_ (i, area_ptr);		/* must initialize */
	     call alloc_ (size, area_ptr, return_ptr);
	     return;
	end;

	area_ptr -> area_header (4) =
	     area_ptr -> area_header (3);		/* set high water mark */
retry:
	i = size;
	if area_ptr -> area_header (6) > 23 then
	     go to bad_area;			/* this word has evidently been overwritten */
	count = 0;
try_to_allocate:
	do ind = 2 to area_ptr -> area_header (6)-5;	/* find what stratum is large enough */
	     count = count + 1;
	     if count > stop then go to bad_area;
	     if exp_tbl (ind) >= i+2 then do;		/* found the right size now */
		i = exp_tbl (ind);
		place = ind+5;
		if area_ptr -> area_header (place) ^= 0 then do; /* got a chain of free blocks this size */
alloc_block:
		     if area_ptr -> area_header (place)+front+size > sys_info$max_seg_size then do;
			count = count + 1;
			if count > stop then
bad_area:			     do;			/* area is no good */
			     signal bad_area_format;
			     go to restart;
			end;
			block_ptr = addrel (area_ptr, area_ptr -> area_header (place));
			if block_ptr -> block_header.forwardptr = 0 then go to break_up;
			area_ptr -> area_header (place) = block_ptr -> block_header.forwardptr;
			buddy_block_ptr = addrel (area_ptr, area_ptr -> area_header (place));
			block_ptr -> block_header.forwardptr = buddy_block_ptr -> buddy_block_header.forwardptr;
			buddy_block_ptr -> buddy_block_header.forwardptr =
			     fixed (rel (block_ptr), 18)-front;
			go to alloc_block;
		     end;
		     block_ptr = addrel (area_ptr, area_ptr -> area_header (place)); /* set block_ptr to beginning of free block */


		     area_ptr -> area_header (place) =
			block_ptr -> block_header.forwardptr; /* relink chain */
		     block_ptr -> block_header.busy_bit = "1"b; /* indicate that this block is busy */
		     block_ptr -> block_header.new_area = "11111111"b; /* used by freen_ to indicate new type block */
		     return_ptr = addrel (block_ptr, 2); /* offset return_ptr to actual beginning of storage in this block */
		     return;
		end;				/* thats all for allocating a block */
		else
break_up:		do j = ind+1 to area_ptr -> area_header (6)-5; /* look for bigger blocks which are free */
		     if area_ptr -> area_header (j+5) ^= 0 then do;
			do k = j to ind+1 by -1;	/* break up this block */
			     place = k+5;
			     indx = exp_tbl (k-1);
			     buddy_block_ptr = addrel (area_ptr, area_ptr -> area_header (place)); /* point at this block */
			     if area_ptr -> area_header (place)+indx+front > sys_info$max_seg_size then do;
				if buddy_block_ptr -> buddy_block_header.forwardptr ^= 0 then do;
				     block_ptr = addrel (area_ptr, buddy_block_ptr -> buddy_block_header.forwardptr);
				     area_ptr -> area_header (place) =
					buddy_block_ptr -> buddy_block_header.forwardptr;
				     buddy_block_ptr -> buddy_block_header.forwardptr =
					block_ptr -> block_header.forwardptr;
				     block_ptr -> block_header.forwardptr = fixed (rel (buddy_block_ptr), 18) - front;
				     go to try_to_allocate;
				end;
				i = size * 2;
				go to try_to_allocate;
			     end;
			     buddy_block_ptr -> buddy_block_header.size = place-1;
			     area_ptr -> area_header (place) = buddy_block_ptr -> buddy_block_header.forwardptr;
			     place = place -1;
			     save_offset = area_ptr -> area_header (place);
			     buddy_block_ptr -> buddy_block_header.forwardptr =
				fixed (rel (buddy_block_ptr), 18)+indx-front;
			     area_ptr -> area_header (place) = fixed (rel (buddy_block_ptr), 18)-front;
						/* have just relinked both sized stratum chains */
			     buddy_block_ptr = addrel (buddy_block_ptr, indx); /* must free up other half of the original block */
			     buddy_block_ptr -> buddy_block_header.busy_bit = "0"b; /* not busy */
			     buddy_block_ptr -> buddy_block_header.backptr = fixed (rel (buddy_block_ptr), 18) - front; /* point at front of this area */
			     buddy_block_ptr -> buddy_block_header.size = place;
			     buddy_block_ptr -> buddy_block_header.forwardptr =
				save_offset;	/* close chain */
			end;
			go to alloc_block;
		     end;
		end;
	     end;					/* end of 2**ind being large enough */
	end;					/* end of ind do loop */
error_return:					/* come here if there is not room to allocate desired space */
	if bit1 then signal area;
	else signal storage;
	go to retry;				/* maybe some storage was freed */
     end;




		    buddy_area_.pl1                 11/11/89  1145.7rew 11/11/89  0804.7       51363



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* area_ recoded 8.9.72 into pl1.
   calling sequence is:
   call area_(size,area_ptr) where size is number of words in the area, and is fixed bin(26),
   and area_ptr is its to area.  area_ptr is made to lie on a (0 mod 2) word boundery.
   coded by alan downing */
/* note: the actual size of this style area is the largest block which is a power of 2 <= size */

/* Last modified (date and reason):
   11/6/75	by S.Webber to rename it buddy_area_ from area_.
*/

buddy_area_: procedure (s, area_ptr);

%include area_header_v2pl1;
%include block_header_v2pl1;
dcl (s, size, i, j, k, l) fixed bin (26),
     sys_info$max_seg_size ext static fixed bin (26),
    (addrel, rel, bin, null) builtin,
     area condition;

	size = s;					/* make a copy of the size */
	if size < 28 | size > sys_info$max_seg_size + 24 then go to error_return;
	front = bin (rel (area_ptr), 18);
	area_ptr -> area_header (1), area_header (2) = 0; /* first two words are 0 if a new type area */
	area_ptr -> area_header (4) = 25;		/* if zero alloc_ knows its a virgin area */
	area_ptr -> area_header (5) = 24;		/* set up first usable storage word */
	do i = 7 to 23;
	     area_ptr -> area_header (i) = 0;		/* 0 header stratum words */
	end;
	if size = sys_info$max_seg_size then
	     size = sys_info$max_seg_size + 24;
	do i = 2 to 18 while (exp_tbl (i) <= size - 24);
	end;
	if i > 2 then do;				/* found actual usable size */
	     i = i-1;
	     area_ptr -> area_header (6) = i+5;
	     area_ptr -> area_header (3) =
		24 + exp_tbl (i);
	     block_ptr = addrel (area_ptr, 24);
	     block_ptr -> block_header.size = i+5;
	     block_ptr -> block_header.backptr = bin (rel (block_ptr), 18)-front;
	     block_ptr -> block_header.forwardptr = 0;
	     block_ptr -> block_header.busy_bit = "0"b;
						/* have just produced the dummy block_header */
	     area_ptr -> area_header (i+5) = 24;	/* set the correct stratum word */
break:
	end;
	else go to error_return;
	return;


buddy_redef:	entry (s, area_ptr);			/* alternate entry into area_ */
dcl  create_block bit (1);				/* used to indicate that a whole new block header is required */
	size = s;					/* copy the input argument */
	if size < 28 | size > sys_info$max_seg_size + 24 then do;
error_return:
	     signal area;
	     return;
	end;
	else do;					/* at least minimum amount of words required */
	     do i = 2 to 18 while (exp_tbl (i) <= size - 24);
	     end;
	     if i > 2 then do;			/* found right size */
		i = i-1;
		if i = area_ptr -> area_header (6)-5 then return; /* not changing the size */
		front = bin (rel (area_ptr), 18);
		if i > area_ptr -> area_header (6)-5 then do; /* must increase the area */
		     block_ptr = addrel (area_ptr, area_ptr -> area_header (3));
		     do j = area_ptr -> area_header (6)-5 to i-1;
			block_ptr -> block_header.backptr = bin (rel (block_ptr), 18) - front; /* point at front of area */
			block_ptr -> block_header.size = j+5;
			block_ptr -> block_header.forwardptr = 0;
			block_ptr -> block_header.busy_bit = "0"b;
			if j = area_ptr -> area_header (6)-5 then do;
			     block_ptr -> block_header.forwardptr =
				area_ptr -> area_header (j+5);
			     area_ptr -> area_header (j+5) = bin (rel (block_ptr), 18)- front; /* fix this stratum chain */
			end;
			else area_ptr -> area_header (j+5) = bin (rel (block_ptr), 18)- front; /* fix stratum */
			k = exp_tbl (j);
			block_ptr = addrel (block_ptr, k); /* point to next block */
		     end;
		     area_ptr -> area_header (6) = i+5;
		     area_ptr -> area_header (3) = 24 + exp_tbl (i);
		     if area_ptr -> area_header (4) > 25 then
			area_ptr -> area_header (4) = area_ptr -> area_header (3);
		     return;
		end;				/* of increasing the size */
		else do;				/* decreasing the size */
		     create_block = "0"b;		/* initialize the flag */
		     if area_ptr -> area_header (area_ptr -> area_header (6)) = 0 then /* whole area not free */
			do j = area_ptr -> area_header (6)-1 to i+5 by -1; /* see what blocks are free */
			if area_ptr -> area_header (j) <= 24 then go to error_return; /* can not shrink down because a block which is bigger is not free */
		     end;
		     else create_block = "1"b;
		     j = i+5;
		     do l = j to area_ptr -> area_header (6); /* now we do a shrink */
			area_ptr -> area_header (l) = 0;
		     end;
		     area_ptr -> area_header (3) = exp_tbl (i)+ 24;
		     area_ptr -> area_header (6) = j;
		     if area_ptr -> area_header (4) > 25 then
			area_ptr -> area_header (4) = area_ptr -> area_header (3);
		     if create_block then do;		/* no block was here before */
			area_ptr -> area_header (j) = 24;
			block_ptr = addrel (area_ptr, 24);
			block_ptr -> block_header.backptr = bin (rel (block_ptr), 18) - front;
			block_ptr -> block_header.size = j;
			block_ptr -> block_header.forwardptr = 0;
			block_ptr -> block_header.busy_bit = "0"b;
			block_ptr -> block_header.new_area = "11111111"b;
		     end;
		end;				/* of shrinking the area */
	     end;
	     else go to error_return;
	     return;
	end;
     end;




		    buddy_area_assign_.pl1          11/11/89  1145.7rew 11/11/89  0804.7       26271



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* buddy_area_assign_ assigns one area to another if possible.  If the sending area has no more allocated in it than
   can be held by the receiver, the assignment is successful.  If there is not enough room in the receiver,
   the area condition is signaled.  The state of the receiver after an unsuccessful assignment
   is unpredictable.
   usage, dcl buddy_area_assign_ ext entry(ptr,ptr), call buddy_area_assign_(receivingptr,sendingptr),
   the area pointed to by "receivingptr" is made equal to the area pointed to by "sendingptr".  note,
   equal means that what was allocated in one area is allocated at the same offset in the other, it does not
   mean that the areas have the same total size.
   coded on 12.26.72 by A. Downing */

buddy_area_assign_: proc (area_ptr, send_ptr);
dcl  send_ptr ptr,
    (null, rel, fixed) builtin,
     buddy_area_$buddy_redef ext entry (fixed bin (26), ptr),
     save_size fixed bin (26),
     image1 (receiver_size) based bit (36) aligned,
     receiver_size fixed bin (26),
     image2 (send_size) based bit (36) aligned,
     send_size fixed bin (26),
     area condition,
     sys_info$max_seg_size ext static fixed bin (26);
%include area_header_v2pl1;

	on condition (area) go to error_return;		/* can not make the desired area assignment */

	save_size, receiver_size = area_ptr -> area_header (3);
	if receiver_size + fixed (rel (area_ptr), 18) > sys_info$max_seg_size then
	     receiver_size = receiver_size - 24;
	if send_ptr -> area_header (4) < area_ptr -> area_header (3) then
	     send_size = send_ptr -> area_header (4);
	else do;
	     if area_ptr -> area_header (3) > send_ptr -> area_header (3) then
		send_size = send_ptr -> area_header (3);
	     else send_size = area_ptr -> area_header (3);
	end;
	if send_size + fixed (rel (send_ptr), 18) > sys_info$max_seg_size then
	     send_size = send_size - 24;
	if receiver_size < send_size then area_ptr -> image1 = send_ptr -> image1;
	else area_ptr -> image2 = send_ptr -> image2;
	call buddy_area_$buddy_redef (save_size, area_ptr);
	return;
error_return:
	revert area;				/* must do this so that the user thinks that the signal originated from buddy_area_assign_ */
	signal area;
	return;
     end buddy_area_assign_;




		    buddy_freen_.pl1                11/11/89  1145.7rew 11/11/89  0804.2       44361



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* freen_ coded 9.25.72 by Alan Downing as part of the pl1 area managment package.
   freen_ is called with a pointer to an allocated block of storage and free's this block using the
   buddy system of allocations and free's.  freen_ must be used with the style of area created by the area_ procedure
   which is part of this package.
   */
/* modified August 1973 to do loop checking */

/* Last modified (date and reason):
   11/6/75	by S.Webber to rename from freen_
*/

buddy_freen_: procedure (bptr);

dcl  bptr ptr;
dcl  bad_area_format condition;
dcl  temp_ptr ptr,
    (addrel, bin, null, addr, substr, bool, ptr, rel, divide) builtin,
     1 s1 aligned based (addr (i)),			/* just to put a bit string on a fixed bin */
     2 address (2) bit (18) unaligned,
     tempstr bit (18) aligned,
     1 s2 aligned based (addr (j)),
     2 buddy_address (2) bit (18) unaligned,
    (i, j, k, count, stop) fixed bin (26) init (0);
%include block_header_v2pl1;
%include area_header_v2pl1;

	block_ptr = addrel (bptr, -2);		/* point to actual beginning of this block */
	bptr = null ();
	area_ptr = addrel (block_ptr, - block_ptr -> block_header.backptr); /* set pointer to beginning of the area */
	front = bin (rel (area_ptr), 18);
	stop = 70000;				/* to eliminate infinite looping in a bad area */
	if area_ptr -> area_header (block_ptr -> block_header.size) = 0 then do; /* no others free of this size */
	     block_ptr -> block_header.busy_bit = "0"b;	/* no longer busy */
	     block_ptr -> block_header.new_area = "11111111"b;
	     block_ptr -> block_header.forwardptr = 0;	/* nothing to point to */
	     area_ptr -> area_header (block_ptr -> block_header.size) =
		bin (rel (block_ptr), 18)-front;	/* put this block in the proper stratum */
	     return;
	end;					/* nothing else to do if there were not others of this size */
	else
combine:	do;					/* must try to recombine */
	     count = count + 1;			/* keep a total of times through */
	     if count > stop then do;			/* looping */
bad_area:
		signal bad_area_format;
		return;
	     end;
	     address (2) = rel (block_ptr);		/* needed for address calculations */
	     i = i-24-front;			/* address arithmetic must be done with out the area header being regarded */
	     tempstr = "0"b;			/* reset the string */
	     k = 18 - (block_ptr -> block_header.size -5);
	     substr (tempstr, k, 1) = "1"b;		/* set the correct bit to 1 */
	     buddy_address (2) = bool (address (2), tempstr, "0110"b);
	     j = j+24+front;
	     buddy_block_ptr = ptr (block_ptr, j);	/* need a pointer to this buddy */
	     if buddy_block_ptr -> buddy_block_header.busy_bit |
	     buddy_block_ptr -> buddy_block_header.size ^=
	     block_ptr -> block_header.size then do;	/* can not recombine this buddy_block */
thats_it:
		block_ptr -> block_header.busy_bit = "0"b;
		block_ptr -> block_header.new_area = "11111111"b;
		block_ptr -> block_header.forwardptr =
		     area_ptr -> area_header (block_ptr -> block_header.size);
		area_ptr -> area_header (block_ptr -> block_header.size) =
		     bin (rel (block_ptr), 18)-front;	/* have relinked the chain */
		return;
	     end;
	     else do;				/* the buddy block is available for recombining */
		k = bin (rel (buddy_block_ptr), 18);
		temp_ptr = buddy_block_ptr;		/* save copy */
		buddy_block_ptr = addr (area_ptr -> area_header (buddy_block_ptr -> buddy_block_header.size));
		do while ("1"b);
		     if addrel (area_ptr, buddy_block_ptr -> buddy_block_header.forwardptr) =
		     temp_ptr then do;		/* found link and will remove it */
			buddy_block_ptr -> buddy_block_header.forwardptr =
			     temp_ptr -> buddy_block_header.forwardptr;
			go to found;
		     end;
		     else buddy_block_ptr = addrel (area_ptr, buddy_block_ptr -> buddy_block_header.forwardptr);
		     count = count + 1;
		     if count > stop then go to bad_area;
		end;
found:
		if j < i+24+front then block_ptr = temp_ptr; /* point to beginning of the new block */
		block_ptr -> block_header.size = block_ptr -> block_header.size + 1;
		if block_ptr -> block_header.size < area_ptr -> area_header (6) then go to combine;
		else do;
		     area_ptr -> area_header (4) = 25;	/* set high water mark down */
		     go to thats_it;
		end;
	     end;
	end;
     end;




		    call_outer_ring_.pl1            11/11/89  1145.7r w 11/11/89  0804.7       63144



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

/* format: style2 */
/* call_outer_ring_ -- prepares faked outward call via rtcd */
/* From outward_call_handler Benson I. Margulies April 1981 */

/* 830529 BIM Fixed not to try to set validation level < execution level. */

call_outer_ring_:
     procedure (a_ref_ptr, a_segname, a_entrypoint, a_ring_to_call, a_code);

	declare a_ref_ptr		 pointer;
	declare (a_segname, a_entrypoint)
				 character (*);
	declare a_ring_to_call	 fixed bin (3);
	declare a_code		 fixed bin (35);

	dcl     1 arglist_and_ptr	 aligned based,	/* argument list header FOUR WORDS LONG */
		2 arg_count	 fixed bin (17) unal,
		2 code		 fixed bin (17) unal,
		2 desc_count	 fixed bin (17) unal,
		2 pad		 fixed bin (17) unal,
		2 rtcd_ptr	 aligned like its_unsigned;

	dcl     1 given_its		 aligned like its_unsigned;

/* goodies in case we are in ring 0 */

	dcl     pds$highest_ring	 fixed bin (3) external;
						/* highest permissable ring for process */
	dcl     pds$initial_ring	 fixed bin (3) ext; /* initial non-hardcore ring for process */
	dcl     pds$ips_mask	 (0:7) bit (36) aligned ext;
						/* IPS mask for each ring */
	dcl     pds$stacks		 (0:7) pointer external;
	dcl     pds$first_call	 fixed bin ext;	/* non-zero until first call from Ring 0 */
	dcl     active_all_rings_data$stack_base_segno
				 fixed bin (18) ext;/* segno of base of array of 8 stacks */

	dcl     get_ring_		 entry () returns (fixed bin (3));
	dcl     hcs_$level_set	 entry (fixed bin (3));
	dcl     hcs_$get_max_length_seg
				 entry (pointer, fixed bin (19), fixed bin (35));
	dcl     hcs_$level_get	 entry returns (fixed bin (3));
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     rtcd_util_		 entry (pointer, pointer);

	dcl     (addrel, addr, baseptr, max, null)
				 builtin;

	dcl     ref_ptr		 pointer;
	dcl     segname		 character (32);
	dcl     entrypoint		 character (32);
	dcl     thing_to_call	 pointer;
	dcl     ring_to_call	 fixed bin (3);
	dcl     ap		 pointer;
	dcl     calling_ring	 fixed bin (3);
	dcl     calling_level	 fixed bin (3);
	dcl     code		 fixed bin (35);
	dcl     r			 fixed bin (3);
	dcl     stack_segno		 fixed bin;
	dcl     target_sb		 pointer;
	dcl     bit36		 bit (36) aligned;
	dcl     based_bit36		 based bit (36) aligned;

	dcl     (
	        error_table_$badringno,
	        error_table_$action_not_performed,
	        error_table_$outward_call_failed
	        )			 external static fixed bin (35);

	dcl     cleanup		 condition;
	dcl     any_other		 condition;
%page;
%include stack_header;
%include its;

	ref_ptr = a_ref_ptr;
	segname = a_segname;
	entrypoint = a_entrypoint;
	ring_to_call = a_ring_to_call;
	code = 0;

	calling_ring = get_ring_ ();
	calling_level = hcs_$level_get ();
	on cleanup call clean_up;

	if ring_to_call <= calling_ring
	then do;
		code = error_table_$badringno;
		go to return_;
	     end;

	if calling_ring = 0
	then do;					/* Call out from ring 0 */

/* A process may make only one outward call from Ring 0 during its existence.
   The target ring number of this call must be no less than the value
   contained in pds$initial_ring.
*/

		if pds$first_call = 0
		then /* If this is not the first call from Ring 0 ... */
		     do;
			code = error_table_$action_not_performed;
			go to return_;
		     end;
		pds$first_call = 0;			/* Indicate first call from Ring 0 is being accomplished. */
		if ring_to_call < pds$initial_ring
		then do;
			code = error_table_$badringno;
			go to return_;

/* Don't allow call inside initial ring. */
		     end;
	     end;

/* first insure existence of outer ring stack so we can snap links */

	stack_segno = active_all_rings_data$stack_base_segno + ring_to_call;
	target_sb = baseptr (stack_segno);
	bit36 = target_sb -> based_bit36;

/* now run make_ptr to get a link snapped to it so it has linkage in the 
   right ring */

	call hcs_$level_set (ring_to_call);
	thing_to_call = null ();
	call hcs_$make_ptr (ref_ptr, segname, entrypoint, thing_to_call, code);
	if thing_to_call = null ()			/* no such luck */
	then go to return_;
	code = 0;
	call hcs_$level_set (calling_ring);		/* back in for a while */
	do r = calling_ring to ring_to_call - 1;	/* mask IPS signals in all lower rings */
	     call hcs_$level_set (r);
	     call hcs_$set_ips_mask (""b, (""b));
	end;

	call hcs_$level_set (ring_to_call);

/* once we enter this do loop we cannot return, regardless of
   what happens. There is no stack history behind us. Oh well ... */

	on any_other go to terminate_the_process;

	do r = calling_ring to ring_to_call;
	     if calling_ring = 0
	     then sb = pds$stacks (r);
	     else do;
		     stack_segno = active_all_rings_data$stack_base_segno + r;
		     sb = baseptr (stack_segno);
		     call hcs_$get_max_length_seg (sb, (0), code);
		     if code ^= 0
		     then do;
			     sb = null ();
			     code = 0;
			end;
		end;
	     if sb ^= null ()
	     then /* If stack exists for ring ... */
		sb -> stack_header.stack_end_ptr = sb -> stack_header.stack_begin_ptr;
						/* Reset stack. */
	end;

	ap = target_sb;				/* There are four words at the beginning reserved for this */

	ap -> arglist_and_ptr.arg_count, ap -> arglist_and_ptr.desc_count, ap -> arglist_and_ptr.pad = 0;
	ap -> arglist_and_ptr.code = 4;		/* Make a null argument list. */

	unspec (given_its) = unspec (thing_to_call);
	ap -> arglist_and_ptr.rtcd_ptr = given_its;	/* we must set ringno to tell rtcd where to go */
	ap -> arglist_and_ptr.rtcd_ptr.ringno = ring_to_call;
						/* we go there */

/* This program should be bound together with rtcd_util_ to insure
       this call works. */

	call rtcd_util_ (addr (ap -> arglist_and_ptr.rtcd_ptr), ap);

	go to terminate_the_process;

return_:
	call clean_up;
	a_code = code;
	return;
clean_up:
     procedure;
	call hcs_$level_set (calling_level);
     end clean_up;

terminate_the_process:
	begin;

	     declare (baseptr, pointer)     builtin;
	     declare other_deadly_reference fixed bin (35) based;
	     declare deadly_reference	      fixed bin (35);

nowhere_fast:
	     deadly_reference = pointer (baseptr (-2), -5) -> other_deadly_reference;
						/* bang */
	     go to nowhere_fast;			/* what else is there to do? */

	end terminate_the_process;

     end call_outer_ring_;




		    convert_access_operation_.pl1   11/11/89  1145.7r w 11/11/89  0804.6       22347



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */

/* format: off */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CONVERT_ACCESS_OPERATION_							*/
	/*									*/
	/* Routine to convert a bit string which uniquely describes a system access operation	*/
	/* into its associated text.  The text strings as well as the table of unique access	*/
	/* operation codes are in "access_operations_".  The format of the file is described by	*/
	/* "access_operations_.incl.pl1"  The format of the encoded operation is described by	*/
	/* "access_audit_encoded_op.incl.pl1".						*/
	/*									*/
	/* History:								*/
	/* 84-11-14 EJ Sharpe - created						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


convert_access_operation_:
	procedure (a_oper_code) returns (char (50));

dcl	a_oper_code	bit (36) aligned parameter;

dcl	oper_index	fixed bin;	/* unique part of encoded operation */
dcl	based_char_str	char (char_str_len) based (char_str_ptr);  /* the string we'll return */
dcl	char_str_len	fixed bin (21);	/* length of text for the operation */
dcl	char_str_ptr	pointer;		/* pointer to the text */

dcl	fifty_exs		char (50)		/* returned in cases where supplied code is not in table */
				init ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
				static internal options (constant);


dcl	addr		builtin;
dcl	fixed		builtin;
dcl	addrel		builtin;

	oper_index = fixed(addr(a_oper_code)->encoded_access_op.operation_index);
	if  oper_index <= 0
	  | oper_index > access_operations_$num_codes
	  | access_operations_$version ^= ACCESS_OPERATIONS_V1
	then return (fifty_exs);

	char_str_ptr = addrel (addr(access_operations_$text_area),
			fixed(access_operations_$text_offset_table.text_offset(oper_index)));
	char_str_len = access_operations_$text_offset_table.text_len(oper_index);
	return (based_char_str);
%page;

%include access_audit_encoded_op;



%include access_operations_;

end convert_access_operation_;




		    copy_on_write_handler_.pl1      11/11/89  1145.7r w 11/11/89  0804.8       86040



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
copy_on_write_handler_:
     procedure (mcptr, cname, dummy1, dummy2) returns (bit (1) aligned);

/* Modified 6/77 by M. Weaver to save lot entry */
/* Modified 6/79 by C. Hornig to work in ring 0 */
/* Modified May 1981 by C. Hornig to really work in any ring */
/* Modified November 1984 by Keith Loepere to rename terminate to terminate_. */

/* Parameters */

dcl  cname char (*) parameter;
dcl  (dummy1, dummy2) ptr parameter;
dcl  mcptr ptr parameter;				/* pointer to machine conditions */

/* Automatic */

dcl  1 old_status like branch;			/* status of faulted segment */
dcl  old_segno fixed bin (15);			/* segment number of faulted segment */
dcl  old_ptr ptr;					/* pointer to faulted segment */
dcl  old_dirname char (168);				/* directory containing faulted segment */
dcl  old_ename char (32);				/* and its entry name */

dcl  new_ptr ptr;					/* pointer to copy */
dcl  new_dirname char (168);				/* directory containing copy */
dcl  new_ename char (32);				/* entry name of copy */

dcl  maxlength fixed bin (19);			/* max length of segment */
dcl  size fixed bin (21);				/* size of segment in words */
dcl  rb (3) fixed bin (6);				/* ring brackets of copy */
dcl  group_id char (32);				/* group ID for ACL's */
dcl  ref_names (10) char (32);			/* refnames so they can be put back */
dcl  saved_lote bit (36) aligned;			/* LOT entry for the same reason */
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  initiate_entry variable entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
						/* hcs_$initiate is saved here in case we have no linkage sectoion */
dcl  (
     val_ring,					/* validation ring at time of fault */
     my_ring,					/* current ring of execution */
     x_ring,					/* ring of execution at time of fault */
     t_ring					/* validation ring of faulting reference */
     ) fixed bin (3);
dcl  saved_useable_lot bit (1) aligned;			/* whether LOT was good when fault happened */

/* Entries callable in any ring */

dcl  hcs_$level_get entry () returns (fixed bin (3));
dcl  hcs_$level_set entry (fixed bin (3));
dcl  hcs_$append_branchx
	entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*), fixed bin (1), fixed bin (1),
	fixed bin (24), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$fs_get_ref_name entry (ptr, fixed bin, char (*), fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$get_max_length entry (char(*), char(*), fixed bin (19), fixed bin(35));
dcl  hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  hcs_$terminate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));

/* User-ring entries */

dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  get_group_id_ entry returns (char (32));
dcl  get_pdir_ entry returns (char (168));
dcl  get_ring_ entry returns (fixed bin (3));

/* Hardcore entries */

dcl  makeunknown_ entry (fixed bin (15), bit (2) aligned, bit (1) aligned, fixed bin (35));
dcl  initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));

dcl  pds$process_dir_name char (32) ext;
dcl  pds$process_group_id char (32) ext;
dcl  pds$useable_lot (0:7) ext bit unaligned;

/* External static */

dcl  error_table_$no_s_permission ext fixed bin (35);
dcl  sys_info$page_size fixed bin ext static;

/* Builtins */

dcl  (addr, baseptr, baseno, binary, max, null, pointer, unspec) builtin;

dcl  cleanup condition;

/* Based */

dcl  move char (size) based aligned;
%page;
	scup = addr (mcptr -> mc.scu);
	old_segno = binary (scu.tpr.tsr, 15);		/* extract segment number */
	x_ring = binary (scu.ppr.prr, 3);		/* ring that faulted */
	val_ring = hcs_$level_get ();			/* save the validation level */
	my_ring = get_ring_ ();			/* find ring we are in now */
	if x_ring < my_ring then return ("1"b);		/* must have crawled out already */
	t_ring = binary (scu.tpr.trr, 3);		/* validation ring of reference */
	if my_ring = 0 then saved_useable_lot = pds$useable_lot (t_ring);
						/* we have to restore this later */
	on cleanup
	     begin;				/* restore in case of accidents */
		if my_ring = 0 then pds$useable_lot (t_ring) = saved_useable_lot;
		call hcs_$level_set (val_ring);
	     end;
	call hcs_$level_set (t_ring);			/* set validation level */

	old_ptr = baseptr (old_segno);
	call hcs_$fs_get_path_name (old_ptr, old_dirname, (0), old_ename, code);
						/* get path name of faulted sgement */
	if code ^= 0 then goto error;
	call hcs_$status_long (old_dirname, old_ename, 1, addr (old_status), null (), code);
						/* get its copy switch */
	if (code ^= 0) & (code ^= error_table_$no_s_permission) then goto error;
	if old_status.copy_switch = "0"b then goto error; /* no copy switch set */
	call hcs_$get_max_length (old_dirname, old_ename, maxlength, code);
	if (code ^= 0) & (code ^= error_table_$no_s_permission) then goto error;
	t_ring = max (t_ring, binary (old_status.ring_brackets (0), 3));
						/* update t_ring from ring brackets */
	if my_ring = 0 then saved_useable_lot = pds$useable_lot (t_ring);
						/* must save it again */
	call hcs_$level_set (t_ring);

/* find ring whose lot entry is saved */

	if /* case */ my_ring = 0 then do;
	     pds$useable_lot (t_ring) = "0"b;		/* this allows faults on the LOT to work */
	     new_dirname = pds$process_dir_name;
	     group_id = pds$process_group_id;
	     end;
	else if t_ring ^= x_ring			/* someday we should be able to handle this case */
	then goto error;
	else do;
	     sb = pointer (mcptr -> mc.prs (6), 0);	/* get ptr to our stack */
	     new_dirname = get_pdir_ ();
	     group_id = get_group_id_ ();
	     end;

/* Copy switch was ON, do the copy on write work */

	new_ename = unique_chars_ ("0"b) || ".cp." || old_ename;
	do i = 1 to 3;				/* compute new ring brackets */
	     rb (i) = max (t_ring, binary (old_status.ring_brackets (i - 1), 3));
	end;
	call hcs_$append_branchx (new_dirname, new_ename, 01110b, rb, group_id, 0, 0, binary (old_status.bit_count, 24),
	     code);				/* create the copy */
	if code ^= 0 then goto error;
	call hcs_$initiate (new_dirname, new_ename, "", 0, 0, new_ptr, code);
						/* get a pointer to it */
	if new_ptr = null () then goto error;
	call hcs_$set_max_length_seg (new_ptr, maxlength, code);
	if code ^= 0 then goto error;
	size = binary (old_status.current_length, 12) * sys_info$page_size * 4;
	new_ptr -> move = old_ptr -> move;		/* copy the segment */

/* now swap the new segment for the old one */
/* NOTE: we don't seem to do the right thing by known counts; this is hard to fix.
   Don't do so well by refnames, either, if you have more than 10. */

	if my_ring = 0 then do;
	     call makeunknown_ (binary (baseno (new_ptr), 15), "01"b, (""b), code);
	     if code ^= 0 then goto error;		/* make the new copy unknown */
	     call makeunknown_ (old_segno, "11"b, (""b), code);
						/* free up the segment number */
	     if code ^= 0 then goto error;
	     call initiate (new_dirname, new_ename, "", 1, 0, old_ptr, code);
						/* make the copy known with the old segment number */
	     pds$useable_lot (t_ring) = saved_useable_lot;/* restore useable_lot */
	     if code ^= 0 then goto error;
	     end;
	else do;
	     call hcs_$terminate_seg (new_ptr, 0, code);	/* terminate new copy */
	     if code ^= 0 then goto error;
	     do i = 1 to 10 while (code = 0);		/* save the refnames */
		call hcs_$fs_get_ref_name (old_ptr, i, ref_names (i), code);
	     end;
	     saved_lote = unspec (stack_header.lot_ptr -> lot.lp (old_segno));
						/* and the LOT entry */
	     initiate_entry = hcs_$initiate;		/* must save since our linkage section is going away */
	     call hcs_$terminate_seg (old_ptr, 1, code);	/* terminate old segment */
	     if code ^= 0 then goto error;
	     call initiate_entry (new_dirname, new_ename, "", 1, 0, old_ptr, code);
						/* initiate new one in its place */
	     if code ^= 0 then goto error;
	     unspec (stack_header.lot_ptr -> lot.lp (old_segno)) = saved_lote;
						/* restore LOT entry */
	     do i = 1 to i - 1;			/* and ref names */
		call hcs_$initiate (new_dirname, new_ename, ref_names (i), 0, 0, old_ptr, code);
	     end;
	     end;

	call hcs_$level_set (val_ring);		/* restore saved validation level */
	return ("0"b);

error:						/* an error has occurred */
	call hcs_$level_set (val_ring);		/* restore validation level */
	if my_ring = 0 then pds$useable_lot (t_ring) = saved_useable_lot;
	return ("1"b);
%page;
%include status_info;
%include mc;
%include lot;
%include stack_header;

     end copy_on_write_handler_;




		    crawlout_default_handler_.pl1   11/11/89  1145.7rew 11/11/89  0804.8       38637



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* format: style2 */
crawlout_default_handler_:
     proc (mcptr, cond_name, wcptr, infoptr, retsw);

/* This procedure is called by signal_ before crawlouts in case the condition can
   be handled in the lower ring.  This is necessary for pl1 conditions */
/* coded 8 November 1973 by M. Weaver */
/* Quiet restart support added by BIM August 1981 */
/* Error condition signalling improved BIM same time */

	declare (mcptr, wcptr, infoptr)
				 ptr;

	declare i			 fixed bin;

	declare retsw		 bit (1) aligned;

	declare conname		 character (32);
	declare cond_name		 character (*);

	declare return_conditions	 (4) character (32)
				 init ("command_error", "stringsize", "underflow", "command_question")
				 internal static options (constant);

	declare error_conditions	 (14) character (32)
				 init ("area", "storage", "endfile", "undefinedfile", "overflow", "fixedoverflow",
				 "zerodivide", "size", "conversion", "key", "record", "transmit", "stringrange",
				 "subscriptrange") internal static options (constant);

	declare based_file		 file variable based;

	declare signal_		 entry options (variable);

%include condition_info_header;
	declare 1 pl1_info_struc	 aligned like pl1_info based (infoptr);
%include pl1_info;

	declare 1 error_info	 aligned like condition_info_header;
						/* thie minimal info structure */

	declare (currentsize, hbound, lbound, null, string)
				 builtin;



	retsw = "0"b;				/* only return if we set this bit */

	if infoptr ^= null ()
	then if infoptr -> condition_info_header.quiet_restart /* this is obvious */
		| infoptr -> condition_info_header.default_restart
						/* The semantics say "print a message and continue." */
						/* If they didnt think continuing was important, they would not set, */
						/* and so we restart */
	     then do;
		     retsw = "1"b;
		     return;
		end;

	conname = cond_name;			/* copy for ease of comparing */
						/* preserve special cases in case there is no info */

	do i = lbound (return_conditions, 1) to hbound (return_conditions, 1);
	     if conname = return_conditions (i)
	     then do;
		     retsw = "1"b;			/* don't crawl out */
		     return;
		end;
	end;

	do i = lbound (error_conditions, 1) to hbound (error_conditions, 1);
	     if conname = error_conditions (i)
	     then do;

/* By setting the quiet restart bit, we force another invocation of
    ourself to return, eventually to us. Then we can go ahead and let
    the original condition signal out, instead of the useless and
    uninformative "error". This PL/I programs that have handlers for
    the error condition catch the signal if they are there, and we
    signal out the original condition otherwise. */

		     error_info.version = 1;
		     error_info.length = currentsize (error_info);
		     string (error_info.action_flags) = ""b;
		     error_info.quiet_restart = "1"b;
		     error_info.info_string = "";	/* This is never allowed to get to default error handler */
		     error_info.status_code = 0;

		     call signal_ ("error", null /* No MC */, addr (error_info));
		     return;			/* crawl out with original equipment */
		end;
	end;

/* below code for endpage stolen from Belmont's pl1_signal_,
   but we don't support V1 PL/I running in an Inner Ring. Tough. */

	if conname = "endpage"
	then if infoptr ^= null
	     then if pl1_info_struc.content_flags.file_ptr_sw
		then do;
			put page file (pl1_info_struc.file_ptr -> based_file);
			retsw = "1"b;		/* finished handling condition */
			return;
		     end;

	return;					/* can't handle any other condition in this ring */
     end crawlout_default_handler_;




		    ipc_validate_.pl1               11/11/89  1145.7rew 11/11/89  0803.8       57078



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */

/* format: style2 */

/* format: off */
/*
   IPC_VALIDATE_:  A collection of utilities available to both hardcore
   and user-ring IPC for event channel name validation support.  The
   following entries are provided:

   encode_event_channel_name:  Given the values for the R-offset, R-factor,
   event channel index, event channel flags, ring number, event channel
   type, and event channel unique id, returns an encoded event channel
   name of datatype fixed bin (71).

   decode_event_channel_name: Given an event channel name of datatype 
   fixed bin (71), and the values of R-offset and R_factor, decodes the
   values of the event channel index, the event channel flags, ring
   number, event channel type, and event channel unique id.  It returns
   error_table_$invalid channel if the supplied event channel name is
   incorrectly formatted or invalidly encoded.

   validate_event_channel_name:  This entry is similar to 
   decode_event_channel_name and exists for efficiency.  It verifies that
   the encoded index and verify are correct for the event channel specified
   and decodes the index and flags.  It does nothing with the rest of the
   unencoded portion of the event channel name.  It is used by hc_ipc.
*/
/* format: on */

/* Written 1984-11-14 by E. Swenson */


/****^  HISTORY COMMENTS:
  1) change(86-08-09,Kissel), approve(86-08-12,MCR7479),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Changed to move the structure declaration for encoded_index into the
     event_channel_name include file.  Also, renamed some automatic variables
     for clarity.  NOTE:  the algorithm for decoding the encoded_index is
     duplicated in pxss in ALM.  Therefore, any change must also be reflected
     there.
                                                   END HISTORY COMMENTS */


ipc_validate_:
     procedure ();
	return;

/* Parameters */

	dcl     P_code		 fixed bin (35) parameter;
	dcl     P_ev_chn_index	 fixed bin (15) parameter;
	dcl     P_ev_chn_flags	 bit (3) aligned parameter;
	dcl     P_ev_chn_ring	 fixed bin (3) parameter;
	dcl     P_ev_chn_type	 bit (1) aligned parameter;
	dcl     P_ev_chn_unique_id	 fixed bin (18) parameter;
	dcl     P_event_channel_name	 fixed bin (71) parameter;
	dcl     P_r_offset		 fixed bin (18);
	dcl     P_r_factor		 fixed bin (35);

/* Automatic */

	dcl     decoded_index_binary	 fixed bin (18) unsigned;
	dcl     1 auto_decoded_index	 structure aligned like decoded_index;
	dcl     1 ev_chn_name	 structure aligned like event_channel_name;
	dcl     r_offset		 fixed bin (18) unsigned;
	dcl     r_factor		 fixed bin (35) unsigned;
	dcl     temp		 fixed bin (71);	/* temporary; large enough to avoid overflows */

/* External */

	dcl     error_table_$invalid_channel
				 fixed bin (35) external;
						/* Builtin */

	dcl     (binary, mod, substr, unspec)
				 builtin;

%page;
encode_event_channel_name:
     entry (P_r_offset, P_r_factor, P_ev_chn_flags, P_ev_chn_index, P_ev_chn_ring, P_ev_chn_type, P_ev_chn_unique_id,
	P_event_channel_name);

/* This entry encodes an event channel name given the various values
   which make up an event channel name.  It uses the IPC event channel
   name validation algorithm to encode the supplied index and flags. */

	auto_decoded_index.flags = P_ev_chn_flags;
	auto_decoded_index.index = P_ev_chn_index;
	decoded_index_binary = binary (substr (unspec (auto_decoded_index), 1, 18));

	r_offset = P_r_offset;
	r_factor = P_r_factor;

	unspec (ev_chn_name) = ""b;

	temp = decoded_index_binary + r_offset;
	ev_chn_name.encoded_index = substr (unspec (temp), 55, 18);

	temp = decoded_index_binary * r_factor;
	ev_chn_name.verifier = substr (unspec (temp), 37, 18);

	ev_chn_name.ring = P_ev_chn_ring;
	ev_chn_name.type = P_ev_chn_type;
	ev_chn_name.unique_id = P_ev_chn_unique_id;

	unspec (P_event_channel_name) = unspec (ev_chn_name);
	return;
%page;
decode_event_channel_name:
     entry (P_r_offset, P_r_factor, P_event_channel_name, P_ev_chn_flags, P_ev_chn_index, P_ev_chn_ring, P_ev_chn_type,
	P_ev_chn_unique_id, P_code);

/* This entry decodes an event channel name into its constituent parts.
   At the same time, it validates the event channel name. */

	unspec (ev_chn_name) = unspec (P_event_channel_name);

	if ev_chn_name.mbz ^= ""b
	then do;
		P_code = error_table_$invalid_channel;
		return;
	     end;

	r_offset = P_r_offset;
	r_factor = P_r_factor;
	temp = binary (ev_chn_name.encoded_index, 18);
	decoded_index_binary = mod (temp - r_offset, ENCODED_INDEX_CONSTANT);
	temp = decoded_index_binary * r_factor;

	if ev_chn_name.verifier ^= substr (unspec (temp), 37, 18)
	then do;
		P_code = error_table_$invalid_channel;
		return;
	     end;

	unspec (auto_decoded_index) = substr (unspec (decoded_index_binary), 19, 18);
	P_ev_chn_index = auto_decoded_index.index;
	P_ev_chn_flags = auto_decoded_index.flags;

	P_ev_chn_ring = ev_chn_name.ring;
	P_ev_chn_type = ev_chn_name.type;
	P_ev_chn_unique_id = ev_chn_name.unique_id;
	P_code = 0;
	return;
%page;
validate_event_channel_name:
     entry (P_r_offset, P_r_factor, P_event_channel_name, P_ev_chn_flags, P_ev_chn_index, P_code);


	r_offset = P_r_offset;			/* change to unsigned data type */
	r_factor = P_r_factor;
	unspec (ev_chn_name) = unspec (P_event_channel_name);
	temp = binary (ev_chn_name.encoded_index, 18);
	decoded_index_binary = mod (temp - r_offset, ENCODED_INDEX_CONSTANT);
	temp = decoded_index_binary * r_factor;

	if ev_chn_name.verifier ^= substr (unspec (temp), 37, 18)
	then do;
		P_code = error_table_$invalid_channel;
		return;
	     end;

	unspec (auto_decoded_index) = substr (unspec (decoded_index_binary), 19, 18);
	P_ev_chn_index = auto_decoded_index.index;
	P_ev_chn_flags = auto_decoded_index.flags;
	P_code = 0;
	return;

/* format: off */
%page; %include event_channel_name;
/* format: on */

     end ipc_validate_;




		    isot_fault_handler_.pl1         11/11/89  1145.7r w 11/11/89  0804.9       22599



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


isot_fault_handler_: proc (mcptr, cname, d1, d2) returns (bit (1) aligned);

/* modified September 1976 by M. Weaver  to use area package allocation */
/* modified December 1976 by M. Weaver to handle isot faults from ring 0 */

dcl  mcptr ptr,
     cname char (*),
    (d1, d2) ptr,
    (isotpp, statp, new_statp) ptr,
    (ring, level) fixed bin (3),
     area condition,
     statlen fixed bin (17),
     segno fixed bin (17),
     copy_static (statlen) fixed bin (35) aligned based,
     based_ptr ptr unaligned based,
     based_area area based,
     hcs_$level_get entry returns (fixed bin (3)),
     hcs_$level_set entry (fixed bin (3)),
     pds$stacks (0:7) ptr ext;
dcl (addr, baseptr, bin, ptr, rel) builtin;

	scup = addr (mcptr -> mc.scu(0));
	ring = bin (scup -> scu.trr, 3);
	level = hcs_$level_get ();
	if level ^= ring then call hcs_$level_set (ring);
	if bin (scup -> scu.prr, 3) = 0 then sb = pds$stacks (ring);	/* can only reference pds in ring 0 */
	else sb = ptr (mcptr -> mc.prs (6), 0);
	segno = bin (scup -> scu.ca, 18) - bin (rel (sb -> stack_header.isot_ptr), 18);
	isotpp = ptr (baseptr (bin (bin (scup -> scu.tsr, 15), 18)), scup -> scu.ca);
	statp = ptr (baseptr (segno), rel (isotpp -> based_ptr));
	statlen = bin (sb -> stack_header.lot_ptr -> lot.lp (segno) -> header.static_length);
	on area goto error;
	allocate copy_static in (sb -> stack_header.combined_stat_ptr -> based_area) set (new_statp);
	if level ^= ring then call hcs_$level_set (level);
	new_statp -> copy_static = statp -> copy_static;
	isotpp -> based_ptr = new_statp;
	return ("0"b);


error:	if level ^= ring then call hcs_$level_set (level);
	return ("1"b);
						/*
						   
						   */
%include lot;
/*
   
*/
%include linkdcl;
/*
   
*/
%include stack_header;
/*
   
*/
% include mc;

     end isot_fault_handler_;




		    link_trap_caller_.pl1           11/11/89  1145.7rew 11/11/89  0804.6       60651



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to trap damaged_object_msf_ condition and return a code to
     caller.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
link_trap_caller_:
     proc (dummy_ptr, mcptr, header_ptr, def_ptr, type_ptr, link_ptr, ecode_ptr);

/* This procedure is "called" from the linker so that it can call trap procedures
   in the original faulting ring.  It is always called with 7 arguments, but
   only mcptr and header_ptr are relevant for traps-at-first-reference.
   Only mcptr is really necessary, but the others are
   needed at some point and the linker already had their values.
*/
/* coded by M. B. Weaver 5/17/73 */
/* modified 1/2/83 by M. Weaver to handle traps for VLA common */
/* modified 2/5/85 by M. Weaver to reset aborted first reference traps */

declare	dummy_ptr		ptr;			/* dummy pointer so that mcptr is second arg so cleanup handler will work */
declare	(mcptr, header_ptr, def_ptr, type_ptr, link_ptr, ecode_ptr)
			ptr;
declare	(trap_ptr, call_ptr_ptr, arg_ptr_ptr, fr_ptr, nsp)
			ptr;
declare	call_ptr		ptr based;

declare	trap_proc		entry variable options (variable);
declare	cu_$make_entry_value
			entry (pointer, entry);
declare	i		fixed bin;
declare	indirect		bit (6) aligned static init ("010000"b) options (constant);
declare	ecode		fixed bin (35) based;
declare	ec		fixed bin (35);
declare	(
	error_table_$bad_first_ref_trap,
	error_table_$bad_trap_before_link,
	error_table_$inconsistent_object_msf,
	error_table_$no_vla_support
	)		ext fixed bin (35);


declare	(addr, addrel, baseptr, null)
			builtin;

declare	cleanup		condition;
declare	object_msf_damaged_ condition;

declare	cu_$stack_frame_ptr entry () returns (ptr);
declare	nonlocal_goto_$same_ring
			entry (ptr, ptr);
declare	signal_		ext entry options (variable);
declare	hcs_$make_entry	entry (ptr, char (*), char (*), entry, fixed bin (35));
declare	term_$nomakeunknown entry (ptr, fixed bin (35));

declare	1 fr_traps	based aligned,		/* describes first reference trap array */
	  2 dcl_vers	fixed bin,
	  2 n_traps	fixed bin,
	  2 trap_ptrs	(1000) aligned,
	    3 call_ptr	bit (18) unaligned,
	    3 arg_ptr	bit (18) unaligned;

declare	1 instr		(0:1) based aligned,
	  2 address	bit (18) unal,
	  2 op_code	bit (12) unal,
	  2 mod		bit (6) unal;

/*  */
	if def_ptr = null
	then do;					/* first reference trap case */
						/* here header_ptr points to the base of the linkage section being
						   linked to */

	     fr_ptr =
		addrel (header_ptr, header_ptr -> header.original_linkage_ptr -> virgin_linkage_header.first_ref_relp)
		;				/* get ptr to trap structure */

	     header_ptr -> its.pad4 = "0"b;		/* don't want to go through this again */

	     if fr_ptr -> fr_traps.dcl_vers ^= 1
	     then do;				/* not something we know about */
		ec = error_table_$bad_first_ref_trap;
sig_err:
		if mcptr ^= null
		then do;				/* must abort; signal linkage_error */
		     mcptr -> mc.errcode = ec;
		     call signal_ ("linkage_error", mcptr);
		end;
		else ecode_ptr -> ecode = ec;		/* linker was called; can return code */
	     end;

	     else do;
		on cleanup call term_$nomakeunknown (baseptr (header_ptr -> header.stats.segment_number), ec);
						/* reset first ref trap if aborted */
		on object_msf_damaged_ begin;
		  ec = error_table_$inconsistent_object_msf;
		  goto sig_err;
		end;
		
		do i = 1 to fr_ptr -> fr_traps.n_traps; /* call all trap procedures */
		     call_ptr_ptr = addrel (header_ptr, fr_ptr -> fr_traps.call_ptr (i));
		     if fr_ptr -> fr_traps.arg_ptr (i) ^= ""b
		     then arg_ptr_ptr = addrel (header_ptr, fr_ptr -> fr_traps.arg_ptr (i));
		     else arg_ptr_ptr = null;
		     call cu_$make_entry_value (call_ptr_ptr -> call_ptr, trap_proc);
		     call trap_proc (arg_ptr_ptr);
		end;
		revert object_msf_damaged_;
	     end;

	end;

	else if header_ptr = null			/* VLA common trap */
	then do;
	     call hcs_$make_entry (null, "fortran_storage_", "resolve_VLA_COMMON_link", trap_proc, ec);
	     if ec ^= 0
	     then do;
		ec = error_table_$no_vla_support;
		go to sig_err;
	     end;
	     call trap_proc (link_ptr, def_ptr, type_ptr, ec);
	     if ec ^= 0
	     then go to sig_err;
	     else if mcptr ^= null			/* following code should be the same */
	     then do;				/* as adjust_mc proc in link_snap */

/* This code modifies the hardware machine conditions so that they may be
   restarted without retaking the linkage fault. */

		scup = addr (mcptr -> mc.scu (0));	/* get ptr to SCU data */
		addr (scu.even_inst) -> instr (0).address = scu.ca;
		addr (scu.even_inst) -> instr (0).mod = indirect;
	     end;
	end;

	else do;					/* trap before link case */
	     trap_ptr = addrel (def_ptr, type_ptr -> type_pair.trap_ptr);
	     call_ptr_ptr = addrel (header_ptr, trap_ptr -> trap_word.call_ptr);
	     if trap_ptr -> trap_word.arg_ptr ^= ""b
	     then arg_ptr_ptr = addrel (header_ptr, trap_ptr -> trap_word.arg_ptr);
	     else arg_ptr_ptr = null ();
	     call cu_$make_entry_value (call_ptr_ptr -> call_ptr, trap_proc);
	     call trap_proc (arg_ptr_ptr, mcptr, link_ptr);
	     if link_ptr -> link.ft2 ^= "100011"b
	     then do;				/* link was not snapped; will loop if try to restart */
		ec = error_table_$bad_trap_before_link;
		go to sig_err;
	     end;
	end;

/* now return to proc that invoked linker; if there was a fault,
   restore mc (refetch bit has already been turned on); otherwise just "return" */

	if mcptr = null
	then do;					/* return to caller of linker */
	     sp = cu_$stack_frame_ptr ();		/* get ptr to current stack frame */
	     nsp = sp -> stack_frame.prev_sp -> stack_frame.prev_sp;
	     call nonlocal_goto_$same_ring (nsp, nsp -> stack_frame.return_ptr);
	end;

	else return;				/* and let signaller restore mc */
						/*  */
%include mc;
/*  */
%include linkdcl;


%include its;

/*  */
%include stack_frame;


     end link_trap_caller_;




		    list_init_.pl1                  11/11/89  1145.7rew 11/11/89  0804.9      196839



/****^  ******************************************
        *                                        *
        * Copyright, (C) Honeywell Limited, 1983 *
        *                                        *
        ****************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-10-21,DGHowe), approve(86-10-21,MCR7420), audit(86-11-12,Zwick),
     install(86-11-20,MR12.0-1222):
     Added the ability to initialize an external pointer to a
     non-constant value via list_init_.  Changed the calling sequence of
     list_init_ and already_zero.  Removed the signaling of malformed
     list template.  list_init_ now returns a standard error code leaving
     the error handling up to the caller.  Added a segment pointer to
     the variable node structure.
                                                   END HISTORY COMMENTS */


/* format: style3 */
list_init_:
     proc (variable_p, list_template_p, vsize, a_sb, a_seg_ptr, a_code) options (support);

/* Procedure to do a list template initialization of a variable. */
/* Created: 82-11-18. T. Oke (UNCA). */

/* Modification History:
   83-04-21 M. Weaver to add $variable_already_zero and to handle large datum
   83-05-10 M. Weaver to not use fortran_storage include file
   84-10-19 M. Mabey to enable skipping backwards while initializing.  Data
		skipped over is no longer zeroed.  The condition
		'malformed_list_template_entry_' is signalled when an
		error is encountered.  "options (support)" is added to
		the procedure declaration.
*/

/* Parameters

    variable_p	 Input pointer to base of variable.

    list_template_p	 Input pointer to 'list_init_info' or null to init to "0"b.

    vsize		 Input size of variable to be initialized.

    a_sb		 Input pointer to the stack header for the object 
		 containing the variable

    a_seg_ptr	 Input pointer to the segment containing the variable
		 reference or null if it would be impossible to initialize
		 a pointer to it or if the ext var has no pointers
		 When called from link_snap this is a pointer based on
		 the address in the init_info pointer (ie the 
		 list_template_p).

    a_code	 Is a system error code (Output).

*/

dcl	list_template_p	pointer parameter;
dcl	variable_p	pointer parameter;
dcl	vsize		fixed bin (35) parameter;
dcl	a_seg_ptr		pointer parameter;
dcl	a_code		fixed bin (35) parameter;
dcl	a_sb		pointer;



/* Automatic Storage */

dcl	fill_in_zeroes	bit (1) aligned automatic;	/* "1"b if reinitializing */
dcl	max_bit		fixed bin (35) automatic;	/* top bit in variable */
dcl	min_bit		fixed bin (35) automatic;	/* base bit in variable */
dcl	seg_end		fixed bin (35) automatic;	/* bit address of segment end */
dcl	skip_addr		fixed bin (35) automatic;	/* final address after skipping */
dcl	seg_ptr		ptr automatic;		/* local copy of seg ptr */
dcl	tp		ptr automatic;		/* local list pointer */
dcl	var_p		ptr automatic;		/* pointer to current point in variable */
dcl	vlength		fixed bin (35) automatic;	/* length to init */


/* Builtins */

dcl	(addr, addrel, addbitno, copy, currentsize, divide, 
	fixed, length, max, min, null, ptr, substr, segno,
	unspec)		builtin;


/* Linkage and external */

dcl	hcs_$link_force	entry (pointer, fixed bin, fixed bin (35));

dcl	error_table_$invalid_ptr_target
			fixed bin (35) external;
dcl	error_table_$malformed_list_template_entry
			fixed bin (35) external;
dcl	error_table_$null_info_ptr
			fixed bin (35) external;

dcl	pl1_operators_$VLA_words_per_seg_
			fixed bin (35) external;

/* list_init_ entry point: we set the fill in zeros flag because we can 
   not be sure if the variable was already zeroed
*/
	fill_in_zeroes = "1"b;

/* Driver */

join:
	a_code = 0;
	seg_ptr = a_seg_ptr;
	var_p = variable_p;
	tp = list_template_p;
	vlength = vsize * 36;
	max_bit = bit_logical (var_p, vlength);
	min_bit = bit_logical (var_p, 0);

	if tp = null ()
	then call init_zero (var_p, vlength, tp);

	else do while (tp ^= null ());		/* go through list */
		if tp -> list_template_entry.n_bits = 0 /* KEY END LIST */
		then tp = null ();

/* check for ptr intialization */


		else if tp -> list_template_entry.init_type = ITS_PTR_INIT
		then do;				/* ITS ptr initialization */
			call initialize_ptr (tp, seg_ptr, a_sb, ("1"b), var_p);
			tp = addrel (tp, currentsize (tp -> list_template_entry));
		     end;


		else if tp -> list_template_entry.init_type = PACKED_PTR_INIT
		then do;				/* packed ptr initialization */
			call initialize_ptr (tp, seg_ptr, a_sb, ("0"b), var_p);
			tp = addrel (tp, currentsize (tp -> list_template_entry));
		     end;


		else if tp -> list_template_entry.repeat = 0
						/* KEY FOR SKIPPING */
		then do;
			skip_addr = bit_logical (var_p, tp -> list_template_entry.n_bits);

			if skip_addr > max_bit | skip_addr < min_bit
			then do;
				a_code = error_table_$malformed_list_template_entry;
				goto ERROR_EXIT;
			     end;

			call p_inc (var_p, tp -> list_template_entry.n_bits);
			tp = addrel (tp, 2);
		     end;

		else do;
			call set_value (var_p, tp);
			tp = addrel (tp, currentsize (tp -> list_template_entry));
		     end;

	     end;
ERROR_EXIT:					/* escape */
	return;

/* External entrypoints ------------------------------------------ */

/* already_zero: the caller has asured us that the variable has been 
   zeroed so we can skip zeroing it.
*/

variable_already_zero:
     entry (variable_p, list_template_p, vsize, a_sb, a_seg_ptr, a_code);

	fill_in_zeroes = "0"b;
	go to join;


/* Internal Procedures ------------------------------------------- */



/* initializes a pointer to one of the following references text, linkage, 
   static sections. This routine sets var_p and the variable
   it points to. The basic format is 

   base_ptr = target_section + section_offset;
   target_ptr = base_ptr (snapped if linkage) + word_offset + bit_offset;

   The idea behind this type of initialization is to allow
   compilers such as the C compiler, to initialize external
   pointers to an object that is only known at runtime.  eg.  a
   pointer to a subroutine within an execution unit or a pointer to
   a string stored in the text section / static section of the
   object or a pointer to another external variable.
   
   The compiler can generate encoded information concerning the
   target. It knows where the target will be located and how to
   reference it but may not be able to get the exact address. The
   information required is stored in an existing format ie. the
   list_init_template. list_init_ through this routine converts
   that symbolic pointer information into a real pointer and stores
   the resulting address in the target variable via set_value.
   
   In this way compilers can initialize pointers to more than a
   constant value such as null().

   Parameters
   template_ptr    is a pointer to the template for the field being inited
   seg_ptr         is a pointer to the segment containing the initialization
	         information. The init_ptr can't be used due to the 
	         possibility of set_fortran_common being used to initialize
	         the variable. sfc creates its own initialization inforamtion
	         in some circumstances. The seg_ptr is used as a base for
	         text section references.
   sb	         stack base pointer
   is_its_ptr      specifies if the ptr to be inited is an its or an packed
	         if it is "0"b
   var_p	         is a pointer to the target variable where the datum is
	         to be copied.

*/

initialize_ptr:
     procedure (template_ptr, seg_ptr, sb, is_its_ptr, var_p);

/* parameters */

dcl	template_ptr	pointer parameter;
dcl	seg_ptr		pointer parameter;
dcl	sb		pointer parameter;
dcl	is_its_ptr	bit (1) parameter;
dcl	var_p		pointer parameter;

/* automatic */

dcl	bit_offset	fixed bin (6) unsigned automatic; /* num of bits to add to target addr */
dcl	datum_ptr		ptr automatic;		    /* ptr to ptr init template */
dcl	packed_section_ptr	pointer unaligned automatic;	    /* packed ptr to desired section */
dcl	section_offset	fixed bin (18) unsigned automatic; /* offset in wrds in specified section */
dcl	section_ptr	pointer automatic;		     /* ptr to desired section */
dcl	target_seg_ptr	pointer automatic;		     /* ptr to target seg */
dcl	target_ptr	pointer automatic;		     /* ptr to final target its */
dcl	target_packed_ptr	pointer unaligned;		     /* ptr to final target packed */
dcl	word_offset	fixed bin (18) unsigned automatic; /* offset from target base in wrds */

/* structures */

dcl	1 temp_template	like list_template_entry_ptr;

/* based */

dcl	1 ptr_typed_datum	like pointer_init_template based (datum_ptr);
dcl	target_its	pointer aligned based;

/* get general information about the passed segment */

	if seg_ptr = null ()
	then do;
		a_code = error_table_$malformed_list_template_entry;
		goto ERROR_EXIT;
	     end;


	target_seg_ptr = ptr (seg_ptr, 0);

/* get pointer information */

	datum_ptr = addr (template_ptr -> list_template_entry.datum);
	section_offset = ptr_typed_datum.section_offset;
	word_offset = ptr_typed_datum.word_offset;
	bit_offset = ptr_typed_datum.bit_offset;


/* make our own copy of the template */

	if is_its_ptr				/* copy important data to new template */
	then temp_template.n_bits = length (unspec (target_ptr));
	else temp_template.n_bits = length (unspec (target_packed_ptr));

	temp_template.mbz = ""b;
	temp_template.init_type = template_ptr -> list_template_entry.init_type;
	temp_template.repeat = template_ptr -> list_template_entry.repeat;

/* now get the target value by the section specifier */

	if ptr_typed_datum.ptr_type = PTR_INIT_TEXT
	then do;					/* text section reference */
		section_ptr = target_seg_ptr;
		target_ptr = addrel (section_ptr, section_offset);
		target_ptr = addrel (target_ptr, word_offset);
		target_ptr = addbitno (target_ptr, bit_offset);

		if is_its_ptr
		then unspec (temp_template.datum) = unspec (target_ptr);
		else do;
			target_packed_ptr = target_ptr;
			unspec (temp_template.datum) = unspec (target_packed_ptr);
		     end;
	     end;


	else if (ptr_typed_datum.ptr_type = PTR_INIT_LOT) | (ptr_typed_datum.ptr_type = PTR_INIT_ISOT)
	then do;
		if sb = null
		then do;
			a_code = error_table_$null_info_ptr;
			goto ERROR_EXIT;

		     end;

		if (segno (target_seg_ptr) > sb -> stack_header.cur_lot_size)
		then do;
			a_code = error_table_$malformed_list_template_entry;
			goto ERROR_EXIT;
		     end;

		packed_section_ptr = sb -> stack_header.lot_ptr -> lot.lp (segno (target_seg_ptr));

/* check if we have a valid seg number. If 0 the seg is invalid. If lot fault
   the linkage and static sections have not been combined.
*/

		if (unspec (packed_section_ptr) = lot_fault) | (fixed (unspec (packed_section_ptr)) = 0)
		then do;
			a_code = error_table_$malformed_list_template_entry;
			goto ERROR_EXIT;
		     end;

		if (ptr_typed_datum.ptr_type = PTR_INIT_ISOT)
		then /* ISOT ptr init */
		     packed_section_ptr = sb -> stack_header.isot_ptr -> isot.isp (segno (target_seg_ptr));

/* just in case we better check the ISOT entry for a valid reference even
   though it is set if the lot is set.  It doesn't hurt to make sure. ie.
   if the static section is combined the ISOT is set and if it is separate
   this better be set.
*/

		if (unspec (packed_section_ptr) = lot_fault) |
		   (fixed (unspec (packed_section_ptr)) = 0) |
		   (sb -> stack_header.isot_ptr -> isot1 (segno (target_seg_ptr)).flags.fault ="11"b)
		then do;
			a_code = error_table_$malformed_list_template_entry;
			goto ERROR_EXIT;
		     end;

/* try to initialize the pointer to the target.
   Get target link and snap it if it is not snapped. 
*/
		target_ptr = addrel (packed_section_ptr, section_offset);

		if ptr_typed_datum.ptr_type = PTR_INIT_LOT
		then do;
			if (target_ptr -> its.its_mod ^= ITS_MODIFIER)
			then do;			/* we have an unsnapped link so snap it */
				call hcs_$link_force (target_ptr, (0), a_code);
				if a_code ^= 0
				then do;
					a_code = error_table_$invalid_ptr_target;
					goto ERROR_EXIT;
				     end;
			     end;


/* now we have the address of the target link get the address of the target
   variable
*/
			target_ptr = addrel (target_ptr -> target_its, word_offset);
						/* indirect through the link and add the word offset */
			target_ptr = addbitno (target_ptr, bit_offset);

/* get address of target from link */
			if is_its_ptr
			then unspec (temp_template.datum) = unspec (target_ptr);
			else do;
				target_packed_ptr = target_ptr;
				unspec (temp_template.datum) = unspec (target_packed_ptr);
			     end;
		     end;

		else if ptr_typed_datum.ptr_type = PTR_INIT_ISOT
		then do;

			target_ptr = addrel (target_ptr, word_offset);
			target_ptr = addbitno (target_ptr, bit_offset);

			if is_its_ptr
			then unspec (temp_template.datum) = unspec (target_ptr);
			else do;
				target_packed_ptr = target_ptr;
				unspec (temp_template.datum) = unspec (target_packed_ptr);
			     end;
		     end;
	     end;					/* PTR_INIT_LOT & PTR_INIT_ISOT */

	else do;					/* unknown init type */
		a_code = error_table_$malformed_list_template_entry;
		goto ERROR_EXIT;
	     end;

	call set_value (var_p, addr (temp_template));

	return;



     end initialize_ptr;

/* Set Area to "0"b 
   Paramters
    var_p         points to the target variable
    vlength       is the length of the area to be zeroed
    tp            is a pointer to the init template
*/

init_zero:
     proc (var_p, vlength, tp);

/* Initialize the variable based at var_p to zero for vlength bits. */

/* If you look at this code you will believe that an explanation is in order.

   The purpose of this code is to efficiently set an area to "0"b, which may
   span over a segment boundary, and further to permit a segment to be seen as
   a certain key number of words (pl1_operators_$VLA_words_per_seg_) to be
   exact.  This is done by basing a bit variable on the desired point to start
   initializing, and then determining the length that can be done within this
   segment, if the full area can be done then this is done with an unspec
   assignment.  If the area to clear spans the segment end, then we slice off
   chunks and clear them individually.  At the end of the clear, var_p points
   to the next bit which would be affected. 
*/


dcl	var_p		ptr;
dcl	vlength		fixed bin (35);
dcl	tp		ptr;

dcl	(
	bsize,					/* size of area currently to set */
	vdone
	)		fixed bin (35);		/* amount of variable done */

dcl	variable		(bsize) bit (1) unaligned based (var_p);

	if bit_logical (var_p, vlength) > max_bit
	then do;
		a_code = error_table_$malformed_list_template_entry;
		goto ERROR_EXIT;
	     end;

	bsize = vlength;
	vdone = 0;

/* if we fit within a segment from our base, then do it. */

	seg_end = bit_logical (ptr (var_p, "0"b), pl1_operators_$VLA_words_per_seg_ * 36);

	if seg_end >= bit_logical (var_p, vlength)
	then do;
		if fill_in_zeroes
		then unspec (variable) = "0"b;
		call p_inc (var_p, bsize);
	     end /* simple set */;

/* clear multi-segment area, or across a segment bound */

	else do while (vdone < vlength);

/* find space left in this segment from current base.		*/
/* end of segment is next segment - 1 bit			*/

		seg_end = bit_logical (ptr (var_p, "0"b), pl1_operators_$VLA_words_per_seg_ * 36);

		bsize = min (vlength - vdone, seg_end - bit_logical (var_p, 0));
		if fill_in_zeroes
		then unspec (variable) = "0"b;

/* do center section til end */
		vdone = bsize + vdone;
		call p_inc (var_p, bsize);
	     end;
	return;
     end init_zero;

/* Set Area to value 
   the area pointed to by var_p is set to the value of the datum contained in
   the template and repeated by the repeat factor specified in the template

   Parameters
   var_p        pointer to the target variable
   tp	      pointer to the initialization template
*/

set_value:
     proc (var_p, tp);

/* This is again a complex procedure.			        */

/* Speed is an essential for multi-segment initializations. 

   Initialization is done by replicating the datum by doing a long
   OVERWRITING EIS move to replicate in one fast operation.  This is done in
   one of two methods.

   1. If the area left to initialize is small, or the datum is to be repeated 
      only once, then we do a simple copy to the area, 
      offset by the bit offset necessary from the last segment break.

   2. If the area left to initialize is large, then we do a copy of at least
      eight words of datum replication to the start of the area to init, offset
      within the datum by the point of the last segment break.  Then we do an
      EIS copy with intentional overwrite to replicate the datum.  This
      requires at least an eight word offset between the source position and
      the target bit position.  We chose up to 32 words to be safe on hardware
      capability changes.

   Slicing of initialization permits spanning segment bounds at any bit point
   within the datum replication. 
*/

dcl	var_p		ptr;
dcl	tp		ptr;

/* builtin */

dcl       mod                 builtin;
     

/* automatic */

dcl	bsize		fixed bin (35);		/* size in bits to do this slice */
dcl	bstart		fixed bin (18);		/* template offset from datum start */
dcl	copy_offset	fixed bin (35);		/* bit offset of target from source */
dcl	template_length	fixed bin (35);

dcl	p		ptr;
dcl	variable		(bsize) bit (1) based (var_p);
dcl	(
	vlength,					/* length of total set */
	vdone
	)		fixed bin (35);		/* length of set done */

dcl	template		bit (template_length) based (var_p);
						/* where template is stored */
dcl	replications	fixed bin;		/* number of copies of datum in template */

dcl	1 its		like its_unsigned based (addr (var_p));

/* Check if there is an invalid template entry */

	if tp -> list_template_entry.n_bits < 0
	then do;
		a_code = error_table_$malformed_list_template_entry;
		goto ERROR_EXIT;
	     end;

/* Find total length to set. */

	vlength = tp -> list_template_entry.n_bits * tp -> list_template_entry.repeat;


	if bit_logical (var_p, vlength) > max_bit
	then do;
		a_code = error_table_$malformed_list_template_entry;
		goto ERROR_EXIT;
	     end;
	bstart, vdone = 0;
	template_length = max (32 * 36, tp -> list_template_entry.n_bits);

/* do fast "0"b init if possible */

	if tp -> list_template_entry.datum = "0"b
	then call init_zero (var_p, vlength, tp);

/* do slower template initialization as necessary */

	else do while (vdone < vlength);

/* determine bit slice we can do, and number of repications needed.   */
/* find space left in this segment from current base.		*/
/* end of segment is next segment - 1 bit			*/

		seg_end = bit_logical (ptr (var_p, "0"b), pl1_operators_$VLA_words_per_seg_ * 36);

		bsize = min (vlength - vdone, seg_end - bit_logical (var_p, 0));

		if (bsize < 100 * 36) | (tp -> list_template_entry.repeat = 1)
		     | (bsize <= tp -> list_template_entry.n_bits)
		then do;
			replications =
			     divide (fixed (bsize, 30) + bstart + fixed (tp -> list_template_entry.n_bits, 24) - 1,
			     fixed (tp -> list_template_entry.n_bits, 24), 18);
			unspec (var_p -> variable) =
			     substr (copy (tp -> list_template_entry.datum, replications), bstart + 1, bsize);
		     end;

/* make minimum replications in a template area at base of variable, then use
   overlapping EIS move to replicate it throughout. */

		else do;

/* number of primary copies needed */

			p = var_p;
			replications =
			     divide (length (template) + bstart + fixed (tp -> list_template_entry.n_bits, 24) - 1,
			     fixed (tp -> list_template_entry.n_bits, 24), 18);
			copy_offset =
			     divide (length (template), fixed (tp -> list_template_entry.n_bits, 24), 24)
			     * fixed (tp -> list_template_entry.n_bits, 24);
			template =
			     substr (copy (tp -> list_template_entry.datum, replications), bstart + 1, copy_offset);

/* overlay copy the strings */

			begin;
dcl	source		bit (bsize - copy_offset) based (var_p);
dcl	target		bit (bsize - copy_offset) based (addr (substr (template, copy_offset + 1)));

			     target = source;
			end /* overlay copy */;
		     end;

		vdone = bsize + vdone;
		call p_inc (var_p, bsize);
		bstart = mod (bsize, fixed (tp -> list_template_entry.n_bits, 24));
	     end /* do set area */;
     end set_value;

/* increment a pointer by binc bits, keeping in mind the VLA_words_per_seg_
   limit of a segment and return the updated pointer. 

   Parameters
   var_p     pointer to the target variable
   binc	   is the increment to be added to the var_p to obtain the address
	   where further information is to be added.

*/

p_inc:
     proc (var_p, binc);

/* parameters */
dcl	var_p		ptr;
dcl	binc		fixed bin (35);

/* builtin */

dcl       mod                 builtin;


/* automatic */
dcl	address		fixed bin (35);
dcl	1 its		like its_unsigned based (addr (var_p));


	address = bit_logical (var_p, binc);
	its.bit_offset = mod (address, 36);
	address = divide (address, 36, 35);
	its.offset = mod (address, pl1_operators_$VLA_words_per_seg_);
	its.segno = divide (address, pl1_operators_$VLA_words_per_seg_, 18);
	return;
     end p_inc;


/* return a fixed bin (35) logical bit address from a pointer plus an offset
   use pl1_operators_$VLA_words_per_seg_ as the segment length determination 

   Parameters
   p          pointer to the start of the target
   offset	    offset to be added to the target ptr

*/

bit_logical:
     proc (p, offset) returns (fixed bin (35));

/* parameters */
dcl	p		ptr;
dcl	offset		fixed bin (35);

/* automatic */
dcl	address		fixed bin (35);
dcl	1 its		like its_unsigned based (addr (p));

	address =
	     (fixed (its.segno * pl1_operators_$VLA_words_per_seg_, 24) + its.offset) * 36 + its.bit_offset + offset;
	return (address);
     end bit_logical;
%page;
/* Include Files */

%include system_link_init_info;
%page;
%include its;
%page;
%include stack_header;
%page;
%include lot;
     end list_init_;




		    lot_fault_handler_.pl1          11/11/89  1145.7r w 11/11/89  0804.9       29142



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


lot_fault_handler_:
     proc (mcptr, condname, infoptr, wcptr, continue_sw);

/* This procedure is invoked when a reference to the LOT causes a lot_fault.  This usually happens in a run
   unit when a segment has had its LOT entry reset to a lot_fault but there are already snapped links to it,
   so that it gets executed without the intervention of the linker.
*/

/* coded March 1977 by Melanie Weaver */
/* modified October 1979 by Melanie Weaver  to call link_trap_caller_ */



	dcl     (mcptr, infoptr, wcptr)
				 ptr;
	dcl     condname		 char (*);
	dcl     continue_sw		 bit (1) aligned;

	dcl     (ring, level)	 fixed bin;

	dcl     segno		 fixed bin (18);
	dcl     header_ptr		 ptr;
	dcl     segptr		 ptr;
	dcl     code		 fixed bin (35);
	dcl     (addr, baseptr, bin, null, ptr, rel)
				 builtin;

	dcl     get_ring_		 entry () returns (fixed bin);
	dcl     hcs_$combine_linkage	 entry (ptr, fixed bin, fixed bin (35));
	dcl     hcs_$level_get	 entry () returns (fixed bin);
	dcl     hcs_$level_set	 entry (fixed bin);
	dcl     link_trap_caller_	 entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr);
	dcl     pds$stacks		 (0:7) ptr ext;


	scup = addr (mcptr -> mc.scu (0));
	ring = bin (scup -> scu.trr, 3);
	if bin (scup -> scu.prr, 3) = 0
	then do;
		if get_ring_ () = 0
		then sb = pds$stacks (ring);		/* can only reference pds in ring 0 */
		else do;				/* shouldn't happen--would be crawlout from ring 0 */
			continue_sw = "1"b;
			return;
		     end;
	     end;
	else sb = ptr (mcptr -> mc.prs (6), 0);

	level = hcs_$level_get ();
	if level > ring
	then call hcs_$level_set (ring);

	segno = bin (scup -> scu.ca, 18) - bin (rel (sb -> stack_header.lot_ptr), 18);
	segptr = baseptr (segno);

	call hcs_$combine_linkage (segptr, ring, code);

	if level ^= ring
	then call hcs_$level_set (level);

	if code ^= 0
	then continue_sw = "1"b;

	else if (level = ring) & (ring ^= 0)
	then do;

/* If there is a trap at first reference and we are not in ring 0,
   call link_trap_caller_ to handle it.  If it becomes necessary to handle
   this in ring 0, hcs_$combine_linkage will have to be changed to 
   call trap_caller_caller_ when there is a trap at first reference. */

		header_ptr = sb -> stack_header.lot_ptr -> lot.lp (segno);
						/* get ptr to beginning of linkage section */
		if header_ptr -> virgin_linkage_header.first_ref_relp ^= "0"b
		then call link_trap_caller_ (null, mcptr, header_ptr, null, null, null, null);
	     end;

	return;

/*  */
%include mc;

%include stack_header;


%include lot;

%include linkdcl;


     end;




		    mode_string_.pl1                11/11/89  1145.7rew 11/11/89  0804.9      150741



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* The mode_string_ subroutine is a general way to handle mode strings.
   It was described in MCR 4670, and approved 15 October 1980

   Designed, Coded by James R. Davis
   Modified 12 January 1981 by J. Spencer Love for quoted strings

   modes are separated from each other by commas
   the first nonwhite character in the string is the beginning of the first mode
   the end of the last mode precedes the first unquoted period or is the last nonwhite character

   A mode may be one of these forms:

   MODE             boolean mode (true)
   ^MODE            boolean mode (false)
   MODE=XXX         XXX may be char or decimal digits, XXX may be quoted
   MODEnnn          nnn must be decimal digits
*/

/* format:  style3,ll122,idind30,ifthenstmt */

mode_string_$parse:
     procedure (P_string, P_areap, P_mode_string_info_ptr, P_status);

declare	P_areap			ptr parameter,
	P_status			fixed bin (35) parameter,
	P_excludes		(*) char (*) parameter,
	P_mode_name		char (*) parameter,
	P_mode_value_ptr		ptr parameter,
	P_mode_string_info_ptr	ptr parameter,
	P_mode_string_info_ptr2	ptr parameter,
	P_string			char (*) parameter;

declare	(addr, addrel, char, hbound, index, lbound, length, ltrim, maxlength, null, substr, reverse, rtrim, unspec,
	verify)			builtin;

declare	cleanup			condition;

declare	(counting_modes, dummy)	bit (1) aligned,
	modes2			ptr,
	modex			fixed bin,
	must_cleanup		bit (1) aligned,
	status			fixed bin (35),
	string_len		fixed bin (21),
	string_pos		fixed bin (21);	/* length of P_string used */

declare	1 auto_mode		aligned like mode_value;

declare	based_area		area based (areap),
	areap			ptr;

declare	BREAKS			char (10) static options (constant) initial (".,=^""
	 "),					/* DOT COMMA EQUALS INVERT QUOTE NL VT FF TAB SPACE */
	NUMERIC			char (12) static options (constant) init ("0123456789+-"),
	LEGAL_CHARS		char (89) static options (constant)
				initial (
				"!#$%&'()*+-/0123456789:;<>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]_`abcdefghijklmnopqrstuvwxyz{|}~"
				),
	QUOTE			char (1) static options (constant) initial ("""");

declare	(
	error_table_$bad_mode_syntax,
	error_table_$mode_string_truncated,
	error_table_$undefined_mode,
	error_table_$unimplemented_version
	)			fixed bin (35) external;

declare	cv_dec_check_		entry (char (*), fixed bin (35)) returns (fixed bin (35)),
	get_system_free_area_	entry () returns (ptr),
	requote_string_		entry (char (*)) returns (char (*));
%page;
%include mode_string_info;
%page;
/* mode_string_$parse:
   procedure (P_string, P_areap, P_mode_string_info_ptr, P_status); */

	areap = P_areap;
	if areap = null () then areap = get_system_free_area_ ();

	must_cleanup = "1"b;
	mode_string_info_ptr = null ();

	number_of_modes = 0;
	string_len = length (rtrim (P_string));
	string_pos = 0;				/* scan from beginning of string */

	counting_modes = "1"b;
	do while (parse_mode (auto_mode));
	end;					/* count modes -- don't do hard work */
	counting_modes = "0"b;

	on cleanup call parse_cleanup ();

	allocate mode_string_info in (based_area);
	mode_string_info.version = mode_string_info_version_2;

	string_pos = 0;				/* start over from beginning for second scan */
	number_of_modes = 0;			/* mode count used to permit special case "." */

	do modex = 1 to mode_string_info.number;
	     dummy = parse_mode (mode_string_info.modes (modex));
	end;					/* ignore "more left" result, already have mode count */

	P_mode_string_info_ptr = mode_string_info_ptr;
	P_status = 0;

	return;

parse_cleanup:
     procedure ();

	P_mode_string_info_ptr = null ();		/* if we are here, caller gets nothing */
	if mode_string_info_ptr ^= null then free mode_string_info;

	return;

     end parse_cleanup;
%page;
mode_string_$get:
     entry (P_mode_string_info_ptr, P_string, P_status);

	mode_string_info_ptr = P_mode_string_info_ptr;

	if mode_string_info.version ^= mode_string_info_version_2 then call unsupported_version ();

	string_pos = 0;
	do modex = 1 to mode_string_info.number;
	     call cons (mode_string_info.modes (modex));
	end;

(nostringsize):
	substr (P_string, string_pos + 1) = ".";	/* clear out rest of string */
	P_status = 0;

	return;



mode_string_$get_error:
     entry (P_mode_string_info_ptr, P_string, P_status);

	mode_string_info_ptr = P_mode_string_info_ptr;

	if mode_string_info.version ^= mode_string_info_version_2 then call unsupported_version ();

	string_pos = 0;
	do modex = 1 to mode_string_info.number;
	     if mode_string_info.modes (modex).code ^= 0 then call cons (mode_string_info.modes (modex));
	end;

(nostringsize):
	substr (P_string, string_pos + 1) = ".";	/* clear out rest of string */
	P_status = 0;

	return;
%page;
mode_string_$delete:
     entry (P_mode_string_info_ptr, P_excludes, P_string, P_status);

	mode_string_info_ptr = P_mode_string_info_ptr;
	if mode_string_info.version ^= mode_string_info_version_2 then call unsupported_version ();

	string_pos = 0;
	do modex = 1 to mode_string_info.number;
	     if ^excludep (mode_string_info.modes (modex).mode_name) then call cons (mode_string_info.modes (modex));
	end;

(nostringsize):
	substr (P_string, string_pos + 1) = ".";
	P_status = 0;

	return;

excludep:
     procedure (name) returns (bit (1) aligned);

declare	name			char (32) parameter;
declare	idx			fixed bin;

	do idx = lbound (P_excludes, 1) to hbound (P_excludes, 1);
	     if P_excludes (idx) = name then return ("1"b);
	end;

	return ("0"b);

     end excludep;
%page;
/* This entrypoint finds the value of a single mode.  The value is returned in a mode_value structure which
   is allocated by our caller.  If the pointer is null, just the error code is returned indicating whether or
   not the mode named could be found in the mode string.  Otherwise, full info is returned.  The version
   number must be filled in by our caller. */

mode_string_$get_mode:
     entry (P_string, P_mode_name, P_mode_value_ptr, P_status);

	mode_value_ptr = P_mode_value_ptr;

	if mode_value_ptr ^= null ()
	then if mode_value.version ^= mode_value_version_3 then call unsupported_version ();

	counting_modes, must_cleanup = "0"b;
	number_of_modes = 0;
	string_len = length (rtrim (P_string));
	string_pos = 0;

	do while (parse_mode (auto_mode));
	     if auto_mode.mode_name = P_mode_name then go to FOUND_MODE;
	end;

	if number_of_modes > 0
	then if auto_mode.mode_name = P_mode_name then go to FOUND_MODE;

	P_status = error_table_$undefined_mode;

	return;

FOUND_MODE:
	if mode_value_ptr ^= null () then mode_value = auto_mode;

	P_status = 0;

	return;
%page;
mode_string_$combine:
     entry (P_mode_string_info_ptr, P_mode_string_info_ptr2, P_string, P_status);

	mode_string_info_ptr = P_mode_string_info_ptr;
	modes2 = P_mode_string_info_ptr2;

	if mode_string_info_ptr ^= null ()
	then if mode_string_info.version ^= mode_string_info_version_2 then call unsupported_version ();

	if modes2 ^= null ()
	then if modes2 -> mode_string_info.version ^= mode_string_info_version_2 then call unsupported_version ();

	string_pos = 0;
	if mode_string_info_ptr ^= null ()
	then if modes2 ^= null ()
	     then do modex = 1 to mode_string_info.number;
		     if ^present_in_second (mode_string_info.modes (modex).mode_name)
		     then call cons (mode_string_info.modes (modex));
		end;				/* loop thru first */
	     else do modex = 1 to mode_string_info.number;
		     call cons (mode_string_info.modes (modex));
		end;

	if modes2 ^= null ()
	then do modex = 1 to modes2 -> mode_string_info.number;
		call cons (modes2 -> mode_string_info.modes (modex));
	     end;

(nostringsize):
	substr (P_string, string_pos + 1) = ".";
	P_status = 0;

	return;

present_in_second:
     procedure (mn) returns (bit (1) aligned);
declare	mn			char (32) parameter;
declare	mx			fixed bin;

	do mx = 1 to modes2 -> mode_string_info.number;
	     if mn = modes2 -> mode_string_info.modes (mx).mode_name then return ("1"b);
	end;

	return ("0"b);				/* fell out */

     end present_in_second;
%page;
parse_mode:
     procedure (P_mode) returns (bit (1) aligned);

declare	1 P_mode			parameter aligned like mode_value,
	1 mode_name		aligned,
	  2 len			fixed bin (21),
	  2 pos			fixed bin (21),
	1 value			aligned like mode_name,
	break			fixed bin,
	(bool_value, bool_valuep, more_left, two_tokens)
				bit (1) aligned,
	char_value_overlay		char (length (P_mode.char_value)) based (addrel (addr (P_mode.char_value), 1));

	unspec (P_mode) = ""b;			/* Initialize */
	P_mode.version = mode_value_version_3;
	bool_value, bool_valuep, two_tokens = "0"b;
	mode_name.len = 0;

GET_MODE_NAME:
	call get_token (mode_name);
	go to FIRST_TOKEN (break);

FIRST_TOKEN (-1):					/* ILLEGAL CHAR */
	call syntax_error ();

FIRST_TOKEN (0):					/* DOT, legal as first char but not after COMMA */
	if string_pos < string_len then call syntax_error ();
	more_left = "0"b;
	if mode_name.len > 0 then go to HAVE_ATOMIC_MODE;
	if number_of_modes > 0 | bool_valuep then call syntax_error ();
	return ("0"b);

FIRST_TOKEN (1):					/* COMMA */
	if mode_name.len = 0 then call syntax_error ();
	go to HAVE_ATOMIC_MODE;

FIRST_TOKEN (2):					/* EQUALS */
	if mode_name.len = 0 then call syntax_error ();
	number_of_modes = number_of_modes + 1;
	two_tokens = "1"b;
	value.len = 0;
	go to GET_VALUE;

FIRST_TOKEN (3):					/* INVERT */
	if mode_name.len > 0 then call syntax_error ();
	bool_valuep = "1"b;
	bool_value = ^bool_value;
	go to GET_MODE_NAME;

FIRST_TOKEN (4):					/* QUOTE */
	call syntax_error ();

FIRST_TOKEN (5):					/* NEWLINE */
FIRST_TOKEN (6):					/* VERTICAL TAB */
FIRST_TOKEN (7):					/* FORMFEED */
FIRST_TOKEN (8):					/* TAB */
FIRST_TOKEN (9):					/* SPACE */
	go to GET_MODE_NAME;
%page;
GET_VALUE:
	call get_token (value);
	go to SECOND_TOKEN (break);

SECOND_TOKEN (-1):					/* ILLEGAL_CHAR */
	call syntax_error ();

SECOND_TOKEN (0):					/* DOT */
	if string_pos < string_len then call syntax_error ();
	more_left = "0"b;

SECOND_TOKEN (1):					/* COMMA */
	if counting_modes then return (more_left);
	if value.len > 0
	then if verify (substr (P_string, value.pos + 1, value.len), NUMERIC) - 1 < 0 then P_mode.numeric_valuep = "1"b;
	go to HAVE_VALUE;

SECOND_TOKEN (2):					/* EQUALS */
SECOND_TOKEN (3):					/* INVERT */
	call syntax_error ();

SECOND_TOKEN (4):					/* QUOTE */
	if value.len > 0 then call syntax_error ();

	P_mode.char_valuep = "1"b;

	do while ("1"b);
	     value.len = index (substr (P_string, string_pos + 1), QUOTE) - 1;
	     if value.len < 0 then call syntax_error ();	/* Punt if no matching quote */

	     if value.len + length (P_mode.char_value) > maxlength (P_mode.char_value) then call syntax_error ();
	     P_mode.char_value = P_mode.char_value || substr (P_string, string_pos + 1, value.len);
	     string_pos = string_pos + value.len + 1;	/* Gobble up everything to quote and step over it */

	     if string_pos >= string_len then go to AT_END_OF_STRING;
	     if substr (P_string, string_pos + 1, 1) ^= QUOTE
	     then do while ("1"b);			/* Have whole string, now get break character */
		     call get_token (mode_name);	/* get error if token_len > 0 */
		     if break = 0 /* DOT */ & string_pos >= string_len then go to AT_END_OF_STRING;
		     if break = 1 /* COMMA */ then go to HAVE_MODE;
		     if break < 5 /* not WHITESPACE */ then call syntax_error ();
		end;

	     if length (P_mode.char_value) >= maxlength (P_mode.char_value) then call syntax_error ();
	     P_mode.char_value = P_mode.char_value || QUOTE;
	     string_pos = string_pos + 1;		/* Double quote.  Append a quote and look again */
	end;

AT_END_OF_STRING:
	more_left = "0"b;
	go to HAVE_MODE;

SECOND_TOKEN (5):					/* NEWLINE */
SECOND_TOKEN (6):					/* VERTICAL TAB */
SECOND_TOKEN (7):					/* FORMFEED */
SECOND_TOKEN (8):					/* TAB */
SECOND_TOKEN (9):					/* SPACE */
	go to GET_VALUE;
%page;
HAVE_ATOMIC_MODE:
	number_of_modes = number_of_modes + 1;

	if counting_modes then return (more_left);

	value.len = verify (reverse (substr (P_string, mode_name.pos + 1, mode_name.len)), NUMERIC) - 1;
	if value.len < 0 then call syntax_error ();	/* Forbid numeric mode names */
	else if value.len = 0
	then do;					/* Boolean is the default */
		P_mode.boolean_valuep = "1"b;
		P_mode.boolean_value = ^bool_value;	/* started out false */
		go to HAVE_MODE;
	     end;

	value.pos = mode_name.pos + mode_name.len - value.len;
	mode_name.len = mode_name.len - value.len;
	P_mode.numeric_valuep = "1"b;

HAVE_VALUE:
	if bool_valuep then call syntax_error ();	/* have ^MODEnnn or ^MODE=XXX */

	if value.len > maxlength (P_mode.char_value) then call syntax_error ();
	if value.len > 0 then P_mode.char_value = substr (P_string, value.pos + 1, value.len);

	if P_mode.numeric_valuep
	then begin;				/* All numeric, lets see if its a number */
		P_mode.numeric_value = cv_dec_check_ (char_value_overlay, status);
		if status ^= 0			/* we have MODE2+2 or numeric overflow */
		then if two_tokens
		     then do;			/* Permit foo=+ to be a character value */
			     P_mode.char_valuep = "1"b;
			     P_mode.numeric_valuep = "0"b;
			end;
		     else call syntax_error ();	/* Make foo+ an error */
	     end;
	else P_mode.char_valuep = "1"b;

HAVE_MODE:
	if mode_name.len > maxlength (P_mode.mode_name) then call syntax_error ();
	P_mode.mode_name = substr (P_string, mode_name.pos + 1, mode_name.len);

	return (more_left);
%page;
get_token:
     procedure (P_token);

declare	1 P_token			aligned parameter like mode_name;
declare	1 token			aligned like mode_name;

	token.pos = string_pos;

	token.len = verify (substr (P_string, string_pos + 1, string_len - string_pos), LEGAL_CHARS) - 1;
	if token.len < 0
	then do;
		token.len = string_len - string_pos;
		string_pos = string_len;
		break = 0;			/* DOT - end of mode string */
		more_left = "0"b;
	     end;
	else do;
		break = index (BREAKS, substr (P_string, string_pos + token.len + 1, 1)) - 1;
		string_pos = string_pos + token.len + 1;
		more_left = "1"b;
	     end;

	if token.len = 0 then return;			/* Just return break character */
	if P_token.len > 0 then call syntax_error ();	/* Only one token to a token */

	P_token = token;

	return;

     end get_token;

     end parse_mode;
%page;
cons:
     procedure (P_mode);

declare	1 P_mode			like mode_value aligned parameter,
	char_value_overlay		char (length (P_mode.char_value)) based (addrel (addr (P_mode.char_value), 1)),
	modestr			char (101) varying; /* comma + invert + 32 + equals + 66 */

	if string_pos = 0
	then modestr = "";
	else modestr = ",";

	if P_mode.boolean_valuep & ^P_mode.boolean_value then modestr = modestr || "^";

	modestr = modestr || rtrim (P_mode.mode_name);

	if P_mode.numeric_valuep
	then do;
		modestr = modestr || "=";
		modestr = modestr || rtrim (ltrim (char (P_mode.numeric_value)));
	     end;
	else if P_mode.char_valuep
	then do;
		modestr = modestr || "=";
		if verify (P_mode.char_value, LEGAL_CHARS) - 1 ^< 0 | verify (P_mode.char_value, NUMERIC) - 1 < 0
		then modestr = modestr || requote_string_ (char_value_overlay);
		else modestr = modestr || P_mode.char_value;
	     end;

	if string_pos + length (modestr) > maxlength (P_string)
	then do;
(nostringsize):
		substr (P_string, string_pos + 1) = ".";/* clear out rest of string */
		P_status = error_table_$mode_string_truncated;
		go to EGRESS;
	     end;

	substr (P_string, string_pos + 1, length (modestr)) = modestr;
	string_pos = string_pos + length (modestr);

	return;

     end cons;
%page;
/* The following internal procedures are to facilitate debugging:
   If an error occurs a breakpoint set in one of them will permit the site of
   the error to be derived from a stack trace.  This code is left in the
   production version since it isn't much less efficient than a GOTO and
   the error cases needn't be superfast anyway.  */

syntax_error:
     procedure ();

	if must_cleanup then call parse_cleanup ();
	P_status = error_table_$bad_mode_syntax;

	go to EGRESS;

     end syntax_error;


unsupported_version:
     procedure ();

	P_status = error_table_$unimplemented_version;

	go to EGRESS;

     end unsupported_version;


EGRESS:
	return;

     end mode_string_$parse;




		    object_info_.pl1                11/11/89  1145.7rew 11/11/89  0804.9      274176



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* object_info_ - procedure to return structural control information
   extracted from an object segment. Coded for compatibility with obsolete
   procedure decode_object_.

   Designed and coded February 8, 1972 by Michael J. Spier		*/
/* modified 5/75 and 6/75  by M. Weaver for version 2 structure */
/* modified 1/77 by M. Weaver to initialize rel ptrs in non-standard object case */
/* modified 5/77 by M. Weaver to set perprocess_static flag */
/* modified 9/81 by M. Weaver to correct userid offset and check for not_in_read_bracket */

object_info_$long: procedure (seg_ptr, bitcount, arg_ptr, code);

declare (seg_ptr, arg_ptr) pointer, bitcount fixed bin (24), code fixed bin (35);

/* DECLARATION OF EXTERNAL SYMBOLS */

declare (error_table_$bad_segment, error_table_$zero_length_seg, error_table_$bad_ring_brackets) external fixed bin (35);
declare  decode_definition_$init external entry (pointer, fixed bin (24));
declare  decode_definition_ external entry (pointer, pointer) returns (bit (1) aligned);

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare (p, mapp, segp, oip, lastword, sblkp) pointer;
declare (i, lng, defcount) fixed bin;
declare (wordcount, len, base18) fixed bin (18);
declare  base21 fixed bin (21);
declare  bitlng fixed bin (24);
declare  entrypoint char (8) aligned;

declare 1 dd aligned,
        2 next_def pointer,
        2 dum1 pointer,
        2 dum2 pointer,
        2 section char (4) aligned,
        2 offset fixed bin,
        2 entrypoint fixed bin,
        2 defname char (32) aligned;


/* DECLARATION OF BUILTIN FUNCTIONS */

declare (addr, addrel, bin, bit, divide, fixed, mod, null, substr, unspec) builtin;
declare  not_in_read_bracket condition;

/* DECLARATION OF BASED STRUCTURES */

%include object_info;

declare 1 oi aligned based (oip) like object_info;

/* version 1 structure for object_info_ */

declare 1 old_oi aligned based (oip),			/* structure containing object info, returned by object_info_ */
        2 version_number fixed bin,			/* version number of current structure format */
        2 textp pointer,				/* pointer to beginning of text section */
        2 defp pointer,				/* pointer to beginning of definition section */
        2 linkp pointer,				/* pointer to beginning of linkage section */
        2 symbp pointer,				/* pointer to beginning of symbol section */
        2 bmapp pointer,				/* pointer to beginning of break map (may be null) */
        2 tlng fixed bin,				/* length in words of text section */
        2 dlng fixed bin,				/* length in words of definition section */
        2 llng fixed bin,				/* length in words of linkage section */
        2 slng fixed bin,				/* length in words of symbol section */
        2 blng fixed bin,				/* length in words of break map */
        2 format,					/* word containing bit flags about object type */
	3 old_format bit (1) unaligned,		/* on if segment isn't in new format, i.e. has old style object map */
	3 bound bit (1) unaligned,			/* on if segment is bound */
	3 relocatable bit (1) unaligned,		/* on if seg has relocation info in its first symbol block */
	3 procedure bit (1) unaligned,		/* on if segment is an executable object program */
	3 standard bit (1) unaligned,			/* on if seg is in standard format (more than just standard map) */
	3 gate bit (1) unaligned,			/* on if segment is a gate */
        2 call_delimiter fixed bin,			/* call delimiter if segment is a gate */

/* LIMIT OF BRIEF STRUCTURE */

        2 compiler char (8) aligned,			/* name of processor which generated segment */
        2 compile_time fixed bin (71),			/* clock reading of date/time object was generated */
        2 userid char (32) aligned,			/* standard Multics id of creator of object segment */
        2 cvers aligned,				/* generator version name in printable char string form */
	3 offset bit (18) unaligned,			/* offset of name in words relative to base of symbol section */
	3 length bit (18) unaligned,			/* length of name in characters */
        2 comment aligned,				/* printable comment concerning generator or generation of seg */
	3 offset bit (18) unaligned,			/* offset of comment in words rel to base of symbol section */
	3 length bit (18) unaligned,			/* length of comment in characters */
        2 source_map fixed bin,			/* offset, rel to base of symbol section, of source map structure */

/* LIMIT OF DISPLAY STRUCTURE */

        2 rel_text pointer,				/* offset rel to base of symbol section of text sect. relocation info */
        2 rel_def pointer,				/* offset relative to symbp of definition section relocation info */
        2 rel_link pointer,				/* offset relative to symbp of linkage section relocation info */
        2 rel_symbol pointer,				/* offset relative to symbp of symbol section relocation info */
        2 text_boundary fixed bin,			/* specifies mod  of text section base boundary */
        2 static_boundary fixed bin,			/* specifies mod of internal static base boundary */
        2 default_truncate fixed bin,			/* offset rel to symbp for binder to automatically trunc. symb sect. */
        2 optional_truncate fixed bin;			/* offset rel to symbp for binder to optionally trunc. symb sect. */

% include object_map;

/* version 1 object map structure */

declare 1 map1 aligned based (mapp),			/* structure describing version 1 standard object map */
        2 decl_vers fixed bin,			/* version number of current structure format */
        2 identifier char (8) aligned,			/* must be the constant "obj_map" */
        2 text_offset bit (18) unaligned,		/* offset rel to base of object segment of base of text section */
        2 text_length bit (18) unaligned,		/* length in words of text section */
        2 def_offset bit (18) unaligned,		/* offset rel to base of object seg of base of definition section */
        2 def_length bit (18) unaligned,		/* length in words of definition section */
        2 link_offset bit (18) unaligned,		/* offset rel to base of object seg of base of linkage section */
        2 link_length bit (18) unaligned,		/* length in words of linkage section */
        2 symb_offset bit (18) unaligned,		/* offset rel to base of object seg of base of symbol section */
        2 symb_length bit (18) unaligned,		/* length in words of symbol section */
        2 bmap_offset bit (18) unaligned,		/* offset rel to base of object seg of base of break map */
        2 bmap_length bit (18) unaligned,		/* length in words of break map */
        2 format aligned,				/* word containing bit flags about object type */
	3 bound bit (1) unaligned,			/* on if segment is bound */
	3 relocatable bit (1) unaligned,		/* on if seg has relocation info in its first symbol block */
	3 procedure bit (1) unaligned,		/* on if segment is an executable object program */
	3 standard bit (1) unaligned,			/* on if seg is in standard format (more than just standard map) */
	3 unused bit (14) unaligned;			/* not currently used */


declare 1 old_map aligned based (mapp),
        2 sentinel1 bit (72) aligned,
        2 sentinel2 bit (72) aligned,
        2 info (4),
	3 offset fixed bin,
	3 length fixed bin (24);

% include symbol_block;


declare 1 osb aligned based (sblkp),
        2 gen_name_boff fixed bin,
        2 dum1 bit (18) unaligned,
        2 gen_name_blength bit (18) unaligned,
        2 gen_vers_boff fixed bin,
        2 dum2 bit (18) unaligned,
        2 gen_vers_blength bit (18) unaligned,
        2 gen_creation_time fixed bin (71),
        2 obj_creation_time fixed bin (71),
        2 symb_tree bit (18) unaligned,
        2 extension bit (18) unaligned,
        2 hmap bit (18) unaligned,
        2 n bit (18) unaligned,
        2 next_header bit (18) unaligned,
        2 bind_flag bit (18) unaligned,
        2 text_lng bit (18) unaligned,
        2 link_lng bit (18) unaligned,
        2 obj_name_boff fixed bin,
        2 dum3 bit (18) unaligned,
        2 obj_name_blength bit (18) unaligned;

declare  old_map_ptr fixed bin (18) based (lastword);
declare  string char (1048576) based (sblkp);

%include linkdcl;


/*  */

	entrypoint = "long    ";
	goto start;

object_info_$display: entry (seg_ptr, bitcount, arg_ptr, code);

	entrypoint = "display ";
	goto start;

object_info_$brief: entry (seg_ptr, bitcount, arg_ptr, code);

	entrypoint = "brief   ";
start:
	if bitcount = 0 then do;			/* if bitcount is 0 we have nothing */
	     code = error_table_$zero_length_seg;
	     return;
	end;

	segp = seg_ptr;
	oip = arg_ptr;
	code = 0;
	wordcount = divide (bitcount+35, 36, 18, 0);
	if oi.version_number = 2 then unspec (oi.format) = "0"b;
						/* reset indicators and entry bound */
	else unspec (old_oi.format) = "0"b;

	on not_in_read_bracket go to access_error_return;

	lastword = addrel (segp, wordcount-1);
	i = fixed (lastword -> map_ptr, 18);		/* will want to see if value is in reasonable range */

	revert not_in_read_bracket;

	if i <= 0 then go to old_format;		/* last word won't point to new format map */
	if i >= wordcount then go to old_format;
	mapp = addrel (segp, lastword -> map_ptr);	/* get ptr to map */
	if mapp -> object_map.identifier ^= "obj_map " then goto old_format;

	if oi.version_number = 2 then do;		/* fill in version 2 structure */
	     if mapp -> object_map.decl_vers = 2 then do; /* have version 2 object map */
		oi.textp = addrel (segp, mapp -> object_map.text_offset);
		oi.defp = addrel (segp, mapp -> object_map.definition_offset);
		oi.linkp = addrel (segp, mapp -> object_map.linkage_offset);
		oi.statp = addrel (segp, mapp -> object_map.static_offset);
		oi.symbp = addrel (segp, mapp -> object_map.symbol_offset);
		if mapp -> object_map.break_map_offset then oi.bmapp = addrel (segp, mapp -> object_map.break_map_offset);
		else oi.bmapp = null;		/* don't have break map & don't want ptr to beg */
		oi.tlng = fixed (mapp -> object_map.text_length, 18);
		oi.dlng = fixed (mapp -> object_map.definition_length, 18);
		oi.llng = fixed (mapp -> object_map.linkage_length, 18);
		oi.ilng = fixed (mapp -> object_map.static_length, 18);
		oi.slng = fixed (mapp -> object_map.symbol_length, 18);
		oi.blng = fixed (mapp -> object_map.break_map_length, 18);
		oi.format.old_format = "0"b;		/* at least we seem to have standard obj. map */
		oi.format.procedure = mapp -> object_map.format.procedure;
		oi.format.bound = mapp -> object_map.format.bound;
		oi.format.relocatable = mapp -> object_map.format.relocatable;
		oi.format.standard = mapp -> object_map.format.standard; /* could have standard obj. map but not std. seg. */
		oi.format.gate = (mapp -> object_map.entry_bound ^= "0"b);
		oi.format.separate_static = mapp -> object_map.format.separate_static;
		oi.format.links_in_text = mapp -> object_map.format.links_in_text;
		oi.format.perprocess_static = mapp -> object_map.format.perprocess_static;
		oi.entry_bound = fixed (mapp -> object_map.entry_bound, 18);
		oi.textlinkp = addrel (segp, mapp -> object_map.text_link_offset);
	     end;
	     else do;				/* have version 1 map */
		oi.textp = addrel (segp, map1.text_offset);
		oi.defp = addrel (segp, map1.def_offset);
		oi.linkp = addrel (segp, map1.link_offset);
		oi.symbp = addrel (segp, map1.symb_offset);
		if map1.bmap_offset then oi.bmapp = addrel (segp, map1.bmap_offset);
		else oi.bmapp = null;		/* don't have break map & don't want ptr to beg */
		oi.tlng = fixed (map1.text_length, 18);
		oi.dlng = fixed (map1.def_length, 18);
		oi.llng = fixed (map1.link_length, 18);
		oi.slng = fixed (map1.symb_length, 18);
		oi.blng = fixed (map1.bmap_length, 18);
		oi.format.old_format = "0"b;		/* at least we seem to have standard obj. map */
		oi.format.procedure = map1.format.procedure;
		oi.format.bound = map1.format.bound;
		oi.format.relocatable = map1.format.relocatable;
		oi.format.standard = map1.format.standard; /* could have standard obj. map but not std. seg. */
		call fill_in_new_items (oi.linkp, oi.llng); /* fill in items not directly available from obj seg */
	     end;
	end;					/* end of section for version 2 oi structure */

	else do;					/* fill in version 1 structure */
	     if mapp -> object_map.decl_vers = 2 then do; /*   have version 2 object map */
		old_oi.textp = addrel (segp, mapp -> object_map.text_offset);
		old_oi.defp = addrel (segp, mapp -> object_map.definition_offset);
		old_oi.linkp = addrel (segp, mapp -> object_map.linkage_offset);
		old_oi.symbp = addrel (segp, mapp -> object_map.symbol_offset);
		if mapp -> object_map.break_map_offset then old_oi.bmapp = addrel (segp, mapp -> object_map.break_map_offset);
		else old_oi.bmapp = null;		/* don't have break map & don't want ptr to beg */
		old_oi.tlng = fixed (mapp -> object_map.text_length, 18);
		old_oi.dlng = fixed (mapp -> object_map.definition_length, 18);
		old_oi.llng = fixed (mapp -> object_map.linkage_length, 18);
		old_oi.slng = fixed (mapp -> object_map.symbol_length, 18);
		old_oi.blng = fixed (mapp -> object_map.break_map_length, 18);
		old_oi.format.old_format = "0"b;	/* at least we seem to have standard obj. map */
		old_oi.format.procedure = mapp -> object_map.format.procedure;
		old_oi.format.bound = mapp -> object_map.format.bound;
		old_oi.format.relocatable = mapp -> object_map.format.relocatable;
		old_oi.format.standard = mapp -> object_map.format.standard; /* could have standard obj. map but not std. seg. */
		old_oi.format.gate = (mapp -> object_map.entry_bound ^= "0"b);
		old_oi.call_delimiter = fixed (mapp -> object_map.entry_bound, 18);
	     end;
	     else do;				/* have version 1 object map */
		old_oi.textp = addrel (segp, map1.text_offset);
		old_oi.defp = addrel (segp, map1.def_offset);
		old_oi.linkp = addrel (segp, map1.link_offset);
		old_oi.symbp = addrel (segp, map1.symb_offset);
		if map1.bmap_offset then old_oi.bmapp = addrel (segp, map1.bmap_offset);
		else old_oi.bmapp = null;		/* don't have break map & don't want ptr to beg */
		old_oi.tlng = fixed (map1.text_length, 18);
		old_oi.dlng = fixed (map1.def_length, 18);
		old_oi.llng = fixed (map1.link_length, 18);
		old_oi.slng = fixed (map1.symb_length, 18);
		old_oi.blng = fixed (map1.bmap_length, 18);
		old_oi.format.old_format = "0"b;	/* at least we seem to have standard obj. map */
		old_oi.format.procedure = map1.format.procedure;
		old_oi.format.bound = map1.format.bound;
		old_oi.format.relocatable = map1.format.relocatable;
		old_oi.format.standard = map1.format.standard; /* could have standard obj. map but not std. seg. */
	     end;
	end;

	if entrypoint = "brief   " then goto return;

/* The following section has only 2 versions because it copies stuff from
   the symbol section, which has not been changed along with the mapp->object_map. */

	if oi.version_number = 2 then do;		/* fill in version 2 structure */
	     sblkp = oi.symbp;
	     oi.compiler = sb.generator;
	     oi.compile_time = fixed (unspec (sb.obj_creation_time), 71); /* if archived, may not be on double word */
	     base21 = fixed (sb.uid_offset, 18) * 4 + 1;	/* get offset in terms of characters */
	     len = fixed (sb.uid_length, 18);
	     oi.userid = substr (string, base21, len);	/* copy userid */
	     oi.cvers.offset = bit (fixed (sb.gen_name_offset, 18), 18); /* first symbol block is at beg of symbol section */
	     oi.cvers.length = sb.gen_name_length;
	     oi.comment.offset = bit (fixed (sb.comment_offset, 18), 18);
	     oi.comment.length = sb.comment_length;
	     oi.source_map = fixed (sb.source_map, 18);
	     if entrypoint = "display " then goto return;

	     if oi.format.relocatable = "1"b then
		do;
		oi.rel_text = addrel (sblkp, sb.rel_text);
		oi.rel_def = addrel (sblkp, sb.rel_def);
		oi.rel_link = addrel (sblkp, sb.rel_link);
		oi.rel_symbol = addrel (sblkp, sb.rel_symb);
	     end;
	     else do;
		oi.rel_text,
		     oi.rel_def,
		     oi.rel_link,
		     oi.rel_symbol = null;
	     end;
	     oi.rel_static = null;			/* there aren't ant rel bits for static yet */
	     oi.text_boundary = fixed (sb.tbound, 18);
	     oi.static_boundary = fixed (sb.stat_bound, 18);
	     oi.default_truncate = fixed (sb.default_truncate, 18);
	     oi.optional_truncate = fixed (sb.optional_truncate, 18);
	end;

	else do;					/* fill in version 1 structure */
	     sblkp = old_oi.symbp;
	     old_oi.compiler = sb.generator;
	     old_oi.compile_time = fixed (unspec (sb.obj_creation_time), 71);
						/* if archived, may not be on double word */
	     base21 = fixed (sb.uid_offset, 18) * 4 + 1;	/* get offset in terms of characters */
	     len = fixed (sb.uid_length, 18);
	     old_oi.userid = substr (string, base21, len);	/* copy userid */
	     old_oi.cvers.offset = bit (fixed (sb.gen_name_offset, 18), 18);
						/* first symbol block is at beg of symbol section */
	     old_oi.cvers.length = sb.gen_name_length;
	     old_oi.comment.offset = bit (fixed (sb.comment_offset, 18), 18);
	     old_oi.comment.length = sb.comment_length;
	     old_oi.source_map = fixed (sb.source_map, 18);
	     if entrypoint = "display " then goto return;

	     if old_oi.format.relocatable = "1"b then
		do;
		old_oi.rel_text = addrel (sblkp, sb.rel_text);
		old_oi.rel_def = addrel (sblkp, sb.rel_def);
		old_oi.rel_link = addrel (sblkp, sb.rel_link);
		old_oi.rel_symbol = addrel (sblkp, sb.rel_symb);
	     end;
	     else do;
		old_oi.rel_text,
		     old_oi.rel_def,
		     old_oi.rel_link,
		     old_oi.rel_symbol = null;
	     end;
	     old_oi.text_boundary = fixed (sb.tbound, 18);
	     old_oi.static_boundary = fixed (sb.stat_bound, 18);
	     old_oi.default_truncate = fixed (sb.default_truncate, 18);
	     old_oi.optional_truncate = fixed (sb.optional_truncate, 18);
	end;

return:
	return;

access_error_return:
	code = error_table_$bad_ring_brackets;
	return;

/*  */

/* object_info_ was called for a non-standard object segment */

old_format:
	if old_map_ptr <= 0 then go to bad_obj_map;	/* last word can't point to map */
	if old_map_ptr >= wordcount then go to bad_obj_map;
	mapp = addrel (segp, old_map_ptr);		/* get ptr to object map */
	if old_map.sentinel1 ^= (36)"10"b then goto bad_obj_map;
	if old_map.sentinel2 ^= (36)"10"b then
	     if old_map.sentinel2 ^= (36)"01"b then
		do;
bad_obj_map:
		code = error_table_$bad_segment;
		return;
	     end;

	if oi.version_number = 2 then do;		/* fill in version 2 structure */
	     oi.textp = addrel (segp, old_map.info (1).offset);
	     p,
		oi.linkp = addrel (segp, old_map.info (2).offset);
	     oi.symbp = addrel (segp, old_map.info (3).offset);
	     lng = old_map.info (2).offset;
	     oi.llng = old_map.info (3).offset - lng;
	     oi.slng = divide (old_map.info (3).length+35, 36, 17, 0);
	     oi.tlng = fixed (p -> virgin_linkage_header.def_offset, 18);
	     if p -> virgin_linkage_header.defs_in_link = "010000"b then do; /* defs in linkage section */
		oi.dlng = old_map.info (3).offset - lng - oi.tlng;
						/* length of defs is length of linkage - defoffset */
		oi.defp = addrel (p, oi.tlng);
		oi.tlng = lng;
	     end;
	     else do;				/* defs in text section, separate */
		oi.defp = addrel (segp, oi.tlng);
		oi.dlng = lng - oi.tlng;
	     end;
	     if old_map.info (4).offset ^= old_map_ptr then do; /* break map has been added */
		oi.bmapp = addrel (segp, old_map.info (4).offset);
		oi.blng = divide (old_map.info (4).length, 76, 17, 0);
	     end;
	     else do;				/* there is no break map */
		oi.bmapp = null;
		oi.blng = 0;
	     end;
	     sblkp = oi.symbp;			/* pointer to symbol section header */
	     oi.old_format = "1"b;			/* segment has old style object map */
	     base18 = divide (osb.gen_name_boff, 9, 18, 0) +1;
	     lng = divide (fixed (osb.gen_name_blength, 18), 9, 17, 0);

	     if substr (string, base18, lng) = "binder" then oi.format.bound = "1"b;

	     call fill_in_new_items (oi.linkp, oi.llng);	/* fill in items not directly available from obj seg */

	     if entrypoint = "brief   " then goto return; /* relocatable flag only set for $long */

	     oi.compiler = substr (string, base18, lng);
	     oi.compile_time = fixed (unspec (osb.obj_creation_time), 71); /* if archived, may not be on double word */
	     oi.userid = "";
	     base18 = divide (osb.gen_vers_boff, 36, 17, 0);
	     oi.cvers.offset = bit (fixed (base18, 18), 18);
	     oi.cvers.length = bit (bin (divide (fixed (osb.gen_vers_blength, 18), 9, 18, 0), 18), 18);
	     oi.comment.offset,
		oi.comment.length = ""b;
	     oi.source_map = 0;
	     if entrypoint = "display " then goto return;

	     oi.text_boundary,
		oi.static_boundary = 2;
	     unspec (oi.default_truncate) = ""b;
	     oi.rel_text,				/* initialize rel ptrs to null in case seg is bound */
		oi.rel_def,
		oi.rel_link,
		oi.rel_symbol = null;
	     call decode_definition_$init (segp, bitcount);
	     dd.next_def = oi.defp;			/* initialize decode_definition_ calls */
	     defcount = 0;				/* count relevant defs, for acceleration */
follow_defs:
	     if decode_definition_ (dd.next_def, addr (dd)) = "1"b then goto return;
	     if dd.section ^= "symb" then goto follow_defs;
	     if dd.defname = "rel_text" then
		do;
		oi.rel_text = addrel (oi.symbp, dd.offset);
		oi.default_truncate,
		     oi.optional_truncate = dd.offset;
		defcount = defcount +1;
	     end;
	     else if dd.defname = "rel_link" then
		do;
		oi.rel_link = addrel (oi.symbp, dd.offset);
		defcount = defcount +1;
	     end;
	     else if dd.defname = "rel_symbol" then
		do;
		oi.rel_symbol = addrel (oi.symbp, dd.offset);
		defcount = defcount +1;
	     end;
	     if defcount = 3 then do;
		oi.format.relocatable = "1"b;		/* at least this might help the binder */
		go to table_check;
	     end;
	     goto follow_defs;

table_check:
	     if oi.compiler = "PL/I"
	     | oi.compiler = "v2pl1"
	     | oi.compiler = "fortran"
	     | oi.compiler = "pl1"
	     then do;				/* may have a symbol table which can be truncated */
		base18 = bin (sblkp -> osb.symb_tree, 18); /* get rel ptr to symbol table */
						/* assume that these segs have only 1 symbol block */
		if base18 ^= 0 then oi.optional_truncate = base18;
	     end;
	     oi.rel_static = null;			/* there are no rel bits for static */
	end;



	else do;					/* fill in version 1 structure */
	     old_oi.textp = addrel (segp, old_map.info (1).offset);
	     p,
		old_oi.linkp = addrel (segp, old_map.info (2).offset);
	     old_oi.symbp = addrel (segp, old_map.info (3).offset);
	     lng = old_map.info (2).offset;
	     old_oi.llng = old_map.info (3).offset - lng;
	     old_oi.slng = divide (old_map.info (3).length+35, 36, 17, 0);
	     old_oi.tlng = fixed (p -> virgin_linkage_header.def_offset, 18);
	     if p -> virgin_linkage_header.defs_in_link = "010000"b then do; /* defs in linkage section */
		old_oi.dlng = old_map.info (3).offset - lng - old_oi.tlng;
						/* length of defs is length of linkage - defoffset */
		old_oi.defp = addrel (p, old_oi.tlng);
		old_oi.tlng = lng;
	     end;
	     else do;				/* defs in text section, separate */
		old_oi.defp = addrel (segp, old_oi.tlng);
		old_oi.dlng = lng - old_oi.tlng;
	     end;
	     if old_map.info (4).offset ^= old_map_ptr then do; /* break map has been added */
		old_oi.bmapp = addrel (segp, old_map.info (4).offset);
		old_oi.blng = divide (old_map.info (4).length, 76, 17, 0);
	     end;
	     else do;				/* there is no break map */
		old_oi.bmapp = null;
		old_oi.blng = 0;
	     end;
	     sblkp = old_oi.symbp;			/* pointer to symbol section header */
	     old_oi.old_format = "1"b;		/* segment has old style object map */
	     base18 = divide (osb.gen_name_boff, 9, 18, 0) +1;
	     lng = divide (fixed (osb.gen_name_blength, 18), 9, 17, 0);

	     if substr (string, base18, lng) = "binder" then old_oi.format.bound = "1"b;
	     if entrypoint = "brief   " then goto return; /* relocatable flag only set for $long */

	     old_oi.compiler = substr (string, base18, lng);
	     old_oi.compile_time = fixed (unspec (osb.obj_creation_time), 71);
						/* if archived, may not be on double word */
	     old_oi.userid = " ";
	     base18 = divide (osb.gen_vers_boff, 36, 17, 0);
	     old_oi.cvers.offset = bit (fixed (base18, 18), 18);
	     old_oi.cvers.length = bit (bin (divide (fixed (osb.gen_vers_blength, 18), 9, 18, 0), 18), 18);
	     old_oi.comment.offset,
		old_oi.comment.length = "0"b;
	     old_oi.source_map = 0;
	     if entrypoint = "display " then goto return;

	     old_oi.text_boundary,
		old_oi.static_boundary = 2;
	     unspec (old_oi.default_truncate) = "0"b;
	     old_oi.rel_text,			/* initialize rel ptrs to null in case seg is bound */
		old_oi.rel_def,
		old_oi.rel_link,
		old_oi.rel_symbol = null;
	     call decode_definition_$init (segp, bitcount);
	     dd.next_def = old_oi.defp;		/* initialize decode_definition_ calls */
	     defcount = 0;				/* count relevant defs, for acceleration */
follow_defs_2:
	     if decode_definition_ (dd.next_def, addr (dd)) = "1"b then goto return;
	     if dd.section ^= "symb" then goto follow_defs_2;
	     if dd.defname = "rel_text" then
		do;
		old_oi.rel_text = addrel (old_oi.symbp, dd.offset);
		old_oi.default_truncate,
		     old_oi.optional_truncate = dd.offset;
		defcount = defcount +1;
	     end;
	     else if dd.defname = "rel_link" then
		do;
		old_oi.rel_link = addrel (old_oi.symbp, dd.offset);
		defcount = defcount +1;
	     end;
	     else if dd.defname = "rel_symbol" then
		do;
		old_oi.rel_symbol = addrel (old_oi.symbp, dd.offset);
		defcount = defcount +1;
	     end;
	     if defcount = 3 then do;
		old_oi.format.relocatable = "1"b;	/* at least this might help the binder */
		go to table_check_2;
	     end;
	     goto follow_defs_2;

table_check_2:
	     if old_oi.compiler = "PL/I"
	     | old_oi.compiler = "v2pl1"
	     | old_oi.compiler = "fortran"
	     | old_oi.compiler = "pl1"
	     then do;				/* may have a symbol table which can be truncated */
		base18 = bin (sblkp -> osb.symb_tree, 18); /* get rel ptr to symbol table */
						/* assume that these segs have only 1 symbol block */
		if base18 ^= 0 then old_oi.optional_truncate = base18;
	     end;
	end;
	go to return;

/*  */
fill_in_new_items: proc (link_ptr, link_len);

/* This procedure fills in items in the version 2 oi structure which
   are not available from the object segment. */

declare  link_ptr ptr;
declare  link_len fixed bin;

	     if fixed (link_ptr -> virgin_linkage_header.link_begin, 18) <= 8 then do; /* no static section */
		oi.statp = null;
		oi.ilng = 0;
	     end;
	     else do;
		oi.statp = addrel (link_ptr, 8);
		oi.ilng = fixed (link_ptr -> virgin_linkage_header.link_begin, 18) - 8;
	     end;
	     oi.entry_bound = 0;
	     oi.textlinkp = null;

	     return;
	end;
						/*  */

decode_object_: entry (seg_ptr, bitcount, index, sect_ptr, sect_lng, sect_bc);

declare (index, sect_lng) fixed bin, sect_ptr pointer;
declare  sect_bc fixed bin (24);

	sect_ptr = null;				/* preset error return */
	i = index;				/* copy section index into stack);
						   if i <= 0 then return;
						   if i > 3 then return;	/* index out og bounds */

	segp = seg_ptr;
	if bitcount <= 287 then return;		/* absolute minimum for a 1-component, 1-word object */
	if mod (bitcount, 18) ^= 0 then return;		/* want bitcount to include map pointer */
	wordcount = divide (bitcount+35, 36, 18, 0);
	lastword = addrel (segp, wordcount-1);
	if old_map_ptr <= 0 then go to new_format;	/* out of range */
	if old_map_ptr >= wordcount then go to new_format; /* also out of range */
	mapp = addrel (segp, old_map_ptr);		/* get ptr to object map */
	if old_map.sentinel1 ^= (36)"10"b then goto new_format;
	if old_map.sentinel2 ^= (36)"10"b then
	     if old_map.sentinel2 ^= (36)"01"b then goto new_format; /* this is acceptable too */

/* perform some more consistency checks */
	base18 = old_map.info (i).offset;
	if base18  < 0 then go to new_format;		/* section not within object */
	if base18 >= old_map_ptr then go to new_format;	/*  "  */

	bitlng = old_map.info (i).length;
	if bitlng < 0 then go to new_format;
	len = old_map.info (i+1).offset - base18;		/* this method is more accurate for word length */
	if len < 0 then go to new_format;

	sect_ptr = addrel (segp, old_map.info (i).offset); /* pointer to specified section */
	sect_bc = bitlng;
	sect_lng = len;
	return;


new_format:
	len = fixed (lastword -> map_ptr, 18);		/* find "offset" of obj map */
	if len <= 0 then return;			/* map ptr is out of bounds */
	if len >= wordcount then return;		/*     "   */
	mapp = addrel (segp, lastword -> map_ptr);
	if mapp -> object_map.identifier ^= "obj_map " then return;

	if mapp -> object_map.decl_vers = 2 then do;	/* have version 2 map */
	     if i = 1 then
		do;				/* text section */
		sect_ptr = addrel (segp, mapp -> object_map.text_offset);
		sect_lng = fixed (mapp -> object_map.text_length, 18) + fixed (mapp -> object_map.definition_length, 18);
	     end;
	     else if i = 2 then
		do;				/* linkage section */
		sect_ptr = addrel (segp, mapp -> object_map.linkage_offset);
		sect_lng = fixed (mapp -> object_map.linkage_length, 18);
	     end;
	     else if i = 3 then
		do;				/* symbol section */
		sect_ptr = addrel (segp, mapp -> object_map.symbol_offset);
		sect_lng = fixed (mapp -> object_map.symbol_length, 18);
	     end;
	     sect_bc = sect_lng * 36;
	end;
	else do;					/* have version 1 map */
	     if i = 1 then
		do;				/* text section */
		sect_ptr = addrel (segp, map1.text_offset);
		sect_lng = fixed (map1.text_length, 18) + fixed (map1.def_length, 18);
	     end;
	     else if i = 2 then
		do;				/* linkage section */
		sect_ptr = addrel (segp, map1.link_offset);
		sect_lng = fixed (map1.link_length, 18);
	     end;
	     else if i = 3 then
		do;				/* symbol section */
		sect_ptr = addrel (segp, map1.symb_offset);
		sect_lng = fixed (map1.symb_length, 18);
	     end;
	     sect_bc = sect_lng * 36;
	end;



     end object_info_$long;




		    object_lib_.pl1                 11/11/89  1145.7rew 11/11/89  0804.2      222066



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-10-03,DGHowe), install(86-11-20,MR12.0-1222):
     Written to support object multisegment files, for initiation, definition
     searches, and info extraction.
                                                   END HISTORY COMMENTS */

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

object_lib_:
  proc;

  /*** ****************************************************************/
  /***							*/
  /***	Name:	object_lib_				*/
  /***	Function:	This is a collection of subroutines used for the	*/
  /***		manipulation of executable binaries (segments or	*/
  /***		MSFs).					*/
  /***							*/
  /*** ****************************************************************/

  /* constants */

  dcl true		bit (1) static options (constant) init ("1"b);
  dcl false		bit (1) static options (constant) init ("0"b);

  dcl fault_tag_3		bit (6) static options (constant) init ("47"b3);

  /* parameters */

  dcl A_areap		ptr parameter;
  dcl A_code		fixed bin (35) parameter;
  dcl A_comp_infop		ptr parameter;
  dcl A_count		fixed bin (24) parameter;
  dcl A_dname		char (*) parameter;
  dcl A_ename		char (*) parameter;
  dcl A_live		bit (1) parameter;
  dcl A_offsetname		char (*) parameter;
  dcl A_oi_type		char (*) parameter;
  dcl A_refname		char (*) parameter;
  dcl A_segname		char (*) parameter;
  dcl A_segp		ptr parameter;
  dcl A_targetp		ptr parameter;
  dcl A_validate		bit (1) parameter;
  dcl A_version_reqd	char (8) parameter;
  dcl A_msf_sw		bit (1) parameter;

  /* procedures */

  dcl get_definition_	entry (ptr, char (*), char (*), ptr,
			fixed bin (35));
  dcl get_system_free_area_	entry () returns (ptr);
  dcl hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*),
			fixed bin (35));
  dcl hcs_$initiate_count	entry (char (*), char (*), char (*),
			fixed bin (24), fixed bin (2), ptr,
			fixed bin (35));
  dcl hcs_$status_minf	entry (char (*), char (*), fixed bin (1),
			fixed bin (2), fixed bin (24),
			fixed bin (35));
  dcl hcs_$status_mins	entry (ptr, fixed bin (2), fixed bin (24),
			fixed bin (35));
  dcl hcs_$terminate_noname	entry (ptr, fixed bin (35));
  dcl initiate_file_	entry (char (*), char (*), bit (*), ptr,
			fixed bin (24), fixed bin (35));
  dcl object_info_$brief	entry (ptr, fixed bin (24), ptr,
			fixed bin (35));
  dcl object_info_$display	entry (ptr, fixed bin (24), ptr,
			fixed bin (35));
  dcl object_info_$long	entry (ptr, fixed bin (24), ptr,
			fixed bin (35));
  dcl pathname_		entry (char (*), char (*)) returns (char (168));
  dcl term_$no_clear	entry (char (*), fixed bin (35));
  dcl term_$single_refname	entry (char (*), fixed bin (35));

  /* external */

  dcl error_table_$bad_arg	external fixed bin (35);
  dcl error_table_$bad_class_def
			external fixed bin (35);
  dcl error_table_$bad_indirect_def
			external fixed bin (35);
  dcl error_table_$dirseg	external fixed bin (35);
  dcl error_table_$inconsistent_object_msf
			external fixed bin (35);
  dcl error_table_$namedup	external fixed bin (35);
  dcl error_table_$nolinkag	external fixed bin (35);
  dcl error_table_$segknown	external fixed bin (35);
  dcl error_table_$unimplemented_version
			external fixed bin (35);

  /* based */

  dcl based_area		area based (based_areap);
  dcl based_ptr		ptr based;
  dcl 01 def		aligned like definition based (defp);
  dcl 01 dh		aligned like definition_header based (dhp);
  dcl 01 mm		aligned like msf_map based (mmp);

  /* automatic */

  dcl based_areap		ptr automatic;
  dcl bc			fixed bin (24) automatic;
  dcl bit_count		fixed bin (24) automatic;
  dcl c			fixed bin automatic;
  dcl comp		fixed bin automatic;
  dcl defp		ptr automatic;
  dcl dhp			ptr automatic;
  dcl dname		char (168) automatic;
  dcl dnamel		fixed bin automatic;
  dcl ec			fixed bin (35) automatic;
  dcl ename		char (32) automatic;
  dcl i			fixed bin automatic;
  dcl info_ep		variable entry (ptr, fixed bin (24), ptr,
			fixed bin (35)) automatic;
  dcl mmp			ptr automatic;
  dcl n_comp		fixed bin (24) automatic;
  dcl no_clear_sw		bit (1) automatic;
  dcl 01 oi		aligned like object_info automatic;
  dcl segp		ptr automatic;
  dcl targetp		ptr automatic;
  dcl term_sw		bit (1) automatic;
  dcl type		fixed bin automatic;

  /* conditions */

  dcl cleanup		condition;

  /* builtin */

  dcl addr		builtin;
  dcl addrel		builtin;
  dcl char		builtin;
  dcl ltrim		builtin;
  dcl null		builtin;
  dcl unspec		builtin;

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


initiate:
  entry (A_dname,			/** target dir name     ( in)	*/
       A_ename,			/** target entry name   ( in)	*/
       A_refname,			/** target refname	    ( in)	*/
       A_validate,			/** validate switch	    ( in) */
       A_targetp,			/** target pointer	    (out)	*/
       A_count,			/** bit_count	    (out) */
       A_msf_sw,			/** MSF switch	    (out)	*/
       A_code);			/** error code	    (out)	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	object_lib_$initiate			*/
  /***	Input:	dname, ename, refname, validate		*/
  /***	Function:	Initiates the binary file (segment or MSF),	*/
  /***		specified by dir_name and entry_name, with the	*/
  /***		reference name specified.  If the pathname given	*/
  /***		specifies an MSF, component 0 is initiated with	*/
  /***		the given refname.  If the validate switch is set	*/
  /***		the resultant segment is checked via object_info_	*/
  /***		to insure that it is in fact an object segment.	*/
  /***		The object segment is also checked to determine	*/
  /***		if it is a valid object MSF.  The pointer to the	*/
  /***		segment is returned if the thing in question ends	*/
  /***		up referring to an object segment regardless of	*/
  /***		conflicting information about it being an object	*/
  /***		MSF.					*/
  /***	Output:	targetp, count, msf_sw, code			*/
  /***							*/
  /*** ****************************************************************/


  no_clear_sw = false;
  goto INITIATE_JOIN;

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


init_no_clear:
  entry (A_dname,			/** target dir name	    ( in)	*/
       A_ename,			/** target entryname    ( in)	*/
       A_refname,			/** target ref name	    ( in)	*/
       A_validate,			/** validate switch	    ( in) */
       A_targetp,			/** target pointer	    (out)	*/
       A_count,			/** bit count	    (out) */
       A_msf_sw,			/** MSF switch	    (out)	*/
       A_code);			/** error code	    (out)	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	object_lib_$init_no_clear			*/
  /***	Input:	dname, ename, refname, validate		*/
  /***	Function:	the same as object_lib_$initiate except that	*/
  /***		term_$no_clear is called rather than		*/
  /***		term_$single_refname if the refname is already	*/
  /***		on another entry and must be terminated.  It is	*/
  /***		intended for use only by find_command_ who will	*/
  /***		take care of its associative memory itself.	*/
  /***	Output:	targetp, count, msf_sw, code			*/
  /***							*/
  /*** ****************************************************************/

  no_clear_sw = true;
  goto INITIATE_JOIN;

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


INITIATE_JOIN:
  dname = A_dname;
  ename = A_ename;
  n_comp = 0;
  term_sw = false;

  A_code = 0;
  A_targetp = null;
  A_msf_sw = false;
  A_count = 0;

  /* try to initiate the segment/MSF */

  call hcs_$initiate_count (dname, ename, A_refname, bc, 0, targetp, ec);

  /* if the target is a directory, see if it is an MSF and try to	*/
  /* initiate component 0.					*/

  if ec = error_table_$dirseg
    then do;
      call hcs_$status_minf (dname, ename, 0, 0, n_comp, ec);
      if ec ^= 0
        then call exit (ec);
      if n_comp = 0
        then call exit (error_table_$dirseg);
      dname = pathname_ (dname, ename);
      ename = "0";
      call hcs_$initiate_count (dname, ename, A_refname, bc, 0, targetp, ec);
    end;

  /* if another segment already has that refname, terminate the	*/
  /* refname and retry the initiation.				*/

  if ec = error_table_$namedup
    then do;
      if no_clear_sw
        then call term_$no_clear (A_refname, ec);
        else call term_$single_refname (A_refname, ec);
      if ec ^= 0
        then call exit (ec);
      term_sw = true;
      call hcs_$initiate_count (dname, ename, A_refname, bc, 0, targetp, ec);
    end;

  /* if at this point we have a problem other than that the segment	*/
  /* is already known, we give up and return the code.		*/

  if ec = error_table_$segknown
    then ec = 0;
  else if ec ^= 0
    then call exit (ec);

  if A_validate
    then do;

      /* now we try to validate the target segment. */

      oi.version_number = object_info_version_2;
      call object_info_$brief (targetp, bc, addr (oi), ec);

      /* first see if it is an object at all */

      if ec ^= 0
        then call exit (ec);

      /* if we have gotten this far, we actually have an object so we	*/
      /* can legitimately return the pointer and bit count		*/

      A_targetp = targetp;
      A_count = bc;

      /* now we validate the status as a object MSF/segment */

      def_header_ptr = oi.defp;
      if definition_header.msf_map_relp ^= 0
        then do;

	/* if the definition_header/msf_map say this thing is a MSF	*/
	/* component, make sure the directory bit_count and the	*/
	/* msf_map agree on how many components are here, as well	*/
	/* as making sure that this component really is component 0	*/

	msf_map_ptr = addrel (def_header_ptr,
	     definition_header.msf_map_relp);
	if msf_map.version ^= msf_map_version_1
	  then A_msf_sw = false;
	  else do;
	    if (msf_map.component_count ^= n_comp) |
	         (msf_map.my_component ^= 0)
	      then call exit (error_table_$inconsistent_object_msf);
	    A_msf_sw = true;
	  end;
        end;
        else do;

	/* if the definition_header says there is no msf_map, make	*/
	/* sure we didn't find this thing through MSF indirection.	*/
	/* (ie. in an MSF component.)				*/

	if n_comp > 0
	  then call exit (error_table_$inconsistent_object_msf);
	A_msf_sw = false;
        end;
    end;
    else do;
      if n_comp > 0
        then A_msf_sw = true;
        else A_msf_sw = false;
      A_targetp = targetp;
      A_count = bc;
    end;

  /* if everything checks out, return the pointer and msf_switch. If	*/
  /* the no_clear_sw and term_sw are both set, return the error code	*/
  /* error_table_$namedup so that find_command_ will know to adjust	*/
  /* its associative memory.					*/

  if term_sw & no_clear_sw
    then call exit (error_table_$namedup);
    else call exit (0);

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_component_info:
  entry (A_segp,			/** obejct segment ptr  (in )	*/
       A_areap,			/** area to allocate in (in ) */
       A_version_reqd,		/** version to return   (in ) */
       A_oi_type,			/** type of object_info (in ) */
       A_comp_infop,		/** component_info ptr  (out)	*/
       A_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	object_lib_$get_component_info		*/
  /***	Input:	segp, areap, version_reqd, oi_type		*/
  /***	Function:	given a pointer to an object segment or MSF	*/
  /***		component, initiate all of the components of the	*/
  /***		MSF and return various information about them.	*/
  /***	Output:	comp_infop, code				*/
  /***							*/
  /*** ****************************************************************/

  /* preset the return value */

  A_comp_infop = null;

  /* make sure the version requested is legitimate */

  if A_version_reqd ^= component_info_version_1
    then call exit (error_table_$unimplemented_version);

  /* get the area to allocate the return structure in */

  if A_areap = null
    then based_areap = get_system_free_area_ ();
    else based_areap = A_areap;

  /* get the bit count of the segment passed for the call to object_info_ */

  call hcs_$status_mins (A_segp, (0), bit_count, ec);
  if ec ^= 0
    then call exit (ec);

  /* get the section pointers and validate that this is an object seg */

  oi.version_number = object_info_version_2;
  if A_oi_type = "none" | A_oi_type = "brief"
    then info_ep = object_info_$brief;
  else if A_oi_type = "display"
    then info_ep = object_info_$display;
  else if A_oi_type = "long"
    then info_ep = object_info_$long;
  else call exit (error_table_$bad_arg);

  call info_ep (A_segp, bit_count, addr (oi), ec);
  if ec ^= 0
    then call exit (ec);

  /* see if we have an MSF component, a non-MSF returns a structure	*/
  /* with a single component entry and the msf flag false		*/

  dhp = oi.defp;
  if dh.msf_map_relp = 0
    then max_component = 0;
    else do;
      mmp = addrel (dhp, dh.msf_map_relp);
      if mm.version ^= msf_map_version_1
        then max_component = 0;
        else max_component = mm.component_count - 1;
    end;

  /* preset the structure pointer to remove cleanup error windows */

  comp_infop = null;
  c = -1;

  /* make sure the structure goes away if we abort */

  on cleanup
    begin;
    if comp_infop ^= null
      then do;
        do i = 0 to c;
	if component_info.comp (c).segp ^= null
	  then call hcs_$terminate_noname (component_info.comp (c).segp,
		  (0));
        end;
        free component_info in (based_area);
      end;
  end;

  /* allocate the component info structure */

  allocate component_info in (based_area);
  component_info.version = A_version_reqd;
  component_info.flags.mbz = ""b;
  component_info.comp (*).mbz = ""b;
  component_info.comp (*).segp = null;

  if max_component = 0
    then do;

      /* if we have only 1 component (ie. a non-MSF), just copy the	*/
      /* info for the segment we were passed.			*/

      component_info.flags.msf = false;
      component_info.comp (0).segp = A_segp;
      component_info.comp (0).bc = bit_count;
      component_info.comp (0).info = oi;
    end;
    else do;

      /* if we have an MSF component, get the containing dir path and	*/
      /* initiate each of the other components.			*/

      component_info.flags.msf = true;

      call hcs_$fs_get_path_name (A_segp, dname, (0), ename, ec);

      do c = 0 to max_component;
        if c ^= mm.my_component
	then do;

	  /* if this isn't the component we were passed, generate	*/
	  /* a name and try to initiate in the containing directory	*/

	  ename = ltrim (char (c));
	  call initiate_file_ (dname, ename, R_ACCESS,
	       component_info.comp (c).segp,
	       component_info.comp (c).bc, ec);

	  /* if any other code was returned, free the structure and	*/
	  /* complain that this MSF is broken.			*/

	  if ec ^= 0
	    then do;

	      /* terminate all of the segments that we initiated	*/

	      do i = 0 to c - 1;
	        if component_info.comp (i).segp ^= null
		   & i ^= mm.my_component
		then call hcs_$terminate_noname (
			component_info.comp (i).segp, (0));
	      end;

	      free component_info in (based_area);
	      call exit (error_table_$inconsistent_object_msf);
	    end;

	  /* if the initiate was ok, try to get the object_info_ */

	  if A_oi_type ^= "none"
	    then do;
	      component_info.comp (c).info.version_number =
		 object_info_version_2;
	      call info_ep (component_info.comp (c).segp,
		 component_info.comp (c).bc,
		 addr (component_info.comp (c).info), ec);
	      if ec ^= 0
	        then do;

		/* terminate all the segments that we initiated	*/

		do i = 0 to c;
		  if component_info.comp (i).segp ^= null
		       & i ^= mm.my_component
		    then call hcs_$terminate_noname (
			    component_info.comp (i).segp, 0);
		end;

		free component_info in (based_area);
		call exit (ec);
	        end;
	    end;
	    else unspec (component_info.comp (c).info) = ""b;

	end;
	else do;

	  /* if this was the component he passed us, just fill in	*/
	  /* the pointer and bit count 			*/

	  component_info.comp (c).segp = A_segp;
	  component_info.comp (c).bc = bit_count;
	  if A_oi_type ^= "none"
	    then component_info.comp (c).info = oi;
	    else unspec (component_info.comp (c).info) = ""b;
	end;
      end;
    end;

  /* everything worked so set the return pointer and return a 0 code */

  A_comp_infop = comp_infop;

  call exit (0);

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_def_target:
  entry (A_segp,			/** segment to search   (in )	*/
       A_count,			/** segment bit count   (in ) */
       A_segname,			/** segname to find	    (in ) */
       A_offsetname,		/** offsetname to find  (in ) */
       A_live,			/** active/static	    (in ) */
       A_targetp,			/** target of def found (out) */
       A_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	object_lib_$get_def_target			*/
  /***	Input:	segp, count, segname, offsetname, live		*/
  /***	Function:	searches the given segment for the definition	*/
  /***		specified and return a pointer to the eventual	*/
  /***		target.  If the specified definition is an	*/
  /***		indirect definition, the pointer returned is the	*/
  /***		target of the indirection, not a pointer to the	*/
  /***		indirect link itself.  If the target of the	*/
  /***		definition is in the static or linkage sections,	*/
  /***		the live switch is used to determine whether the	*/
  /***		active version is used, or the static copy in the	*/
  /***		actual object segment.			*/
  /***	Output:	targetp, code				*/
  /***							*/
  /*** ****************************************************************/

  A_targetp = null;

  /* get the object info for the target segment */

  oi.version_number = object_info_version_2;
  call object_info_$brief (A_segp, A_count, addr (oi), ec);
  if ec ^= 0
    then call exit (ec);

  dhp = oi.defp;

  /* search for the definition */

  call get_definition_ (dhp, A_segname, A_offsetname, defp, ec);
  if ec ^= 0
    then call exit (ec);

  /* if the live switch is set, use the active linkage and static	*/
  /* pointers from the LOT and ISOT rather than the ones returned	*/
  /* by object_info_.					*/

  if A_live
    then do;
      call get_lp (A_segp, oi.linkp, oi.statp, ec);
      if ec ^= 0
        then call exit (ec);
    end;

  /* derive the target pointer of the definition. */

  if def.class = CLASS_TEXT
    then targetp = addrel (oi.textp, def.thing_relp);
  else if def.class = CLASS_LINKAGE
    then targetp = addrel (oi.linkp, def.thing_relp);
  else if def.class = CLASS_SYMBOL
    then targetp = addrel (oi.symbp, def.thing_relp);
  else if def.class = CLASS_STATIC
    then targetp = addrel (oi.statp, def.thing_relp);
  else call exit (error_table_$bad_class_def);

  /* if we are in an MSF transfer vector, indirect through the TV */

  if def.flags.indirect
    then do;

      /* make sure the definition target is a partial link */

      if def.class ^= CLASS_LINKAGE
        then call exit (error_table_$bad_indirect_def);

      /* if the live target was requested, return the value of the	*/
      /* snapped partial link.  Otherwise check to see if the target	*/
      /* is an unsnapped partial link.				*/

      if A_live
        then if targetp -> partial_link.tag ^= ITS_MODIFIER
	     then call exit (error_table_$bad_indirect_def);
	     else do;
	       A_targetp = targetp -> based_ptr;
	       call exit (0);
	     end;
      else if targetp -> partial_link.tag ^= fault_tag_3
        then call exit (error_table_$bad_indirect_def);
      else ;

      /* get the pathname to find the target component */

      call hcs_$fs_get_path_name (targetp, dname, dnamel, ename, ec);
      if ec ^= 0
        then call exit (ec);

      comp = targetp -> partial_link.component;
      type = targetp -> partial_link.type;
      ename = ltrim (char (comp));

      /* initiate the target */

      call initiate_file_ (dname, ename, R_ACCESS, segp, bc, ec);
      if ec ^= 0
        then call exit (ec);

      call object_info_$brief (segp, bc, addr (oi), ec);
      if ec ^= 0
        then call exit (ec);

      /* apply the link offset to the appropriate section base */

      if type = CLASS_TEXT
        then targetp = addrel (segp, targetp -> partial_link.offset);
      else if type = CLASS_LINKAGE
        then targetp = addrel (oi.linkp, targetp -> partial_link.offset);
      else if type = CLASS_STATIC
        then targetp = addrel (oi.statp, targetp -> partial_link.offset);
      else if type = CLASS_SYMBOL
        then targetp = addrel (oi.symbp, targetp -> partial_link.offset);
      else call exit (error_table_$bad_indirect_def);

    end;

  A_targetp = targetp;

  call exit (0);

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_lp:
  proc (segp,			/** segment pointer	    (in )	*/
       linkp,			/** linkage section ptr (out) */
       statp,			/** static section ptr  (out) */
       ec);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	get_lp					*/
  /***	Input:	segp					*/
  /***	Function:	gets the live linkage/static section pointers for	*/
  /***		the segment specified from the LOT/ISOT.  If the	*/
  /***		sections have not been copied, an error code is	*/
  /***		returned.					*/
  /***	Output:	linkp, statp, ec				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segp		ptr;
  dcl linkp		ptr;
  dcl statp		ptr;
  dcl ec			fixed bin (35);

  /* automatic */

  dcl seg_no		fixed bin;

  /* builtin */

  dcl segno		builtin;
  dcl stackbaseptr		builtin;
  dcl unspec		builtin;

  /* get the lot and isot pointers from the stack header */

  sb = stackbaseptr ();
  lotp = stack_header.lot_ptr;
  isotp = stack_header.isot_ptr;

  /* get the segment number for the segment we want */

  seg_no = segno (segp);
  
  /* make sure the lot is big enough */
  
  if seg_no > stack_header.cur_lot_size
    then do;
      ec = error_table_$nolinkag;
      return;
    end;
    
  /* make sure there is a lot entry */

  if unspec (lot.lp (seg_no)) = lot_fault
    then do;
      ec = error_table_$nolinkag;
      return;
    end;

  /* extract the pointers from the lot and isot */

  linkp = lot.lp (seg_no);
  statp = isot.isp (seg_no);

  end get_lp;

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


exit:
  proc (ec);			/** error code	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	exit					*/
  /***	Input:	ec					*/
  /***	Function:	returns from object_lib_ returning the		*/
  /***		supplied error code.			*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl ec			fixed bin (35);

  A_code = ec;
  goto EXIT;

  end exit;

EXIT:
  return;

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


%include access_mode_values;
%include definition_dcls;
%include its;
%include object_lib_defs;
%include object_info;
%include object_link_dcls;
%include lot;
%include stack_header;

  end object_lib_;




		    parse_tty_name_.pl1             11/11/89  1145.7rew 11/11/89  0804.9       38376



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* format: style4,delnl,insnl,^ifthendo */
parse_tty_name_:
     proc (name, fno, type, ano, chno);

/* This procedure hides in one place all knowledge of how to change
   a tty channel name into an FNP number and adaptor and channel numbers. */

/* Coded May 1976 by Mike Grady */
/* Modified July 1978 by Larry Johnson for new style tty names */
/* Modified May 1981 by Robert Coren to recognize COLTS channel (X.c000) */

dcl  name char (*),
     (fno, ano, chno) fixed bin,
     code fixed bin (35),
     type bit (1);
dcl  tag char (1);

dcl  i fixed bin;
dcl  temp char (3);

dcl  TAGS char (8) int static options (constant) init ("abcdefgh");

dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);

dcl  (bin, divide, index, mod, substr, verify) builtin;


	i = index (name, ".");			/* Check for presence of a period */
	if i = 0
	then do;					/* No period indicates old name */
	     ano = index ("012345678ABCDEFGHIJKLMNOPQRSTUVWXYZ*", substr (name, 4, 1));
	     if ano = 0
	     then do;
err:
		fno = -1;
		return;
	     end;
	     ano = ano - 1;
	     fno = divide (ano, 9, 17, 0) + 1;
	     ano = mod (ano, 9);
	     if ano > 5
	     then do;
		ano = ano - 6;
		type = "1"b;
	     end;
	     else type = "0"b;

	     chno = cv_dec_check_ (substr (name, 5, 2), code);
	     if code ^= 0
	     then go to err;
	end;

	else do;					/* New style name */
	     if i < 2
	     then go to err;			/* Must be x. */
	     call parse_fnp_name_ (substr (name, 1, i - 1), fno);
	     if fno < 0
	     then go to err;
	     if substr (name, i + 1, 1) = "l"
	     then type = "0"b;
	     else if substr (name, i + 1, 1) = "h"
	     then type = "1"b;
	     else if substr (name, i + 1, 1) = "c"	/* COLTS executive pseudo-channel */
	     then do;
		if substr (name, i + 2) ^= "000"	/* this is the only form allowed */
		then go to err;
		;
		type = "1"b;			/* pretend it's HSLA */
		ano = 7;				/* we will force line number of 1777(8) */
		chno = 63;
		return;
	     end;
	     else go to err;
	     temp = substr (name, i + 2, 3);		/* Rest is digits: adapter and sub-chan */
	     if temp ^= substr (name, i + 2)
	     then go to err;			/* Extra chars somewhere */
	     if verify (temp, "0123456789") ^= 0
	     then go to err;
	     ano = bin (substr (temp, 1, 1));
	     if ano > 5
	     then go to err;
	     if ano > 2 & type
	     then go to err;
	     chno = bin (substr (temp, 2, 2));
	end;

	return;

/* Entry for comparing two tty channel names for equality */
/* It compares old and new style names as equal */

compare_tty_name_:
     entry (name1, name2) returns (bit (1));

dcl  (name1, name2) char (*);
dcl  (fnp1, fnp2, adp1, adp2, chn1, chn2) fixed bin;
dcl  (hsla1, hsla2) bit (1);

	if name1 = name2
	then return ("1"b);
	call parse_tty_name_ (name1, fnp1, hsla1, adp1, chn1);
	if fnp1 = -1
	then return ("0"b);
	call parse_tty_name_ (name2, fnp2, hsla2, adp2, chn2);
	if fnp2 = -1
	then return ("0"b);
	return (fnp1 = fnp2 & hsla1 = hsla2 & adp1 = adp2 & chn1 = chn2);

/* entry to "parse" an fnp name */
/* the intention is that this be the only place in the system that knows the format of fnp names */

parse_fnp_name_:
     entry (name, fno);

	tag = substr (name, 1, 1);
	if tag ^= name
	then go to err;
	fno = index ("abcdefgh", tag);
	if fno = 0
	then go to err;
	return;

/* this entry, given the number returned by parse_fnp_name_, returns the fnp's name */

get_fnp_name_:
     entry (fno) returns (char (32));

	if fno < 1 | fno > length (TAGS)
	then return ("?");
	else return (substr (TAGS, fno, 1));

     end parse_tty_name_;




		    pl1_resignaller_.pl1            11/11/89  1145.7r   11/11/89  0804.9       15651



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* format: style2 */

/* This program catches the conditions that the FIM signals from ring 0
   and resignals them with the correct pl1_info structure, using 
   pl1_signal_ */

/* BIM June 1981 */

pl1_resignaller_:
     procedure options (support);
	return;					/* not used */
	declare pl1_signal_$pl1_signal_from_ops_
				 entry (character (256), fixed binary, pointer, fixed binary (35), pointer);

stringsize:
     entry;
	call pl1_signal_$pl1_signal_from_ops_ ("stringsize", length ("stringsize"), null () /* no file */,
	     702 /* oncode for stringsize */, null () /* no file */);
	return;

size:
     entry;
	call pl1_signal_$pl1_signal_from_ops_ ("size", length ("size"), null (), 703 /* oncode */, null () /* no file */)
	     ;
	return;


establish_handlers:
     entry;

	declare sct_manager_$set	 entry (fixed binary, pointer, fixed binary (35));

	call sct_manager_$set (stringsize_sct_index, codeptr (stringsize), (0));
	call sct_manager_$set (size_sct_index, codeptr (size), (0));

%include static_handlers;
     end pl1_resignaller_;




		    rtcd_util_.alm                  11/11/89  1145.7rew 11/11/89  0804.9       11223



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" rtcd_util_ is a utility to do an RTCD to
" an outer ring procedure. This is cheaper and
" more robust than depending on the fault/outward_call_handler_
" mechanism

" Coded April 1981 Benson I. Margulies

	name	rtcd_util_
	entry	rtcd_util_

	" declare rtcd_util_ entry (pointer, pointer)
	" call rtcd_util_ (addr (rtcd_ptr), arg_list_ptr)

	equ	procedure,2
	equ	arglist,4
rtcd_util_: 
	epp2	pr0|procedure,*	" pointer to pointer to procedure
	epp0	pr0|4,*		" arg list ptr ptr
	epp0	pr0|0,*		" arg list pointer
	epbp7	pr0|0
	epp6	null,*		" stack base to stack_n, sp to null
	rtcd	pr2|0,*		" shazzam!
	even
null:	its	-1,1
	end




		    set_ext_variable_.pl1           11/11/89  1145.7rew 11/11/89  0804.9      195111



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-06-24,DGHowe), approve(86-06-24,MCR7396), audit(86-11-13,Zwick),
     install(86-11-20,MR12.0-1222):
     added the entrypoint star_heap to perform the look up and allocation of
     heap links. This is called by the user and by link_snap. Reorganized this
     routine to allow the changes to follow the existing methodology used in
     the program.
  2) change(86-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-11-13,Zwick),
     install(86-11-20,MR12.0-1222):
     changed the calling sequence of list_init_ to include a segment pointer.
     changed the parameter list of the following entrypoints (for_linker
     star_heap) to include a segment pointer. Added an entrypoint named pointer
     to allow system links to have pointer initialization.
  3) change(86-06-24,DGHowe), approve(86-06-24,MCR7421), audit(86-11-13,Zwick),
     install(86-11-20,MR12.0-1222):
     removed the entrypoint allocate as it was not being used by the routine it
     was meant for.
                                                   END HISTORY COMMENTS */


/* MODIFICATION NOTICES -------------------------------------

   Written by M. Weaver in 1976.
   Modified by M. Jordan 1981 to add $locate
   Modified by M. Weaver December 1982 to call fortran_storage_manager_ for
    	LIST_TEMPLATE_INIT and to add entries for the linker and the trap 
	procedure
   Modified by T. Oke January 27 1983 to fix list_init_ ref to node_ptr to ref
	  p (which is the real pointer to the node at that point).
   Modified by M. Weaver February 1983 to set have_vla_variables flag
   Modified by M. Weaver December 1984 to catch the 
	  malformed_list_template_entry_ condition
   ------------------------------------------------------------ */


/* format: style3,^indnoniterdo */

/* ENTRYPOINTS in set_ext_variable_
   set_ext_variable_ called by users to find or allocate *system variables
   locate		 called to find *system links on the name table
   for_linker	 called by link snap to allocate or find *system links
   star_heap	 called by link snap to allocate or find *heap links.
   pointer	 called by the user to allcoate or find *system variables
		 allows for pointer initialization via list_init_
*/

set_ext_variable_:
     proc (a_ext_name, a_init_info_ptr, a_sb, a_found_sw, a_node_ptr, a_code);



/* This procedure looks up the *system link symbol name in the name table.
   If the name is not found, the variable is added.
   If the requested size is larger, an error is returned.

   This entry is not called in ring 0 because it calls fortran_storage_manager_
   directly to allocate the variable if the size > sys_info_$max_seg_size.
   This entry is intended to be called by set_fortran_common and by
   fortran_storage_ in the normal case.
*/

/* parameters */

dcl	a_ext_name	char (*) parameter;		/* variable name */
dcl	a_found_sw	bit (1) aligned parameter;	/* is it found */
dcl	a_code		fixed bin (35) parameter;	/* system error code */
dcl	a_def_ptr		pointer parameter;		/* ptr to the def for the lk */
dcl	a_node_ptr	pointer parameter;		/* returned ptr to the target*/
dcl	a_link_ptr	pointer parameter;		/* */
dcl	a_mc_ptr		pointer parameter;		/* ptr to the machine conds */
dcl	a_seg_ptr		pointer parameter;		/* ptr to segmetn containing the reference */
dcl	a_type_ptr	pointer parameter;		/* ptr to type pair */

dcl	a_init_info_ptr	pointer parameter;		/* pointer to init info */
dcl	a_sb		pointer parameter;		/* pointer to stack header */

/* local vars */

dcl	found		bit (1);			/* temp found bit */
dcl	hash_index	fixed bin (6);		/* index into hash table for the ext name */
dcl	heap_header_ptr	pointer;			/* ptr to heap header */
dcl	is_heap_link	bit (1) init ("0"b);	/* specifies we are working on a heap link */
dcl	i		fixed bin;		/* used in loop to init hash table */
dcl	called_by_linker	bit (1) aligned;		/* bits specifying called info */
dcl	loop_count	fixed bin;		/* number of times we have performed a look up loop */
dcl	nchars		fixed bin;		/* length of ext name */
dcl	(new_ptr, table_ptr)
			pointer;			/* ptr to variable and var table */
dcl	ring_no		fixed bin;
dcl	seg_ptr		pointer automatic;		/* autmatic var for seg ptr value */
dcl	(t1, t2, t3, t4)	fixed bin (71);		/* clock times for calculating meters */
dcl	var_ptr		pointer;			/* points to variable_node */
dcl	vsize		fixed bin (35);		/* size of variable to allocate */
dcl	where_to_allocate_ptr
			pointer automatic;		/* ptr to area where we should allocate our structs */



/* based */

dcl	based_area	area (vsize) based;		/* an overlay area to allocate in */
dcl	variable		(vsize) fixed bin (35) based; /* the actual variable */

/* conditions */

dcl	area		condition;
dcl	bad_area_format	condition;


/* external routines */

dcl	cu_$level_get	entry (fixed bin);
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), pointer, fixed bin (35));
dcl	unique_chars_	entry (bit (*)) returns (char (15));
dcl	fortran_storage_manager_$alloc
			entry (fixed bin, pointer, pointer);
dcl	heap_manager_$create_heap_for_set_ext_var
			entry (pointer, fixed bin, pointer, fixed bin (35));
dcl	list_init_$variable_already_zero
			entry (pointer, pointer, fixed bin (35), pointer, pointer, fixed bin (35));
dcl	trap_caller_caller_ entry (pointer, pointer, pointer, pointer, pointer, pointer, fixed bin (35));

/* external variables */

dcl	(
	error_table_$invalid_heap,
	error_table_$invalid_heap_var_size,
	error_table_$bigger_ext_variable,
	error_table_$notalloc,
	error_table_$noalloc,
	error_table_$defs_loop,
	error_table_$no_ext_sym,
	error_table_$bad_link_target_init_info
	)		ext fixed bin (35);
dcl	sys_info$max_seg_size
			fixed bin (19) ext;
dcl	pl1_operators_$VLA_words_per_seg_
			fixed bin (19) ext;



/*		BUILTIN FUNCTIONS		*/


dcl	(addr, bin, clock, divide, empty,  hbound, lbound,
	 length, max, multiply, null, ptr, rtrim, substr,
	 unspec, vclock)		builtin;


/* set_ext_variable_ starts here .. set initial values for check bits */

	called_by_linker = "0"b;			/* this entry called outside ring 0 */
	is_heap_link = "0"b;
	seg_ptr = null ();				/* can't do ptr init */
	where_to_allocate_ptr = a_sb -> stack_header.user_free_ptr;
	table_ptr = a_sb -> stack_header.sys_link_info_ptr;

/* this is a block of common code used by set_ext_var$allocate and 
   set_ext_var$for_linker and set_ext_var$star_heap.

   we check for no var table and make sure the init info passed to us is
   valid
*/

JOIN:
	a_found_sw = "0"b;
	a_node_ptr = null;
	a_code = 0;


	on bad_area_format, area
	     begin;
		a_code = error_table_$notalloc;
		goto ERROR;
	     end;

	nchars = length (rtrim (a_ext_name));
	hash_index = HASH ();

/* check init info setting vsize if 0 no init and we set an error
   after allocating the table if it doesnot exist
*/

	if a_init_info_ptr ^= null
	then do;
	     vsize = a_init_info_ptr -> init_info.size;
	     if a_ext_name = "blnk*com"
	     then vsize = max (sys_info$max_seg_size - 50, vsize);
	     if vsize < 0
	     then do;
		a_code = error_table_$bad_link_target_init_info;
		return;
	     end;
	end;
	else vsize = 0;				/*  = a_def_ptr indicates no init info, don't create */

/* If invoked from the user ring, there is a small window here.  The
   user can quit while we are in the trap procedure and invoke a
   program which causes the variable (or one with the same name) to be
   allocated.  However the same thing can happen (with a smaller
   window) when set_ext_variable_ is called in the user ring.  I don't
   think that this will be a problem in practice. 
*/


	if table_ptr = null ()
	then do;
	     allocate variable_table_header in (where_to_allocate_ptr -> based_area) set (table_ptr);
	     if ^is_heap_link
	     then a_sb -> stack_header.sys_link_info_ptr = table_ptr;
	     else heap_header_ptr -> heap_header.heap_name_list_ptr = table_ptr;

/* initialize table  */

	     do i = lbound (table_ptr -> variable_table_header.hash_table, 1)
		to hbound (table_ptr -> variable_table_header.hash_table, 1);
		table_ptr -> variable_table_header.hash_table (i) = null;
	     end;
	end;
	else do;					/* search only if table was already initialized */
	     call LOOKUP ();
	     if a_code ^= 0
	     then return;
	     a_found_sw = found;
	     if found
	     then do;
		if vsize > var_ptr -> variable_node.vbl_size
		then a_code = error_table_$bigger_ext_variable;
		return;
	     end;
	end;

/* no existing variable by this name; must allocate */

	if vsize = 0 & ^is_heap_link
	then do;					/* no init info; can't create */
	     a_code = error_table_$no_ext_sym;
	     return;
	end;
	else if ((vsize = 0) | (vsize > (sys_info$max_seg_size - 50))) & is_heap_link
	then do;
	     a_code = error_table_$invalid_heap_var_size;
	     return;
	end;


/* Check for valid initialization types before allocating and threading so
   we won't have to undo the allocation. */

	if (a_init_info_ptr -> init_info.type ^= NO_INIT) & (a_init_info_ptr -> init_info.type ^= TEMPLATE_INIT)
	     & (a_init_info_ptr -> init_info.type ^= EMPTY_AREA_INIT)
	     & (a_init_info_ptr -> init_info.type ^= LIST_TEMPLATE_INIT)
	then do;
	     a_code = error_table_$bad_link_target_init_info;
	     return;
	end;


/* allocate the var node and check for valid init type. call out if
   we have a vla -- to fortran_storage_manager (this will not return to here)
   if doen via trap caller caller. other wise allocate the variable it self and
   add it to the variable name list at its hash index
*/

	t3 = vclock ();

	allocate variable_node in (where_to_allocate_ptr -> based_area) set (var_ptr);

	if vsize > sys_info$max_seg_size
	then do;
	     if (a_init_info_ptr -> init_info.type ^= NO_INIT)
		& (a_init_info_ptr -> init_info.type ^= LIST_TEMPLATE_INIT)
	     then do;				/* multi_seg variable can't have template or be an area */
		free var_ptr -> variable_node;
		a_code = error_table_$bad_link_target_init_info;
		return;
	     end;
	     if called_by_linker
	     then call trap_caller_caller_ (a_mc_ptr, null, a_def_ptr, a_type_ptr, a_link_ptr, null, a_code);
	     else call fortran_storage_manager_$alloc (
		     divide (vsize + pl1_operators_$VLA_words_per_seg_ - 1, pl1_operators_$VLA_words_per_seg_, 17),
		     var_ptr, new_ptr);
	end;

	else if vsize > (sys_info$max_seg_size - 50)
	then do;
	     call hcs_$make_seg ("", unique_chars_ (""b) || "linker", "", 01110b, new_ptr, a_code);
	     if a_code ^= 0
	     then do;
		free var_ptr -> variable_node;
		a_code = error_table_$noalloc;
		return;
	     end;
	end;

/* *heap links should always come here as they can not be bigger than 
   mxsegsiz-50 */

	else allocate variable in (where_to_allocate_ptr -> based_area) set (new_ptr);

	var_ptr -> variable_node.forward_thread = table_ptr -> variable_table_header.hash_table (hash_index);
	table_ptr -> variable_table_header.hash_table (hash_index) = var_ptr;
	var_ptr -> variable_node.name_size = nchars;
	var_ptr -> variable_node.name = substr (a_ext_name, 1, nchars);
	var_ptr -> variable_node.vbl_ptr = new_ptr;
	var_ptr -> variable_node.vbl_size = vsize;
	var_ptr -> variable_node.init_type = a_init_info_ptr -> init_info.type;
	var_ptr -> variable_node.init_ptr = a_init_info_ptr;
	if seg_ptr ^= null ()
	then var_ptr -> variable_node.seg_ptr = ptr (seg_ptr, 0);
	else var_ptr -> variable_node.seg_ptr = null ();
	if vsize > sys_info$max_seg_size
	then table_ptr -> variable_table_header.flags.have_vla_variables = "1"b;
						/* let run_ know to clean up */

/* Initialize the variable.
*/

	if a_init_info_ptr -> init_info.type ^= 0
	then do;
	     if a_init_info_ptr -> init_info.type = EMPTY_AREA_INIT
	     then var_ptr -> variable_node.vbl_ptr -> based_area = empty ();
	     else if a_init_info_ptr -> init_info.type = TEMPLATE_INIT
	     then var_ptr -> variable_node.vbl_ptr -> variable = a_init_info_ptr -> init_info.init_template;
	     else if a_init_info_ptr -> init_info.type = LIST_TEMPLATE_INIT
	     then do;
		call list_init_$variable_already_zero (var_ptr -> variable_node.vbl_ptr,
		     addr (a_init_info_ptr -> list_init_info.template), vsize, a_sb, seg_ptr, a_code);
		if a_code ^= 0
		then go to FINISH_METERS;		/* might as well fill in meters */
	     end;
	end;

FINISH_METERS:					/* complete the metering information. generally this is the number of ext vars
   and how long it takes to work on them
*/
	t4 = vclock ();
	table_ptr -> variable_table_header.total_allocation_time =
	     table_ptr -> variable_table_header.total_allocation_time + t4 - t3;
	table_ptr -> variable_table_header.total_allocated_size =
	     table_ptr -> variable_table_header.total_allocated_size + vsize;
	table_ptr -> variable_table_header.number_of_variables =
	     table_ptr -> variable_table_header.number_of_variables + 1;
	table_ptr -> variable_table_header.cur_num_of_variables =
	     table_ptr -> variable_table_header.cur_num_of_variables + 1;
	var_ptr -> variable_node.time_allocated = clock ();
	a_node_ptr = var_ptr;


ERROR:						/* nonlocal label for condition handlers */
	return;

/* NOTE the code removed from the following space was documented out
   for the following reason and was deleted to clean up the code.

   Following is the code  that was used to automatically reallocate
   the variable's storage if the new size is larger than the old size.
   It was removed because it had bad side effects-- programs saved 
   pointers to the original storage and got faults at some indefinite
   time after the reallocation.

  It is impossible to guarantee that a user will not reference the 
  reallocated area via an automatic pointer.

*/

/* this fuction performs the hashing alogorithm */

HASH:
     proc () returns (fixed bin (6));


dcl	tname		char (16);
dcl	w		(4) fixed bin (30) based (addr (tname));
dcl	hash_temp		fixed bin (71);
dcl	hash_index	fixed bin (6);


	tname = a_ext_name;
	hash_temp = multiply ((w (1) + w (2)), (w (3) + w (4)), 71);
	hash_index = bin (substr (unspec (hash_temp), 31, 6), 6);

	return (hash_index);


     end HASH;

/* this funciton looks through a index into the hash table for a specific name
   it expects a_ext_name and table_ptr to be set elsewhere. it sets found and 
   a_node_ptr if the name is found on the name list
*/
LOOKUP:
     proc ();


	found = "0"b;

	table_ptr -> variable_table_header.number_of_searches =
	     table_ptr -> variable_table_header.number_of_searches + 1;
	t1 = vclock ();
	loop_count = 0;
	do var_ptr = table_ptr -> variable_table_header.hash_table (hash_index)
	     repeat (var_ptr -> variable_node.forward_thread) while (var_ptr ^= null ());
	     loop_count = loop_count + 1;
	     if loop_count > 200
	     then do;
		a_code = error_table_$defs_loop;
		return;
	     end;
	     table_ptr -> variable_table_header.number_of_steps =
		table_ptr -> variable_table_header.number_of_steps + 1;
	     if var_ptr -> variable_node.name_size = nchars
	     then if var_ptr -> variable_node.name = a_ext_name
		then do;
		     t2 = vclock ();		/* done searching */
		     table_ptr -> variable_table_header.total_search_time =
			table_ptr -> variable_table_header.total_search_time + t2 - t1;
		     a_node_ptr = var_ptr;
		     found = "1"b;
		     return;
		end;
	end;					/* of searching */

	t2 = vclock ();
	table_ptr -> variable_table_header.total_search_time =
	     table_ptr -> variable_table_header.total_search_time + t2 - t1;

	return;


     end LOOKUP;

/* END LOCAL ROUTINES ------------------------------------------------- */

/* EXTERNAL ENTRYPOINTS ----------------------------------------------- */

/* locate is used to find ext vars on the external var list and returns a ptr
   to them in a_node_ptr; It expects the var to exist as well as the var table

   parameters
   a_ext_name       variable name to be found
   a_sb		stack base ptr of callers stack
   a_node_ptr	ptr to variable (Output)
   a_code		system error code

*/

locate:
     entry (a_ext_name, a_sb, a_node_ptr, a_code);


	a_node_ptr = null ();
	a_code = 0;
	table_ptr = a_sb -> stack_header.sys_link_info_ptr;

	if table_ptr = null ()
	then do;
NOT_FOUND:
	     a_code = error_table_$no_ext_sym;
	     return;
	end;

	nchars = length (rtrim (a_ext_name));
	hash_index = HASH ();
	call LOOKUP ();				/* now try to find the variable */
	if a_code ^= 0
	then return;				/* some error has occured */
	if ^found
	then goto NOT_FOUND;			/* the symbol was not found */

	return;


/* for_linker
   This entry must be called when in ring 0 and only in ring 0.
   If a multi_segment variable is to be created, this entry traps out
   to fortran_storage_ in the user ring, which in turn calls
   set_ext_variable_$allocate.

   parameters
     a_ext_name      the name of the variable (Input)
     a_init_info_ptr a pointer to initialization informatio for the 
		 variable (Input)
     a_sb		 a pointer to the targets stack header ie in the
		 ring where the link was faulted (Input)
     a_seg_ptr	 pointer to the seg containing the ext reference (Input)
     a_found_sw	 specifies if the variable was found (Output)
     a_node_ptr	 a pointer to the target variable (Output)
     a_code	 a system error_code (Output)
     a_mc_ptr	 a pointer to the machine conditions for 
		 trap_caller_caller_
     a_def_ptr	 passed on to trap_caller_caller_
     a_type_ptr	 passed on to trap_caller_caller_
     a_link_ptr	 passed on to trap_caller_caller_
*/

for_linker:
     entry (a_ext_name, a_init_info_ptr, a_sb, a_seg_ptr, a_found_sw, a_node_ptr, a_code, a_mc_ptr, a_def_ptr, a_type_ptr,
	a_link_ptr);

	called_by_linker = "1"b;
	is_heap_link = "0"b;
	seg_ptr = a_seg_ptr;
	where_to_allocate_ptr = a_sb -> stack_header.user_free_ptr;
	table_ptr = a_sb -> stack_header.sys_link_info_ptr;

	goto JOIN;

/* star_heap
   allocates and initializes heap variables or finds them on the
   existing heap list and returns a pointer to the target in a_node_ptr

   paramters
     a_ext_name      the name of the variable (Input)
     a_init_info_ptr a pointer to initialization information for the 
		 variable (Input)
     a_sb		 a pointer to the targets stack header ie in the
		 ring where the link was faulted (Input)
     a_seg_ptr	 pointer to the seg containing the ext reference (Input)
     a_found_sw	 specifies if the variable was found (Output)
     a_node_ptr	 a pointer to the target variable (Output)
     a_code	 a system error_code (Output)
*/

star_heap:
     entry (a_ext_name, a_init_info_ptr, a_sb, a_seg_ptr, a_found_sw, a_node_ptr, a_code);

/* initialize values required by the general code */

	called_by_linker = "0"b;
	is_heap_link = "1"b;
	a_found_sw = "0"b;
	a_node_ptr = null;
	seg_ptr = a_seg_ptr;
	vsize = 0;
	a_code = 0;

	on bad_area_format, area
	     begin;
		a_code = error_table_$notalloc;
		goto ERROR;
	     end;


/* check and see if we have a heap area defined 
*/

	heap_header_ptr = a_sb -> stack_header.heap_header_ptr;
	if heap_header_ptr = null ()
	then do;

/* if we do not have a heap it means we have been entered either from a non
   C program or someone is executing a C program without using main_.
   This is not nice but we set up a heap level 0 anyway....
   This is similar to heap_manager_$push_heap_level but not quite the
   same in that it is using level 0....
*/
	     a_code = 0;
	     call cu_$level_get (ring_no);		/* get ring no for Heap area owner name */
	     call heap_manager_$create_heap_for_set_ext_var (a_sb, ring_no, heap_header_ptr, a_code);
	     if a_code ^= 0 then
		return;
	end;
	if (heap_header_ptr -> heap_header.version ^= heap_header_version_1)
	then do;
	     a_code = error_table_$invalid_heap;
	     return;
	end;

	where_to_allocate_ptr = a_sb -> stack_header.heap_header_ptr -> heap_header.area_ptr;

	table_ptr = heap_header_ptr -> heap_header.heap_name_list_ptr;

	goto JOIN;

/* allows *system variable to have pointer initialization using 
   the list_init_template structure. finds or allocates *system variables.

   paramters
     a_ext_name      the name of the variable (Input)
     a_init_info_ptr a pointer to initialization information for the 
		 variable (Input)
     a_sb		 a pointer to the targets stack header ie in the
		 ring where the link was faulted (Input)
     a_seg_ptr	 pointer to the seg containing the ext reference (Input)
     a_found_sw	 specifies if the variable was found (Output)
     a_node_ptr	 a pointer to the target variable (Output)
     a_code	 a system error_code (Output)
*/

pointer:
     entry (a_ext_name, a_init_info_ptr, a_sb, a_seg_ptr, a_found_sw, a_node_ptr, a_code);


	called_by_linker = "0"b;			/* this entry called outside ring 0 */
	is_heap_link = "0"b;
	seg_ptr = a_seg_ptr;
	where_to_allocate_ptr = a_sb -> stack_header.user_free_ptr;
	table_ptr = a_sb -> stack_header.sys_link_info_ptr;
	goto JOIN;


/* END EXTERNAL ENTRYPOINTS --------------------------------------- */

/* INCLUDE FILES -------------------------------------------------- */
%include system_link_names;
%page;
%include system_link_init_info;
%page;
%include stack_header;

     end set_ext_variable_;




		    unique_bits_.pl1                11/11/89  1145.7rew 11/11/89  0804.9       10872



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


unique_bits_:
	procedure returns (bit (70));

/* function to return a unique bit string

Last modified: (date and reason)
84-08-10 by E. A. Ranzenbach to remove "unique_bits" entry per MCR6634.
11/12/73 by RE Mullen--converted to v2pl1
06/26/72 by D. M. Wells to get rid of "aligned"ness of strings to conform with documentation
coded 1/15/70		JW Gintell
*/

dcl	clock_ external entry returns(fixed bin(71));

dcl	(bit, fixed) builtin;

	return ("000000000000000001"b || bit(fixed((clock_ () ),52),52));

end unique_bits_;




		    unique_chars_.pl1               11/11/89  1145.7rew 11/11/89  0804.2       20970



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


unique_chars_:
	proc(in_bits, out_chars);

/* function to return a unique character string as in BY.15.01.
The character string is 15 characters long.
The given bit string is either a unique string or null in which
 case the function unique_bits_ is used to obtain the bit string.

Last modified: (Date and reason)
84-08-10 by E. A. Ranzenbach to remove "unique_chars" entry per MCR6634.
11/12/73 by RE Mullen, converted to v2pl1
08/08/72 by C Garman to use explicit assignment to output parameter, instead of "return(...);"
06/26/72 by D. M. Wells to get rid of "aligned"ness of strings to conform with documentation
07/17/71 by Richard H. Gumpertz to make "charsi" automatic
Coded 1/15/70			JW Gintell
*/

dcl	in_bits bit(*),
	out_chars char(15),

	table char(32) static init("BCDFGHJKLMNPQWXZbcdfghjklmnpqwxz"),

	charsi char(15),
	bit70 bit(70),

	unique_bits_ entry returns(bit(70)),
	i fixed bin(17);

dcl	(bin, bit, fixed, index, substr) builtin;

	bit70 = in_bits;		/* copy argument */

	if bit70 = (70)"0"b then bit70 = unique_bits_();

	substr(charsi, 1, 1) = "!";

	do i = 1 to 14;

	  substr(charsi,i+1,1) = substr(table,fixed(substr(bit70,i*5-4,5),5)+1,1);
	end;

	out_chars = charsi;
	return;

/* 
   entry to convert unique_character string back to bit string */

bits:
	entry(in_chars, out_bits);

dcl	in_chars char(15),
	out_bits bit(70),
	j fixed bin(5);

	out_bits = (70)"0"b;
	charsi = in_chars;

	if substr(charsi,1,1) ^= "!" then return;

	do i = 1 to 14;

	  j = index(table,substr(charsi,i+1,1));
	  if j = 0 then return;
	  else substr(bit70,i*5-4,5) = bit(bin(j-1,5),5);

	end;

	out_bits = bit70;

end unique_chars_;





		    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
