COMPILATION LISTING OF SEGMENT rs_open_seq_in_ Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Bull, Phx, AZ, Sys-M Compiled on: 09/10/87 1451.7 mst Thu Options: optimize list 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 /* record_stream_ program for handling sequential input openings */ 12 rs_open_seq_in_: 13 proc (iocb_ptr_arg, code); 14 iocb_ptr = iocb_ptr_arg; 15 /* set entries in iocb for valid operations in this mode */ 16 read_record = read_record_rs; 17 read_length = read_length_rs; 18 position = position_seq_rs; 19 return; /* end of opening routine */ 20 21 read_record_rs: 22 entry (iocb_ptr_arg, buff_ptr_arg, buff_len, rec_len, code); 23 call initialize; 24 buff_ptr = buff_ptr_arg; 25 if n_left ^= 0 26 then /* internal buffer contains a record */ 27 do; /* get record from rs_buffer */ 28 if n_left > 0 29 then rec_len = n_left; 30 else rec_len = 0; 31 n_left = 0; /* set rs_buffer empty */ 32 if rec_len > buff_len 33 then code = error_table_$long_record; 34 n_moved = min (rec_len, buff_len); 35 if n_moved > 0 36 then substr (buffer, 1, n_moved) = substr (rs_buffer, 1, n_moved); 37 end; /* record moved between buffers */ 38 39 else /* rs_buffer empty */ 40 if length_n > 0 41 then do; /* -length n case */ 42 rec_len = 0; 43 n_asked = min (buff_len, length_n); 44 get_data: 45 call iox_$get_chars (target_iocb_ptr, buff_ptr, n_asked, n_read, code); 46 rec_len = rec_len + n_read; 47 if code ^= 0 48 then if code = error_table_$short_record 49 then do; /* pick up more chars */ 50 n_asked = n_asked - n_read; 51 buff_ptr = addr (buff (n_read + 1)); 52 go to get_data; 53 end; 54 else go to eof_exit; 55 else /* no errors yet */ 56 if length_n > buff_len 57 then /* long record case unless we are at EOF */ 58 do; /* munch past record tail */ 59 n_extra = length_n - buff_len; 60 call iox_$get_chars (target_iocb_ptr, rs_buff_ptr, n_extra, n_read, code); 61 rec_len = rec_len + n_read; 62 if n_read > 0 63 then code = error_table_$long_record; 64 else if code = error_table_$end_of_info 65 then code = 0; /* short last record is OK */ 66 end; 67 end; /* end of -length n case */ 68 69 else do; /* default case */ 70 call iox_$get_line (target_iocb_ptr, buff_ptr_arg, buff_len, rec_len, code); 71 if code = 0 72 then rec_len = rec_len - 1; /* delete newline char */ 73 else if code ^= error_table_$long_record 74 then do; /* check for short record */ 75 eof_exit: 76 if rec_len > 0 77 then code = 0; 78 end; /* done */ 79 else do; /* line is longer than input buffer */ 80 call iox_$get_chars (target_iocb_ptr, addr (next_char), 1, n_read, code); 81 if code = 0 82 then if substr (next_char, 1, 1) = newline 83 /* avoids compiler bug */ 84 then return; /* normal return */ 85 else do; /* munch record tail */ 86 rec_len = rec_len + 1; 87 call iox_$get_line (target_iocb_ptr, rs_buff_ptr, max_bufsize, n_read, code); 88 rec_len = rec_len + n_read; 89 end; 90 code = error_table_$long_record; 91 end; /* entire record processed */ 92 end; /* end of default case */ 93 return; /* end of read record routine */ 94 95 96 read_length_rs: 97 entry (iocb_ptr_arg, rec_len, code); 98 call initialize; 99 if n_left = 0 /* rs_buffer is empty */ 100 then do; /* get a new record */ 101 call read_record_rs (iocb_ptr, rs_buff_ptr, max_bufsize, n_left, code); 102 if (n_left = 0) & (code = 0) 103 then n_left = -1; 104 end; 105 if n_left > 0 106 then rec_len = n_left; 107 else rec_len = 0; 108 return; /* end of read length routine */ 109 110 position_seq_rs: 111 entry (iocb_ptr_arg, type, count, code); 112 call initialize; 113 n = count; 114 if type ^= 0 115 then do; /* bof and eof cases */ 116 n_left = 0; /* discard rs_buffer contents */ 117 pass_call: 118 call iox_$position (target_iocb_ptr, type, n, code); 119 /* pass call to target */ 120 end; 121 else do; /* skip case */ 122 if n ^= 0 123 then do; /* skip n records */ 124 old_n_left = n_left; 125 if n_left ^= 0 126 then do; /* skip record in rs_buffer */ 127 n = n - 1; 128 n_left = 0; 129 end; 130 if length_n = 0 /* default case */ 131 then go to pass_call; 132 else /* -length case */ 133 if n < 0 134 then do; /* error: no backwards skips */ 135 code = error_table_$negative_nelem; 136 n_left = old_n_left;/* restore rs_buffer */ 137 end; 138 else /* read past n records */ 139 do while ((n > 0) & (code = 0)); 140 call read_record_rs (iocb_ptr, rs_buff_ptr, max_bufsize, n_read, code); 141 n = n - 1; 142 end; 143 end; /* n records skipped */ 144 end; /* end of skip case */ 145 return; /* end of seq position routine */ 146 147 /* internal procedure for initializing pointers upon entry */ 148 initialize: 149 proc; 150 iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; 151 rsab_ptr = attach_data_ptr; 152 rs_buff_ptr = open_data_ptr; 153 code = 0; 154 return; 155 156 end initialize; 157 158 /* declarations for entire program */ 159 dcl (iocb_ptr_arg, iocb_ptr) 160 ptr; 161 dcl code fixed bin (35); 1 1 1 2 dcl 1 iocb aligned based (iocb_ptr), 1 3 /* I/O control block. */ 1 4 2 iocb_version fixed init (1), /* Version number of structure. */ 1 5 2 name char (32), /* I/O name of this block. */ 1 6 2 actual_iocb_ptr ptr, /* IOCB ultimately SYNed to. */ 1 7 2 attach_descrip_ptr ptr, /* Ptr to printable attach description. */ 1 8 2 attach_data_ptr ptr, /* Ptr to attach data structure. */ 1 9 2 open_descrip_ptr ptr, /* Ptr to printable open description. */ 1 10 2 open_data_ptr ptr, /* Ptr to open data structure (old SDB). */ 1 11 2 reserved bit (72), /* Reserved for future use. */ 1 12 2 detach_iocb entry (ptr, fixed (35)),/* detach_iocb(p,s) */ 1 13 2 open entry (ptr, fixed, bit (1) aligned, fixed (35)), 1 14 /* open(p,mode,not_used,s) */ 1 15 2 close entry (ptr, fixed (35)),/* close(p,s) */ 1 16 2 get_line entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 1 17 /* get_line(p,bufptr,buflen,actlen,s) */ 1 18 2 get_chars entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 1 19 /* get_chars(p,bufptr,buflen,actlen,s) */ 1 20 2 put_chars entry (ptr, ptr, fixed (21), fixed (35)), 1 21 /* put_chars(p,bufptr,buflen,s) */ 1 22 2 modes entry (ptr, char (*), char (*), fixed (35)), 1 23 /* modes(p,newmode,oldmode,s) */ 1 24 2 position entry (ptr, fixed, fixed (21), fixed (35)), 1 25 /* position(p,u1,u2,s) */ 1 26 2 control entry (ptr, char (*), ptr, fixed (35)), 1 27 /* control(p,order,infptr,s) */ 1 28 2 read_record entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 1 29 /* read_record(p,bufptr,buflen,actlen,s) */ 1 30 2 write_record entry (ptr, ptr, fixed (21), fixed (35)), 1 31 /* write_record(p,bufptr,buflen,s) */ 1 32 2 rewrite_record entry (ptr, ptr, fixed (21), fixed (35)), 1 33 /* rewrite_record(p,bufptr,buflen,s) */ 1 34 2 delete_record entry (ptr, fixed (35)),/* delete_record(p,s) */ 1 35 2 seek_key entry (ptr, char (256) varying, fixed (21), fixed (35)), 1 36 /* seek_key(p,key,len,s) */ 1 37 2 read_key entry (ptr, char (256) varying, fixed (21), fixed (35)), 1 38 /* read_key(p,key,len,s) */ 1 39 2 read_length entry (ptr, fixed (21), fixed (35)); 1 40 /* read_length(p,len,s) */ 1 41 162 2 1 /* BEGIN: rs_attach_block.incl.pl1 * * * * * */ 2 2 2 3 2 4 /****^ HISTORY COMMENTS: 2 5* 1) change(75-02-13,Asherman), approve(), audit(), install(): 2 6* Initial coding. 2 7* 2) change(87-08-30,GWMay), approve(87-08-30,MCR7730), audit(87-09-10,GDixon), 2 8* install(87-09-10,MR12.1-1104): 2 9* Changed target_name to be unaligned. 2 10* END HISTORY COMMENTS */ 2 11 2 12 2 13 dcl rsab_ptr ptr; 2 14 dcl 1 rs_attach_block based (rsab_ptr) aligned, 2 15 /* record_stream_ attach block */ 2 16 /* the following are set during attachment */ 2 17 2 attach_descrip, 2 18 3 attach_descrip_len 2 19 fixed (35), 2 20 3 attach_descrip_string 2 21 char (66), /* "record_stream_