



		    expand_.pl1                     11/04/82  1915.8rew 11/04/82  1614.5      230481



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


expand_:proc(path,ent,segp1,bit_count,segp2,bit_count2,val);

	/* expand_ does the real work of implementing % include ; statements. This entry point is called 
	directly by the expand command and assembler and pl1.  Most of the actual work is done inside the 
	recursive internal procedure work. Whenever an include statement is recognized, work calls
	itself. There is no possibility of getting into an infinite loop by having an include file
	include itself because this error is checked for. There are some things that work does not do
	the first time it is called in an invocation of expand_. This is implemented by providing
	two entry points to work, one called work_first and the other called work.

	Most of the time expand_ is able to recover from errors in the ascii file it is expanding.
	Since expand_ follows sss conventions, it reflects the error code of the last serious error.
	Due to this, the caller of expand_ can't tell from the error code whether expand found
	a fatal error, since the only fatal errors are file system errors that do not allow the 
	expanded segment to be made or truncated. Therefore, a caller of expand_ should check segp2.
	if this pointer is null, then there was a fatal error, otherwise expand_ put something in the 
	expanded segment correctly(that is, expand operated correctly) even if the bit count of the
	expanded segment is zero.

	segp is a pointer that is static with respect to work to aid in the generation of error messages.

	pwork is a pointer that points to the expanded segment - it is easier to access than segp2.

	revi is at first used in finding the suffix. Later it is used with segp in error messages.

	outi is the number of characters that have been put into the expanded segment. It must be static
		with respect to work.

	suffix is a varying string that contains the suffix  that is on ent. This tells us what syntax
		to assume the ascii file is in and also helps specify names of include files.

	bit_count is the bit count of the file to be expanded.

	bit_count2 is the bit count of the expanded segment.

	segp1  is a pointer to file to be expanded. It is a parameter and is hard to access.

	segp2 is a pointer to the expanded segment. It is a parameter and is not used
		for accessing that segment inside expand_.

	val is the parameter that is the error code we want to return.

	code is what we use to find out about errors in routines we call.

	i is a variable we don't really need except for ease of understanding the program. It is a temporary.

	level is used to keep track of what level of recursion we are working on at present.

	major_init is a flag that tells us whether we are dealing with assembler or pl1 syntax."1"b means assembler syntax,
		"0"b means pl1 syntax.

	path holds the directory path name that is searched for include files before ">library_dir_dir>include"
		is searched. 
							*/

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


	dcl null builtin;
	dcl (com_err_, com_err_$suppress_name, ioa_) entry options (variable);
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin);
dcl  hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin);
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2),
     ptr, fixed bin);
	dcl (bit_count,bit_count2) fixed bin(24),(segp,segp1,segp2,pwork) ptr;
	dcl (val,code,revi,i) fixed bin(17);
	dcl (outi,level) fixed bin(17),(ent, group_id, wkent)char(32) aligned;
	dcl major_init bit(1) aligned init("0"b);
	dcl path char(168) aligned;
	dcl proj_incl_dir char(168) aligned;
	dcl proj_incl_dir_init bit(1) aligned initial("0"b);
	dcl suffix char(32) aligned varying init ("");
	dcl (error_table_$namedup,error_table_$zero_length_seg,error_table_$badsyntax,error_table_$recursion_error,
		error_table_$entlong) ext fixed bin(17);

	dcl get_group_id_$tag_star external entry returns (char(32));
	dcl hcs_$truncate_seg ext entry(ptr,fixed bin(17),fixed bin(17));

	segp2=null;
	outi,level,val,bit_count2=0;

		/* revi=reverse_index(ent,".",0); I generate code for this routine.*/
	do revi=32 by-1 while(revi>0&substr(ent,revi,1)^=".");	/* find the last suffix, if any */
	end;

			/*locate the suffix*/
	if revi>0 then do;

		i=index(substr(ent,revi)," ");

		if i=0 then i=33-revi;

		suffix = substr(ent,revi,i-1); /* get suffix*/

		end;

		else do; /* probably an error - no suffix - continue any way, though */

			revi=index(ent," "); /*find size of file name*/
			if revi=0 then revi=33;

			end;

	if suffix=".eplbsa"|suffix=".alm" then major_init="1"b;/*is it an eplbsa
						or a pl1 type expand?*/

	wkent=substr(ent,1,revi-1)||".ex"||suffix; /* generate name of expanded file*/

	if (revi+length(suffix))>30	/* if (revi-1 + 3 + length(suffix)>32 - only faster */
	then do;		/* it is an error if the new name is longer than 32 chars */

	     code=error_table_$entlong;	/* Entry too long */
	     go to error;

	     end;

	call hcs_$make_seg(path,wkent,"",11,pwork,code);	/* get expanded segment */
	if code = error_table_$namedup then call hcs_$truncate_seg(pwork,0,code);
	if pwork=null then go to error;

	segp2=pwork;		/* set parameter */

	call work_first;/* special entry point for work when it is first called*/

	bit_count2=outi*9;

	if outi=0 & val=0 then val=error_table_$zero_length_seg;

	call hcs_$set_bc(path,wkent,bit_count2,code);	/* set the bit count on the expanded segment */

	if code^=0
	then 
error:		do;

		call com_err_(code,"expand_","^a^/",wkent);

		val=code;

		end;

	/* This is where the internal procedure work begins. There are no more statements in expand_ proper. */

work:proc(nmp,nmn,checkp) recursive;

	/*
	This is where most of the work is done.
	This entry point is only used for recursive calls to work.

	The code that appears between here and the entry work_first is only executed when processing
		an include statement.

	quote is used in assembler syntax to remember what the quoting character of an acc or aci pseudo-op was.

	opcode is used in assembler syntax to get the opcode in a convenient location for checking against
	"acc","aci",and "include".

	start_item is used to remember where a statement or comment or quote begins for use in 
		diagnostics.

	i is the variable in the huge loop that looks at each character. It tells which character in the 
		present file is being looked at.

	k has two uses. 1) as a flag to tell whether we are in the midst of an identifier
		2) to remember where an identifier begins, so we will be able to look at it when we have
			come to the end of the identifier.

	n tells the number of characters in the file.

	lineno tells us which line we are presently looking at.

	start_id is used in much the same way that k is used.

	lasti is used to tell which character in the present file was the last one sent to the expanded segment.
		In order to delete some characters from the expanded segment, merely call output_text
		and then update value of lasti to skip over a part of the file being scanned.
	size is used to tell how large various identifiers are. It is usually used in conjunction with k.

	c is an easily accessable place that contains the character in the file that is presently being looked at.
		i tells where in the current file this character came from.


		There are several different states that work can be in when it considers one
		character. For example, are we inside of a comment? are we using pl1 or assembler syntax?, etc.
		These different states are implemented by four label variables, called major_state,minor_state,
		pct_break, and pct_finish. The main use of major_state is to distinguish between pl1 and ma
		syntax and also to ignore include statements inside comments and/or quoted strings.
		Minor_state is used to distinguish between processing inside and outside of an
		include statement. Pct_break is transferred to whenever a blank or tab is found 
		right after an identifier. Pct_finish is transferred to whenever the end of
		statement character is encountered if we care. Pct_break and pct_finish are only
		transferred to if we care whether we just finished an identifier or statement.
		For example, in pl1 syntax where statements begin and end is not kept track of
		except for include statements, while for eplbsa, the statements are kept track
		of.

	switch is a structure containing several flag bits. qcomment is used for deciding
		whether a possible missing quote diagnostic has been given for this quotation.
		percent_flag tells us whether we are in a percent statement in eplbsa. The
		end_file_flag tells us whether we are ready to reach the end of the file or not.
		"1"b means that, for qcomment, the diagnostic has been given, for percent_flag
		we are in an include statement, for end_file_flag, we are not ready to end the file.

	bc contains the bit count of the file being considered.

	nmp was set from i before work was called.

	nmn was set as nmp was.

	checkp points to chain_link in the previous stack frame.

	chain_link is a structure that allows us to check for recursion error. Since there are no conditionals
		in include statement processing, any loop of includes that closes on itself, of
		any length, will cause infinite recursion.
		segpt points to the include file in this level. It is used as such all during
			work.
		backpt points to chain_link in the previous stack frame. If there is no previous stack frame 
			of work, then backpt is null.
		entr contains the entry name of the current include file. It is mostly for diagnostics. The 
			reason it is in this structure is so that if the next invocation of work
			can't initiate it's include file, not only can the error message say which
			file had a file system error, but also which line in which include file caused the 
			error.
		startline contains the line on which a statement started, if we know we are at a statement.

	text is a character string consisting of the entire segment that we are processing.

	nm tells us how to find the name of the include file directly from the ascii segment
		containing the include file.

	texti is thetext, only for the previous invocation of work. It is just for the purpose 
		of using nmn and nmp to get a pointer to nm.
							*/

	dcl hcs_$terminate_noname ext entry(ptr,fixed bin(17));
	dcl find_include_file_$initiate_count entry (char (*), ptr, char (*) aligned, fixed bin (24), ptr, fixed bin (17));
	dcl quote char(1) aligned;	/* quote char for acc and aci statements in EPLBSA */
	dcl opcode char(7) varying aligned ;
	dcl (start_item,i,k,n,lineno,start_id,lasti,size) fixed bin(17);
	dcl c char(1) aligned;

	dcl  major_state     label local;

	dcl  minor_state     label local;

	dcl pct_finish       label local;

	dcl pct_break        label local;

	dcl 1 switch aligned,
		2(qcomment,percent_flag,end_file_flag) unaligned bit(1);

	dcl (indx, num_chars) fixed binary(17);		/* used in evaluating person's project */
	dcl bc fixed bin(24);
	dcl (nmp /*tells where in the segment of the previous generation the name of the
		include file for this generation is*/,nmn /*tells the number of characters in the
		name*/)fixed bin(17),checkp ptr /*links the chainof recursive calls together*/;
	dcl 1 chain_link aligned auto,
		2 segpt ptr,  /* points to the text segment*/
		2 backpt ptr,  /* points to the previous generation*/
		2 entr char(32) aligned,	/* for diagnostics */
		2 startline fixed bin(17);
	dcl 1 chain aligned based(chain_link.backpt),
		2 segptr ptr,
		2 backp ptr,
		2 entr1 char(32) aligned,
		2 startline1 fixed bin(17);
	dcl text char(n) aligned based(segpt),nm char(nmn) based(segpt),texti(nmp) char(1) based;

print_key:proc(mess1,mess2,incr);
	/*
	Print_key is used to print out most of the diagnostics for work.

	It is in charge of making sure that the header for error messages is correct at all times.

	There are two entry points,print_key and print_error. The basic difference is that print_key 
		prints out part of the include file and has a two part variable message while
		print_error just has a one part error message and is just used to give miscellaneous
		or simple error messages.
							*/

	dcl statement char(52) aligned varying;
	dcl (mess1,mess2) char(*),incr fixed bin(17),print_switch bit(1) aligned;

	print_switch="0"b;

	go to print_maybe;

print_error:entry(message);

	dcl message char(*);

	print_switch="1"b;

print_maybe:
	if segp^=segpt|revi^=level	/* Only print this message once per call to work */
				/* segp and revi are static wrt work and so remember the 
				last segment and level for which this message was typed */
	then do;

	     call ioa_("expand_: Error in ^a at level ^d.^/",entr,level);

	     segp=segpt;
	     revi=level;		/* remember the segment and level for which message typed */

	     end;

	if print_switch="0"b

	then do;
	     statement=substr(text,start_item,i-start_item+incr);	/*This makes sure I grab
								no more than 52 characters*/
	     call com_err_$suppress_name(0,"expand_","	^a (starting on line ^d) ""^a"" ^a.^/",mess1,startline,
		statement,mess2);
	     end;

	else
	     call com_err_$suppress_name(0,"expand_","	^a on line ^d.^/	Expansion will continue.^/",message,lineno);

	if val=0 then val=error_table_$badsyntax;

end print_key;

output_text:proc;

	dcl out_text char(j) based(pwork),(j,nout) fixed bin(17);

	nout=i-lasti-1;

	if nout<=0 then return;

	j=outi+nout;

	substr(out_text,outi+1,nout)=substr(text,lasti+1,nout);

	outi=j;

end output_text;

	segpt=addr(checkp->segptr->texti(nmp)); /* find out where nm begins*/

	entr=nm||".incl"||suffix;

	backpt=checkp;
		/*perform search - first of wdir then of projects include dir, then of >ldd>include*/

	if (nmn+length(suffix))>27		/* if length(nm||".incl"||suffix)>32 */
	then do;

	     code=error_table_$entlong;	/* Entry too long. */
	     go to too_long;

	     end;

	call find_include_file_$initiate_count (substr (suffix, 2), chain.segptr, entr, bc, segpt, code);
	if segpt=null then do;

too_long:	     if segp^=chain.segptr | revi^=level
	     then do;


		call ioa_("expand_: Error in ^a at level ^d.^/",chain.entr1,level);

		segp = chain.segptr;
		revi = level;		/* write header for error messages and remember */

		end;

	     call com_err_(code,"	expand_","^a, due to include statement starting on line ^d.^/",
		entr,chain.startline1);

	     val=code;

	     return;
	     end;

	do i=1 by 1 while(chain.backp^=null);
			/* check for recursion error - don't check against original source*/

		if chain.segptr=chain_link.segpt
		then do;

		     val=error_table_$recursion_error;	/* fatal error*/

		     call com_err_(0,"expand_","Recursion of include files starting with ^a is ^d levels deep.^/",
		     entr,i);

		     return;
		     end;

		chain_link.backpt=chain.backp;

	end;

	chain_link.backpt=checkp;

	go to start_work;

work_first:entry;

	backpt=null;
	segpt=segp1;
	entr=ent;
	bc=bit_count;

	segp=null;
	revi=0;		/*revi and segp are used by the print_key and print_error routines to decide
			whether it is necessary to type out the name of the file and the level
			number for an error message - need a variable that tis static with respect
			to work */


start_work:


	start_id,start_item,k,lasti=0;
	percent_flag,end_file_flag = "0"b;	/* flags that are used to determine state */
	if bc<9 then go to term_seg;

	n=divide(bc,9,35,0);

	level=level+1;

	if major_init="1"b
	then do;

		major_state=eb_major;
		minor_state=eb_new_stmt;
		pct_break=eb_have_opcode;
		pct_finish=eb_early_eos;

	     end;

	else do;

		major_state=any;
		minor_state=usual;

	     end;


	lineno,startline=1;

		/* Initialization all done - ready for work loop */

loop:	do i=1 to n;

	c=substr(text,i,1);  /* this is a huge loop that looks at each character in the file. If we look
			so hard, we need easy access to the character under consideration*/

	go to major_state;/* a label variable is more efficient than a constant transfer vector*/

any:	/* major_state - normal running */

	if c = "/"
	then if i<n
		then if substr(text,i+1,1)="*"	/*is this the beginning of a comment?*/
			then do;

				major_state=in_commnt;
				end_file_flag = "1"b;	/* can't end this way */

				if ^percent_flag		/* if we are not in a percent statement */
				then do;
				     startline=lineno;
				     start_item=i;
				     end;
				else if start_id ^= 0 then go to pct_break;

				i=i+1;	/* Skip over "*" unless it interfers with pct_break*/

				go to not_nl;

				end;

	go to minor_state;

