examine_object_.pl1 11/15/82 1829.3rew 11/15/82 1506.3 43047 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ examine_object_: proc(seg_ptr, bit_count, segment_name, archive_name, prog_list, total); /* examine_object_ - examine the segment identified by seg_ptr and determine if it is a PL/I object segment that uses unaligned decimal data */ /* Written by Peter C. Krupp on January 14, 1978 */ dcl seg_ptr pointer; dcl (segment_name, archive_name) character(*); dcl prog_list(3) file variable; dcl total(3) fixed bin; dcl (addr, bin, hbound, string, substr, ltrim) builtin; %include object_info; dcl object_info_$long entry (ptr, fixed bin(24), ptr, fixed bin(35)); dcl decimal_use_code fixed bin; dcl decimal_use_record char(256) varying; dcl 1 info like object_info; dcl bit_count fixed bin(24); dcl code fixed bin(35); info.version_number=2; call object_info_$long (seg_ptr, bit_count, addr(info), code); if code^=0 then return; if info.compiler^="PL/I" & info.compiler^="v2pl1" then return; decimal_use_code=type_object_segment(); total(decimal_use_code)=total(decimal_use_code)+1; decimal_use_record=ltrim(archive_name || " " || segment_name); if decimal_use_code^=1 then write file(prog_list(decimal_use_code)) from(decimal_use_record); return; /* type_object_segment - classify a PL/I segment according to its use of arithmetic decimal instructions */ type_object_segment: procedure returns(fixed bin); dcl 1 pl1$op_mnemonic(0:1023) ext static aligned, 2 (opcode char(6), dtype fixed bin(2), /* 0-desc9a, 1-descb, 2-decimal */ num_desc fixed bin(5), num_words fixed bin(8)) unaligned; dcl 1 instruction based(text_ptr) aligned, 2 (base bit(3), offset bit(15), op_code bit(10), unused bit(1), ext_base bit(1), tag bit(6)) unaligned; dcl 1 mod_factor aligned, 2 (ext_base bit(1), length_in_reg bit(1), indirect_descriptor bit(1), tag bit(4)) unaligned; dcl mf(3) fixed bin(6) int static init(30,12,3); dcl eis_modifier(0:15) char(3) aligned int static init("n","au","qu","du","ic","al","ql","dl","x0","x1","x2","x3","x4","x5","x6","x7"); dcl 1 descriptor based aligned, 2 (address bit(18), char bit(3), nsd_type bit(3), scale_factor bit(6), length bit(6)) unaligned; dcl (text_offset,max_text_offset) fixed bin; dcl dec_data bit(1); dcl text_ptr pointer; dcl mop fixed bin; text_offset=0; max_text_offset=info.tlng-1; dec_data="0"b; do while(text_offset<=max_text_offset); text_ptr=addrel(info.textp,text_offset); mop=bin(instruction.op_code); if opcode(mop)^=" " then do; if num_words(mop)^=1 & dtype(mop)=2 & dec_arith(opcode(mop)) then do; dec_data="1"b; if unaligned_data(text_ptr) then return(3); /* unaligned decimal data found */ end; text_offset=text_offset+num_words(mop); end; else text_offset=text_offset+1; end; if dec_data then return(2); /* only word aligned decimal data */ return(1); /* no decimal data found */ /* dec_arith - is opcode an arithmetic decimal opcode */ dec_arith: procedure(opcode) returns(bit(1) aligned); dcl opcode char(6); dcl dec_arith_ops(8) char(6) aligned int static init("ad2d","ad3d","sb2d","sb3d","mp2d","mp3d","dv2d","dv3d"); dcl i fixed bin; do i=1 to hbound(dec_arith_ops,1); if opcode=dec_arith_ops(i) then do; do i=1 to num_desc(mop); if addrel(text_ptr,i)->nsd_type ^= "001"b & addrel(text_ptr,i)->nsd_type ^= "000"b then return("0"b); end; return("1"b); end; end; return("0"b); end dec_arith; /* unaligned_data - determines whether or not the EIS instruction identified by inst_ptr accesses unaligned data */ unaligned_data: procedure(inst_ptr) returns(bit(1) aligned); dcl inst_ptr ptr; dcl i fixed bin; do i=1 to num_desc(mop); if addrel(inst_ptr,i)->descriptor.char^="000"b then return("1"b); /* unaligned - nonzero digit offset */ string(mod_factor)=substr(string(inst_ptr->instruction),mf(i),7); if eis_modifier(bin(mod_factor.tag))^="n" & eis_modifier(bin(mod_factor.tag))^="ic" then return("1"b); /* unaligned - address modification */ end; return("0"b); /* all data aligned - zero digit offsets and no address modification */ end unaligned_data; end type_object_segment; end examine_object_;  hunt_dec.pl1 11/16/82 1436.3rew 11/16/82 1435.6 87381 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ hunt_dec: proc; /* HUNT - find a segment in a given subtree. */ /* Modified by Peter C. Krupp on 1/14/78 to find and classify PL/I object segments that use decimal data */ /* Modified 780809 by PG to terminate archive segments when finished with them. */ /* automatic */ dcl path char (168), /* Root of tree to be scanned. */ i fixed bin, ap ptr, segp ptr, al fixed bin, bchr char (al) unaligned based (ap), ec fixed bin(35), an fixed bin init (2), code fixed bin (35); /* entries */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)), cu_$arg_count entry returns (fixed bin), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), com_err_ entry options (variable), ioa_$rsnnl entry options (variable), cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin(35)), sweep_disk_dec_ ext entry (char (168), entry), get_wdir_ entry returns (char (168)), ioa_ entry options (variable); /* builtins */ dcl (addr, bin, hbound, index, length, null, rtrim, substr) builtin; /* files */ dcl (no_decimal,aligned_decimal,unaligned_decimal) file record output environment(stringvalue); dcl prog_list(3) file variable init(no_decimal,aligned_decimal,unaligned_decimal); dcl attach_description(3) char(256) varying init("discard_","record_stream_ -target vfile_ aligned_decimal.hd","record_stream_ -target vfile_ unaligned_decimal.hd"); dcl header(3) char(132) var init("/* PL/I object segments that do not reference decimal data */", "/* PL/I object segments that reference aligned decimal data */", "/* PL/I object segments that reference unaligned decimal data */"); dcl total(3) fixed bin init((3)0); dcl message char(256) var init(""); dcl cleanup condition; /* --------------------- */ path = get_wdir_ (); call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then do; call com_err_ (0, "hunt_dec", "Usage: hunt_dec {root_of_tree} {-control_args}^/ Control arguments: -aligned_decimal -unaligned_decimal "); return; end; call absolute_pathname_ (bchr, path, code); if code ^= 0 then go to er; call process_ctl_args(code,message); if code^=0 | message^="" then go to er; do i=2 to 3; open file(prog_list(i)) title(attach_description(i)); end; on cleanup begin; do i=2 to 3; close file(prog_list(i)); end; end; do i=2 to 3; write file(prog_list(i)) from(header(i)); end; /* Now, go to work. Call disk sweeper program */ call sweep_disk_dec_ (path, counter); call ioa_ ("^/Total no decimal ^d^/Total aligned decimal ^d^/Total unaligned decimal ^d^/",total(1),total(2),total(3)); do i=2 to 3; close file(prog_list(i)); end; return; er: call com_err_ (code, "hunt_dec", message); return; counter: proc (sdn, sen, lvl, een, bptr, nptr); dcl archive_util_$first_disected entry(ptr, ptr, char(32) aligned, fixed bin(24), fixed bin(35)); dcl archive_util_$disected_element entry(ptr, ptr, char(32) aligned, fixed bin(24), fixed bin(35)); dcl examine_object_ entry (ptr,fixed bin(24),char(*),char(*),(3) file,(3) fixed bin); /* examine segment to see if it is a PL/I object segment with unaligned decimal code */ dcl message char(256); dcl ml fixed bin; dcl header_ptr ptr; /* ptr to current archive header...input/output to archive util_ */ dcl comp_ptr ptr; /* pointer to component in archive segment */ dcl comp_name char(32) aligned; /* name of component in archive segment */ dcl bit_count fixed bin(24); /* bit count of component */ dcl sdn char (168), /* superior dir name */ sen char (32), /* dirname */ lvl fixed bin, /* distance from root */ een char (32), /* entry name */ namec fixed bin, (j, k) fixed bin, names (100) char (32) aligned based (nptr), ename char (32), bptr ptr, /* ptr to info structure */ nptr ptr; /* ptr to names structure */ dcl xp char (168), xi fixed bin; dcl 1 branch based (bptr) aligned, /* thing returned by star_long */ 2 type bit (2) unal, 2 nname bit (16) unal, 2 nindex bit (18) unal, 2 dtm bit (36) unal, 2 dtu bit (36) unal, 2 mode bit (5) unal, 2 pad bit (13) unal, 2 records bit (18) unal; dcl ecc fixed bin (35); dcl any_other condition; dcl continue_to_signal_ entry (fixed bin(35)); dcl find_condition_info_ entry (ptr,ptr,fixed bin(35)); dcl condition_name(5) char(32) aligned int static init ("no_read_permission","not_in_read_bracket","seg_fault_error", "program_interrupt","out_of_bounds"); dcl 1 cond_info, %include cond_info;; on any_other begin; dcl (i,code) fixed bin(35); cond_info.version=1; call find_condition_info_(null,addr(cond_info),code); do i=1 to hbound(condition_name,1); if condition_name(i)=cond_info.condition_name then go to bypass_segment; end; call continue_to_signal_(code); end; if branch.type^="01"b then return; /* do not process links or directories */ if sdn^=">" then call ioa_$rsnnl ("^a>^a", xp, xi, sdn, sen); else call ioa_$rsnnl (">^a", xp, xi, sen); xi = bin (branch.type, 2); namec = bin (branch.nname, 16); do j = 1 to namec; ename = names (bin (branch.nindex, 18)+j-1); ecc = index (ename, "."); if ecc = 0 then do; if xp = ">" then call ioa_$rsnnl (">^a", message, ml, een); else call ioa_$rsnnl ("^a>^a", message, ml, xp, een); call hcs_$initiate_count(xp, ename, "", bit_count, 0b, segp, ecc); if segp^=null then do; call examine_object_(segp, bit_count, rtrim (message), "", prog_list, total); call hcs_$terminate_noname(segp,ecc); end; return; end; k = length (rtrim (ename)); if k > 8 & substr (ename, k-7, 8) = ".archive" then do; call hcs_$initiate (xp, ename, "", 0b, 0b, segp, ecc); if segp = null then return; header_ptr = segp; call archive_util_$first_disected(header_ptr, comp_ptr, comp_name, bit_count, ecc); do while (ecc = 0); ecc = index (header_ptr -> archive_header.name, "."); if ecc = 0 then do; if xp ^= ">" then call ioa_$rsnnl ("^a>^a", message, ml, xp, ename); else call ioa_$rsnnl (">^a", message, ml, ename); call examine_object_ (comp_ptr, bit_count, rtrim(header_ptr -> archive_header.name), rtrim (message), prog_list, total); end; loop: call archive_util_$disected_element(header_ptr, comp_ptr, comp_name, bit_count, ecc); end; call hcs_$terminate_noname (segp, ecc); return; end; end; return; bypass_segment: revert any_other; /* just in case a condition recurs while recovering */ call hcs_$terminate_noname(segp,ecc); return; end counter; /* process_ctl_args - process control arguments for hunt_dec */ process_ctl_args: procedure(code,message); dcl code fixed bin(35); dcl message char(*) varying; dcl specified(3) bit(1) aligned initial((3)(1)"0"b); dcl (arg_count,arg_index) fixed bin; dcl ctl_index fixed bin; dcl sc fixed bin(35); dcl arg_string char(arg_length) based(arg_ptr); dcl arg_length fixed bin; dcl arg_ptr pointer; dcl suffixed_path character(168) varying; dcl dir char(168); dcl entry char(32); dcl error_table_$badopt fixed bin(35) ext static; dcl expand_pathname_$add_suffix entry(char(*),char(*),char(*),char(*),fixed bin(35)); dcl suffix char(2) init("hd") int static; code=0; message=""; arg_count=cu_$arg_count(); arg_index=2; do while(arg_index<=arg_count); call cu_$arg_ptr(arg_index,arg_ptr,arg_length,sc); ctl_index=valid_ctl(arg_string); if ctl_index=0 then do; code=error_table_$badopt; message=arg_string; return; end; if specified(ctl_index) then do; message=arg_string || " ctl argument specified more than once"; return; end; arg_index=arg_index+1; if arg_index>arg_count then do; code=0; message="pathname must follow ctl argument"; return; end; call cu_$arg_ptr(arg_index,arg_ptr,arg_length,sc); call expand_pathname_$add_suffix(arg_string,suffix,dir,entry,code); suffixed_path=rtrim(arg_string) || "." || suffix; if code ^=0 then do; message=suffixed_path; return; end; specified(ctl_index)="1"b; attach_description(ctl_index)="record_stream_ -target vfile_ " || suffixed_path; arg_index=arg_index+1; end; return; /* valid_ctl - validate and encode control arguments */ valid_ctl: procedure(ctl_arg) returns(fixed bin); dcl valid_arg(3,2) char(18) aligned int static init("-nd","-no_decimal","-ad","-aligned_decimal","-ud","-unaligned_decimal"); dcl ctl_arg character(*); dcl i fixed bin; do i=2 to hbound(valid_arg,1); if ctl_arg=valid_arg(i,1) | ctl_arg=valid_arg(i,2) then return(i); end; return(0); end valid_ctl; end process_ctl_args; /* */ %include archive_header; end hunt_dec;  sweep_disk_dec_.pl1 11/15/82 1829.3rew 11/15/82 1506.4 74826 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ sweep_disk_dec_: proc (path, counter); /* SWEEP_DISK_ - driver for statistics programs. This program is called with a pathname, the root node of a tree to sweep, and a function, which will be called for each directory entry. The program recursively walks down the directory tree and calls the user function for each entry found. This version of the program will try to give itself access if it doesn't have it THVV Modified January 14, 1978 by Peter C. Krupp to be used with hunt_dec. Modified March 16, 1977 by S. Webber to remove long entry, and to chase links that go to dirs (via chase_links entry). Modified on 9 September 1976 by R. G. Bratt to not terminate and to use (get release)_temp_segments_. Modified on 5 June 1975 by J. C. Whitmore to attempt to set system privileges. */ dcl path char (168), /* path name to sweep */ counter entry (char (168), char (32), fixed bin, char (32), ptr, ptr); dcl dummy_dir char (168), dummy_ename char (32); dcl areap ptr, /* ptr to area segment. */ two_ptr (2) ptr init (null,null), myname char (15) init ("sweep_disk_dec_") static options (constant), n_ids fixed bin init (0), /* number of dir UIDs we've processed */ ec fixed bin (35); /* err code */ dcl ids (1) bit (36) aligned based (two_ptr (2)); dcl chase_links_sw bit (1) aligned init ("0"b); /* Indicates if links to dirs are to be chased */ dcl priv_off bit (1); /* flag to tell that system privileges are off */ dcl priv_set fixed bin (35); /* this will be zero if we set system privileges */ dcl sys_info$max_seg_size fixed bin (35) ext; dcl 1 acla (1) aligned, 2 userid char (32), 2 modes bit (36), 2 erc fixed bin (35); dcl 1 delacla (1) aligned, 2 userid char (32), 2 erc fixed bin (35); dcl com_err_ entry options (variable), get_group_id_ entry () returns (char (32) aligned), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), area_ entry (fixed bin (35), ptr); dcl system_privilege_$dir_priv_on entry (fixed bin (35)); dcl system_privilege_$dir_priv_off entry (fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$star_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)), get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)), release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl (cleanup, linkage_error) condition; dcl (addr, null, index, fixed) builtin; /* - - - - */ start: call get_temp_segments_ (myname, two_ptr, ec); areap = two_ptr (1); call area_ (sys_info$max_seg_size, areap); acla (1).userid = get_group_id_ (); delacla (1).userid = acla (1).userid; acla (1).modes = "111"b; priv_off = "1"b; /* assume that we don't have dir privilege */ priv_set = 1; /* and that we did not set dir priv */ on cleanup call clean_up; /* so we can undo what we did */ /* Now we will try to set dir privilege so we can look at each dir in the system. */ on linkage_error go to revert_handler; /* in case of no access to system_privilege_ */ call system_privilege_$dir_priv_on (priv_set); /* try to set it */ priv_off = "0"b; /* privileges are on now for sure */ revert_handler: revert linkage_error; /* it was only to catch system_privilege_ error */ if priv_off then do; /* see if we now have the dir priv */ call com_err_ (0, myname, "Unable to set directory privilege. Access to storage system may not be complete."); priv_set = 1; /* just to be safe */ end; call expand_pathname_ (path, dummy_dir, dummy_ename, ec); /* Just check for syntax error */ if ec ^= 0 then do; call com_err_ (ec, myname, "^a", path); call clean_up; return; end; call process (path, 0); /* Looks innocent ... */ call clean_up; return; /* Done. */ /* - - - - - - - - - - - - - - */ process: proc (apth, lvl); /* internal doit procedure */ dcl apth char (168), /* path of tree to process */ lvl fixed bin; /* recursion level */ dcl npth char (168), /* new path for recursion */ dstar char (2) init ("**") internal static options (constant), /* for star, gets all. */ ddn char (168), /* ... for expand */ een char (32), /* ... */ c32 char (32), new_dirname char (168), new_ename char (32), ifail fixed bin (35), (eptr, nptr) ptr init (null), /* for star and status */ ecc fixed bin (35), (t, bcount, lc, ii, nix, i) fixed bin; /* indices */ dcl names (100) char (32) aligned based (nptr); /* Structure returned by star_ */ dcl 1 branches (100) aligned based (eptr), /* ... */ 2 type bit (2) unaligned, /* 10b is directory */ 2 nnam bit (16) unaligned, /* number of names this seg */ 2 nindex bit (18) unaligned, /* index in names structure */ 2 padx bit (108) unaligned; dcl 1 entry aligned, 2 type bit (2) unaligned, 2 nnam fixed bin (15) unaligned, 2 nindex fixed bin (17) unaligned, 2 padx bit (288) aligned, 2 uid bit (36) aligned; on cleanup begin; if eptr ^= null then free eptr -> branches; if nptr ^= null then free nptr -> names; if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (delacla), 1, ecc); end; call expand_pathname_ (apth, ddn, een, ecc); /* needn't check ecc, cause we made path */ /* except for first time which is checked */ /* Now get UID of the dir and place on stack */ call hcs_$status_long (ddn, een, 0, addr (entry), null, ecc); n_ids = n_ids + 1; ids (n_ids) = entry.uid; call hcs_$add_dir_acl_entries (ddn, een, addr (acla), 1, ifail); call hcs_$star_list_ (apth, dstar, 111b, areap, bcount, lc, eptr, nptr, ecc); if ecc = 0 then do; do ii = 1 to bcount + lc; /* Now do all branches, look for sub-dirs. */ nix = fixed (eptr -> branches (ii).nindex); c32 = nptr -> names (nix); call counter (ddn, een, lvl, c32, addr (eptr -> branches (ii)), nptr); if eptr -> branches (ii).type = "10"b then do; if apth = ">" then npth = ">" || c32; else npth = rtrim (apth) || ">" || c32; call process (npth, lvl+1); /* recursion here */ end; /* Now check to see if we have a link to a directory */ else if eptr -> branches (ii).type = "00"b & chase_links_sw then do; call hcs_$get_link_target (apth, c32, new_dirname, new_ename, ecc); if ecc = 0 then do; call hcs_$status_long (new_dirname, new_ename, 0, addr (entry), null, ecc); if ecc = 0 then do; if entry.type = "10"b then do; do i = 1 to n_ids; if ids (i) = entry.uid then goto already_done; end; n_ids = n_ids + 1; ids (n_ids) = entry.uid; call process (rtrim (new_dirname) || ">" || new_ename, lvl+1); end; end; end; already_done: end; end; free eptr -> branches; /* Clean up area. */ free nptr -> names; /* ... */ end; if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (delacla), 1, ecc); end process; /* Whew. */ /* CHASE_LINK: Entry to chase links to directories */ chase_links: entry (path, counter); chase_links_sw = "1"b; goto start; clean_up: proc; if priv_set = 0 then call system_privilege_$dir_priv_off (priv_set); call release_temp_segments_ (myname, two_ptr, ec); return; end clean_up; end; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved