COMPILATION LISTING OF SEGMENT gcos_gsr_read_ Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/19/82 1004.8 mst Fri Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 /* This procedure will return one record from a gcos standard format 12* 320 word block. It will read from the stream "attname" and return a 13* pointer to the record just read in buffp, the length of the read 14* data will be in reclen, the record header (media and report codes) 15* will be in rcrdhdr, and eofsw will be set if this record is the last 16* in the last block 17* 18* WRITTEN BY DICK SNYDER 1971 19* MODIFIED BY P.M. HABER SEPTEMBER 1973 20* MODIFIED BY T. CASEY APRIL 1974, AUGUST 1974, NOVEMBER 1974 21* 22* */ 23 24 25 gcos_gsr_read_: proc (attname, buffp, reclen, rcrdhdr, eofsw, fx_code); 26 27 dcl attname char (*); 28 dcl eofsw bit (1); 29 dcl buffp ptr; 30 dcl reclen fixed bin; 31 dcl rcrdhdr bit (12); 32 dcl fx_code fixed bin (35); 33 34 dcl 1 word based aligned, 35 2 upper bit (18) unaligned, 36 2 lower bit (18) unaligned; 37 38 dcl ios_$read ext entry 39 (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); 40 41 dcl (error_table_$bad_file, error_table_$file_already_opened, error_table_$file_not_opened) ext fixed bin (35); 42 dcl forcesw bit (1) init ("0"b); 43 dcl (first, last) ptr int static init (null); 44 45 dcl 1 c_block based (cp), /* control block for a file being read */ 46 2 name char (32), /* file name */ 47 2 mybuf char (1280), /* read buffer */ 48 2 rcrdp ptr, 49 2 myeofsw bit (1), 50 2 readsw bit (1), 51 2 blklen fixed bin, 52 2 forward ptr, 53 2 backward ptr; 54 55 dcl cp ptr init (null) int static; 56 dcl st bit (72) aligned; 57 dcl code fixed bin (35) based (addr (st)); 58 dcl stringlen fixed bin; 59 dcl mybufp ptr; 60 dcl j fixed bin; 61 dcl (addr, addrel, baseno, fixed, null, substr) builtin; 62 63 dcl closing bit (1) aligned init ("0"b); 64 65 dcl get_system_free_area_ ext entry returns (ptr); 66 dcl system_free_ptr ptr int static init (null); 67 dcl system_free_area area based (system_free_ptr); 68 69 /* */ 70 71 COMMON: /* come here from gsr_read_close entry point */ 72 fx_code = 0; /* initialize return code */ 73 if first = null then go to error; /* attempt to read without initing */ 74 75 cp = first; /* get ptr to first control block */ 76 srch_loop: 77 if attname = c_block.name then go to hit; 78 cp = c_block.forward; 79 if cp ^= null then go to srch_loop; /* continue to look */ 80 error: 81 fx_code = error_table_$file_not_opened; 82 return; 83 84 hit: 85 if closing then goto nodata; /* if entered at gsr_read_close entry point */ 86 87 mybufp = addr (c_block.mybuf); 88 if readsw then do; 89 if myeofsw then do; /* eof already encountered */ 90 nodata: 91 if c_block.backward = null then do; /* first block in chain */ 92 first = c_block.forward; /* set first to point to next block */ 93 if first ^= null then /* don't reference thru null ptr if only 1 block */ 94 first -> c_block.backward = null; /* set back point in next block to null */ 95 /* (it is new first blk) */ 96 end; 97 else if c_block.forward = null then do; /* last block in chain */ 98 last = c_block.backward; /* set up new last ptr */ 99 last -> c_block.forward = null; /* previous block is new last block */ 100 end; 101 else do; /* block is in middle of chain */ 102 c_block.backward -> c_block.forward = c_block.forward; /* thread this block out of list */ 103 c_block.forward -> c_block.backward = c_block.backward; 104 end; 105 106 free cp -> c_block in (system_free_area); /* deallocate block */ 107 108 if closing then return; /* if entered at gsr_read_close entry point */ 109 110 eofsw = "1"b; 111 reclen = 0; 112 return; 113 end; 114 115 read: 116 call ios_$read (attname, mybufp, 0, 320, j, st); 117 if substr (st, 1, 3) = "100"b /* hardware status returned */ 118 then do; 119 if substr (st, 27, 4) = "0100"b /* "tape mark" status */ 120 then do; 121 myeofsw = "1"b; /* return eof condition to caller */ 122 substr (st, 1, 36) = "0"b; /* and zero out returned error code */ 123 end; 124 else goto io_error; /* not "tape mark" status, error */ 125 end; 126 127 else /* not hardware status */ 128 do; 129 if code ^= 0 then do; /* error occurred */ 130 io_error: fx_code = code; /* return error code */ 131 return; 132 end; 133 myeofsw = substr (st, 1, 46); /* take eof switch from normal location */ 134 end; 135 readsw = "0"b; 136 137 if j = 0 then go to nodata; /* nothing read */ 138 rcrdp = addrel (mybufp, 1); /* point to first record */ 139 blklen = fixed (mybufp -> word.lower, 17); /* reinit block len */ 140 if blklen > 319 | blklen < 1 then do; /* test for legal block length */ 141 buffp = mybufp; /* return pointer to bad bcw, in case 142* caller wants to examine or display it */ 143 goto fmt_err; 144 end; 145 end; 146 147 if substr (rcrdp -> word.lower, 1, 6) = "001111"b then goto nodata; /* check for eof in rcw */ 148 149 reclen = fixed (rcrdp -> word.upper, 17); /* get record len */ 150 if reclen >= blklen | reclen > 318 | reclen = 0 then do; /* check for legal record length */ 151 buffp = rcrdp; /* return pointer to bad rcw, in case 152* caller wants to examine or display it */ 153 goto fmt_err; 154 end; 155 rcrdhdr = substr (rcrdp -> word.lower, 7, 12); /* return report and media codes */ 156 blklen = blklen - reclen - 1; /* decrement block len */ 157 if blklen = 0 then readsw = "1"b; /* remember to read new block if end of block */ 158 eofsw = "0"b; 159 buffp = addrel (rcrdp, 1); /* point to data */ 160 rcrdp = addrel (rcrdp, reclen+1); /* point to next record */ 161 return; 162 163 164 /* Come here if bcw or rcw had bad length field */ 165 166 fmt_err: fx_code = error_table_$bad_file; 167 goto nodata; 168 169 170 171 172 /* Must enter here before reading to init control block */ 173 174 175 gsr_read_init: entry (attname, fx_code); 176 177 fx_code = 0; /* initialize return code */ 178 if first = null then go to create; /* no blocks yet */ 179 cp = first; /* see if guy is attmepting to init same file twice */ 180 cr_loop: 181 if attname = c_block.name then do; 182 fx_code = error_table_$file_already_opened; 183 return; 184 end; 185 186 if c_block.forward = null then go to create; 187 cp = c_block.forward; /* on to next one */ 188 go to cr_loop; 189 190 create: 191 if system_free_ptr = null then system_free_ptr = get_system_free_area_ (); 192 allocate c_block in (system_free_area) set (last); /* allocate a control block for this file */ 193 if first = null then do; 194 cp, first = last; /* this is first and only block */ 195 c_block.backward = null; /* no back block */ 196 end; 197 else do; 198 c_block.forward = last; /* fill in forward pointer in last block */ 199 last -> c_block.backward = cp; /* fill in backward pointer in this block */ 200 cp = last; /* point now to new block */ 201 end; 202 203 c_block.forward = null; /* no next block */ 204 c_block.readsw = "1"b; /* cause read at next call */ 205 c_block.myeofsw = "0"b; /* no eof */ 206 c_block.name = attname; 207 return; 208 209 210 gsr_read_close: entry (attname, fx_code); 211 212 closing = "1"b; 213 goto COMMON; 214 215 end gcos_gsr_read_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/19/82 0930.4 gcos_gsr_read_.pl1 >spec>on>11/19/82>gcos_gsr_read_.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. addr builtin function dcl 61 ref 87 129 130 addrel builtin function dcl 61 ref 138 159 160 attname parameter char unaligned dcl 27 set ref 25 76 115* 175 180 206 210 backward 516 based pointer level 2 dcl 45 set ref 90 93* 98 102 103* 103 195* 199* blklen 513 based fixed bin(17,0) level 2 dcl 45 set ref 139* 140 140 150 156* 156 157 buffp parameter pointer dcl 29 set ref 25 141* 151* 159* c_block based structure level 1 unaligned dcl 45 set ref 106 192 closing 000107 automatic bit(1) initial dcl 63 set ref 63* 84 108 212* code based fixed bin(35,0) dcl 57 ref 129 130 cp 000014 internal static pointer initial dcl 55 set ref 75* 76 78* 78 79 87 88 89 90 92 97 98 102 102 103 103 106 121 133 135 138 139 140 140 147 149 150 151 155 156 156 157 157 159 160 160 179* 180 186 187* 187 194* 195 198 199 200* 203 204 205 206 eofsw parameter bit(1) unaligned dcl 28 set ref 25 110* 158* error_table_$bad_file 000022 external static fixed bin(35,0) dcl 41 ref 166 error_table_$file_already_opened 000024 external static fixed bin(35,0) dcl 41 ref 182 error_table_$file_not_opened 000026 external static fixed bin(35,0) dcl 41 ref 80 first 000010 internal static pointer initial dcl 43 set ref 73 75 92* 93 93 178 179 193 194* fixed builtin function dcl 61 ref 139 149 forcesw 000100 automatic bit(1) initial unaligned dcl 42 set ref 42* forward 514 based pointer level 2 dcl 45 set ref 78 92 97 99* 102* 102 103 186 187 198* 203* fx_code parameter fixed bin(35,0) dcl 32 set ref 25 71* 80* 130* 166* 175 177* 182* 210 get_system_free_area_ 000030 constant entry external dcl 65 ref 190 ios_$read 000020 constant entry external dcl 38 ref 115 j 000106 automatic fixed bin(17,0) dcl 60 set ref 115* 137 last 000012 internal static pointer initial dcl 43 set ref 98* 99 192* 194 198 199 200 lower 0(18) based bit(18) level 2 packed unaligned dcl 34 ref 139 147 155 mybuf 10 based char(1280) level 2 packed unaligned dcl 45 set ref 87 mybufp 000104 automatic pointer dcl 59 set ref 87* 115* 138 139 141 myeofsw 512 based bit(1) level 2 packed unaligned dcl 45 set ref 89 121* 133* 205* name based char(32) level 2 packed unaligned dcl 45 set ref 76 180 206* null builtin function dcl 61 ref 73 79 90 93 93 97 99 178 186 190 193 195 203 rcrdhdr parameter bit(12) unaligned dcl 31 set ref 25 155* rcrdp 510 based pointer level 2 dcl 45 set ref 138* 147 149 151 155 159 160* 160 readsw 512(01) based bit(1) level 2 packed unaligned dcl 45 set ref 88 135* 157* 204* reclen parameter fixed bin(17,0) dcl 30 set ref 25 111* 149* 150 150 150 156 160 st 000102 automatic bit(72) dcl 56 set ref 115* 117 119 122* 129 130 133 substr builtin function dcl 61 set ref 117 119 122* 133 147 155 system_free_area based area(1024) dcl 67 ref 106 192 system_free_ptr 000016 internal static pointer initial dcl 66 set ref 106 190 190* 192 upper based bit(18) level 2 packed unaligned dcl 34 ref 149 word based structure level 1 dcl 34 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. baseno builtin function dcl 61 stringlen automatic fixed bin(17,0) dcl 58 NAMES DECLARED BY EXPLICIT CONTEXT. COMMON 000044 constant label dcl 71 ref 213 cr_loop 000405 constant label dcl 180 ref 188 create 000430 constant label dcl 190 ref 178 186 error 000073 constant label dcl 80 set ref 73 fmt_err 000347 constant label dcl 166 ref 143 153 gcos_gsr_read_ 000025 constant entry external dcl 25 gsr_read_close 000507 constant entry external dcl 210 gsr_read_init 000356 constant entry external dcl 175 hit 000076 constant label dcl 84 ref 76 io_error 000241 constant label dcl 130 ref 119 nodata 000110 constant label dcl 90 ref 84 137 147 167 read 000162 constant label dcl 115 srch_loop 000054 constant label dcl 76 ref 79 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 650 702 533 660 Length 1072 533 32 153 114 10 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gcos_gsr_read_ 106 external procedure is an external procedure. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 first gcos_gsr_read_ 000012 last gcos_gsr_read_ 000014 cp gcos_gsr_read_ 000016 system_free_ptr gcos_gsr_read_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME gcos_gsr_read_ 000100 forcesw gcos_gsr_read_ 000102 st gcos_gsr_read_ 000104 mybufp gcos_gsr_read_ 000106 j gcos_gsr_read_ 000107 closing gcos_gsr_read_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out_desc call_ext_out return ext_entry_desc alloc_based free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. get_system_free_area_ ios_$read THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_file error_table_$file_already_opened error_table_$file_not_opened LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 42 000013 63 000014 25 000017 71 000044 73 000045 75 000052 76 000054 78 000065 79 000067 80 000073 82 000075 84 000076 87 000100 88 000102 89 000105 90 000110 92 000116 93 000120 96 000126 97 000127 98 000133 99 000135 100 000140 102 000141 103 000144 106 000147 108 000151 110 000153 111 000160 112 000161 115 000162 117 000220 119 000224 121 000231 122 000235 125 000236 129 000237 130 000241 131 000243 133 000244 135 000252 137 000254 138 000256 139 000261 140 000264 141 000270 143 000273 147 000274 149 000302 150 000306 151 000314 153 000316 155 000317 156 000324 157 000330 158 000333 159 000337 160 000341 161 000346 166 000347 167 000351 175 000352 177 000375 178 000376 179 000403 180 000405 182 000416 183 000420 186 000421 187 000425 188 000427 190 000430 192 000442 193 000451 194 000455 195 000457 196 000462 198 000463 199 000465 200 000466 203 000467 204 000472 205 000474 206 000476 207 000504 210 000505 212 000526 213 000530 ----------------------------------------------------------- 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