in_commnt:	/* major_state - inside a comment */

	if c="*"
	then if i<n
	     then if substr(text,i+1,1)="/"
		then do;

		     i=i+1;	/* Skip over "/" */
		     major_state=any;
		     end_file_flag = "0"b;		/* can end this way */

		     go to not_nl;

		     end;

	go to next;

in_quote:	/* major_state - inside a quoted string */

	if c=""""
	then do;

	     if i<n
	     then if substr(text,i+1,1)=""""
		then do;

		     i=i+1;	/* Skip over quoted quote for unpaired quote diagnostic */

		     go to not_nl;

		     end;
	     major_state=any;
	     end_file_flag="0"b;

	     end;

	if c="
"		/* newline - check for possible error */
	then if qcomment="0"b
	     then do;

		if suffix=".pl1"
		then do;

		     if (i-start_item)>256
		     then 

print_miss_quote:		do;

			qcomment="1"b;

			call print_key("Probable missing quote","",1);

			end;

		     end;

		else go to print_miss_quote;

		end;

	go to next;

	/* Minor states - only transferred to by major state any */

usual:	/* minor_state - not in a % statement or comment or quote*/

	if c = "%"

	then do;

		call output_text;

		startline=lineno;
		start_item=i;	/* used in diagnostics */
		start_id=0;
		pct_break=form_include;
		pct_finish=null_pct;
		minor_state=in_pct;
		percent_flag="1"b;		/* we are now in a percent statement in pl1 syntax */

		go to not_nl;

		end;

	else if c=""""
		then do;

		major_state=in_quote;
		end_file_flag="1"b;
		start_item=i;
		startline=lineno;
		qcomment="0"b;

		go to not_nl;

		end;

	go to next;

in_pct:	/* minor_state - inside % statement. Don't ignore quoted strings anymore */

	if c=";"
	then go to pct_finish;

	if c <= " "	/* checks for blank,newline,tab all at once */
	then if start_id ^= 0
		then go to pct_break;
		else go to next;

	if start_id=0 then start_id=i;	/* we are either at the beginning or in the middle of an atom*/

	go to not_nl;

	/* Termination states for processing "%" */

have_name:	/* pct_finish - have now seen "include" and a name and maybe more */

	if start_id ^= 0
	then call print_key("Extra items in ""include"" statement
	","ignored",1);

recurse:	call work(k,size,addr(chain_link));

	go to pct_clean;

null_pct:	/* pct_finish - null % statement */

	if start_id^=0
	then go to bad_pct;

pct_clean:
	lasti=i;
	minor_state=usual;
	percent_flag="0"b;		/* we are out of the percent statement */
	start_id=0;

	go to not_nl;

bad_pct:	/* pct_finish - illegal */

	call print_key("Illegal construction","deleted",1);

	go to pct_clean;	/* clean up anyway */

finish_name:	/* pct_finish - name ends with a ";" */

	k=start_id;
	size=i-start_id;

	go to recurse;

	/* States to process break characters */

form_include:	/* pct_break - have gotten "include" */

	if substr(text,start_id,i-start_id)="include"
	then do;

	     pct_break=form_name;
	     pct_finish=finish_name;

	     end;

	else do;

	     pct_break=next;	/* ignore any future break characters */
	     pct_finish=bad_pct;	/* Yell when the statement is finished*/

	     end;

fin_break:
	start_id=0;

	if c="/"
	then do;

	     i=i+1;	/* didn't increment i to skip * so I could use i in substr above*/

	     go to not_nl;

	     end;

	go to next;

form_name:	/* pct_break - have just received a break char for the name - remember where name is */

	k=start_id;
	size=i-start_id;
	pct_break=next;	/*ignore any further breaks */
	pct_finish=have_name;

	go to fin_break;


/* New states for recognizing "include" pseudo-op in EPLBSA syntax */

eb_major: /* major_state - processing normal statement */

	if c = ";"
	then go to pct_finish;

	if c = "
"		/* newline */
	then go to pct_finish;		/* End of statement delimiters */

	go to minor_state;		/* something else, see who has his hand up */

eb_ascii: /* major_state - handling quoted string in ACC or ACI pseudo-ops */

	if c = quote
	then if i < n
	     then if substr(text,i+1,1) = quote
		then i = i + 1;			/* doubled quote means insert quote character */
		else do;

		     major_state=eb_major;
ignore_to_EOS:	     pct_finish = eb_normal_eos;	/* at EOS ignore whatever opcode was */
ignore_rest_of_stmt:	     minor_state = not_nl;		/* at EOS do whatever opcode demands */

		     end;

	go to next;


eb_new_stmt: /* minor_state */

	if c = ":"
	then do;

	     if k = 0
	     then do;

err_c:		call print_error("Error in syntax involving <"||c||">");

		end_file_flag = "1"b;	/* we are in a statement - cannot end without eos */

		end;

	     else k=0;			/* legitimate label, reset and restart */

	     go to not_nl;

	     end;

eb_get_opcode: /* minor_state */

	if c = "%"
	then if k ^= 0
	     then go to err_c;		/* a % in the middle of an identifier - comment and continue */
	     else do;

		start_id = i;		/* save */
		i = start_item;		/* start_item is the beginning of the present statement */
		call output_text;
		i = start_id;		/* restore */
		lasti = i;		/* drop "%" from segment */

		end_file_flag = "1"b;	/* we are in a statement */

		go to not_nl;

		end;

	if c = """"
	then if k ^= 0
	     then go to err_c;		/* .. */
	     else do;

		end_file_flag = "1"b;	/* we are in statement */

		go to ignore_rest_of_stmt;

		end;

	if c <= " "	/* checks for blank, tab all at once */
	then if k ^= 0
	     then go to pct_break;
	     else go to not_nl;

	if k=0 then do;
		k=i;
		end_file_flag="1"b;

		end;

	go to not_nl;

eb_get_ascii_quote: /* minor_state - looking for quoting char */

	if c > " "	/* not blank,tab,etc */
	then do;

	     quote = c;
	     major_state = eb_ascii;

	     end;

	go to not_nl;

eb_early_eos: /* pct_finish */

	if k ^= 0
	then do;

	     size=i-k;

	     if size <= 7
	     then do;

		opcode = substr(text,k,size);

		if opcode ^= "acc"
		then if opcode ^= "aci"
		then if opcode ^= "include"	/* if opcode^="acc"&opcode^="aci"&opcode^="include" */
		then 

eb_normal_eos: /* pct_finish */
			do;

			start_item = i + 1;
			if c = "
"				/* newline*/
			then startline = lineno + 1;		/* For diagnostics */
			else startline = lineno;		/* Rarely */
			k = 0;
			major_state=eb_major;
			end_file_flag="0"b;		/* end of statement - we can end file now */
			minor_state = eb_new_stmt;
			pct_break = eb_have_opcode;
			pct_finish = eb_normal_eos;

			go to next;

			end;

	/* error, opcode requiring operand followed by EOS */

		call print_error("Opcode "||opcode||" requires operand");

		end;
	     end;

	go to eb_normal_eos;	/* random opcode - don't care */

eb_include_eos: /* pct_finish */

	if k^=0 & size=0 then size=i-k;

eb_include_eos_x: /* pct_finish */

	/* include statement completed, now the fun begins */

	start_id = i;		/* save value */
	i = start_item;		/* fudge for output_text */

	call output_text;

	if k=0
	then call print_error("Segment-name missing from ""include"" statement");
	else call work(k,size,addr(chain_link));		/* recurse */

	i = start_id;
	lasti = i;
	go to eb_normal_eos;

eb_have_opcode: /* pct_break */

	size = i - k;
	if size <= 7
	then do;

	     opcode = substr(text,k,size);

	     if opcode = "acc"
	     then do;

set_acc:		minor_state=eb_get_ascii_quote;	/* looking for quote */
		go to next;

		end;

	     if opcode = "aci"
	     then go to set_acc;

	     if opcode = "include"
	     then do;

		size=0;
		k = 0;		/* start collecting */
		pct_finish = eb_include_eos;
		minor_state = eb_get_opcode;		/* don't look for labels */
		pct_break = eb_have_include_name;

		go to not_nl;

		end;
	     end;

	/* we're not interested, ignore to EOS */

	go to ignore_to_EOS;

eb_have_include_name: /* pct_break */

	if size=0 then if k^=0	/* if size=0 & k^=0 */
	then do;

	     size=i-k;

	     minor_state = not_nl;	/* leave name undisturbed */
	     pct_finish = eb_include_eos_x;

	     end;

	go to not_nl;

/* End of loop, all states described */

next:	if c="
"		/*newline*/
	then lineno=lineno+1;

not_nl:	end loop;

	if ^(end_file_flag | percent_flag)
	then call output_text;
	else do;
	     start_id=start_item;	/* Set variables for call to print_key */
	     start_item = i;	/* Save for call to output_text */
	     i = start_id;		/* Only move up to before error */

	     call output_text;	/* copy out any characters before error */

	     i = start_item;	/* restore */
	     start_item = start_id;

	     call print_key("Unbalanced comment or quote or improper ""%"" sequence
	","deleted",0);

	     end;

	level=level-1;

term_seg:
	if level^=0
	then do;
	     call hcs_$terminate_noname(segpt,code);
	     if code^=0
	     then do;
		val=code;
		call com_err_(code,"expand_","^a^/",entr);
		end;
	     end;

end work;
end expand_;




		    find_source_file_.pl1           06/09/89  1002.8rew 06/09/89  0808.5       62820



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-01-30,JRGray), approve(89-04-17,MCR8064), audit(89-04-18,Huen),
     install(89-06-09,MR12.3-1055):
     Modified to work with explicit archive component pathnames.
                                                   END HISTORY COMMENTS */


/* format: style4,indattr,ifthenstmt,ifthen,^indcomtxt,idind33 */

find_source_file_:
     proc (p_pathname, p_suffix, p_source_name, p_source_ptr, p_source_bit_count, p_code);

/* DESCRIPTION:

         Find  a source file given a pathname (including archive component 
     pathname) and optional suffix to apply to the entryname portion.  The
     results given back to the caller  are the sourcename, pointer to, and
     bit count of the source file.  A  status code is returned to indicate
     a fatal error; it only indicates a fatal error if it   is   non-zero
     on   return.      There   are   three   entrypoints:
     find_source_file_, $look_in_wdir, and $search_path.  The first looks only
     where its input arguments tell it.  $look_in_wdir will use the processes'
     current  working_dir  if  the  first check fails.  The $search_path entry
     will only use the search path specified in the argument list.
*/

/* HISTORY:

Written by Melanie Weaver, 07/12/83:  based on a version by
	  J. R. Gray, 04/25/83.
Modified:
08/18/83 by S. Herbst: fix bug that only found segs in wdir.
08/29/83 by Lee A. Newcomb: add $search_paths entry to implement probe
	  search paths, see MCR 6240 as amended.
*/
%page;
/* START OF DECLARATIONS */
/* Parameter */
dcl  (
     p_pathname		        char (*),		/* full pathname of source file to find */
     p_suffix		        char (*),		/* (optional) suffix to be apply */
     p_search_list_name	        char (*),		/* name of search list to use */
     p_source_name		        char (*),		/* entryname of the file found */
     p_source_ptr		        ptr,		/* pointer to the file found */
     p_source_bit_count	        fixed bin (24),	/* size of the file found */
     p_code		        fixed bin (35)	/* status code, ^= 0 only error occurred */
     )			        parameter;

/* Automatic */
dcl  (
     component_name		        char (32),		/* archive component name. */
     dir_name		        char (528),		/* curr. dir to look in, 528 max. depth */
     entry_name		        char (32),
     ref_dir		        char (528),		/* only used in $search_path entry */
     working_dir_name	        char (528)		/* only used in $look_in_wdir */
     )			        automatic;

/* Builtin */

dcl  null			        builtin;

/* Entry */
dcl
     expand_pathname_$component_add_suffix entry (char (*), char (*), char (*), char (*), char (*), fixed bin (35)),
     get_wdir_		        entry () returns (char (168)),
     initiate_file_$component	        entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)),
     search_paths_$find_dir	        entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35));


/* END OF DECLARATIONS */
%page;
/* find_source_file_:
/*      proc (p_pathname, p_suffix, p_source_name, p_source_ptr, p_source_bit_count, p_code); */

	call COMMON_INIT ();			/* init output params. & parse p_pathname */
	if p_code ^= 0 then return;			/* will be zero if no error */

	call initiate_file_$component (dir_name, entry_name, component_name, R_ACCESS, p_source_ptr, p_source_bit_count, p_code);
	return;

/* end find_source_file_; */


look_in_wdir:
     entry (p_pathname, p_suffix, p_source_name, p_source_ptr, p_source_bit_count, p_code);

/* do the same as the main entry, but look in the working directory */
/* if we do not find the file where p_pathname says it is */

	call COMMON_INIT ();			/* init output params. & parse p_pathname */
	if p_code ^= 0 then return;			/* will be zero if no error */

	call initiate_file_$component (dir_name, entry_name, component_name, R_ACCESS, p_source_ptr, p_source_bit_count, p_code);
	if p_code = 0 then return;

/* if we get here, we need to look in the working directory */

	working_dir_name = get_wdir_ ();
	if working_dir_name ^= dir_name then do;	/* only do if not dup. effort */
	     call initiate_file_$component (working_dir_name, entry_name, component_name, R_ACCESS, p_source_ptr, p_source_bit_count, p_code);
	     if p_code = 0 then return;
	end;

	if component_name ^= "" then			/* look for unarchived source in working_dir */
	     call initiate_file_$component (working_dir_name, component_name, "", R_ACCESS, p_source_ptr, p_source_bit_count, p_code);

	return;

/* end find_source_file_$look_in_wdir; */
%page;
search_path:
     entry (p_pathname, p_suffix, p_search_list_name, p_source_name, p_source_ptr, p_source_bit_count, p_code);

/* This entry only uses the search list given to find the source file. */
/* This is currently being added for support of the probe search list. */

	call COMMON_INIT ();			/* get entryname to look for */
	if p_code ^= 0 then return;			/* will be zero if no error */

/* set the ref_dir from dir_name so dir_name will be the resultant dir */

	ref_dir = dir_name;
	call search_paths_$find_dir (p_search_list_name, null (), entry_name, ref_dir, dir_name, p_code);
	if p_code = 0 then do;
	     call initiate_file_$component (dir_name, entry_name, component_name,
		R_ACCESS, p_source_ptr, p_source_bit_count, p_code);
	     if p_code = 0 then return;
	end;

	if component_name = "" then return;

/* couldn't find archive?, look for unarchived source */
	call search_paths_$find_dir (p_search_list_name, null (), component_name, ref_dir, dir_name, p_code);
	if p_code ^= 0 then return;

	call initiate_file_$component (dir_name, component_name, "", R_ACCESS, p_source_ptr, p_source_bit_count, p_code);
	return;

/* end find_source_file_$search_path; */




COMMON_INIT:
     proc ();

/* This procedure parses the input pathname into its directory and entryname */
/* portions.  If the input is an archive pathname, we return a status code   */
/* until support for them is added.  First, all output parameters are        */
/* initialized, just for safety.				       */

	p_source_name = "";
	p_source_ptr = null;
	p_source_bit_count = 0;

	call expand_pathname_$component_add_suffix (p_pathname, p_suffix, dir_name, entry_name, component_name, p_code);
	if p_code ^= 0 then return;			/* bad input */

	if component_name ^= "" then p_source_name = component_name;
	else p_source_name = entry_name;
     end COMMON_INIT;


/* INCLUDE FILES start next page */
%page;
%include access_mode_values;


     end find_source_file_;




		    initiate.pl1                    11/20/86  1400.7rew 11/20/86  1148.6       62541



/****^  ***********************************************************
        *                                                         *
        * 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 allow initiation of MSFs by initiating component 0 of the MSF.
                                                   END HISTORY COMMENTS */


initiate: in: proc;

/* The initiate command:

	initiate path {reference_names} {-control_args}

Rewritten 01/11/80 by S. Herbst */


%include branch_status;

dcl names (99 /* arbitrary */) char (32) aligned based (names_ptr);

dcl arg char (arg_len) based (arg_ptr);
dcl (dn, act_dn) char (168);
dcl (en, act_en, refname) char (32);

dcl type fixed bin (2);
dcl bc fixed bin (24);

dcl area area based (area_ptr);

dcl (all_sw, chase_sw, force_sw, forced, got_path, got_refname) bit (1);
dcl (long_sw, second_refname, some_args) bit (1);

dcl (area_ptr, arg_ptr, names_ptr, seg_ptr) ptr;

dcl (arg_count, arg_len, i, j, names_count, segno) fixed bin;
dcl code fixed bin (35);

dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$dirseg fixed bin (35) ext;
dcl error_table_$namedup fixed bin (35) ext;
dcl error_table_$segknown fixed bin (35) ext;

dcl active_fnc_err_ entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl ioa_ entry options (variable);
dcl term_$single_refname entry (char (*), fixed bin (35));

dcl (addr, addrel, baseno, bin, fixed, null, rtrim, substr) builtin;

dcl cleanup condition;
/**/
	call cu_$af_return_arg (arg_count, null, 0, code);
	if code = 0 then do;
	     call active_fnc_err_ (0, "initiate", "Cannot be called as an active function.");
	     return;
	end;

	all_sw, force_sw, long_sw, some_args = "0"b;
	chase_sw = "1"b;
	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if substr (arg, 1, 1) ^= "-" then some_args = "1"b;

	     else if arg = "-all" | arg = "-a" then all_sw = "1"b;
	     else if arg = "-brief" | arg = "-bf" then long_sw = "0"b;
	     else if arg = "-long" | arg = "-lg" | arg = "-s" then long_sw = "1"b;
	     else if arg = "-chase" then chase_sw = "1"b;
	     else if arg = "-no_chase" then chase_sw = "0"b;
	     else if arg = "-force" | arg = "-fc" then force_sw = "1"b;
	     else if arg = "-no_force" | arg = "-nfc" then force_sw = "0"b;
	     else do;
		call com_err_ (error_table_$badopt, "initiate", "^a", arg);
		return;
	     end;
	end;

	if ^some_args then do;
	     call com_err_$suppress_name (0, "initiate",
		"Usage:  initiate path {reference_names} {-control_args}");
	     return;
	end;

	names_ptr = null;
	got_path, got_refname, second_refname = "0"b;
	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if substr (arg, 1, 1) = "-" then go to NEXT_ARG;

	     if ^got_path then do;
		call expand_pathname_ (arg, dn, en, code);
		if code ^= 0 then do;
		     call com_err_ (code, "initiate", "^a", arg);
		     return;
		end;
		got_path = "1"b;

		if all_sw then do;
		     got_refname = "1"b;
		     area_ptr = get_system_free_area_ ();

		     on condition (cleanup) call clean_up;

		     call hcs_$status_ (dn, en, fixed (chase_sw, 1), addr (branch_status), area_ptr, code);
		     if code ^= 0 then do;
			call com_err_ (code, "initiate",
			     "Unable to get names of ^a^[>^]^a", dn, dn ^= ">", en);
			return;
		     end;
		     names_ptr = addrel (area_ptr, branch_status.names_rel_pointer);
		     names_count = bin (branch_status.number_names);
		     do j = 1 to names_count;
			refname = names (j);	/* initiate by each name on seg */

			call init;
		     end;
		end;
	     end;
	     else do;				/* reference name specified */
		if got_refname then second_refname = "1"b;  /* err msg for first refname only */
		got_refname = "1"b;
		refname = arg;

		if ^all_sw then call init;

		else do;
		     do j = names_count by -1 to 1 while (names (j) ^= refname); end;
						/* only do those names not already init'd by -all */
		     if j = 0 then call init;
		end;
	     end;
NEXT_ARG:	end;

	if ^got_refname then do;
	     refname = en;				/* no refnames specified: initiate by entryname */

	     call init;
	end;

RETURN:	if all_sw then call clean_up;
	return;
/**/
init: proc;

/* This internal procedure initiates a segment by one reference name */

	forced = "0"b;

	act_dn = dn;
	act_en = en;
INITIATE:	call hcs_$initiate (act_dn, act_en, refname, 0, 0, seg_ptr, code);
	if code ^= 0 & code ^= error_table_$segknown then  /* OK if seg already known by same name */
	     if code = error_table_$namedup then	/* a different seg known by this name */
		if force_sw & ^forced then do;
		     forced = "1"b;
		     call term_$single_refname (refname, code);  /* terminate old reference to refname */
		     if code ^= 0 then call com_err_ (code, "initiate",
			"Unable to terminate reference name ^a", refname);
		     else go to INITIATE;
		end;
		else call com_err_ (code, "initiate", "^a", refname);
	     else if code = error_table_$dirseg then do;
		call hcs_$status_minf (dn, en, 1, type, bc, code);
		if code = 0 & type = 2 & bc > 0 then do;
		     act_dn = rtrim (dn) || ">" || en;
		     act_en = "0";
		     goto INITIATE;
		end;
		else do;
		     call com_err_ (error_table_$dirseg, "initiate",  "^a^[>^]^a", dn, dn ^= ">", en);
		     go to RETURN;
		end;
	     end;
	     else do;
		if ^second_refname then call com_err_ (code, "initiate", "^a^[>^]^a", dn, dn ^= ">", en);
		if seg_ptr = null then go to RETURN;	/* can't initiate the segment at all */
	     end;

	else if long_sw then do;			/* success */
	     segno = bin (baseno (seg_ptr), 17);
	     call ioa_ ("^a>^a initiated with segment number ^o", dn, en, segno);
	     long_sw = "0"b;			/* print only for first refname */
	end;

end init;




clean_up: proc;

	if names_ptr ^= null then free names in (area);
	names_ptr = null;

end clean_up;


end initiate;




		    link_unsnap_.pl1                11/04/82  1915.8rew 11/04/82  1614.6       62568



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


/* LINK_UNSNAP is a proceedure to unsnap links in a combined linkage section. */
/* it also gives a warning and unsnaps trap before link linkage */
/* Modification record: 				*/
/* first coded by M.A.Meer and completed 10/69 */
/* converted to v2 PL/I and changed to validate the linkage template	  */
/* pointer in the linkage section header (to get around a bug in HC)	*/
/* by D. M. Wells on 1974.05.02 (MCR 476 - part iii)		*/
/* 11/6/74 by S. Webber to allow lots to begin other than at the base of a segment */
/* 5/17/76 by M. Weaver to check for links to separate static */
/* 6/11/76 by M. Weaver to fix bug that unsnaps almost all links */

link_unsnap_: proc (lotptr, isotptr, linkageptr, hcsc, high_seg);

dcl (addrel, baseno, bit, bin, fixed, null, rel) builtin;
dcl  term_segno bit (15) aligned;			/* Seg. no. of seg. to be discarded. */
dcl  term_link_segno bit (15) aligned;			/* Seg. no. of linkage to be discarded. */
dcl  term_static_segno bit (15) aligned;		/* seg. no. of static to be discarded */
dcl  sep_static_sw bit (1) aligned;			/* ON if static is separate from linkage */
dcl  bptr bit (72) aligned based;
dcl  based_ptr ptr based;

dcl (lotptr,					/* pointer to linkage offset tabel */
     linkageptr,					/* pointer to linkage section to be discarded */
     headptr,					/* pointer to beginning of block -- header */
     defstartptr,					/* pointer to beginning of definition section for this block */
     linkstartptr,					/* pointer to beginning of links in this block */
     itsptr,					/* pointer to a link -- its pair */
     vlp,						/* pointer to virgin linkage section */
     isotptr,					/* pointer to static offset table */
     nxtblkptr) ptr;				/* pointer to next block in this section */

dcl (hcsc,					/* hard core segment count */
     segno,
     hard_core_seg_count,
     high_seg) fixed bin (17);			/* highest segment number used minus hcsc */
dcl  t_segno fixed bin (18);


dcl  fword fixed bin (35) based (lotp);			/* useful way of addressing a word */


dcl (relbeginptr,					/* relative ptr to beginning of linkage section to be discarded */
     block_end,					/* rel ptr to end of links in this block */
     rel_end_ptr) bit (18) aligned;			/* end of linkage section to be discarded */

dcl (static_relbeginptr,				/* relative ptr to beginning of static to be discarded */
     static_rel_end_ptr) bit (18) aligned;		/* end of static section to be discarded */



%include its;
%include lot;
%include linkdcl;

/*  */


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

	hard_core_seg_count = hcsc;
	if rel (linkageptr) = (18)"1"b then do;		/* initialize for no linkage section to be discarded */
	     term_segno = bit (bin (baseno (linkageptr), 15, 0), 15);
	     headptr = null ();
	     relbeginptr = "0"b;
	     rel_end_ptr = "0"b;
	     term_link_segno = "0"b;
	     sep_static_sw = "0"b;
	end;
	else do;					/* for segments with linkage sections to be discarded */
	     headptr = linkageptr;			/* header pointer for linkage section to be discarded */
	     relbeginptr = rel (headptr);		/* rel ptr to beginning of linkage section to be discarded */

/* first set up variables relating to linkage to be discarded */

	     rel_end_ptr = bit (bin (bin (headptr -> header.block_length, 18)+bin (relbeginptr, 18)-1, 18));
	     term_segno = bit (bin (headptr -> header.stats.segment_number, 15, 0), 15); /* segment to be discarded */
	     term_link_segno = bit (bin (baseno (headptr), 15, 0), 15); /* segment number of linkage to be discarded */
	     t_segno = bin (term_segno, 18);		/*  see if we have a separate static section allocated */
	     if isotptr -> isot1 (t_segno).flags.fault = "11"b then sep_static_sw = "0"b;
	     else if isotptr -> isot.isp (t_segno) = lotptr -> lot.lp (t_segno) then sep_static_sw = "0"b;
	     else do;
		sep_static_sw = "1"b;
		static_relbeginptr = rel (isotptr -> isot.isp (t_segno));
		static_rel_end_ptr = bit (bin (bin (headptr -> header.static_length, 18)
		     + bin (static_relbeginptr, 18) - 1, 18));
		term_static_segno = bit (bin (baseno (isotptr -> isot.isp (t_segno)), 15), 15);
	     end;
	end;

/* next fiddle with the linkage offset table to start down the combined linkage section */

	do segno = hard_core_seg_count+1 to hard_core_seg_count+high_seg;
	     if rel (lotptr -> lot.lp (segno)) ^= "0"b then do;
		headptr = lotptr -> lot.lp (segno);
		defstartptr = headptr -> header.def_ptr; /* pointer to beginning of def section */
		linkstartptr = addrel (headptr, headptr -> header.stats.begin_links); /* pointer to beginning of links */

/* check for defs in linkage section and compute end of links */

		if (baseno (linkstartptr) = baseno (defstartptr)) & (fixed (rel (defstartptr), 18) > fixed (rel (linkstartptr), 18))
		then block_end = rel (defstartptr);	/* end of links before end of block if defs follow links */
		else block_end = rel (addrel (headptr, headptr -> header.stats.block_length));
						/* end of links and end of block are the same	*/

/* GET LINK PAIRS */


		do itsptr = linkstartptr repeat (addrel (itsptr, 2)) /* loop through all ITS ptrs here	*/
			while (bin (rel (itsptr), 18) < bin (block_end, 18));
		     if itsptr -> its.its_mod ^= "100011"b then go to next_lk; /* not a snapped link */
		     if fixed (itsptr -> its.segno, 18) < hard_core_seg_count then
			go to next_lk;		/* an aos count should never get this big */

/* now check for segment or linkage section to be deleted */

		     if itsptr -> its.segno ^= term_segno
		     then do;			/* need to check more to see if should unsnap	*/
			if itsptr -> its.segno ^= term_link_segno then goto check_static;
			if itsptr -> its.offset > rel_end_ptr then goto check_static;
			if itsptr -> its.offset >= relbeginptr then goto unsnap;
						/* link is to linkage section to be discarded */
check_static:		if sep_static_sw then do;	/*  check to see if link points to separate static */
			     if itsptr -> its.segno ^= term_static_segno then goto next_lk;
			     if itsptr -> its.offset > static_rel_end_ptr then goto next_lk;
			     if itsptr -> its.offset < static_relbeginptr then goto next_lk;
			end;
			else goto next_lk;		/* no separate static */
		     end;

unsnap:		     vlp = headptr -> header.original_linkage_ptr;
		     itsptr -> bptr = addrel (vlp, bit (bin (bin (rel (itsptr), 18)-bin (rel (headptr), 18), 18))) -> bptr;

next_lk:
		end;

	     end;

	end;

	return;

     end;




		    make_object_map_.pl1            11/04/82  1915.8rew 11/04/82  1614.7       30627



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


make_object_map_:	proc(object_ptr,textl,linkl,symboll,bitcnt,code);



/*	procedure to make an object map and place it in the end of
	the object segment

	the first four arguments are given to be a ptr to the segment
	  and the lengths of the three component parts (in words)
	  the assumption is that the text begins at loc 0
	  the link at the first 0mod(2) loc after the end of  the text
	  and the symbol at the first 0mod(2) loc after then end of the link

	the map immediately follows

	the bitcnt is returned as is the code which is equal to 0 if sucessful
	and equal to 1 if there is no room for the map */

dcl	object_ptr ptr,
	(textl,linkl,symboll,code) fixed bin(17),
	bitcnt fixed bin(24);

dcl	(i,linkrel,symbolrel,maprel) fixed bin(17);
dcl	p ptr;

dcl	max_length fixed bin (17),
	hcs_$get_max_length_seg entry (ptr, fixed bin (17), fixed bin (17));

dcl	1 object_glop based(p) aligned,
	  2 idwords(0:3) bit(36) aligned,
	  2 textrel fixed bin(35),
	  2 textbc fixed bin(35),
	  2 linkrel fixed bin(35),
	  2 linkbc fixed bin(35),
	  2 symbolrel fixed bin(35),
	  2 symbolbc fixed bin(35),
	  2 maprel fixed bin(35);

dcl	(segp,map_ptr) ptr;

dcl	map_words fixed bin(17);

dcl	map_ptr_offset fixed bin(17),
	fb18 fixed bin(18) based;
/**/


	linkrel = divide(textl+1,2,17,0)*2;

	symbolrel = divide(linkrel+linkl+1,2,17,0)*2;

	maprel = symbolrel + symboll;

	call hcs_$get_max_length_seg (object_ptr, max_length, code);
	if code ^= 0 then return;

	if (maprel +11) > max_length then do;
	  code = 1;	/* no room for map */
	  return;
	end;


	p = ptr(object_ptr,maprel);		/* make ptr to map */

	do i = 0 to 3;
	p->object_glop.idwords(i) = "101010101010101010101010101010101010"b;
	end;

	p->object_glop.textrel = 0;
	p->object_glop.textbc = textl*36;
	p->object_glop.linkrel = linkrel;
	p->object_glop.linkbc = linkl*36;
	p->object_glop.symbolrel = symbolrel;
	p->object_glop.symbolbc = symboll*36;
	p->object_glop.maprel = maprel;

	bitcnt = multiply(maprel+11,36,24,0);

	code = 0;
	return;
