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 i256 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