COMPILATION LISTING OF SEGMENT gcos_gsr_write_ 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.9 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 /* 12* This procedure will write one record in gecos standard format. 13* It will write blocks to the stream "attname", it will copy the record 14* into a block from the place pointed to by buffp, it will copy the 15* number of words specified by reclen, it will use the supplied report 16* code, and if eofsw is on, it will force the current block to be 17* written out even if not full ( and will not allow anymore write 18* calls until reinitialized). 19* 20* WRITTEN BY DICK SNYDER 1971 21* MODIFIED BY P.M. HABER SEPTEMBER 1973 22* MODIFIED BY T. CASEY APRIL 1974 23* 24* */ 25 26 27 gcos_gsr_write_: proc (attname, buffp, reclen, report_code, eofsw, fx_code); 28 dcl attname char (*); 29 dcl eofsw bit (1); 30 dcl report_code bit (12); 31 dcl buffp pointer; 32 dcl reclen fixed bin; 33 dcl fx_code fixed bin (35); 34 35 dcl 1 word based aligned, 36 2 upper bit (18) unaligned, 37 2 lower bit (18) unaligned; 38 dcl ios_$write ext entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); 39 dcl (error_table_$file_not_opened, error_table_$file_already_opened) ext fixed bin (35); 40 dcl thing char (20) varying; 41 dcl forcesw bit (1) init ("0"b); 42 dcl (first, last) pointer int static init (null); 43 dcl 1 c_block based (cp), /* control block for a file being written */ 44 2 name char (32), /* file name */ 45 2 mybuf char (1280), /* write buffer */ 46 2 rcrdp pointer, 47 2 serial_no fixed bin, 48 2 blklen fixed bin, 49 2 forward pointer, 50 2 backward pointer; 51 52 dcl cp pointer int static init (null); 53 dcl st bit (72) aligned; 54 dcl code fixed bin (35) based (addr (st)); 55 dcl stringlen fixed bin; 56 dcl basedstring bit (stringlen) based; 57 dcl mybufp pointer; 58 dcl j fixed bin; 59 dcl (addr, addrel, baseno, null, unspec, substr) builtin; 60 61 dcl closing bit (1) aligned init ("0"b); 62 63 dcl get_system_free_area_ ext entry returns (ptr); 64 dcl system_free_ptr ptr int static init (null); 65 dcl system_free_area area based (system_free_ptr); 66 67 68 COMMON: /* come here from gsr_write_close entry */ 69 fx_code = 0; /* initialize return argument */ 70 71 if first = null then go to error; /* attempt to write without initing */ 72 73 cp = first; /* get pointer to first control block */ 74 srch_loop: 75 if attname = c_block.name then go to hit; 76 cp = c_block.forward; 77 if cp ^= null then go to srch_loop; /* continue to look */ 78 error: 79 fx_code = error_table_$file_not_opened; 80 return; 81 82 83 hit: 84 if closing then goto free_buffer; /* if entered at gsr_write_close entry */ 85 86 mybufp = addr (c_block.mybuf); 87 if blklen = -1 then do; /* new block */ 88 89 newblk: mybufp -> word.upper = substr (unspec (serial_no), 19, 18); /* put serial no in block */ 90 serial_no = serial_no+1; /* update serial no */ 91 blklen = 0; 92 rcrdp = addrel (mybufp, 1); /* point to first record header */ 93 end; 94 95 if blklen + reclen > 318 then do; /* new record won't fit in current block */ 96 force: mybufp -> word.lower = substr (unspec (blklen), 19, 18); /* put block len in block */ 97 blklen = -1; 98 call ios_$write (attname, mybufp, 0, 320, j, st); /* write block */ 99 if code ^= 0 then do; 100 fx_code = code; /* return error code */ 101 return; 102 end; 103 104 if forcesw then do; /* all done if eof being written */ 105 free_buffer: 106 107 if c_block.backward = null then do; /* first block in chain */ 108 109 first = c_block.forward; /* set first to point to next block */ 110 if first ^= null then /* don't reference thru null ptr if only 1 block */ 111 first -> c_block.backward = null; /* set back point in next block to null */ 112 /* (it is new first block ) */ 113 end; 114 else if c_block.forward = null then do; /* last block in chain */ 115 116 last = c_block.backward; /* set up new last pointer */ 117 last -> c_block.forward = null; /* previous block is new last block */ 118 end; 119 120 else do; /* we have block in middle of chain */ 121 122 c_block.backward -> c_block.forward = c_block.forward; /* thread this block out of list */ 123 c_block.forward -> c_block.backward = c_block.backward; 124 end; 125 126 free cp -> c_block in (system_free_area); /* deallocate block */ 127 return; 128 end; 129 130 go to newblk; 131 end; 132 133 if reclen ^= 0 then do; 134 rcrdp -> word.upper = substr (unspec (reclen), 19, 18); /* put record len in rcrd header */ 135 rcrdp -> word.lower = "0"b; /* put report and */ 136 substr (rcrdp -> word.lower, 7, 12) = report_code; /* media codes in rcrd header */ 137 rcrdp = addrel (rcrdp, 1); /* now point to data area */ 138 stringlen = 36*reclen; /* get length of rcrd in bits */ 139 rcrdp -> basedstring = buffp -> basedstring; /* copy record into buffer */ 140 rcrdp = addrel (rcrdp, reclen); /* point to next record header */ 141 blklen = blklen+reclen+1; /* update block length */ 142 end; 143 144 forcesw = eofsw; /* supposed to write eof? */ 145 if forcesw then go to force; /* yes */ 146 147 return; 148 149 150 151 /* Must enter here before writing to init control block */ 152 153 154 gsr_write_init: entry (attname, fx_code); 155 156 fx_code = 0; /* initialize returned code */ 157 if first = null then go to create; /* no blocks yet */ 158 cp = first; /* see if guy is attmepting to init same file twice */ 159 cr_loop: 160 if attname = c_block.name then do; 161 fx_code = error_table_$file_already_opened; 162 return; 163 end; 164 165 if c_block.forward = null then go to create; 166 cp = c_block.forward; /* on to next one */ 167 go to cr_loop; 168 169 create: 170 if system_free_ptr = null then system_free_ptr = get_system_free_area_ (); 171 allocate c_block in (system_free_area) set (last); /* allocate a control block for this file */ 172 if first = null then do; 173 cp, first = last; /* this is first and only block */ 174 c_block.backward = null; /* no back block */ 175 end; 176 else do; 177 c_block.forward = last; /* fill in forward pointer in last block */ 178 last -> c_block.backward = cp; /* fill in backward pointer in this block */ 179 cp = last; /* point now to new block */ 180 end; 181 182 c_block.forward = null; /* no next block */ 183 c_block.blklen = -1; 184 c_block.serial_no = 1; 185 c_block.name = attname; 186 return; 187 188 189 gsr_write_close: entry (attname, fx_code); 190 191 closing = "1"b; /* remember we are just going to free a buffer */ 192 goto COMMON; /* go look for it */ 193 194 end gcos_gsr_write_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/19/82 0930.5 gcos_gsr_write_.pl1 >spec>on>11/19/82>gcos_gsr_write_.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 59 ref 86 99 100 addrel builtin function dcl 59 ref 92 137 140 attname parameter char unaligned dcl 28 set ref 27 74 98* 154 159 185 189 backward 516 based pointer level 2 dcl 43 set ref 105 110* 116 122 123* 123 174* 178* basedstring based bit unaligned dcl 56 set ref 139* 139 blklen 513 based fixed bin(17,0) level 2 dcl 43 set ref 87 91* 95 96 97* 141* 141 183* buffp parameter pointer dcl 31 ref 27 139 c_block based structure level 1 unaligned dcl 43 set ref 126 171 closing 000111 automatic bit(1) initial dcl 61 set ref 61* 83 191* code based fixed bin(35,0) dcl 54 ref 99 100 cp 000014 internal static pointer initial dcl 52 set ref 73* 74 76* 76 77 86 87 89 90 90 91 92 95 96 97 105 109 114 116 122 122 123 123 126 134 135 136 137 137 139 140 140 141 141 158* 159 165 166* 166 173* 174 177 178 179* 182 183 184 185 eofsw parameter bit(1) unaligned dcl 29 ref 27 144 error_table_$file_already_opened 000024 external static fixed bin(35,0) dcl 39 ref 161 error_table_$file_not_opened 000022 external static fixed bin(35,0) dcl 39 ref 78 first 000010 internal static pointer initial dcl 42 set ref 71 73 109* 110 110 157 158 172 173* forcesw 000100 automatic bit(1) initial unaligned dcl 41 set ref 41* 104 144* 145 forward 514 based pointer level 2 dcl 43 set ref 76 109 114 117* 122* 122 123 165 166 177* 182* fx_code parameter fixed bin(35,0) dcl 33 set ref 27 68* 78* 100* 154 156* 161* 189 get_system_free_area_ 000026 constant entry external dcl 63 ref 169 ios_$write 000020 constant entry external dcl 38 ref 98 j 000110 automatic fixed bin(17,0) dcl 58 set ref 98* last 000012 internal static pointer initial dcl 42 set ref 116* 117 171* 173 177 178 179 lower 0(18) based bit(18) level 2 packed unaligned dcl 35 set ref 96* 135* 136* mybuf 10 based char(1280) level 2 packed unaligned dcl 43 set ref 86 mybufp 000106 automatic pointer dcl 57 set ref 86* 89 92 96 98* name based char(32) level 2 packed unaligned dcl 43 set ref 74 159 185* null builtin function dcl 59 ref 71 77 105 110 110 114 117 157 165 169 172 174 182 rcrdp 510 based pointer level 2 dcl 43 set ref 92* 134 135 136 137* 137 139 140* 140 reclen parameter fixed bin(17,0) dcl 32 ref 27 95 133 134 138 140 141 report_code parameter bit(12) unaligned dcl 30 ref 27 136 serial_no 512 based fixed bin(17,0) level 2 dcl 43 set ref 89 90* 90 184* st 000102 automatic bit(72) dcl 53 set ref 98* 99 100 stringlen 000104 automatic fixed bin(17,0) dcl 55 set ref 138* 139 139 substr builtin function dcl 59 set ref 89 96 134 136* system_free_area based area(1024) dcl 65 ref 126 171 system_free_ptr 000016 internal static pointer initial dcl 64 set ref 126 169 169* 171 unspec builtin function dcl 59 ref 89 96 134 upper based bit(18) level 2 packed unaligned dcl 35 set ref 89* 134* word based structure level 1 dcl 35 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. baseno builtin function dcl 59 thing automatic varying char(20) dcl 40 NAMES DECLARED BY EXPLICIT CONTEXT. COMMON 000044 constant label dcl 68 ref 192 cr_loop 000345 constant label dcl 159 ref 167 create 000370 constant label dcl 169 ref 157 165 error 000073 constant label dcl 78 ref 71 force 000127 constant label dcl 96 ref 145 free_buffer 000203 constant label dcl 105 ref 83 gcos_gsr_write_ 000025 constant entry external dcl 27 gsr_write_close 000447 constant entry external dcl 189 gsr_write_init 000316 constant entry external dcl 154 hit 000076 constant label dcl 83 ref 74 newblk 000105 constant label dcl 89 ref 130 srch_loop 000054 constant label dcl 74 ref 77 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 600 630 472 610 Length 1016 472 30 152 106 10 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gcos_gsr_write_ 110 external procedure is an external procedure. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 first gcos_gsr_write_ 000012 last gcos_gsr_write_ 000014 cp gcos_gsr_write_ 000016 system_free_ptr gcos_gsr_write_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME gcos_gsr_write_ 000100 forcesw gcos_gsr_write_ 000102 st gcos_gsr_write_ 000104 stringlen gcos_gsr_write_ 000106 mybufp gcos_gsr_write_ 000110 j gcos_gsr_write_ 000111 closing gcos_gsr_write_ 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_$write THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$file_already_opened error_table_$file_not_opened LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 41 000013 61 000014 27 000017 68 000044 71 000045 73 000052 74 000054 76 000065 77 000067 78 000073 80 000075 83 000076 86 000100 87 000102 89 000105 90 000113 91 000114 92 000115 95 000120 96 000127 97 000134 98 000136 99 000175 100 000177 101 000200 104 000201 105 000203 109 000211 110 000213 113 000221 114 000222 116 000226 117 000230 118 000233 122 000234 123 000237 126 000242 127 000244 130 000245 133 000246 134 000250 135 000254 136 000256 137 000263 138 000265 139 000267 140 000274 141 000277 144 000302 145 000307 147 000311 154 000312 156 000335 157 000336 158 000343 159 000345 161 000356 162 000360 165 000361 166 000365 167 000367 169 000370 171 000402 172 000411 173 000415 174 000417 175 000422 177 000423 178 000425 179 000426 182 000427 183 000432 184 000434 185 000436 186 000444 189 000445 191 000466 192 000470 ----------------------------------------------------------- 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