/**/

/*	make_object_map_$tl is a special entry for use by the mst generator.  The assumptions are that the last
	  word of the segment is a pointer to the beginning of the object map, and that the current
	  structure of the map causes the first 9 words of the map to be equivalent to a
	  map which would be created for a segment consisting of a text and linkage section only
*/

tl: entry (bitcnt,segp,map_ptr,map_words,code);

	code = 0;						/* zero out error code */

	map_ptr_offset = divide(bitcnt+35,36,17,0)-1;		/* get map offset */
	map_ptr = addrel(segp,addrel(segp,map_ptr_offset)->fb18);	/* create map pointer */
	map_words = 9;					/* return map size */

	do i =0 to 3;					/* check map format */
	   if map_ptr->object_glop.idwords(i) ^= "101010101010101010101010101010101010"b then do;
	      code = 2;
	      return;
	   end;
	end;

	return;

end make_object_map_;




		    msf_prelink_.pl1                11/20/86  1400.6rew 11/20/86  1144.4      103527



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



/****^  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):
     First reference trap procedure for object multisegment files.  This
     procedure completes snapping of all inter-component links in an object
     MSF, and runs any first reference traps in the other MSF components.
                                                   END HISTORY COMMENTS */

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

msf_prelink_:
  proc (info_linkp);		/** ptr to info link    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	msf_prelink_				*/
  /***	Input:	info_linkp				*/
  /***	Function:	given a pointer to an object MSF linkage section	*/
  /***		header,  (derived from the unsnapped link passed	*/
  /***		to it), initiate each of the MSF components,	*/
  /***		combine their linkage sections if necessary, scan	*/
  /***		their linkage sections completing the snapping of	*/
  /***		any partially snapped links, and running the	*/
  /***		first reference traps of all of the other	*/
  /***		components (ie. other than the component whos	*/
  /***		firstref trap cause the procedure to be invoked	*/
  /***		in the first place.)			*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* constants */

  /* parameters */

  dcl info_linkp		ptr parameter;

  /* based */

  dcl 01 comp		(0:n_comp) aligned like component based (ctp);
  dcl 01 dh		aligned like definition_header based (dhp);
  dcl 01 lh		aligned like linkage_header based (lhp);
  dcl 01 mm		aligned like msf_map based (mmp);
  dcl system_free_area	area based (system_free_areap);

  dcl 01 component		aligned based,
       02 segp		ptr,
       02 linkp		ptr,
       02 statp		ptr,
       02 symbp		ptr;

  /* automatic */

  dcl c			fixed bin;
  dcl ctp			ptr;
  dcl dhp			ptr;
  dcl dir_name		char (168);
  dcl ec			fixed bin (35);
  dcl entry_name		char (32);
  dcl lhp			ptr;
  dcl mmp			ptr;
  dcl n_comp		fixed bin;
  dcl ring		fixed bin;
  dcl seg_no		fixed bin;
  dcl system_free_areap	ptr;

  /* procedures */

  dcl cu_$make_entry_value	entry (ptr, entry);
  dcl get_ring_		entry () returns (fixed bin (3));
  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_$link_force	entry (ptr, fixed bin, fixed bin (35));
  dcl hcs_$combine_linkage	entry (ptr, fixed bin, fixed bin (35));
  dcl initiate_file_	entry (char (*), char (*), bit (*), ptr,
			fixed bin (24), fixed bin (35));

  /* conditions */

  dcl cleanup		condition;
  dcl object_msf_damaged_	condition;

  /* builtin */

  dcl addwordno		builtin;
  dcl char		builtin;
  dcl codeptr		builtin;
  dcl hbound		builtin;
  dcl lbound		builtin;
  dcl ltrim		builtin;
  dcl min			builtin;
  dcl null		builtin;
  dcl segno		builtin;
  dcl size		builtin;
  dcl stackbaseptr		builtin;
  dcl unspec		builtin;
  dcl wordno		builtin;
  
  system_free_areap = get_system_free_area_ ();

  /* get address of start of linkage section */

  lhp = addwordno (info_linkp, info_linkp -> object_link.header_relp);

  /* get definition section header */

  dhp = lh.def_ptr;

  if dh.msf_map_relp = 0
    then signal object_msf_damaged_;

  /* get msf_map */

  mmp = addwordno (dhp, dh.msf_map_relp);

  /* set up cleanup handler for component table */

  ctp = null;

  on cleanup
    begin;
    if ctp ^= null
      then free comp in (system_free_area);
  end;

  n_comp = mm.component_count - 1;
  allocate comp in (system_free_area);

  /* get the containing directory name */

  call hcs_$fs_get_path_name (dhp, dir_name, (0), entry_name, ec);

  /* get pointers to the components */

  do c = lbound (comp, 1) to hbound (comp, 1);;
    entry_name = ltrim (char (c));
    call initiate_file_ (dir_name, entry_name, RE_ACCESS, comp (c).segp,
         0, ec);
    if ec ^= 0
      then signal object_msf_damaged_;
  end;

  /* get the linkage, static, and symbol pointers for the components,	*/
  /* combining their linkage sections as necessary		*/

  sb = stackbaseptr ();
  lotp = stack_header.lot_ptr;
  isotp = stack_header.isot_ptr;
  ring = get_ring_ ();
  
  do c = lbound (comp, 1) to hbound (comp, 1);
    seg_no = segno (comp (c).segp);
    if seg_no > stack_header.cur_lot_size
      then signal object_msf_damaged_;
    if unspec (lot.lp (seg_no)) = lot_fault
      then do;
        call hcs_$combine_linkage (comp (c).segp, ring, ec);
        if ec ^= 0
	then signal object_msf_damaged_;
      end;
    comp (c).linkp = lot.lp (seg_no);
    comp (c).statp = isot.isp (seg_no);
    comp (c).symbp = comp (c).linkp -> linkage_header.symbol_ptr;
  end;

  /* now we complete the prelinking in all of the components */

  do c = lbound (comp, 1) to hbound (comp, 1);
    call prelink_component (ctp, n_comp, c);
  end;

  /* then run the firstref_traps in each of the components, taking	*/
  /* care not to invoke msf_prelink_ again.			*/

  do c = lbound (comp, 1) to hbound (comp, 1);
    if c ^= mm.my_component		/* this will occur later anyway */
      then call execute_firstref_traps (ctp, n_comp, c);
  end;

  free comp in (system_free_area);

  return;

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


prelink_component:
  proc (ctp,			/** component table ptr (in )	*/
       n_comp,			/** component count	    (in )	*/
       c);			/** component index	    (in ) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	prelink_component				*/
  /***	Input:	component_table, component_index		*/
  /***	Function:	completes the prelinking of the links in a single	*/
  /***		components linkage section.			*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl ctp			ptr;
  dcl n_comp		fixed bin;
  dcl c			fixed bin;

  /* based */

  dcl 01 comp		(0:n_comp) aligned like component based (ctp);
  dcl 01 its_ptr		aligned like its_unsigned based (linkp);
  dcl 01 lh		aligned like linkage_header based (lhp);
  dcl 01 lk		aligned like partial_link based (linkp);
  dcl 01 vlh		aligned like virgin_linkage_header based (vlhp);

  /* automatic */

  dcl lhp			ptr;
  dcl link		fixed bin(18);
  dcl linkp		ptr;
  dcl lk_end		fixed bin;
  dcl t			fixed bin;
  dcl type		fixed bin;
  dcl vlhp		ptr;

  /* builtin */

  dcl segno		builtin;

  lhp = comp (c).linkp;
  vlhp = lh.original_linkage_ptr;

  /* calculate the number of links */

  if vlh.defs_in_link = "20"b3
    then lk_end = vlh.def_offset;
    else lk_end = vlh.linkage_section_lng;

  if vlh.first_ref_relp ^= 0
    then lk_end = min (lk_end, vlh.first_ref_relp);

  /* scan the linkage section for pre-snapped links */

  do link = vlh.link_begin 
         to lk_end - size (object_link)
         by size (object_link);

    /* get a pointer to the current link */

    linkp = addwordno (lhp, link);

    /* if it has a "47"b3 fault tag 3 rather than a "46"b3 fault tag 2 */

    if its_ptr.its_mod = FAULT_TAG_3
      then do;
        type = lk.type;
        t = lk.component;
        its_ptr.pad1 = ""b;

        /* snap text links to the object segment */

        if type = CLASS_TEXT
	then its_ptr.segno = segno (comp (t).segp);

        /* snap linkage links to the copied linkage section */

        else if type = CLASS_LINKAGE
	then do;
	  its_ptr.offset = lk.offset + wordno (comp (t).linkp);
	  its_ptr.segno = segno (comp (t).linkp);
	end;

        /* snap static links to the copied static section */

        else if type = CLASS_STATIC
	then do;
	  its_ptr.offset = lk.offset + wordno (comp (t).statp);
	  its_ptr.segno = segno (comp (t).statp);
	end;
	
        /* snap symbol links to the object segment */
        
        else if type = CLASS_SYMBOL
	then do;
	  its_ptr.offset = lk.offset + wordno (comp (t).symbp);
	  its_ptr.segno = segno (comp (t).symbp);
	end;
        else signal object_msf_damaged_;
	  
        its_ptr.its_mod = ITS_MODIFIER;
        its_ptr.ringno = get_ring_ ();
      end;
  end;

  end prelink_component;

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


execute_firstref_traps:
  proc (ctp,			/** component table ptr (in ) */
       n_comp,			/** component count	    (in )	*/
       c);			/** component index	    (in ) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	execute_firstref_traps			*/
  /***	Input:	component_table, component_index		*/
  /***	Function:	executes the firstref traps in a given component	*/
  /***		if they have not already run.			*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl ctp			ptr;
  dcl n_comp		fixed bin;
  dcl c			fixed bin;

  /* based */

  dcl call_ptr		ptr based (call_ptr_ptr);
  dcl 01 comp		(0:n_comp) aligned like component based (ctp);
  dcl 01 lh		aligned like linkage_header based (lhp);
  dcl 01 vlh		aligned like virgin_linkage_header based (vlhp);
  dcl 01 frt		aligned like fr_traps based (frtp);

  /* automatic */

  dcl call_ptr_ptr		ptr;
  dcl info_ptr_ptr		ptr;
  dcl lhp			ptr;
  dcl frtp		ptr;
  dcl linkp		ptr;
  dcl trap		fixed bin;
  dcl trap_proc		entry variable options (variable);
  dcl vlhp		ptr;

  /* there are no firstref traps or they have already run. */

  if comp (c).linkp -> its.pad4 = ""b
    then return;

  /* make sure we don't run them again */

  comp (c).linkp -> its.pad4 = ""b;

  lhp = comp (c).linkp;
  vlhp = lh.original_linkage_ptr;

  if vlh.first_ref_relp = 0
    then return;

  /* get the firstref block */

  frtp = addwordno (lhp, vlh.first_ref_relp);

  if frt.decl_vers ^= FR_TRAPS_VERSION_1
    then signal object_msf_damaged_;

  linkp = comp (c).linkp;

  do trap = 1 to frt.n_traps;
    call_ptr_ptr = addwordno (linkp, frt.trap_array (trap).call_relp);
    if frt.trap_array (trap).info_relp = 0
      then info_ptr_ptr = null;
      else info_ptr_ptr = addwordno (linkp, frt.trap_array (trap).info_relp);
    call hcs_$link_force (call_ptr_ptr, (0), ec);
    if ec ^= 0
      then signal object_msf_damaged_;

    /* don't re-run msf_prelink_ */

    if call_ptr ^= codeptr (msf_prelink_)
      then do;
        call cu_$make_entry_value (call_ptr, trap_proc);
        call trap_proc (info_ptr_ptr);
      end;
  end;

  end execute_firstref_traps;

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


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

  end msf_prelink_;




		    term_.pl1                       12/10/86  1114.4rew 12/10/86  1113.0      377820



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



/****^  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):
     Rewritten to allow termination of multisegment files and to terminate all
     components of object MSFs in appropriate circumstances.
  2) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
     audit(86-11-04,GDixon), install(86-11-20,MR12.0-1222):
     set variable_node seg ptr to null when terminating references.
  3) change(86-12-08,Elhard), approve(86-12-08,PBF7391),
     audit(86-12-09,JRGray), install(86-12-10,MR12.0-1240):
     Changed to trap segment faults while calculating link array size (by
     referencing the object segment) and free the linkage and static sections
     for faulted segments in the address space.
                                                   END HISTORY COMMENTS */


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

