1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */
 13 
 14 truncate$trfile: proc (a_dirname, a_ename, a_addrs, a_code);
 15 
 16 /*        Date last modified and reasons:
 17    11/84 by Keith Loepere for terminate_.
 18    7/84 by Keith Loepere to use the new dc_find.
 19    1/82 BIM to lock dir for write to protect truncate_vtoce from activations.
 20    11/2/78 by B. Greenberg for raw/effective mode problem (not checking priv_init).
 21    760630 by L. Scheffler to not audit truncates on copy-on-write segs
 22    05/31/76 by R. Bratt to call find_$finished
 23    04/20/76 by R.  Bratt to  check mountedness before truncate
 24    760309 by L. Scheffler to use info-only entries in dir_control_error
 25    04/28/75 by Greenberg for NSS
 26    10/10/74 by Kobziar to call new access_mode entry
 27    08/24/71 by RHG for page multi-level and to clean up the overlay for zeroing
 28    07/27/71 by David Vinograd
 29    06/13/71 by R. Gumpertz to check for negative addrs
 30    06/12/71 by R. Gumpertz to add zeroing of last page after addrs
 31    and to check fpage properly against seg length
 32    and to eliminate accessing of a_addrs while
 33    a directory is locked
 34  */
 35 %page;
 36 
 37 /* Parameters */
 38 
 39 dcl  a_addrs                            fixed bin (17) parameter;
 40 dcl  a_code                             fixed bin (35) parameter;
 41 dcl  a_dirname                          char (*) parameter;
 42 dcl  a_ename                            char (*) parameter;
 43 dcl  a_ep                               ptr parameter;
 44 dcl  a_segptr                           ptr parameter;
 45 
 46 /* Variables */
 47 
 48 dcl  addrs                              fixed bin (17);
 49 dcl  by_name                            bit (1) aligned init ("0"b);
 50 dcl  code                               fixed bin (35);
 51 dcl  ename                              char (32);
 52 dcl  esw                                fixed bin (17);
 53 dcl  fpage                              fixed bin (17);
 54 dcl  overlay_size                       fixed bin;
 55 dcl  parent                             char (168);
 56 dcl  segptr                             ptr;
 57 dcl  write_lock                         bit (36) aligned init ((36)"1"b);
 58 
 59 /* Based */
 60 
 61 dcl  overlay                            bit (overlay_size) based aligned; /* This is used to get at the words to be zeroed */
 62 
 63 /* External */
 64 
 65 dcl  error_table_$argerr                fixed bin (35) external;
 66 dcl  error_table_$boundviol             fixed bin (35) external;
 67 dcl  error_table_$dirseg                fixed bin (35) external;
 68 dcl  error_table_$rqover                fixed bin (35) external;
 69 dcl  pds$processid                      bit (36) aligned ext;
 70 
 71 /* Entries */
 72 
 73 dcl  get_kstep                          entry (fixed bin (18), ptr, fixed bin (35));
 74 dcl  initiate                           entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
 75 dcl  lock$dir_unlock                    entry (ptr);
 76 dcl  mountedp                           entry (bit (36) aligned) returns (fixed bin (35));
 77 dcl  sum$dirmod                         entry (ptr);
 78 dcl  terminate_$noname                  entry (ptr, fixed bin (35));
 79 dcl  truncate_vtoce                     entry (ptr, fixed bin, fixed bin (35));
 80 
 81 /* Misc */
 82 
 83 dcl  (addrel, baseno, divide, fixed, null, ptr) builtin;
 84 
 85 dcl  out_of_bounds                      condition;
 86 %page;
 87           esw = 0;                                          /* set entry point switch */
 88           code = 0;
 89           addrs = a_addrs;                                  /* copy the args */
 90           parent = a_dirname;                               /* copy directory name */
 91           ename = a_ename;                                  /* copy entry name */
 92           call dc_find$obj_truncate (parent, ename, ep, code); /* get pointer to branch + lock directory */
 93           dp = ptr (ep, 0);
 94           if code ^= 0 then go to finale;
 95           by_name = "1"b;
 96           go to join;                                       /* transfer to common code */
 97 
 98 trseg: entry (a_segptr, a_addrs, a_code);
 99 
100           esw = 1;                                          /* set entry point switch */
101           code = 0;
102           addrs = a_addrs;                                  /* copy the addrs given */
103           segptr = ptr (a_segptr, 0);                       /* copy argument */
104 
105           call get_kstep (fixed (baseno (segptr)), kstep, code);
106           if code ^= 0 then go to finale;
107 
108           if kste.priv_init then call dc_find$obj_truncate_raw_ptr (segptr, ep, code); /* get pointer to branch + lock directory */
109           else call dc_find$obj_truncate_ptr (segptr, ep, code); /* get pointer to branch + lock directory */
110           if code ^= 0 then go to finale;
111           dp = ptr (ep, 0);
112 
113 join:     if ep -> entry.dirsw then do;                     /* truncating directories not allowed */
114                code = error_table_$dirseg;
115                go to unlock;
116           end;
117 
118           if addrs < 0 then do;                             /* check for negative length specified */
119                code = error_table_$argerr;
120                go to unlock;
121           end;
122                                                             /* check for length too big */
123 
124           fpage = divide (addrs + 1023, 1024, 17, 0);       /* get number of first page to be truncated */
125 
126           go to join1;
127 
128 trentry: entry (a_ep);
129 
130           esw = 2;
131           fpage = 0;
132           ep = a_ep;
133           code = 0;
134           dp = ptr (ep, 0);
135 join1:
136 
137           code = mountedp (dir.sons_lvid);
138           if code = 0
139           then do;
140                dir.modify = pds$processid;                  /* Mark dir inconsistent */
141 
142                call truncate_vtoce (ep, fpage, code);       /* Truncate the vtoce/aste */
143 
144                if code ^= 0 then if code = error_table_$rqover then code = 0; /* ignore rqo */
145           end;
146           if esw = 2 then return;                           /* if deleting, return */
147 
148 
149           dir.modify = "0"b;
150           call sum$dirmod (dp);
151           if by_name
152           then call dc_find$finished (dp, "1"b);
153           else call lock$dir_unlock (dp);                   /* unlock the directory */
154 
155 /*        The following code zeros out the last page of the segment starting
156    at addrs. This is so that truncating will be to the word, rather than
157    to the page.
158    */
159 
160           if code ^= 0 then go to finale;
161 
162           on condition (out_of_bounds) go to boundviol;     /* Attempt to trunc beyond current length
163                                                                may cause oob here */
164           overlay_size = (fpage * 1024 - addrs) * 36;       /* compute n bits to zero */
165           if overlay_size ^= 0 then do;                     /* dont bother if none to zero */
166                if esw = 0 then do;                          /* if entered without ptr, we must get one */
167                     call initiate (parent, ename, "", 0, 1, segptr, code);
168                     if segptr = null then goto finale;
169                     code = 0;                               /* forget any segknowns */
170                end;
171                addrel (segptr, addrs) -> overlay = ""b;     /* clear the words */
172                if esw = 0 then call terminate_$noname (segptr, code); /* terminate the pointer if we had to get one */
173           end;
174 
175 finale:   a_code = code;
176           return;
177 
178 unlock:   if dir.modify then dir.modify = "0"b;
179           if by_name
180           then call dc_find$finished (dp, "1"b);
181           else call lock$dir_unlock (dp);
182           go to finale;
183 
184 boundviol:
185           a_code = error_table_$boundviol;
186           return;
187 %page;
188 %page; %include dc_find_dcls;
189 %page; %include dir_entry;
190 %page; %include dir_header;
191 %page; %include kst;
192      end;