term_:
  proc (a_dname,			/** dirname of object   (in )	*/
       a_ename,			/** entryname of object (in ) */
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_					*/
  /***	Function:	this set of subroutines is used to terminate a	*/
  /***		segment or MSF and clean up the environment by	*/
  /***		unsnapping links that referenced it,   freeing	*/
  /***		the linkage and static sections,   closing any	*/
  /***		pl1 I/O file state blocks open for it, freeing	*/
  /***		any fortran static VLA's,   and setting all of	*/
  /***		the init_info pointers to null for any *system	*/
  /***		that refer to the segments being terminated.	*/
  /***							*/
  /*** ****************************************************************/

  /* constants */

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

  /* parameters */

  dcl a_dname		char (*) parameter;
  dcl a_ename		char (*) parameter;
  dcl a_refname		char (*) parameter;
  dcl a_segp		ptr parameter;
  dcl a_code		fixed bin (35) parameter;

  /* procedures */

  dcl find_command_$clear	entry;
  dcl fortran_storage_manager_$free
			entry (ptr);
  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_$fs_get_seg_ptr	entry (char (*), ptr, fixed bin (35));
  dcl hcs_$get_uid_seg	entry (ptr, bit (36) aligned, fixed bin (35));
  dcl hcs_$high_low_seg_count entry (fixed bin (15), fixed bin (15));
  dcl hcs_$initiate		entry (char (*), char (*), char (*),
			fixed bin (1),
			fixed bin (2), ptr, 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_$terminate_name	entry (char (*), fixed bin (35));
  dcl hcs_$terminate_noname	entry (ptr, fixed bin (35));
  dcl hcs_$terminate_seg	entry (ptr, fixed bin (1), fixed bin (35));
  dcl pathname_		entry (char (*), char (*)) returns (char (168));
  dcl plio2_$close_in_this_static
			entry (ptr, ptr, fixed bin (18));

  /* external */

  dcl error_table_$segknown	external fixed bin (35);
  dcl error_table_$seg_unknown
			external fixed bin (35);
  dcl error_table_$invalidsegno
			external fixed bin (35);
  dcl error_table_$dirseg	external fixed bin (35);

  dcl plio2_data_fsb_thread_	ptr external init (null);

  /* based */

  dcl 01 segment		(segment_count) aligned based (segsp),
       02 textp		ptr,
       02 flags		aligned,
        03 separate_static	bit (1) unaligned,
        03 mbz		bit (35) unaligned,
       02 link_segno	fixed bin (18) unsigned unaligned,
       02 link_start	fixed bin (18) unsigned unaligned,
       02 link_end		fixed bin (18) unsigned unaligned,
       02 stat_segno	fixed bin (18) unsigned unaligned,
       02 stat_start	fixed bin (18) unsigned unaligned,
       02 stat_end		fixed bin (18) unsigned unaligned;

  /* automatic */

  dcl segsp		ptr automatic;
  dcl segment_count		fixed bin automatic;
  dcl ec			fixed bin (35) automatic;

  /* conditions */

  dcl cleanup		condition;
  dcl seg_fault_error	condition;

  /* builtin */

  dcl addwordno		builtin;
  dcl baseptr		builtin;
  dcl char		builtin;
  dcl hbound		builtin;
  dcl lbound		builtin;
  dcl ltrim		builtin;
  dcl min			builtin;
  dcl null		builtin;
  dcl segno		builtin;
  dcl setwordno		builtin;
  dcl size		builtin;
  dcl stackbaseptr		builtin;
  dcl string		builtin;
  dcl substr		builtin;
  dcl unspec		builtin;
  dcl wordno		builtin;

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


  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_					*/
  /***	Input:	dname, ename				*/
  /***	Function:	terminates the object specified by dname and	*/
  /***		ename.  If the object is a segment, any links to	*/
  /***		it in other linkage sections are unsnapped,	*/
  /***		its linkage and static sections are freed, and	*/
  /***		any *system links which refer to the segment for	*/
  /***		init_info have the init_info pointer set to null.	*/
  /***		If the object is a MSF, this process is repeated	*/
  /***		for each component.				*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call initiate_name (a_dname, a_ename, segsp, segment_count);
  call find_command_$clear;
  call unsnap_links (segsp, segment_count);
  call terminate_segno (segsp, segment_count);

  call exit (0);

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


single_refname:
  entry (a_refname,			/** name to terminate   (in )	*/
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$single_refname			*/
  /***	Input:	refname					*/
  /***	Function:	terminates a single reference name from a segment	*/
  /***		or MSF and unsnaps any links which refer to that	*/
  /***		file.  If the name was the last name on the	*/
  /***		object, the object is terminated and the linkage	*/
  /***		section(s) are freed.			*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call find_refname (a_refname, segsp, segment_count);
  call find_command_$clear;
  call unsnap_links (segsp, segment_count);
  call terminate_single_refname (a_refname, segsp, segment_count);

  call exit (0);

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


refname:
  entry (a_refname,			/** refname of segment  (in )	*/
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$refname				*/
  /***	Input:	refname					*/
  /***	Function:	terminates the segment or MSF which has the	*/
  /***		reference name given, and unsnaps all links to	*/
  /***		the it, frees the linkage/static section(s), and	*/
  /***		fixes any *system init_info pointers which refer	*/
  /***		to it.					*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call find_refname (a_refname, segsp, segment_count);
  call find_command_$clear;
  call unsnap_links (segsp, segment_count);
  call terminate_segno (segsp, segment_count);

  call exit (0);

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


no_clear:
  entry (a_refname,			/** name to terminate   (in )	*/
       a_code);			/** error code	    (out)	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$no_clear				*/
  /***	Input:	refname					*/
  /***	Function:	This entrypoint is intended for use only by the	*/
  /***		find_command_ subroutine. It terminates a segment	*/
  /***		or MSF without clearing the find_command_ cache	*/
  /***		(by calling find_command_$clear) allowing	*/
  /***		find_command_ to maintain its cache properly.	*/
  /***		It is otherwise identical to term_$single_refname	*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call find_refname (a_refname, segsp, segment_count);
  call unsnap_links (segsp, segment_count);
  call terminate_single_refname (a_refname, segsp, segment_count);

  call exit (0);

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


unsnap:
  entry (a_segp,			/** segment pointer	    (in )	*/
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$unsnap				*/
  /***	Input:	segp					*/
  /***	Function:	unsnaps links to the segment specified by segp	*/
  /***		and clears the find_command_ cache without	*/
  /***		terminating the segment.			*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call get_segs (a_segp, segsp, segment_count);
  call find_command_$clear;
  call unsnap_links (segsp, segment_count);

  call exit (0);

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


nomakeunknown:
  entry (a_segp,			/** segment pointer	    (in )	*/
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$nomakeunknown				*/
  /***	Input:	segp					*/
  /***	Function:	unsnaps all links, frees the linkage and static	*/
  /***		section(s), clears the find_command_ cache, and	*/
  /***		fixes any *system init_info references without	*/
  /***		actually terminating the segment(s) given.	*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call get_segs (a_segp, segsp, segment_count);
  call find_command_$clear;
  call unsnap_links (segsp, segment_count);
  call free_linkage (segsp, segment_count);

  call exit (0);

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


seg_ptr:
  entry (a_segp,			/** segment pointer	    (in )	*/
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$seg_ptr				*/
  /***	Input:	segp					*/
  /***	Function:	terminates the segment/MSF specified by segp and	*/
  /***		unsnaps any links, frees the linkage/static	*/
  /***		section(s), fixes and *system init_info pointers	*/
  /***		and clears the find_command_ cache.		*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;

  on cleanup call clean_up (segsp, segment_count);

  call get_segs (a_segp, segsp, segment_count);
  call find_command_$clear;
  call unsnap_links (segsp, segment_count);
  call terminate_segno (segsp, segment_count);

  call exit (0);


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


no_name:
  entry (a_segp,			/** segment pointer	    (in )	*/
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	term_$no_name				*/
  /***	Input:	segp					*/
  /***	Function:	terminates the null reference name from the given	*/
  /***		segment and decrements the reference count.	*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  segsp = null;
  call hcs_$terminate_noname (a_segp, ec);

  call exit (ec);

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


initiate_name:
  proc (dname,			/** dirname of target   (in )	*/
       ename,			/** entryname of target (in ) */
       segsp,			/** segments struc ptr  (out) */
       seg_ct);			/** segment count	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	initiate_name				*/
  /***	Input:	dname, ename				*/
  /***	Function:	takes an input path given as dirname & entryname	*/
  /***		and checks to insure that the target was known	*/
  /***		and that it is either a segment or an object MSF.	*/
  /***		The segs structure is allocated with pointers to	*/
  /***		each of the segments to be terminated.		*/
  /***	Output:	segsp, seg_ct				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl dname		char (*) parameter;
  dcl ename		char (*) parameter;
  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* automatic */

  dcl segp		ptr automatic;
  dcl ec			fixed bin (35) automatic;
  dcl dn			char (168) automatic;
  dcl bc			fixed bin (24) automatic;

  /* try to initiate the named segment */

  call hcs_$initiate (dname, ename, "", 0, 0, segp, ec);

  /* if it is a directory, we have some object MSF checks to perform */

  if ec = error_table_$dirseg
    then do;

      /* see if it an MSF */

      call hcs_$status_minf (dname, ename, 1, 0, bc, ec);
      if bc > 0
        then do;

	/* try initiating component 0 */

	dn = pathname_ (dname, ename);
	call hcs_$initiate_count (dn, "0", "", bc, 0, segp, ec);

	/* if it is not known, we return a code of	*/
	/* error_table_$seg_unknown			*/

	if segp = null
	  then call exit (error_table_$dirseg);
	else if ec ^= error_table_$segknown
	  then do;

	    /* terminate it, since it was unknown to begin with */

	    call hcs_$terminate_noname (segp, 0);
	    call exit (error_table_$seg_unknown);
	  end;
        end;
    end;

  /* if the target wasn't a directory, but was unknown as well, then	*/
  /* we make it unknown again and return error_table_$seg_unknown	*/

  else if ec ^= error_table_$segknown
    then do;
      if segp ^= null
        then call hcs_$terminate_noname (segp, ec);
      call exit (error_table_$seg_unknown);
    end;

  /* if it actually was known and valid, we go and get pointers and	*/
  /* other info for each of the affected segments.		*/

  call get_segs (segp, segsp, seg_ct);

  end initiate_name;

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


find_refname:
  proc (refname,			/** reference name	    (in )	*/
       segsp,			/** segments struc ptr  (out) */
       seg_ct);			/** segment count	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	find_refname				*/
  /***	Input:	refname					*/
  /***	Function:	locates a segment by reference name and allocates	*/
  /***		the list of all associated segments (in the case	*/
  /***		of a object MSF).				*/
  /***	Output:	segsp, seg_ct				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl refname		char (*) parameter;
  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* automatic */

  dcl ec			fixed bin (35) automatic;
  dcl segp		ptr automatic;

  /* get the segment pointer associated with the refname given */

  call hcs_$fs_get_seg_ptr (refname, segp, ec);
  if segp = null
    then call exit (ec);

  /* get the required info about the segment and any associated	*/
  /* segments if the target is a MSF component.			*/

  call get_segs (segp, segsp, seg_ct);

  end find_refname;

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


get_segs:
  proc (segp,			/** segment pointer	    (in )	*/
       segsp,			/** segments struc ptr  (out) */
       seg_ct);			/** segment count	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	get_segs					*/
  /***	Input:	segp					*/
  /***	Function:	determines if a given segment is an object MSF	*/
  /***		component and if so, gets pointers to the other	*/
  /***		components in the MSF and returns a structure	*/
  /***		with those component pointers.		*/
  /***	Output:	segsp, seg_ct				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segp		ptr parameter;
  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* based */

  dcl 01 seg		(seg_ct) aligned like segment based (segsp);
  dcl sys_area		area based (sys_areap);
  dcl 01 lh		aligned like linkage_header based (lhp);
  dcl 01 mm		aligned like msf_map based (mmp);
  dcl 01 dh		aligned like definition_header based (dhp);

  /* automatic */

  dcl c			fixed bin automatic;
  dcl compp		ptr automatic;
  dcl dhp			ptr automatic;
  dcl dname		char (168) automatic;
  dcl dnl			fixed bin automatic;
  dcl ename		char (32) automatic;
  dcl i			fixed bin automatic;
  dcl isp			ptr automatic;
  dcl lhp			ptr automatic;
  dcl mmp			ptr automatic;
  dcl seg_tempp		ptr automatic;
  dcl ss			bit (1) automatic;
  dcl sys_areap		ptr automatic;

  sys_areap = get_system_free_area_ ();

  /* try to get the linkage/static pointers */

  call get_lp (segno (segp), lhp, isp, ss);

  if lhp = null
    then do;

      /* there is no linkage section.  just handle the one segment */

      seg_ct = 1;
      allocate seg in (sys_area);
      unspec (seg (1)) = ""b;
      seg (1).textp = segp;
      return;
    end;

  dhp = lh.def_ptr;

  on seg_fault_error
    begin;

    /* if we take a segment fault while trying to see if this is an	*/
    /* object MSF, we have no way of telling, so we assume it is a	*/
    /* single segment item and continue.			*/

    seg_ct = 1;
    goto SKIP;
  end;

  /* if the msf_map_relp value is nonzero, validate that it is a	*/
  /* valid msf map.  if so take the seg count from there, otherwise	*/
  /* assume 1.						*/

  if dh.msf_map_relp ^= 0
    then do;
      mmp = addwordno (dhp, dh.msf_map_relp);
      if mm.version ^= msf_map_version_1
        then seg_ct = 1;
        else seg_ct = mm.component_count;
    end;
    else seg_ct = 1;

SKIP:
  revert seg_fault_error;

  /* only 1 segment, so get the info and return. */

  if seg_ct = 1
    then do;

      /* the segment is not an MSF component, just handle the one segment */

      allocate seg in (sys_area);
      seg (1).textp = segp;
      string (seg (1).flags) = ""b;
      seg (1).flags.separate_static = ss;
      seg (1).link_segno = segno (lhp);
      seg (1).link_start = wordno (lhp);
      seg (1).link_end = wordno (lhp) + lh.stats.block_length;
      if isp ^= null
        then do;
	seg (1).stat_segno = segno (isp);
	seg (1).stat_start = wordno (isp);
	seg (1).stat_end = wordno (isp) + lh.stats.static_length;
        end;
      return;
    end;

  /* allocate the segs structure for seg_ct>1.  In order for clean_up
     to work properly, seg.textp(*) must be initialized to null when
     segsp is set.  The code below initializes the seg array before
     setting segsp. */

  allocate seg in (sys_area) set (seg_tempp);
  unspec (seg_tempp -> seg) = ""b;
  seg_tempp -> seg.textp (*) = null;
  segsp = seg_tempp;

  /* get the containing directory */

  call hcs_$fs_get_path_name (segp, dname, dnl, ename, ec);
  dname = substr (dname, 1, dnl);

  /* get the information for the primary component */

  seg (1).textp = segp;
  string (seg (1).flags) = ""b;
  seg (1).flags.separate_static = ss;
  seg (1).link_segno = segno (lhp);
  seg (1).link_start = wordno (lhp);
  seg (1).link_end = wordno (lhp) + lh.stats.block_length;
  if isp ^= null
    then do;
      seg (1).stat_segno = segno (isp);
      seg (1).stat_start = wordno (isp);
      seg (1).stat_end = wordno (isp) + lh.stats.static_length;
    end;

  i = 1;

  /* pick up the information for the other MSF components */

  do c = 0 to mm.component_count - 1;
    if c ^= mm.my_component
      then do;

        i = i + 1;

        /* initiate each component */

        call hcs_$initiate (dname, ltrim (char (c)), "", 0, 0, compp, ec);
        if compp = null
	then call exit (ec);

        /* get the linkage and static pointers */

        call get_lp (segno (compp), lhp, isp, ss);
        if lhp ^= null
	then do;

	  /* if there is a linkage section, copy the info */

	  seg (i).textp = compp;
	  string (seg (i).flags) = ""b;
	  seg (i).flags.separate_static = ss;
	  seg (i).link_segno = segno (lhp);
	  seg (i).link_start = wordno (lhp);
	  seg (i).link_end = wordno (lhp) + lh.stats.block_length;
	  if isp ^= null
	    then do;
	      seg (i).stat_segno = segno (isp);
	      seg (i).stat_start = wordno (isp);
	      seg (i).stat_end = wordno (isp) + lh.stats.static_length;
	    end;
	end;
	else do;

	  /* if there is no linkage section, zero the values */

	  unspec (seg (i)) = ""b;
	  seg (i).textp = compp;
	end;
      end;
  end;

  end get_segs;

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


clean_up:
  proc (segsp,			/** segments struc ptr  (in )	*/
       seg_ct);			/** segment count	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	clean_up					*/
  /***	Input:	segsp, seg_ct				*/
  /***	Function:	frees the segs structure.			*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* based */

  dcl 01 seg		(seg_ct) aligned like segment based (segsp);
  dcl sys_area		area based (sys_areap);

  /* automatic */

  dcl s			fixed bin automatic;
  dcl sys_areap		ptr automatic;

  /* if there is no structure allocated, just return */

  if segsp = null
    then return;

  /* terminate segments we initiated that are not already terminated */

  do s = 2 to seg_ct;
    if seg (s).textp ^= null
      then call hcs_$terminate_noname (seg (s).textp, 0);
  end;

  /* get the area pointer and free the structure */

  sys_areap = get_system_free_area_ ();
  free seg in (sys_area);

  end clean_up;

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


terminate_single_refname:
  proc (refname,			/** refname to kill	    (in )	*/
       segsp,			/** segments struc ptr  (in )	*/
       seg_ct);			/** segment count	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	terminate_single_refname			*/
  /***	Input:	refname, segsp, seg_ct			*/
  /***	Function:	terminates the given name.  If the name was the	*/
  /***		only name on the segment the segment is also	*/
  /***		terminated.  In this case we free the linkage	*/
  /***		sections and terminate any associated segments.	*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl refname		char (*) parameter;
  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* based */

  dcl 01 seg		(seg_ct) aligned like segment based (segsp);

  /* automatic */

  dcl actual_code		fixed bin (35) automatic;
  dcl ec			fixed bin (35) automatic;
  dcl s			fixed bin automatic;

  /* terminate the name */

  call hcs_$terminate_name (refname, ec);
  if ec ^= 0
    then call exit (ec);

  /* reference the segment to see if it was terminated as well */

  call hcs_$get_uid_seg (seg (1).textp, (""b), ec);
  if ec = error_table_$invalidsegno
    then do;

      /* the segment was terminated, so we free the linkage and	*/
      /* terminate any associated segments.			*/

      call free_linkage (segsp, seg_ct);

      actual_code = 0;

      do s = 2 to seg_ct;
        call hcs_$terminate_seg (seg (s).textp, 0b, ec);
        if ec ^= 0
	then actual_code = ec;
	else seg (s).textp = null;
      end;

      if actual_code ^= 0
        then call exit (actual_code);
    end;

  end terminate_single_refname;

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


terminate_segno:
  proc (segsp,			/** segments struc ptr  (in )	*/
       seg_ct);			/** segment count	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	terminate_segno				*/
  /***	Input:	segsp, seg_ct				*/
  /***	Function:	terminates the segments identified by the segs	*/
  /***		structure after freeing their linkage sections	*/
  /***		and fixing any *system init_info references.	*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* based */

  dcl 01 seg		(seg_ct) aligned like segment based (segsp);

  /* automatic */

  dcl actual_code		fixed bin (35) automatic;
  dcl s			fixed bin automatic;
  dcl ec			fixed bin (35) automatic;

  /* free the linkage sections and clean up the environment */

  call free_linkage (segsp, seg_ct);

  /* actually terminate the segments */

  actual_code = 0;

  do s = 1 to seg_ct;
    call hcs_$terminate_seg (seg (s).textp, 0b, ec);
    if ec ^= 0
      then actual_code = ec;
      else seg (s).textp = null;
  end;

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

  end terminate_segno;

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


unsnap_links:
  proc (segsp,			/** segments struc ptr  (in )	*/
       seg_ct);			/** segment count	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	unsnap_links				*/
  /***	Input:	segsp, seg_ct				*/
  /***	Function:	scans the linkage sections of each active segment	*/
  /***		for links to any of the segments listed in the	*/
  /***		segs structure and unsnaps them.		*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* based */

  dcl 01 seg		(seg_ct) aligned like segment based (segsp);
  dcl lk			ptr based (lkp);
  dcl 01 vlh		aligned like virgin_linkage_header based (vlhp);
  dcl 01 lh		aligned like linkage_header based (lhp);

  /* automatic */

  dcl c			fixed bin automatic;
  dcl found		bit (1) automatic;
  dcl hcsc		fixed bin (15) automatic;
  dcl high_seg		fixed bin automatic;
  dcl isp			ptr automatic;
  dcl lhp			ptr automatic;
  dcl lk_end		fixed bin automatic;
  dcl lk_segno		fixed bin (18) unsigned automatic;
  dcl lk_word		fixed bin (18) unsigned automatic;
  dcl lkp			ptr automatic;
  dcl low_seg		fixed bin automatic;
  dcl nsegs		fixed bin (15) automatic;
  dcl offset		fixed bin automatic;
  dcl seg_no		fixed bin (18) automatic;
  dcl trap_errors		bit (1) automatic;
  dcl vlhp		ptr automatic;

  trap_errors = false;

  on seg_fault_error
    begin;

    /* we set up this handler here and enable and disable it using	*/
    /* a flag for better efficiency.				*/

    if trap_errors
      then do;
        found = true;
        trap_errors = false;
        goto UNSNAP;
      end;
      else do;
        call free_faulted_linkage (segsp, seg_ct, seg_no);
        goto SKIP;
      end;
  end;

  call hcs_$high_low_seg_count (nsegs, hcsc);
  low_seg = hcsc + 1;
  high_seg = hcsc + nsegs;

  /* for each initiated segment */

  do seg_no = low_seg to high_seg;

    /* try to get the linkage pointer */

    call get_lp (seg_no, lhp, isp, ""b);

    /* only check segments which have a linkage section */

    if lhp ^= null
      then do;

        /* get the original linkage section pointer */

        vlhp = lh.original_linkage_ptr;

        /* calculate the size of the link array */

        if vlh.defs_in_link = "20"b3
	then lk_end = vlh.def_offset;
	else lk_end = vlh.linkage_section_lng;

        if vlh.first_ref_relp ^= 0
	then lk_end = min (lk_end, vlh.first_ref_relp);

        /* scan the link array of the current linkage section */

        do offset = vlh.link_begin by 2 to lk_end - 2;

	/* get a pointer to the link */

	lkp = addwordno (lhp, offset);

	/* we are only concerned with snapped links */

	if lkp -> its_unsigned.its_mod = ITS_MODIFIER
	  then do;
	    found = false;

	    /* trap seg fault errors when referencing the link and	*/
	    /* unsnap the link if one occurs.			*/

	    trap_errors = true;

	    lk_segno = segno (lk);
	    lk_word = wordno (lk);

	    trap_errors = false;

	    /* scan the segments for a match */

	    do c = 1 to seg_ct while (^found);

	      /* see if the link refers to the target segment */

	      if lk_segno = segno (seg (c).textp)
	        then found = true;

	      /* or its linkage section */

	      else if lk_segno = seg (c).link_segno &
		 lk_word >= seg (c).link_start &
		 lk_word <= seg (c).link_end
	        then found = true;

	      /* or its static section */

	      else if lk_segno = seg (c).stat_segno &
		 lk_word >= seg (c).stat_start &
		 lk_word <= seg (c).stat_end
	        then found = true;
	    end;

	    /* if it refers to one of the given segments, unsnap it */

UNSNAP:
	    if found
	      then unspec (lk) = unspec (addwordno (vlhp, offset) -> lk);
	  end;
        end;
      end;
SKIP:
  end;

  end unsnap_links;

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


free_linkage:
  proc (segsp,			/** segments struc ptr  (in )	*/
       seg_ct);			/** segment count	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	free_linkage				*/
  /***	Input:	segsp, seg_ct				*/
  /***	Function:	closes language I/O files, frees fortran internal	*/
  /***		static LA's and VLA's, free's the linkage and	*/
  /***		static sections, and nulls any references to the	*/
  /***		segments in the init_info pointers of external	*/
  /***		variable nodes.				*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;

  /* based */

  dcl linkage_section	(1:linkl) bit (36) aligned based (linkp);
  dcl 01 seg		(seg_ct) aligned like segment based (segsp);
  dcl static_section	(1:statl) bit (36) aligned based (statp);
  dcl based_area		area based;

  /* automatic */

  dcl i			fixed bin automatic;
  dcl isotp		ptr automatic;
  dcl linkl		fixed bin (18) automatic;
  dcl linkp		ptr automatic;
  dcl lotp		ptr automatic;
  dcl np			ptr automatic;
  dcl s			fixed bin automatic;
  dcl sb			ptr automatic;
  dcl seg_no		fixed bin (18) unsigned automatic;
  dcl statl		fixed bin (18) automatic;
  dcl statp		ptr automatic;
  dcl sys_infop		ptr automatic;

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

  /* free the linkage section for each segment with linkage */

  do s = 1 to seg_ct;
    if seg (s).link_segno ^= 0
      then do;

        /* get the pointers and lengths of the linkage and static	*/
        /* sections (if there is a separate static section).	*/

        seg_no = segno (seg (s).textp);
        linkp = baseptr (seg (s).link_segno);
        linkp = setwordno (linkp, seg (s).link_start);
        linkl = seg (s).link_end - seg (s).link_start + 1;
        if seg (s).stat_segno = 0
	then do;
	  statp = null;
	  statl = 0;
	end;
	else do;
	  statp = baseptr (seg (s).stat_segno);
	  statp = setwordno (linkp, seg (s).stat_start);
	  statl = seg (s).stat_end - seg (s).stat_start + 1;
	end;

        /* clean up pl1 I/O stuff from the static section before freeing */

        if plio2_data_fsb_thread_ ^= null
	then call plio2_$close_in_this_static (plio2_data_fsb_thread_,
		statp, statl);

        /* release any static VLAs */

        if linkp -> linkage_header_flags.static_vlas
	then call fortran_storage_manager_$free (linkp);

        /* free the static section if it is separate */

        if seg (s).flags.separate_static & statp ^= null
	then free static_section
		in (sb -> stack_header.combined_stat_ptr -> based_area);

        /* clear the isot entry */

        unspec (isotp -> isot.isp (seg_no)) = ""b;

        /* free the linkage section */

        free linkage_section in (sb -> stack_header.clr_ptr -> based_area);

        /* set the lot entry to lot_fault */

        unspec (lotp -> lot.lp (seg_no)) = lot_fault;
      end;
  end;

  sys_infop = sb -> stack_header.sys_link_info_ptr;

  if sys_infop ^= null
    then do;

      /* there are *system links, so search the table looking for	*/
      /* init_info pointers which refer to the segment(s) being	*/
      /* terminated, and set the init_info pointers to null.	*/

      do i = lbound (sys_infop -> variable_table_header.hash_table, 1)
	 to hbound (sys_infop -> variable_table_header.hash_table, 1);
        do np = sys_infop -> variable_table_header.hash_table (i)
	   repeat (np -> variable_node.forward_thread) while (np ^= null);

	/* compare with each text pointer and null the ptr if it matches */

	do s = 1 to seg_ct while (np -> variable_node.init_ptr ^= null);
	  if segno (np -> variable_node.init_ptr) = segno (seg (s).textp)
	    then do;
	      np -> variable_node.init_ptr = null;
	      np -> variable_node.seg_ptr = null;
	    end;
	end;
        end;
      end;
    end;

  end free_linkage;

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


free_faulted_linkage:
  proc (segsp,			/** segments pointer    (in )	*/
       seg_ct,			/** segment count	    (in )	*/
       seg_no);			/** segment number	    (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	free_faulted_linkage			*/
  /***	Input:	segsp, seg_ct, seg_no			*/
  /***	Function:	If a segment fault occurs during the unsnapping	*/
  /***		of links, one of the following situations exists:	*/
  /***		  - The link we are testing has an indirection	*/
  /***		    tag, and one of the segments in the chain	*/
  /***		    doesnt exist.  This is resolved by unsnapping	*/
  /***		    the link.  This is done in the handler (in	*/
  /***		    unsnap links).				*/
  /***		  - We have take a segment fault on term_, on the	*/
  /***		    stack, or the linkage area.  In any of these	*/
  /***		    cases, we cant do anything anyway (and the	*/
  /***		    process is probably about to die anyway) so	*/
  /***		    we ignore them.				*/
  /***		  - One of the segments in the address space has	*/
  /***		    been deleted or is otherwise inaccessible but	*/
  /***		    its linkage section still exists.  This is	*/
  /***		    the case that this procedure handles. We deal	*/
  /***		    with this case by freeing the linkage and	*/
  /***		    static for the now-defunct segment, and	*/
  /***		    clearing the lot and isot values.		*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segsp		ptr parameter;
  dcl seg_ct		fixed bin parameter;
  dcl seg_no		fixed bin (18) parameter;

  /* based */

  dcl based_area		area based;
  dcl linkage_section	(linkl) bit (36) based (linkp);
  dcl 01 segs		(seg_ct) aligned like segment based (segsp);
  dcl static_section	(statl) bit (36) based (statp);

  /* automatic */

  dcl i			fixed bin automatic;
  dcl isotp		ptr automatic;
  dcl linkl		fixed bin (18) automatic;
  dcl linkp		ptr automatic;
  dcl lotp		ptr automatic;
  dcl sb			ptr automatic;
  dcl ss			bit (1) automatic;
  dcl statl		fixed bin (18) automatic;
  dcl statp		ptr automatic;

  /* if the segment we faulted on is one of the ones we were going	*/
  /* to terminate anyway, just skip this, as the linkage will be	*/
  /* freed shortly.						*/

  do i = 1 to seg_ct;
    if seg_no = segno (segs (i).textp)
      then return;
  end;

  /* find the stack header, lot and isot */

  sb = stackbaseptr ();

  lotp = sb -> stack_header.lot_ptr;
  isotp = sb -> stack_header.isot_ptr;

  /* get the linkage and static pointers and calculate the section lengths */

  call get_lp (seg_no, linkp, statp, ss);

  linkl = linkp -> linkage_header.block_length;
  statl = linkp -> linkage_header.static_length;

  /* clean up pl1 I/O stuff from the static section before freeing */

  if plio2_data_fsb_thread_ ^= null
    then call plio2_$close_in_this_static (plio2_data_fsb_thread_, statp,
	    statl);

  /* release any static VLAs */

  if linkp -> linkage_header_flags.static_vlas
    then call fortran_storage_manager_$free (linkp);

  /* free the static section if we have a separate static section */

  if ss & statp ^= null
    then free static_section
	    in (sb -> stack_header.combined_stat_ptr -> based_area);

  /* and clear the isot entry */

  unspec (isotp -> isot.isp (seg_no)) = ""b;

  /* now free the linkage section and reset the lot entry to lot_fault */

  free linkage_section in (sb -> stack_header.clr_ptr -> based_area);

  unspec (lotp -> lot.lp (seg_no)) = lot_fault;

  end free_faulted_linkage;

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


get_lp:
  proc (segno,			/** segment number	    (in )	*/
       linkp,			/** linkage pointer	    (out) */
       statp,			/** static pointer	    (out) */
       sep_stat);			/** seperate static sw  (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	get_lp					*/
  /***	Input:	segno					*/
  /***	Function:	gets the linkage and static pointers for the	*/
  /***		given segment out of the lot and determines if	*/
  /***		there is a separate static section.		*/
  /***	Output:	linkp, statp, sep_stat			*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl segno		fixed bin (18) parameter;
  dcl linkp		ptr parameter;
  dcl statp		ptr parameter;
  dcl sep_stat		bit (1) parameter;

  /* automatic */

  dcl isotp		ptr automatic;
  dcl lotp		ptr automatic;
  dcl sb			ptr automatic;

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

  linkp = null;
  statp = null;
  sep_stat = false;

  if segno > sb -> stack_header.cur_lot_size
    then return;

  if unspec (lotp -> lot.lp (segno)) ^= ""b &
       unspec (lotp -> lot.lp (segno)) ^= lot_fault
    then do;
      linkp = lotp -> lot.lp (segno);
      if isotp -> isot1 (segno).fault = "11"b
        then sep_stat = true;
      else if isotp -> isot.isp (segno) = linkp
        then statp = addwordno (linkp, size (linkage_header));
      else do;
        sep_stat = true;
        statp = isotp -> isot.isp (segno);
      end;
    end;

  end get_lp;

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


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

  /*** ****************************************************************/
  /***							*/
  /***	Name:	exit					*/
  /***	Input:	ec					*/
  /***	Function:	returns from term_ setting the given error code	*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl ec			fixed bin (35) parameter;

  a_code = ec;
  goto EXIT;

  end exit;

EXIT:
  call clean_up (segsp, segment_count);
  return;

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


%include definition_dcls;
%include object_link_dcls;
%include its;
%include lot;
%include stack_header;
%include system_link_names;

  end term_;




		    terminate.pl1                   04/19/90  1536.5rew 04/19/90  1530.4       52155



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




/****^  HISTORY COMMENTS:
  1) change(90-03-21,Vu), approve(90-03-21,MCR8165), audit(90-03-29,Zimmerman),
     install(90-04-19,MR12.4-1006):
     Fix -bf argument for terminate_refname.
                                                   END HISTORY COMMENTS */


terminate: tm: proc;

/* Implements the terminate commands:

	terminate paths {-control_args}

	terminate_segno segment_numbers {-control_args}

	terminate_refname reference_names {-control_args}

	terminate_single_refname reference_names {-control_args}

The first three terminate segments; the last terminates only specified refnames.
Rewritten 01/11/80 by S. Herbst */
/* Changed to not abort for error_table_$seg_unknown 03/04/81 S. Herbst */


dcl arg char (arg_len) based (arg_ptr);
dcl dn char (168);
dcl (en, myname, refname, usage) char (32);

dcl (brief_sw, some_args) bit (1);

dcl (arg_ptr, seg_ptr) ptr;

dcl (arg_count, arg_len, i, segno) fixed bin;
dcl code fixed bin (35);

dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$invalidsegno fixed bin (35) ext;
dcl error_table_$name_not_found fixed bin (35) ext;
dcl error_table_$seg_unknown fixed bin (35) ext;

dcl active_fnc_err_ entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl get_wdir_ entry returns (char (168));
dcl term_ entry (char (*), char (*), fixed bin (35));
dcl term_$refname entry (char (*), fixed bin (35));
dcl term_$seg_ptr entry (ptr, fixed bin (35));
dcl term_$single_refname entry (char (*), fixed bin (35));

dcl (baseptr, null, substr) builtin;
/**/
	myname = "terminate";
	usage = "paths";
	go to COMMON;

terminate_segno: tms: entry;

	myname = "terminate_segno";
	usage = "segment_numbers";
	go to COMMON;

terminate_refname: tmr: entry;

	myname = "terminate_refname";
	usage = "reference_names";
	go to COMMON;

terminate_single_refname: tmsr: entry;

	myname = "terminate_single_refname";
	usage = "reference_names";


COMMON:	call cu_$af_return_arg (arg_count, null, 0, code);
	if code = 0 then do;
	     call active_fnc_err_ (0, myname, "Cannot be called as an active function.");
	     return;
	end;

	brief_sw, some_args = "0"b;
	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if substr (arg, 1, 1) ^= "-" then some_args = "1"b;

	     else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
	     else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;
	     else if arg = "-name" | arg = "-nm" then do;
		i = i + 1;
		if i > arg_count then do;
		     call com_err_ (0, myname, "No value specified for -name");
		     return;
		end;
		some_args = "1"b;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, myname, "^a", arg);
		return;
	     end;
	end;

	if ^some_args then do;
	     call com_err_$suppress_name (0, myname, "Usage:  ^a ^a {-control_args}", myname, usage);
	     return;
	end;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if substr (arg, 1, 1) ^= "-" then do;

TERMINATE:	if myname = "terminate" then do;
		     call expand_pathname_ (arg, dn, en, code);
		     if code ^= 0 then do;
			call com_err_ (code, myname, "^a", arg);
			return;
		     end;
TERM_PATH:	     call term_ (dn, en, code);
		     if code ^= 0 then do;
			if ^brief_sw | code ^= error_table_$seg_unknown then
			     call com_err_ (code, myname, "^a^[>^]^a", dn, dn ^= ">", en);
			if code ^= error_table_$seg_unknown then return;
		     end;
		end;
		else if myname = "terminate_segno" then do;
		     segno = cv_oct_check_ (arg, code);
		     if code ^= 0 then do;
			call com_err_ (0, myname, "Invalid octal number ^a", arg);
			return;
		     end;
		     seg_ptr = baseptr (segno);
		     call term_$seg_ptr (seg_ptr, code);
		     if code ^= 0 then do;
             		if ^brief_sw | (code ^= error_table_$seg_unknown & code ^= error_table_$invalidsegno) then
			     call com_err_ (code, myname, "^a", arg);
			if code ^= error_table_$seg_unknown then return;
		     end;
		end;
		else if myname = "terminate_refname" then do;
		     refname = arg;
		     call term_$refname (refname, code);
		     if code ^= 0 then do;
TERM_ERROR:		if ^brief_sw | (code ^= error_table_$seg_unknown & code ^= error_table_$name_not_found) then
			     call com_err_ (code, myname, "^a", arg);
			if code ^= error_table_$seg_unknown then return;
		     end;
		end;
		else do;				/* terminate_single_refname */
		     refname = arg;
		     call term_$single_refname (refname, code);
		     if code ^= 0 then go to TERM_ERROR;
		end;
	     end;
	     else if arg = "-name" | arg = "-nm" then do;
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		if myname = "terminate" then do;	/* pathname */
		     dn = get_wdir_ ();
		     en = arg;
		     go to TERM_PATH;
		end;
		else go to TERMINATE;
	     end;
	end;

end terminate;




		    ti_.pl1                         11/04/82  1915.8rew 11/04/82  1614.7       70047



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


ti_$getseg: proc(dir,ename,segp,crock,code);


/* The subroutine ti_ (translator interface) is the interface between Multics
   standard translators and the file system.
   NOTE: THIS PROCEDURE ASSUMES THAT THE POINTER RETURNED BY LISTEN_$GET_AREA
         POINTS TO THE SAME SEGMENT FOR THE LIFE OF THE PROCESS */

	
/* initially coded in June 1969 by V. Voydock */
/*  modified on April 15, 1970 at 8:25 P. M. by V. Voydock */
/* modified by E. Stone on Aug. 4 1970 */
/* modified on December 7, 1970 by V. Voydock to follow new ring conventions */
/* Modified in June 1971 by V. Voydock to not know what segment
   listen_$get_area uses as an area */
/* Coding style cleaned up by V. Voydock in August 1971 */
	
dcl	cleanup condition;
dcl	1 x based(p) aligned,   /*  template to fill in ACL info */
	     2 number_of_acl_entries bit(18) unaligned,
	     2 offset_of_saved_acl bit(18) unaligned;

dcl	1 working_acl aligned internal static,
	     2 process_group_id char(32) aligned,
	     2 mode bit(5) unaligned,
	     2 reterr bit(13) unaligned,
	     2 (rb1,rb2,rb3) bit(6) unaligned;

dcl	dir char(*) aligned,
	ename char(*) aligned;

dcl	(aclp initial(null),
	 area_ptr int static,
	 segp,     /* ptr to segment "dir>ename" */
	 p
			) ptr;

dcl	(code,     /* error code */
	 error_table_$seg_unknown external,
	 error_table_$nolinkag external,
	 acnt      /* number of entries in ACL returned by readacl */
			) fixed bin;

dcl	crock  fixed bin(35);    /* ACL storage information */

dcl	first_time bit(1) aligned internal static initial("1"b);

dcl	cu_$level_get ext entry returns(fixed bin(6)),
	get_group_id_$tag_star ext entry returns(char(32) aligned),
	listen_$get_area ext entry returns(ptr),
	term_$nomakeunknown ext entry(ptr,fixed bin),
	hcs_$truncate_seg external entry(ptr,fixed bin,fixed bin),
	hcs_$make_seg ext entry(char(*) aligned,char(*) aligned,char(*) aligned,fixed bin(5),ptr,fixed bin),
	hcs_$acl_list ext entry(char(*) aligned,char(*) aligned,ptr,fixed bin,ptr,fixed bin),
	hcs_$acl_replace ext entry(char(*) aligned, char(*) aligned,ptr,fixed bin,fixed bin);

dcl	(addr,
	 fixed,
	 max,
	 null,
	 ptr,
	 rel
		) builtin;
/*  */
		/* Set up acl.  This acl will be used either while the translation takes
		   place or when it is done or both (with the mode changed appropriately)  */
	if first_time then
	     do;
	     process_group_id=get_group_id_$tag_star ();
	     area_ptr=listen_$get_area ();
	     first_time="0"b;
	     end;
	rb1=bit (cu_$level_get (), 6);
	rb2,rb3 = rb1;
	
		/* Create segment in directory dir with entry name ename, null reference name
		     and rwa access attributes */
	call hcs_$make_seg(dir,ename,"",01011b,segp,code);
	
		/* If the segment did not previously exist zero the ACL storage argument, "crock",
		   This will tell ti_$finobj or ti_$findata that the segment does
		   not have an ACL to restore */
	if code=0 then  do; crock=0; return; end;

		/* If unable to create segment return with error code */
	if segp=null then return;

		/* If segment did already exist, terminate it, truncate it, and save
		   its ACL so that it can be restored by ti_$finobj or ti_$findata */
	call term_$nomakeunknown(segp,code);
	if code^=0 then
	     if code^=error_table_$seg_unknown then
	          if code^=error_table_$nolinkag then  return;
	          else code=0;
	     else code=0;

		/* Set up cleanup handler to free storage, in case processing
		   is interrupted before control returns to caller */ 
	on cleanup begin; if aclp^=null then do; crock=0; free aclp->acl; end; end;

		/* Save the old ACL in the area returned by listen_$get_area */
	call hcs_$acl_list(dir,ename,aclp,acnt,area_ptr,code);
	if code^=0 then return;

		/* Pack information into the argument crock which will allow ti_$finobj or
		   ti_$findata to restore the ACL which has just been saved. In particular,
		   we pack the number of entries in the saved ACL into the left half of crock and
		   the offset relative to the base of the segment in which listen_$get_area has
		   its area into the right half of crock.  From this offset, the other entries
		   can rebuild a pointer to the saved ACL  */
	p=addr(crock);
	number_of_acl_entries=bit (fixed(acnt,18), 18);
	offset_of_saved_acl=rel(aclp);
	
		/* Put the ACL to be used during the translation onto the segment. */
	mode="01011"b;
	call hcs_$acl_replace(dir,ename,addr(working_acl),1,code);
	if code^=0 then return;

		/* Truncate the segment */
	call hcs_$truncate_seg(segp,0,code);
	return;
/*  */
	
finobj: entry(segp,bitcnt,crock,code);

dcl	1 acl based(aclp) aligned,
	     2 pad char(32),
	     2 mmode bit(5);

dcl	f_dir char(168) aligned,
	f_ename char(32) aligned;

dcl	(lng,
	 bitcnt
		   ) fixed bin;

dcl	processing_object bit(1) aligned;

dcl	hcs_$terminate_noname ext entry(ptr,fixed bin),
	hcs_$fs_get_path_name ext entry(ptr,char(*) aligned,fixed bin,char(*) aligned,fixed bin),
	hcs_$set_bc ext entry(char(*) aligned,char(*) aligned,fixed bin,fixed bin);
/*  */
		/* Indicate that this is call to the "finobj" entry */
	processing_object="1"b;
	go to COMMON;
	
findata: entry(segp,bitcnt,crock,code);
	
	processing_object="0"b;

COMMON:
	
		/* Get pathname of segment pointed to by segp */
	call hcs_$fs_get_path_name(segp,f_dir,lng,f_ename,code);
	if code^=0 then return;
	
		/* Set bit count of segment to bitcnt */
	call hcs_$set_bc(f_dir,f_ename,bitcnt,code);
	if code^=0 then return;
	
		/* Restore old ACL if it exists, otherwise give default ACL */
	if crock^=0 then
	     do;
	     p=addr(crock);
	     aclp=ptr(area_ptr,offset_of_saved_acl);     /* get ptr to ACL */
	     acnt=fixed(number_of_acl_entries,17);

		/* If called from ti_$finobj check the old ACL. If it has only one entry and
		     if the entry is for the current user and if it has RWA as its mode, change
		     the the mode to RE since it is very likely that this acl is left over from
		     an earlier compilation which the user quit out of */
	     if processing_object then if acnt=1 then if mmode="01011"b then mmode="01100"b;
	     call hcs_$acl_replace(f_dir,f_ename,aclp,acnt,code);      /* restore old ACL */
	     if code^=0 then return;
		/* Free up storage used to store ACL and indicate this has been done */
	     if acnt>0 then free aclp->acl;
	     crock=0;
	     end;
	else      

		/* If no old ACL exists then we must put a default ACL on the segment.
		   In the case of data segments this is RWA for the given user.  Since this is the
		   same ACL that was used during the compilation, this ACL is already on the segment
		   and nothing need be done.  If this is an object segment, then the default ACL
		   is RE for the user, and we must put this on the segment */
	if processing_object then  
	     do;
	     mode="01100"b;
	     call hcs_$acl_replace(f_dir,f_ename,addr(working_acl),1,code);
	     if code^=0 then return;
	     end;
	
		/* Terminate segment */
	call hcs_$terminate_noname(segp,code);

	return;
/*  */


clean_up: entry(crock);


		/* Get pointer to storage to be freed up */
	if crock=0 then return;
	p=addr(crock);
	aclp=ptr(area_ptr,offset_of_saved_acl);
	acnt=fixed(number_of_acl_entries,17);

		/* Free up the storage and indicate that storage has been cleaned up */
	if acnt>0 then free aclp->acl;
	crock=0;


end ti_$getseg;




		    translator_info_.pl1            06/09/89  1002.8rew 06/09/89  0808.3       46692



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




/****^  HISTORY COMMENTS:
  1) change(87-01-30,JRGray), approve(89-04-17,MCR8064), audit(89-04-18,Huen),
     install(89-06-09,MR12.3-1055):
     Modified to handle explicit archive component pathnames.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
translator_info_:
     procedure ();

/*	     "translator_info_" -- this procedure contains utility routines	*/
/*	needed by the various system translators.  They are centralized here	*/
/*	to avoid repetitions in each of the individual translators.		*/

/*	Created by D. M. Wells in May, 1972.				*/

/*	Modified by D. M. Wells on 3 August, 1972 to add comments prior	*/
/*		to installation.					*/
/*	Modified by M. Weaver on 12 July 1983 to add the			*/
/*		dummy entrypoint component_get_source_info		*/

/* * * * * PARAMETER DECLARATIONS  * * * * * * * */

declare	(
	bv_seg_ptr	pointer,
	bv_dirname	char (*),
	bv_ename		char (*),
	bv_compname	char (*),
	bv_date_time_modified
			fixed binary (71),
	bv_unique_id	bit (36) aligned,
	bv_error_code	fixed bin (35)
	)		parameter;

/* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

declare	(
	ename		char (32),
	compname		char (32),
	dirname		char (168)
	)		automatic;

declare	find_component	bit (1);

declare	1 branch		aligned automatic,
	  2 type		bit (2) unaligned,
	  2 nnames	bit (16) unaligned,
	  2 nrp		bit (18) unaligned,
	  2 dtm		bit (36) unaligned,
	  2 dtu		bit (36) unaligned,
	  2 mode		bit (5) unaligned,
	  2 padding	bit (13) unaligned,
	  2 records	bit (18) unaligned,
	  2 dtd		bit (36) unaligned,
	  2 dtem		bit (36) unaligned,
	  2 acct		bit (36) unaligned,
	  2 curlen	bit (12) unaligned,
	  2 bitcnt	bit (24) unaligned,
	  2 did		bit (4) unaligned,
	  2 mdid		bit (4) unaligned,
	  2 copysw	bit (1) unaligned,
	  2 pad2		bit (9) unaligned,
	  2 rbs		(0:2) bit (6) unaligned,
	  2 unique_id	bit (36) unaligned;

declare	archive_header_ptr	ptr;
declare	01 ah		like archive_header based (archive_header_ptr);

/* * * * * ENTRY CONSTANT DECLARATIONS * * * * * */

declare	convert_date_to_binary_
			entry (char (*), fixed bin (71), fixed bin (35));
declare	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin (17), char (*), fixed bin (35)),
	hcs_$status_long	entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
declare	error_table_$archive_fmt_err
			ext fixed bin (35);

declare	(addr, fixed, null) builtin;

/* * * * * VALID ARCHIVE HEADER CONSTANTS * * * * */

dcl	valid_header_begin	char (8) int static options (constant) init ("



		");
dcl	valid_pad1	char (4) int static options (constant) init ("    ");
dcl	valid_pad		char (4) int static options (constant) init ("    ");
dcl	valid_header_end	char (8) int static options (constant) init ("



");


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

get_source_info:
     entry (bv_seg_ptr, bv_dirname, bv_ename, bv_date_time_modified, bv_unique_id, bv_error_code);

	find_component = "0"b;
	goto join;

component_get_source_info:
     entry (bv_seg_ptr, bv_dirname, bv_ename, bv_compname, bv_date_time_modified, bv_unique_id, bv_error_code);

	find_component = "1"b;

/* find out where in storage system this is	*/
join:
	call hcs_$fs_get_path_name (bv_seg_ptr, dirname, (0), ename, bv_error_code);
	if bv_error_code ^= 0
	then return;

/* get the structure with all the info		*/
	call hcs_$status_long (dirname, ename, 0b, addr (branch), null (), bv_error_code);
	if bv_error_code ^= 0
	then return;

	bv_dirname = dirname;			/* Notice that we used our own "dirname" and	*/
	bv_ename = ename;				/* "ename" because the caller may have given us	*/
						/* too short a string to hold the names, e.g.,	*/
						/* a string of zero length.			*/

	bv_date_time_modified = fixed (branch.dtm || (16)"0"b, 71);
						/* branch.dtm is a storage system time	*/
	bv_unique_id = branch.unique_id;

	if find_component
	then do;
	     bv_compname = "";
	     if fixed (rel (bv_seg_ptr)) >= size (archive_header)
	     then do;				/* can be archive component */
		archive_header_ptr = addrel (bv_seg_ptr, -size (archive_header));
		if ah.header_begin = valid_header_begin & ah.pad1 = valid_pad1 & ah.pad = valid_pad
		     & ah.header_end = valid_header_end
		then do;
		     bv_compname = ah.name;
		     call convert_date_to_binary_ (ah.timeup, bv_date_time_modified, bv_error_code);
		end;
		else bv_error_code = error_table_$archive_fmt_err;
	     end;
	end;

%page;

%include archive_header;

     end translator_info_;




		    tssi_.pl1                       07/12/88  1442.0rew 07/12/88  1434.9      116802



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





/****^  HISTORY COMMENTS:
  1) change(88-07-06,TLNguyen), approve(88-07-06,MCR7932),
     audit(88-07-08,Parisek), install(88-07-12,MR12.2-1055):
     Fix bug which prevents a null pointer condition raised when calling
     msf_manager_$get_ptr
                                                   END HISTORY COMMENTS */



/*  The translator storage system interface module (tssi_) gets pointers
    to segments needed by translators, relieving them of the burden of
    taking care of acls.  It has several entry points, sometimes in
    pairs - one for strictly Single Segment Files, and another for Multi Segment
    Files.

    Based on ti_, written by V. Voydock.

    Coded by Dan Bricklin April 1972
    Recoded to use new ACL primitives and also better methods by M.J. Grady May 1973
    Modified by E Stone April 1974 to call new msf_manager_ entries $acl_add and $acl_delete
    to fix bug in clean_up_file entry and to cleanup code
    Modified by Richard Lamson January 6, 1982 for better interface with initial ACLs

*/


tssi_:	proc;


dcl
	dirname char(*),
	ename char(*),
	segp ptr,
	aclinfop ptr,
	code fixed bin(35),
	xcode fixed bin(35),
	(addr, null, substr) builtin,
	hcs_$make_seg ext entry(char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)),
	hcs_$list_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	hcs_$replace_acl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35)),
	term_$nomakeunknown ext entry(ptr, fixed bin(35)),
	error_table_$seg_unknown fixed bin(35) ext,
	error_table_$nolinkag fixed bin(35) ext,
	type fixed bin,
	seg fixed bin static init (1),
	file fixed bin static init (2),
	cleanup condition,

	1 info_bead based(aclinfop) aligned,
	   2 dirname char(168),
	   2 ename char(32),
	   2 made_seg bit(1),
	   2 mode bit(3),

	free_area area based(areap),
	areap ptr static init(null),


	1 working_acl aligned,
	   2 process_group_id char(32) aligned,
	   2 mode bit(3) unaligned,
	   2 mbz1 bit(33) unaligned,
	   2 mbz2 bit(36),
	   2 err_code fixed bin(35),

	1 del_acl aligned,
	  2 process_group_id char(32) aligned,
	  2 err_code fixed bin(35),

	hcs_$delete_acl_entries entry(char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$add_acl_entries entry(char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$truncate_seg ext entry(ptr, fixed bin(19), fixed bin(35)),
	bc fixed bin(24),
	msf_manager_$open entry(char(*), char(*), ptr, fixed bin(35)),
	msf_manager_$get_ptr entry(ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)),
	msf_manager_$adjust entry(ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35)),
	msf_manager_$close entry(ptr),
	msf_manager_$acl_add entry(ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$acl_delete entry(ptr, ptr, fixed bin, fixed bin(35)),
	fcbp ptr,
	bit_count fixed bin(24),
	mode bit(36) aligned,
	hcs_$set_bc_seg ext entry(ptr, fixed bin(24), fixed bin(35)),
	dir char(168),
	enm char(32),
	hcs_$terminate_noname ext entry(ptr, fixed bin(35)),
	component fixed bin,
	get_group_id_ ext entry returns(char(32) aligned),
	get_group_id_$tag_star ext entry returns(char(32) aligned),
	get_system_free_area_ ext entry returns(ptr);

%page;
/*  The get_segment entry returns a pointer to segment dirname>ename.  The
     segment will have "rw" access to the current user.  If an old acl had to be
     changed to do this, aclinfop is set pointing to information for reseting
     the acl. */


get_segment:
	entry(dirname, ename, segp, aclinfop, code);


	segp, aclinfop = null;			/* initialize ptrs to show no allocation done */

	if areap = null then areap = get_system_free_area_();

	dir = dirname;				/* copy path name arguments */
	enm = ename;

	call hcs_$make_seg(dir,enm,"",01100b,segp,code); /* try to make seg */
	if segp = null then return;			/* bad error */

	on cleanup call free_acl_info;

	allocate info_bead in(free_area) set(aclinfop);	/* grab some storage */

	aclinfop->info_bead.dirname = dir;		/* save the pathnames */
	aclinfop->info_bead.ename = enm;

	if code = 0 then do;			/* we made the seg save some info */
	     info_bead.made_seg = "1"b;
	     info_bead.mode = "110"b;			/* save mode */

	end;
	else do;					/* we did not make it */
	     info_bead.made_seg = "0"b;
	     info_bead.mode = "0"b;

	     call term_$nomakeunknown(segp,code);	/*term it, but save segno */

	     if code ^= 0 then do;
		if code ^= error_table_$seg_unknown then
		if code ^= error_table_$nolinkag then return;
		code = 0;
	     end;

	end;
	call add_acl;					/* add Person.project.tag to acl of segment */
	if code ^= 0 then return;

	if ^info_bead.made_seg then call hcs_$truncate_seg(segp,0,code);
	return;					/* all done now */

%page;
/*  The get_file entry returns a pointer to component 0 of file dirname>ename.  The
    file will have "rw" access to the current user.  If an old acl had to be changed
    to set the access to "rw", then aclinfop will be left pointing to information
    needed to reset the acl.  */


get_file:
	entry(dirname, ename, segp, aclinfop, fcbp, code);

	segp, aclinfop, fcbp = null;				/* init ptrs to indicate that we haven't allocated	*/
          code = 0;

	if areap = null then areap = get_system_free_area_();	/* grab area */

	dir = dirname;					/* copy path name arguments */
	enm = ename;

	on cleanup begin;					/* in case returned around, want to clean up */
	     call free_acl_info;
	     call free_fcb;
	end;

	call msf_manager_$open(dir, enm, fcbp, code);
	if fcbp = null then return;                                 /* return the code value indicating the reason for opening failure */

	call msf_manager_$get_ptr(fcbp, 0, "1"b, segp, bc, xcode);
	if segp=null then do;
	   call free_fcb;
	   code = xcode;
	   return;
	   end;

	allocate info_bead in (free_area) set (aclinfop);		/* save ptr to acl, acl_count, and set user ptr */

	aclinfop->info_bead.dirname = dir;			/* save the pathnames */
	aclinfop->info_bead.ename = enm;

	if code ^= 0 then do;				/* we made the seg so.. */
	     info_bead.made_seg = "1"b;
	     info_bead.mode = "101"b;				/* put on by msf_manager_ */
	end;
	else do;						/* was there so do other things */
	     info_bead.made_seg = "0"b;
	     info_bead.mode = "0"b;
	     call msf_manager_$adjust(fcbp,0,0,"110"b,code);	/* truncate seg to 0 */
	end;

	call add_acl;					/* add rw for P.P.tag to segment */

	return;						/* that's it */

%page;
/* The following two internal procedures are used through out tssi_ to free allocated storage. */


free_acl_info:
	proc;



	if aclinfop^=null then				/* if aclinfop was set, then free the bead */
	free aclinfop->info_bead in (free_area);

	end free_acl_info;



free_fcb:
	proc;


	if fcbp^=null then					/* if a fcb was allocated, then free it */
	call msf_manager_$close(fcbp);


	end free_fcb;

%page;
/*  The finish_segment entry is used to set the bitcount on the segment after the translator
    is finished with it.  It also resets the acl, if an old one exists.  If one did not,
    then if mode="110"b then the acl is changed to "re", else it is left "rw".  It also terminates
    the segment.  */


finish_segment:
	entry(segp, bit_count, mode, aclinfop, code);

	call hcs_$set_bc_seg(segp, bit_count, code);		/* set the bitcount to the value given 	*/
	if code^=0 then return;				/* if error, then give up */

	type = seg;					/* finishing up a segment, rather than a file */

	call delete_acl (code);				/* remove the acl entry for Person.Project.tag */
	if code ^= 0 then return;

	call adjust_mode;					/* make sure requested mode is on the segment */

	call free_acl_info;

	call hcs_$terminate_noname(segp,code);

	return;						/* finished */


/*  The finish_file entry is used to set the length of the file when the translator is finished
    with it.  It also resets acls like the "finish_segment" entry, and terminates the file.  */


finish_file:
	entry(fcbp, component, bit_count, mode, aclinfop, code);

	call msf_manager_$adjust(fcbp, component, bit_count, "101"b, code);/* set the bitcount and terminate */
	if code ^= 0 then return;				/* set bitcount before changing acl so we know
							  it will work*/

	type = file;					/* flag to indicate a file is being finished */

	call delete_acl (code);				/* remove acl for Person.Project.tag */
	if code ^= 0 then return;

	call adjust_mode;					/* make sure requested mode is on the file */

	call free_acl_info;					/* free info structure */

	call free_fcb;					/* free the fcb */

	return;						/* finished */

%page;
/*  The clean_up entry is called by the user in the event of him having to abnormally abort his work, and
    just frees the storage allocated for acls, if present. */


clean_up_segment:
	entry(aclinfop);

	if aclinfop = null then return;

	type = seg;					/* finishing up a segment, rather than a file */

	call delete_acl (xcode);				/* remove acl entry for P.P.t */

	call free_acl_info;

	return;						/* that's it */


clean_up_file:
	entry(fcbp, aclinfop);


	if aclinfop ^= null then do;

	     type = file;					/* flag to indicate a file is finished */

	     call delete_acl (xcode);				/* delete acl for P.P.tag */

	     call free_acl_info;

	end;

	call free_fcb;

	return;

%page;
/* The internal procedure add_acl is used to add the entry Person.Project.tag  rw for the get entries */

add_acl:
     proc;

	working_acl.process_group_id = get_group_id_();	/* set up acl for Person.Project.tag */
	working_acl.mode = "101"b;
	working_acl.mbz1, working_acl.mbz2 = "0"b;

	call hcs_$add_acl_entries(dir,enm,addr(working_acl),1,code); /* do it */


     end add_acl;






/* The internal procedure delete_acl is used to remove the entry on the segment or msf for
   Person.Project.tag */

delete_acl:
	proc (error);

dcl	error fixed bin (35);



	dir = aclinfop->info_bead.dirname;			/* copy dirname */
	enm = aclinfop->info_bead.ename;			/* copy ename also */

	del_acl.process_group_id = get_group_id_();		/* get Person.Project.tag to del it */

	if type = seg then call hcs_$delete_acl_entries(dir,enm,addr(del_acl),1,error);
 	else call msf_manager_$acl_delete(fcbp,addr(del_acl),1,error);


     end delete_acl;
%page;
/* The internal procedure adjust_mode puts the requested mode on the the acl if the segment or msf
   was made by tssi_. */

adjust_mode:
     proc;



	if info_bead.made_seg then do;
	     working_acl.mode = substr (mode, 1, 3);		/* copy mode */
	     if info_bead.mode ^= working_acl.mode then do;	/* if different mode set it */

		working_acl.process_group_id = get_group_id_$tag_star();
		working_acl.mbz1, working_acl.mbz2 = "0"b;

		if type = seg
		then call hcs_$add_acl_entries(dir,enm,addr(working_acl),1,code);
 		else call msf_manager_$acl_add(fcbp,addr(working_acl),1,code);

	     end;

	if working_acl.mode & E_ACCESS then call fix_inacl_entries;

	end;

fix_inacl_entries:
	procedure;



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* POLICY:								*/
	/*	If the user is trying to put "re" on a new segment, then for each ACL entry	*/
	/*	which was derived from the IACL (which should be all that's on the entry by	*/
	/*	now), if the access is non-null, then if it already contains "e", we assume	*/
	/*	the user knows what she's doing;  otherwise, the corresponding user receives	*/
	/*	"re" permission to the new segment.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



	acl_ptr = null ();
	on cleanup begin;
	     if acl_ptr ^= null then free segment_acl;
	end;

	call hcs_$list_acl (dir, enm, get_system_free_area_ (), acl_ptr, null (), acl_count, xcode);
	if xcode ^= 0 then return;			/* Can't fix initial acl? Too bad. */
	do i = 1 to acl_count;
	     if segment_acl (i).modes ^= N_ACCESS
	     then if (segment_acl (i).modes & E_ACCESS) = ""b
		then segment_acl (i).modes = RE_ACCESS;
	end;
	call hcs_$replace_acl (dir, enm, acl_ptr, acl_count, "1"b, xcode);
	free segment_acl;
	return;

declare 1 segment_acl (acl_count) aligned based (acl_ptr),
	2 access_name	    char (32),
	2 modes		    bit (36),
	2 xmodes		    bit (36),
	2 status_code	    fixed binary (35);

declare	acl_ptr pointer;
declare  (acl_count, i) fixed binary;


	end fix_inacl_entries;

%include access_mode_values;

     end adjust_mode;

	end tssi_;





		    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
