COMPILATION LISTING OF SEGMENT plio2_gvl_ Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Bull, Phx. Az., Sys-M Compiled on: 05/14/87 1608.5 mst Thu Options: optimize map 1 /****^ ****************************************************** 2* * * 3* * Copyright, (C) Honeywell Bull Inc., 1987 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* ****************************************************** */ 9 10 11 /****^ HISTORY COMMENTS: 12* 1) change(87-03-05,Huen), approve(87-03-05,MCR7629), audit(87-04-15,RWaters), 13* install(87-05-14,MR12.1-1030): 14* Fix PL/1 error 2142 - 15* Signal the error condition when the string supplied has insufficient data 16* for the "get" statement. 17* END HISTORY COMMENTS */ 18 19 plio2_gvl_: 20 get_value_list_: 21 procedure (p_ps_ptr) options (support); 22 23 /* Modified: 9 January 1987 by S. Huen to signal the error condition when the string supplied has insufficient data for the "get" statement */ 24 /* Modified: 18 July 1978 by R. A. Barnes to make gvl more quit-start proof if blocked */ 25 26 /* Modified: 4 April 1978 by Peter C. Krupp to implement radix-n bit strings for get list */ 27 28 /* Modified: 20 December 1977 by Richard A. Barnes to fix 1695 (get string) */ 29 30 /* Rewritten Spring 1977 by R.Schoeman as part of the quick stream_io package. 31* Recoded 770612 by PG to maintain fsb.kol accurately, and to use algorithms similar to EIS lex. 32* package. 33* 34* This procedure is called once for each item in a data list 35* in a get list statement. It is called at runtime by pl1_operators_ through the entrypoint 36* get_value_list_. Section 12.14 (GET statement) of AG94 describes in detail 37* the language-defined actions which are performed by this program. */ 38 39 /* parameters */ 40 41 declare p_ps_ptr ptr parameter; /* ptr to PS */ 42 43 /* automatic */ 44 45 declare BIT_STRING bit (1) aligned, 46 bit256 bit (256) varying aligned, 47 break fixed bin (21), 48 code fixed bin (35), 49 convert_index fixed bin (15), 50 erno fixed bin (15), /* oncode number */ 51 error_string char (1000) varying, /* used when raising conversion */ 52 first_bit fixed bin (15), 53 first_char fixed bin (21), 54 in_ptr ptr, 55 iocbp ptr, 56 left fixed bin (21), 57 onchar_index fixed bin (15), 58 pic_buf char(64), 59 pic_ptr ptr, 60 psp ptr, 61 RADIX_FACTOR fixed bin(15), 62 rn_digit char(1) aligned, 63 rn_value fixed bin(15), 64 scan_index fixed bin (21), 65 scan_start fixed bin (21), 66 targ_ptr ptr, 67 token_length fixed bin (21), 68 token_start fixed bin (21), 69 token_string char (257) varying; 70 71 /* based */ 72 73 declare buffer_array (1044480) char (1) unaligned based (fsb.bptr); 74 75 /* builtins */ 76 77 declare (addr, addrel, binary, bit, divide, index, length, reverse, search, substr, verify, unspec) builtin; 78 79 /* conditions */ 80 81 declare conversion condition; 82 83 /* entries */ 84 85 declare iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), 86 iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), 87 plio2_get_util_$get_prep_ entry (ptr), 88 plio2_signal_$conversion_error_ entry (ptr, char (*), fixed bin (15), ptr, fixed bin (15), fixed bin (15), fixed bin (15)), 89 plio2_signal_$s_ entry (ptr, char (*), char (*), fixed bin (15)), 90 plio2_signal_$s_r_ entry (ptr, char (*), char (*), fixed bin (15)), 91 plio2_resig_ entry (ptr), 92 put_copy_ entry (ptr, fixed bin (21)); 93 94 /* external static */ 95 96 dcl (error_table_$short_record, 97 error_table_$long_record, 98 error_table_$end_of_info) external static fixed bin (35); 99 100 /* internal static */ 101 102 declare ( HT char (1) aligned initial (" "), 103 NL char (1) aligned initial (" 104 "), 105 QUOTE char (1) aligned initial (""""), 106 HT_NL_quote char (3) aligned initial (" 107 """), 108 HT_NL_SP_comma char (4) aligned initial (" 109 ,") 110 ) internal static; 111 112 declare max_io_string_length internal static options(constant) initial(256); 113 114 /* include files */ 115 1 1 /* BEGIN INCLUDE FILE ... plio2_ps.incl.pl1 */ 1 2 /* Stream I/O data block used by PL/I I/O runtime routines. 1 3* 1 4* Modified: 31 January 1978 by RAB to change plio2_data_$fsb_thread to plio2_data_fsb_thread_ 1 5**/ 1 6 /* format: style3,idind30 */ 1 7 1 8 /* based */ 1 9 1 10 declare 1 ps aligned based (psp),/* items set NORMALLY by compiled procedures */ 1 11 2 stack_frame_p ptr, /* items set in block prologue */ 1 12 2 ST_top_p ptr, 1 13 2 ST_block_p ptr, 1 14 2 format_area_p ptr, 1 15 2 ss_list_p ptr, 1 16 2 ab_return, /* items set in prep call */ 1 17 3 abret (3) ptr, 1 18 2 source_p ptr, /* addr(fakefsb) for string option, 1 19* addr(file) for explicit file option */ 1 20 2 special_list_p ptr, /* addr(OKlist) for get data, addr(format_list) for edit */ 1 21 2 copy_file_p ptr, 1 22 2 job aligned, 1 23 3 explicit_file bit (1) unal, 1 24 3 string bit (1) unal, 1 25 3 varying_string bit (1) unal, 1 26 3 data bit (1) unal, 1 27 3 edit bit (1) unal, 1 28 3 list bit (1) unal, 1 29 3 get bit (1) unal, 1 30 3 put bit (1) unal, 1 31 3 page bit (1) unal, 1 32 3 line bit (1) unal, 1 33 3 skip bit (1) unal, 1 34 3 copy bit (1) unal, 1 35 3 p1p2 bit (1) unal, 1 36 3 bit_string bit (1) unal, /* for environment(stringvalue) */ 1 37 3 char_string bit (1) unal, 1 38 3 read bit (1) unal, 1 39 3 write bit (1) unal, 1 40 3 rewrite bit (1) unal, 1 41 3 delete bit (1) unal, 1 42 3 locate bit (1) unal, 1 43 3 key bit (1) unal, 1 44 3 keyto bit (1) unal, 1 45 3 keyfrom bit (1) unal, 1 46 3 set bit (1) unal, 1 47 3 into bit (1) unal, 1 48 3 ignore bit (1) unal, 1 49 3 from bit (1) unal, 1 50 3 version bit (6) unal, 1 51 3 not_byte_buffer bit (1) unal, 1 52 3 pad1 bit (1) unal, 1 53 3 packed_ptr bit (1) unal, 1 54 2 number fixed bin (15), 1 55 2 value_p ptr, /* items set NORMALLY by compiled procedures per transmission */ 1 56 2 descriptor bit (36) aligned, 1 57 2 length fixed bin (15), /* may be swallowed into descriptor */ 1 58 2 top_half bit (18) unal, 1 59 2 offset bit (18) unal, 1 60 2 prep fixed bin (15), /* items treated ABNORMALLY, written by user and PLIO */ 1 61 2 new_format fixed bin (15), 1 62 2 switch aligned, /* items used by PLIO and not touched by compiled procedures */ 1 63 3 first_field bit (1) unal, 1 64 3 file bit (1) unal, 1 65 3 transmit_error bit (1) unal, 1 66 3 semi_sep bit (1) unal, 1 67 3 pad2 bit (32) unal, 1 68 2 file_p ptr, 1 69 2 fsbp ptr, 1 70 2 auxp ptr, /* used as addr(ldidata) for GETs */ 1 71 2 fabp ptr, 1 72 2 fab2p ptr, 1 73 2 vp ptr, 1 74 2 descr bit (36) aligned, 1 75 2 start_copy fixed bin (15), 1 76 2 quick_stream_storage, 1 77 3 a_stored fixed bin (35), 1 78 3 q_stored fixed bin (35); 1 79 1 80 /* external static */ 1 81 1 82 declare ( 1 83 plio2_data_$pspstat, 1 84 plio2_data_$fsbpstat, 1 85 plio2_data_$badfsbp, 1 86 plio2_data_$fabpstat, 1 87 plio2_data_$fab2pstat, 1 88 plio2_data_$pliostringfsbp 1 89 ) ptr external static; 1 90 1 91 dcl plio2_data_fsb_thread_ ptr ext static initial (null); 1 92 /* *system var */ 1 93 1 94 declare ( 1 95 plio2_data_$badjob bit (36) aligned, 1 96 plio2_data_$undef_file_sw bit (1) aligned 1 97 ) external static; 1 98 1 99 /* END INCLUDE FILE ... plio2_ps.incl.pl1 */ 116 2 1 /* BEGIN INCLUDE FILE ... plio2_fsb.incl.pl1 */ 2 2 /* format: style3,idind30 */ 2 3 2 4 declare 1 fsb aligned based (fsbp), 2 5 2 switch aligned, 2 6 3 zot (2) bit (1) unaligned, 2 7 3 version_2 bit (1) unaligned, 2 8 3 open bit (1) unaligned, 2 9 3 print bit (1) unaligned, 2 10 3 input bit (1) unaligned, 2 11 3 output bit (1) unaligned, 2 12 3 update bit (1) unaligned, 2 13 3 stream bit (1) unaligned, 2 14 3 notkeyed bit (1) unaligned, 2 15 3 record bit (1) unaligned, 2 16 3 sequential bit (1) unaligned, 2 17 3 direct bit (1) unaligned, 2 18 3 interactive bit (1) unaligned, 2 19 3 not_used_1 bit (1) unaligned, 2 20 3 not_used_2 bit (1) unaligned, 2 21 3 stringvalue bit (1) unaligned, 2 22 3 keyed bit (1) unaligned, 2 23 3 namelist bit (1) unaligned, 2 24 3 implementation bit (1) unaligned, 2 25 3 not_used_4 bit (1) unaligned, /* old get-input eof flag */ 2 26 3 transmit_error bit (1) unaligned, 2 27 3 buffer_in_use bit (1) unaligned, 2 28 3 copy bit (1) unaligned, 2 29 3 detach bit (1) unaligned, 2 30 3 te_hold bit (1) unaligned, 2 31 3 not_used_5 bit (1) unaligned, 2 32 3 internal bit (1) unaligned, 2 33 3 threaded bit (1) unaligned, 2 34 3 fsb_in_use bit (1) unaligned, 2 35 3 console bit (1) unaligned, 2 36 3 emptyline bit (1) unaligned, 2 37 3 iox_close bit (1) unaligned, 2 38 3 xxx4 bit (1) unaligned, 2 39 3 xxx5 bit (1) unaligned, 2 40 3 xxx6 bit (1) unaligned, 2 41 2 nono aligned, 2 42 3 bit_string bit (1) unaligned, 2 43 3 not_used_3 bit (1) unaligned, 2 44 3 read bit (1) unaligned, 2 45 3 write bit (1) unaligned, 2 46 3 rewrite bit (1) unaligned, 2 47 3 delete bit (1) unaligned, 2 48 3 locate bit (1) unaligned, 2 49 3 key bit (1) unaligned, 2 50 3 keyto bit (1) unaligned, 2 51 3 keyfrom bit (1) unaligned, 2 52 3 set bit (1) unaligned, 2 53 3 into bit (1) unaligned, 2 54 3 ignore bit (1) unaligned, 2 55 3 from bit (1) unaligned, 2 56 3 nofrom bit (1) unaligned, 2 57 3 nokey bit (1) unaligned, 2 58 3 nokeyfrom bit (1) unaligned, 2 59 3 nolock bit (1) unaligned, 2 60 2 lsep fixed bin (15), /* (1,COMMA)(2,BL)(3,TAB)(4,NL)(5,SEMI) */ 2 61 2 iocb_p ptr unaligned, /* identifies data_set to iox_ */ 2 62 2 blc fixed bin (21), /* buffer's last character (input) */ 2 63 2 bsize fixed bin (21), /* size of buffer */ 2 64 2 bptr ptr, /* address of buffer */ 2 65 2 bnc fixed bin (15), /* next character in buffer */ 2 66 2 kol fixed bin (15), /* last column read from or written into */ 2 67 2 lsize fixed bin (15), /* line size (output) */ 2 68 2 lineno fixed bin (15), /* current line (output) - starts at 1 on each new page */ 2 69 2 psize fixed bin (35), /* page size (output) */ 2 70 2 pageno fixed bin (15), /* current page number, starts at 1 */ 2 71 2 limit fixed bin (15), 2 72 2 lnzc fixed bin (35), 2 73 2 filename char (32) aligned, /* declared file name */ 2 74 2 title char (32) unaligned,/* Multics I/O switch */ 2 75 2 fsb_thread ptr, 2 76 2 buffer (212) fixed bin (15), 2 77 2 path_name char (168) unal, /* title option */ 2 78 2 declared_attributes (2) bit (36) aligned; 2 79 2 80 declare xbuf char (1000) unaligned based (fsb.bptr); 2 81 2 82 /* END INCLUDE FILE ... plio2_fsb.incl.pl1 */ 117 3 1 /* BEGIN INCLUDE FILE...pl1_stack_frame.incl.pl1 */ 3 2 /* This is an overlay for a stack frame giving pointers 3 3** set and used by pl/I programs only. 3 4**/ 3 5 3 6 dcl 1 pl1_stack_frame based aligned, 3 7 2 pad(32) fixed bin, 3 8 2 display_ptr ptr, /* pointer to stack frame of parent block */ 3 9 2 descriptor_ptr ptr, /* pointer to argument descriptor list */ 3 10 2 linkage_ptr ptr, /* pointer to base of linkage section */ 3 11 2 text_base_ptr ptr; /* pointer to base of text */ 3 12 3 13 /* END INCLUDE FILE ... pl1_stack_frame.incl.pl1 */ 118 4 1 /* BEGIN INCLUDE FILE ... desc_dcls.incl.pl1 */ 4 2 4 3 /* This include segment contains declarations for use with assign_ */ 4 4 4 5 dcl intype fixed bin (17), 4 6 outtype fixed bin (17); 4 7 4 8 dcl inscale_prec fixed bin (35), 4 9 outscale_prec fixed bin (35); 4 10 4 11 dcl 1 info based (addr (inscale_prec)) aligned, 4 12 2 inscale fixed bin (17) unal, 4 13 2 inprec fixed bin (17) unal; 4 14 4 15 dcl 1 outfo based (addr (outscale_prec)) aligned, 4 16 2 outscale fixed bin (17) unal, 4 17 2 outprec fixed bin (17) unal; 4 18 4 19 dcl inclength fixed bin(31) aligned based(addr(inscale_prec)); 4 20 dcl outclength fixed bin(31) aligned based(addr(outscale_prec)); 4 21 4 22 dcl char_to_numeric_ entry (ptr, fixed bin (17), fixed bin (35), ptr, fixed bin (17)), 4 23 assign_ entry (ptr, fixed bin (17), fixed bin (35), ptr, fixed bin (17), fixed bin (35)), 4 24 assign_round_ entry (ptr, fixed bin (17), fixed bin (35), ptr, fixed bin (17), fixed bin (35)), 4 25 assign_truncate_ entry (ptr, fixed bin (17), fixed bin (35), ptr, fixed bin (17), fixed bin (35)); 4 26 4 27 /* END INCLUDE FILE ... desc_dcls.incl.pl1 */ 119 5 1 dcl ( s_fixed_real_desc init( 1), 5 2 d_fixed_real_desc init( 2), 5 3 s_float_real_desc init( 3), 5 4 d_float_real_desc init( 4), 5 5 s_fixed_cplx_desc init( 5), 5 6 d_fixed_cplx_desc init( 6), 5 7 s_float_cplx_desc init( 7), 5 8 d_float_cplx_desc init( 8), 5 9 5 10 D_fixed_real_desc init( 9), 5 11 D_float_real_desc init(10), 5 12 D_fixed_cplx_desc init(11), 5 13 D_float_cplx_desc init(12), 5 14 5 15 pointer_desc init(13), 5 16 offset_desc init(14), 5 17 label_desc init(15), 5 18 entry_desc init(16), 5 19 structure_desc init(17), 5 20 area_desc init(18), 5 21 5 22 bit_desc init(19), 5 23 v_bit_desc init(20), 5 24 5 25 char_desc init(21), 5 26 v_char_desc init(22), 5 27 5 28 file_desc init(23) 5 29 ) fixed bin int static options(constant); 120 6 1 /* BEGIN INCLUDE FILE ... descriptor.incl.pl1 */ 6 2 6 3 dcl 1 desc_ aligned, 6 4 2 version2_ bit(1) unal, 6 5 2 type_ fixed bin(6) unsigned unal, 6 6 2 pack_ bit(1) unal, 6 7 2 dimension_ bit(4) unal, 6 8 2 scale_ fixed bin(11) unal, 6 9 2 precision_ fixed bin(11) unal; 6 10 6 11 /* END INCLUDE FILE ... descriptor.incl.pl1 */ 121 7 1 dcl type(24:28) fixed bin(15) int static init 7 2 ( 42, /* character */ 7 3 18, /* real fixed dec */ 7 4 22, /* cplx fixed dec */ 7 5 20, /* real float dec */ 7 6 24); /* cplx float dec */ 122 8 1 /* BEGIN INCLUDE FILE ... picture_image.incl.pl1 8 2* 8 3* James R. Davis 12 Mar 79 8 4**/ 8 5 8 6 dcl 1 picture_image aligned based, 8 7 2 type fixed bin (8) unal, 8 8 2 prec fixed bin (8) unal, /* precision or length of associated value */ 8 9 2 scale fixed bin (8) unal, /* for both fixed and float pictures, 8 10* =ndigits after "v" - scale_factor */ 8 11 2 piclength fixed bin (8) unal, /* length of picture_constant.chars, <64 8 12* =length of normalized-picture-string */ 8 13 2 varlength fixed bin (8) unal, /* length of pictured variable in chars, <64 8 14* =length of normalized_picture_string - "k" and "v" */ 8 15 2 scalefactor fixed bin (8) unal, /* value of pict-sc-f, -256<=x<256 */ 8 16 2 explength fixed bin (8) unal, /* length of exp field for float */ 8 17 2 drift_character char (1) unal, 8 18 2 chars char (0 refer (picture_image.piclength)) aligned; 8 19 8 20 dcl ( 8 21 picture_char_type init (24), 8 22 picture_realfix_type init (25), 8 23 picture_complexfix_type 8 24 init (26), 8 25 picture_realflo_type init (27), 8 26 picture_complexflo_type 8 27 init (28) 8 28 ) fixed bin (8) unal static internal options (constant); 8 29 8 30 /* END INCLUDE FILE ... picture_image.incl.pl1 */ 123 9 1 /* BEGIN INCLUDE FILE ... picture_util.incl.pl1 */ 9 2 9 3 dcl pack_picture_ entry (char (1), char (1), char (1)), 9 4 unpack_picture_ entry (char (1), char (1), char (1)), 9 5 validate_picture_ entry (char (1), char (1), fixed bin (15), fixed bin (15)), 9 6 9 7 assign_type_d entry (bit (36) aligned, ptr, ptr, fixed bin (17), fixed bin (35)), 9 8 assign_type_p entry (ptr, fixed bin (17), fixed bin (35)), 9 9 9 10 char1 char (1) based; 9 11 9 12 /* END INCLUDE FILE ... picture_util.incl.pl1 */ 124 10 1 /* BEGIN INCLUDE FILE ... radix_factor_constants.incl.pl1 */ 10 2 10 3 /* The following array, "digits", although static, IS assigned to in some cases */ 10 4 /* so could never be "options(constant)!! */ 10 5 10 6 dcl digits(0:5) char(16) int static init( "0101010101010101", /* only 1st two digits are meaningful */ 10 7 "0101010101010101", /* only 1st 2 digits meaningful */ 10 8 "0123012301230123", /* only 1st 4 digits meaningful */ 10 9 "0123456701234567", /* only 1st 8 digits meaningful */ 10 10 "0123456789abcdef", /* all 16 digits meaningful */ 10 11 "0123456789ABCDEF"); /* all 16 digits meaningful */ 10 12 10 13 dcl capital_hex char(6) init("ABCDEF") int static options(constant); 10 14 10 15 dcl lower_case_hex char(6) init("abcdef") int static options(constant); 10 16 10 17 dcl expand_bit_chars(2:4) char(64) int static init( "00011011", 10 18 "000001010011100101110111", 10 19 "0000000100100011010001010110011110001001101010111100110111101111"); 10 20 10 21 dcl expand_bits(2:4) bit(64) int static init( "00011011"b, 10 22 "000001010011100101110111"b, 10 23 "0000000100100011010001010110011110001001101010111100110111101111"b); 10 24 10 25 /* END INCLUDE FILE ... radix_factor_constants.incl.pl1 */ 125 126 127 /* program */ 128 129 psp = p_ps_ptr; 130 131 if ps.prep ^= 0 132 then call plio2_get_util_$get_prep_ (psp); 133 134 iocbp = ps.fsbp -> fsb.iocb_p; 135 BIT_STRING = "0"b; 136 RADIX_FACTOR = 0; 137 138 on conversion call plio2_resig_ (psp); 139 140 init_scan: 141 left = fsb.blc - fsb.bnc + 1; 142 first_char = verify (substr (xbuf, fsb.bnc, left), " "); 143 144 if first_char = 0 145 then do; /* rest of string was blanks */ 146 call refill_buffer_ldi; 147 if code ^= 0 148 then go to raise_eof; 149 go to init_scan; 150 end; 151 152 fsb.kol = fsb.kol + first_char - 1; 153 fsb.bnc = fsb.bnc + first_char - 1; /* step over blanks */ 154 155 if substr (xbuf, fsb.bnc, 1) = NL 156 then do; 157 fsb.kol = 0; /* reset current column */ 158 fsb.bnc = fsb.bnc + 1; /* step over newline */ 159 go to init_scan; 160 end; 161 162 if substr (xbuf, fsb.bnc, 1) = HT 163 then do; 164 fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); 165 fsb.bnc = fsb.bnc + 1; /* step over HT */ 166 go to init_scan; 167 end; 168 169 if substr (xbuf, fsb.bnc, 1) = "," 170 then do; 171 fsb.kol = fsb.kol + 1; 172 fsb.bnc = fsb.bnc + 1; /* step over comma */ 173 174 if fsb.lsep = 2 175 then do; /* last separator was not a comma... */ 176 fsb.lsep = 1; /* let this comma pass by */ 177 goto init_scan; 178 end; 179 /* last separator was a comma...this comma means */ 180 return; /* two commas in a row...input item is unchanged */ 181 end; 182 else if substr (xbuf, fsb.bnc, 1) = QUOTE /* current char is a quote? */ 183 then do; /* yes...scan a quoted string */ 184 scan_start = fsb.bnc + 1; /* start copying after quote */ 185 token_start = scan_start; 186 token_length = 0; 187 188 rescan: 189 scan_index = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_quote); 190 191 if scan_index = 0 192 then do; /* eof while looking for closing quote */ 193 if token_start = 0 /* copy has begun */ 194 then token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1); 195 else do; 196 token_string = substr (xbuf, token_start, fsb.blc - token_start + 1); 197 token_start = 0; 198 end; 199 200 call refill_buffer_ldi; 201 if code ^= 0 202 then go to err163; /* error -- end of file */ 203 204 scan_start = 1; 205 go to rescan; 206 end; 207 208 fsb.kol = fsb.kol + scan_index - 1; /* update kol but not scan_start just yet */ 209 210 if substr (xbuf, scan_start + scan_index - 1, 1) = NL 211 then do; 212 /* AG94 says ignore newlines inside quoted strings when in 213* list-directed input. So we do. Ugh. */ 214 215 fsb.kol = 0; 216 217 if token_start > 0 /* if not copied yet, copy now */ 218 then do; 219 token_string = substr (xbuf, token_start, token_length); 220 token_start = 0; 221 end; 222 223 token_string = token_string || substr (xbuf, scan_start, scan_index - 1); 224 scan_start = scan_start + scan_index; 225 go to rescan; 226 end; 227 else if substr (xbuf, scan_start + scan_index - 1, 1) = HT 228 then do; 229 fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); 230 231 if token_start = 0 232 then token_string = token_string || substr (xbuf, scan_start, scan_index); 233 else token_length = token_length + scan_index; 234 235 scan_start = scan_start + scan_index; 236 go to rescan; 237 end; 238 239 /* Found a matching quote. Ignore it. */ 240 241 if token_start = 0 242 then token_string = token_string || substr (xbuf, scan_start, scan_index - 1); 243 else token_length = token_length + scan_index - 1; 244 245 scan_start = scan_start + scan_index; 246 fsb.kol = fsb.kol + 1; /* step over quote */ 247 248 /* Now look for a quote immediately following, which means we have two quotes in a row. */ 249 /* First make sure we are not at the end of the buffer */ 250 251 if scan_start > fsb.blc 252 then do; 253 if token_start > 0 /* if not copied yet, copy now */ 254 then do; 255 token_string = substr (xbuf, token_start, token_length); 256 token_start = 0; 257 end; 258 259 call refill_buffer_ldi; 260 if code ^= 0 261 then goto finish; /* eof encountered */ 262 scan_start = 1; 263 end; 264 265 if substr (xbuf, scan_start, 1) = QUOTE 266 then do; 267 if token_start > 0 /* if not copied yet, copy now */ 268 then do; 269 token_string = substr (xbuf, token_start, token_length); 270 token_start = 0; 271 end; 272 273 token_string = token_string || QUOTE; 274 fsb.kol = fsb.kol + 1; 275 scan_start = scan_start + 1; 276 go to rescan; 277 end; 278 279 /* We have now parsed the quoted section of the string...scan until the next 280* space or comma and include those characters, too. */ 281 282 find_break: 283 break = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_SP_comma); 284 if break = 0 285 then do; /* eof while looking for delimiters */ 286 if token_start > 0 /* if not copied yet, do it now */ 287 then do; 288 token_string = substr (xbuf, token_start, fsb.blc - token_start + 1); 289 token_start = 0; 290 end; 291 else token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1); 292 293 call refill_buffer_ldi; 294 if code ^= 0 295 then goto finish; /* AG94 says this is a legal termination, not an error */ 296 297 scan_start = 1; 298 goto find_break; 299 end; 300 301 fsb.kol = fsb.kol + break - 1; 302 303 if substr (xbuf, scan_start + break - 1, 1) = HT 304 then fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); 305 else if substr (xbuf, scan_start + break - 1, 1) = NL 306 then fsb.kol = 0; 307 308 /* determine whether we have a bit string */ 309 if break = 2 /* exactly one char after trailing quote */ 310 then if substr (xbuf, scan_start, 1) = "b" /* and that char is "b" */ 311 then do; 312 RADIX_FACTOR = 1; 313 BIT_STRING = "1"b; 314 end; 315 316 /* determine whether we have a radix-n (n=2,4,8,16) bit string */ 317 if break = 3 /* exactly two characters after the trailing quote */ 318 then do; 319 RADIX_FACTOR = index ("1234", substr (xbuf, scan_start + 1, 1)); 320 321 if substr (xbuf, scan_start, 1) = "b" & RADIX_FACTOR ^= 0 322 then BIT_STRING = "1"b; 323 324 end; 325 326 fsb.bnc = scan_start + break; /* step over scanned chars and over delim */ 327 328 if break > 1 /* if trailing stuff after closing quote... */ 329 then do; 330 if token_start > 0 /* ...and not yet copied */ 331 then do; /* ...copy it now. */ 332 token_string = substr (xbuf, token_start, token_length); 333 token_start = 0; 334 end; 335 336 /* At this point, token_string contains the (unquoted) portion of the 337* input item that was originally quoted, and substr (xbuf, scan_start, break - 1) 338* contains the portion of the input item that appeared after the quoted part 339* and before the delimiter. */ 340 341 if ^BIT_STRING 342 then do; /* unknown text immediately follow closing quote of a character string */ 343 erno = 167; 344 call conversion_error; 345 end; 346 347 end; 348 end; /* end quoted string section */ 349 else do; /* scan an unquoted input item */ 350 scan_start = fsb.bnc; 351 token_start = scan_start; /* token starts at first char */ 352 token_length = 0; 353 354 find_break_nq: 355 scan_index = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_SP_comma); 356 if scan_index = 0 /* token ends at the end of buffer */ 357 then do; 358 if token_start > 0 /* if not copied, copy & concatenate */ 359 then do; 360 token_string = substr (xbuf, token_start, fsb.blc - token_start + 1); 361 token_start = 0; 362 end; 363 else token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1); 364 365 fsb.bnc = fsb.bnc + fsb.blc - scan_start + 1; /* step over token */ 366 call refill_buffer_ldi; 367 if code ^= 0 368 then go to finish; /* not an error -- normal termination */ 369 370 scan_start = 1; 371 go to find_break_nq; 372 end; 373 374 fsb.kol = fsb.kol + scan_index - 1; /* update kol but not scan_start yet */ 375 376 if substr (xbuf, scan_start + scan_index - 1, 1) = HT 377 then fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); 378 else if substr (xbuf, scan_start + scan_index - 1, 1) = NL 379 then fsb.kol = 0; 380 381 if token_start > 0 382 then token_length = token_length + scan_index - 1; 383 else token_string = token_string || substr (xbuf, scan_start, scan_index - 1); 384 385 fsb.bnc = scan_start + scan_index; /* step over scanned chars & delim */ 386 end; 387 388 if substr (xbuf, fsb.bnc - 1, 1) = "," /* item terminated by comma? */ 389 then fsb.lsep = 1; /* yes...next comma means null item */ 390 else fsb.lsep = 2; /* no....next comma is ignored */ 391 392 /* We have now parsed the input item....convert it to the type of the target */ 393 394 finish: 395 if token_start > 0 /* token has not been copied */ 396 then do; 397 intype = char_desc * 2; 398 in_ptr = addr (buffer_array (token_start)); /* use substraddr when available! */ 399 inscale_prec = token_length; 400 401 if token_length > max_io_string_length 402 then go to err172; 403 404 end; 405 else if BIT_STRING 406 then do; 407 408 if length (token_string) > max_io_string_length 409 then go to err172; 410 411 if RADIX_FACTOR = 1 /* radix-2 bit string - no radix conversion necessary */ 412 then do; 413 bit256 = bit (token_string); 414 intype = v_bit_desc * 2; 415 in_ptr = addr (bit256); 416 inscale_prec = length (bit256); 417 end; 418 else do; /* radix-4, 8, or 16 bit string - radix conversion necessary */ 419 420 if length (token_string) * RADIX_FACTOR > max_io_string_length 421 then go to err171; 422 423 if RADIX_FACTOR = 4 /* radix-16 bit string - are hexadecimal digits upper or lower case */ 424 then if search (token_string, capital_hex) > 0 425 then substr (digits (4), 11, 6) = capital_hex; 426 else substr (digits (4), 11, 6) = lower_case_hex; 427 428 bit256 = ""b; 429 430 do convert_index=1 to length(token_string); /* convert from radix-n to radix-2 */ 431 rn_digit = substr (token_string, convert_index, 1); 432 rn_value = index (digits (RADIX_FACTOR), rn_digit); 433 434 if rn_value = 0 435 then do; 436 onchar_index = convert_index; 437 erno = 168; 438 error_string = token_string; 439 call conversion_error_for_RADIX_N; 440 go to finish; /* retry conversion with value returned from on unit */ 441 end; 442 443 first_bit = RADIX_FACTOR * (rn_value - 1) + 1; 444 bit256 = bit256 || substr (expand_bits (RADIX_FACTOR), first_bit, RADIX_FACTOR); 445 end; 446 447 intype = v_bit_desc * 2; 448 in_ptr = addr (bit256); 449 inscale_prec = length (bit256); 450 end; 451 end; 452 else do; 453 intype = v_char_desc * 2; 454 in_ptr = addr (token_string); 455 inscale_prec = length (token_string); 456 457 if length (token_string) > max_io_string_length 458 then go to err172; 459 460 end; 461 462 ps.vp = ps.value_p; 463 ps.descr = ps.descriptor; 464 465 if ps.descr = "0"b 466 then do; 467 pic_ptr = psp -> ps.stack_frame_p -> pl1_stack_frame.text_base_ptr; 468 pic_ptr = addrel (pic_ptr, psp -> ps.top_half); 469 470 /* The following block of code should be similiar to or 471* identical with the int. subroutine "set_pic_args" in plio2_qge. */ 472 473 outtype = type (pic_ptr -> picture_image.type); 474 outfo.outscale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor; 475 if outtype = char_desc * 2 476 then outfo.outprec = pic_ptr -> picture_image.varlength; 477 else outfo.outprec = pic_ptr -> picture_image.prec; 478 479 /* end of "set_pic_args" */ 480 481 call assign_ (addr (pic_buf), outtype, outscale_prec, in_ptr, intype, inscale_prec); 482 call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1, addr (pic_buf) -> char1); 483 end; 484 else do; 485 unspec (desc_) = unspec (ps.descr); 486 outtype = desc_.type_ * 2 + binary (desc_.pack_, 1); 487 488 if outtype = v_char_desc * 2 | outtype = v_bit_desc * 2 489 then targ_ptr = addrel (ps.value_p, -1); 490 else targ_ptr = ps.value_p; 491 492 outfo.outscale = desc_.scale_; 493 outfo.outprec = desc_.precision_; 494 call assign_ (targ_ptr, outtype, outscale_prec, in_ptr, intype, inscale_prec); 495 end; 496 497 no_assign: /* target of go to in conversion_error - transfer here when input item is to be left unchanged */ 498 return; 499 500 raise_eof: 501 if ^ ps.string 502 then do; 503 call plio2_signal_$s_r_ (psp, "endfile", "quick_get_list", 163); 504 return; 505 end; 506 507 err163: 508 if ps.string 509 then erno = 162; /* the string supplied with string option */ 510 /* has insufficient data for this get statement. */ 511 else erno = 163; /* end_of_file encountered while executing get statement. */ 512 go to any_err; 513 514 515 err171: 516 erno=171; /* radix-factor bit string has a expanded length that exceeds 256 bits */ 517 go to any_err; 518 519 err172: 520 erno=172; /* string whose length exceeds 256 not handled by plio2_ */ 521 522 any_err: 523 call plio2_signal_$s_r_ (psp, "ERROR", "quick_get_list", erno); 524 return; 525 526 /* The following procedure refills the buffer and returns with code = 0 527* if all went well, otherwise either raises an error itself or 528* returns with a non-zero value of code, depending on AG-94's defined action. */ 529 530 refill_buffer_ldi: 531 procedure; 532 533 if ps.copy 534 then do; 535 call put_copy_ (psp, fsb.blc); 536 ps.start_copy = 1; 537 end; 538 539 if ps.string 540 then do; 541 code = error_table_$end_of_info; 542 return; 543 end; 544 545 fsb.blc = 0; /* protects us somewhat from quit-start */ 546 fsb.bnc = 1; /* .. */ 547 548 if fsb.console 549 then call iox_$get_line (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code); 550 else call iox_$get_chars (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code); 551 552 fsb.bnc = 1; 553 554 if code ^= 0 555 then if (code = error_table_$short_record) | (code = error_table_$long_record) 556 then code = 0; 557 else if code ^= error_table_$end_of_info 558 then do; 559 call plio2_signal_$s_ (psp, "TRANSMIT", "quick_get_list", 153); 560 return; 561 end; 562 return; 563 564 end /* refill_buffer_ldi */; 565 566 /* The following procedure processes conversion errors encountered during The execution 567* of get list statements. It also validates the corrected onsource string and raises the conversion 568* condition again if necessary. */ 569 570 conversion_error: 571 procedure; 572 573 /* AG94 (and ANSI) says raise conversion here. But since we have 574* not been saving the original input string (in the interests 575* of speed), we have to reconstruct it. Ugh. */ 576 577 error_string = QUOTE; 578 do scan_index = 1 to length (token_string); 579 if substr (token_string, scan_index, 1) = QUOTE 580 then error_string = error_string || QUOTE; 581 582 error_string = error_string || substr (token_string, scan_index, 1); 583 end; 584 error_string = error_string || QUOTE; 585 error_string = error_string || substr (xbuf, scan_start, break - 1); 586 587 if substr (xbuf, scan_start, 1) = "b" /* "..."b... ??? */ 588 then break = break - 1; /* set onchar to char after b */ 589 590 onchar_index = length (error_string) - break + 2; 591 592 conversion_error_for_RADIX_N: 593 entry; 594 595 raise_conversion: 596 call plio2_signal_$conversion_error_ (psp, "quick_get_list", 597 erno, addrel (addr (error_string), 1), 1, length (error_string), 598 onchar_index); 599 600 if erno = 168 601 then do; /* radix conversion error occurred - go back */ 602 token_string = error_string; 603 return; 604 end; 605 606 /* Now check the returned onsource of validity. */ 607 608 if substr (error_string, 1, 1) = QUOTE 609 then do; 610 error_string = rtrim (error_string); /* ignore white space to the right fo quoted string */ 611 if substr (error_string, length (error_string) - 1, 2) = """b" 612 then do; 613 BIT_STRING = "1"b; 614 RADIX_FACTOR = 1; 615 token_string = substr (error_string, 2, 616 length (error_string) - 3); 617 end; 618 else if substr (error_string, length (error_string), 1) = QUOTE 619 then do; 620 BIT_STRING = "0"b; 621 token_string = ""; 622 do scan_index = 2 to length (error_string) - 1; 623 if substr (error_string, scan_index, 1) = QUOTE 624 then do; 625 scan_index = scan_index + 1; 626 if substr (error_string, 627 scan_index, 1) ^= QUOTE 628 then do; 629 onchar_index = scan_index; 630 go to raise_conversion; 631 end; 632 end; 633 634 token_string = token_string || substr ( 635 error_string, scan_index, 1); 636 end; 637 638 if token_string = "" 639 then go to no_assign; /* null item...no assign */ 640 641 end; 642 else if substr (error_string, length (error_string) - 2, 2) = """b" 643 then do; 644 RADIX_FACTOR = index ("1234", substr (error_string, length (error_string), 1)); 645 if RADIX_FACTOR ^= 0 646 then do; 647 BIT_STRING = "1"b; 648 token_string = substr (error_string, 2, length (error_string) - 4); 649 end; 650 else do; 651 onchar_index = length (error_string); 652 go to raise_conversion; 653 end; 654 end; 655 else do; 656 onchar_index = length (error_string) - 657 index (reverse (error_string), QUOTE) + 2; 658 659 if onchar_index < length (error_string) 660 then if substr (error_string, onchar_index, 1) = "b" 661 then do; 662 onchar_index = onchar_index + 1; 663 if onchar_index < length (error_string) 664 then if index ("1234", substr (error_string, onchar_index, 1)) ^= 0 665 then onchar_index = onchar_index + 1; 666 end; 667 668 go to raise_conversion; 669 end; 670 end; 671 else if error_string = "" 672 then do; 673 onchar_index = 1; 674 go to raise_conversion; /* onsource cannot be blanks */ 675 end; 676 else do; /* onsource OK */ 677 BIT_STRING = "0"b; 678 token_string = error_string; 679 end; 680 681 end /* conversion_error */; 682 683 684 end /* plio2_gvl_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/14/87 1551.5 plio2_gvl_.pl1 >spec>install>1030>plio2_gvl_.pl1 116 1 08/13/81 2043.5 plio2_ps.incl.pl1 >ldd>include>plio2_ps.incl.pl1 117 2 08/13/81 2043.5 plio2_fsb.incl.pl1 >ldd>include>plio2_fsb.incl.pl1 118 3 05/06/74 1742.6 pl1_stack_frame.incl.pl1 >ldd>include>pl1_stack_frame.incl.pl1 119 4 11/30/78 1227.5 desc_dcls.incl.pl1 >ldd>include>desc_dcls.incl.pl1 120 5 01/12/79 1059.7 desc_types.incl.pl1 >ldd>include>desc_types.incl.pl1 121 6 11/30/78 1227.5 descriptor.incl.pl1 >ldd>include>descriptor.incl.pl1 122 7 05/06/74 1742.6 picture_desc_.incl.pl1 >ldd>include>picture_desc_.incl.pl1 123 8 06/28/79 1204.8 picture_image.incl.pl1 >ldd>include>picture_image.incl.pl1 124 9 09/14/77 1705.7 picture_util.incl.pl1 >ldd>include>picture_util.incl.pl1 125 10 09/14/77 1705.7 radix_factor_constants.incl.pl1 >ldd>include>radix_factor_constants.incl.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. BIT_STRING 000100 automatic bit(1) dcl 45 set ref 135* 313* 321* 341 405 613* 620* 647* 677* HT constant char(1) initial dcl 102 ref 162 227 303 376 HT_NL_SP_comma 000017 constant char(4) initial dcl 102 ref 282 354 HT_NL_quote 000020 constant char(3) initial dcl 102 ref 188 NL constant char(1) initial dcl 102 ref 155 210 305 378 QUOTE 003330 constant char(1) initial dcl 102 ref 182 265 273 577 579 579 584 608 618 623 626 656 RADIX_FACTOR 000546 automatic fixed bin(15,0) dcl 45 set ref 136* 312* 319* 321 411 420 423 432 443 444 444 614* 644* 645 addr builtin function dcl 77 ref 398 415 448 454 474 475 477 481 481 482 492 493 595 595 addrel builtin function dcl 77 ref 468 488 595 595 assign_ 000066 constant entry external dcl 4-22 ref 481 494 binary builtin function dcl 77 ref 486 bit builtin function dcl 77 ref 413 bit256 000101 automatic varying bit(256) dcl 45 set ref 413* 415 416 428* 444* 444 448 449 blc 4 based fixed bin(21,0) level 2 dcl 2-4 set ref 140 188 193 196 251 282 288 291 354 360 363 365 535* 545* 548* 550* bnc 10 based fixed bin(15,0) level 2 dcl 2-4 set ref 140 142 153* 153 155 158* 158 162 165* 165 169 172* 172 182 184 326* 350 365* 365 385* 388 546* 552* bptr 6 based pointer level 2 dcl 2-4 set ref 142 155 162 169 182 188 193 196 210 219 223 227 231 241 255 265 269 282 288 291 303 305 309 319 321 332 354 360 363 376 378 383 388 398 548* 550* 585 587 break 000112 automatic fixed bin(21,0) dcl 45 set ref 282* 284 301 303 305 309 317 326 328 585 587* 587 590 bsize 5 based fixed bin(21,0) level 2 dcl 2-4 set ref 548* 550* buffer_array based char(1) array unaligned dcl 73 set ref 398 capital_hex 000010 constant char(6) initial unaligned dcl 10-13 ref 423 423 char1 based char(1) unaligned dcl 9-3 set ref 482* 482* 482* char_desc constant fixed bin(17,0) initial dcl 5-1 ref 397 475 code 000113 automatic fixed bin(35,0) dcl 45 set ref 147 201 260 294 367 541* 548* 550* 554 554 554 554* 557 console 0(30) based bit(1) level 3 packed unaligned dcl 2-4 ref 548 conversion 000662 stack reference condition dcl 81 ref 138 convert_index 000114 automatic fixed bin(15,0) dcl 45 set ref 430* 431 436* copy 26(11) based bit(1) level 3 packed unaligned dcl 1-10 ref 533 desc_ 000674 automatic structure level 1 dcl 6-3 set ref 485* descr 54 based bit(36) level 2 dcl 1-10 set ref 463* 465 485 descriptor 32 based bit(36) level 2 dcl 1-10 ref 463 digits 000010 internal static char(16) initial array unaligned dcl 10-6 set ref 423* 426* 432 divide builtin function dcl 77 ref 164 229 303 376 erno 000115 automatic fixed bin(15,0) dcl 45 set ref 343* 437* 507* 511* 515* 519* 522* 595* 600 error_string 000116 automatic varying char(1000) dcl 45 set ref 438* 577* 579* 579 582* 582 584* 584 585* 585 590 595 595 595 595 602 608 610* 610 611 611 615 615 618 618 622 623 626 634 642 642 644 644 648 648 651 656 656 659 659 663 663 671 678 error_table_$end_of_info 000064 external static fixed bin(35,0) dcl 96 ref 541 557 error_table_$long_record 000062 external static fixed bin(35,0) dcl 96 ref 554 error_table_$short_record 000060 external static fixed bin(35,0) dcl 96 ref 554 expand_bits 000000 constant bit(64) initial array unaligned dcl 10-21 ref 444 first_bit 000511 automatic fixed bin(15,0) dcl 45 set ref 443* 444 first_char 000512 automatic fixed bin(21,0) dcl 45 set ref 142* 144 152 153 fsb based structure level 1 dcl 2-4 fsbp 42 based pointer level 2 dcl 1-10 ref 134 140 140 142 142 152 152 153 153 155 155 157 158 158 162 162 164 164 164 165 165 169 169 171 171 172 172 174 176 182 182 184 188 188 193 193 196 196 208 208 210 215 219 223 227 229 229 229 231 241 246 246 251 255 265 269 274 274 282 282 288 288 291 291 301 301 303 303 303 303 305 305 309 319 321 326 332 350 354 354 360 360 363 363 365 365 365 374 374 376 376 376 376 378 378 383 385 388 388 388 390 398 535 545 546 548 548 548 548 550 550 550 552 585 587 in_ptr 000514 automatic pointer dcl 45 set ref 398* 415* 448* 454* 481* 494* index builtin function dcl 77 ref 319 432 644 656 663 inscale_prec 000672 automatic fixed bin(35,0) dcl 4-8 set ref 399* 416* 449* 455* 481* 494* intype 000670 automatic fixed bin(17,0) dcl 4-5 set ref 397* 414* 447* 453* 481* 494* iocb_p 3 based pointer level 2 packed unaligned dcl 2-4 ref 134 iocbp 000516 automatic pointer dcl 45 set ref 134* 548* 550* iox_$get_chars 000040 constant entry external dcl 85 ref 550 iox_$get_line 000042 constant entry external dcl 85 ref 548 job 26 based structure level 2 dcl 1-10 kol 11 based fixed bin(15,0) level 2 dcl 2-4 set ref 152* 152 157* 164* 164 164 171* 171 208* 208 215* 229* 229 229 246* 246 274* 274 301* 301 303* 303 303 305* 374* 374 376* 376 376 378* left 000520 automatic fixed bin(21,0) dcl 45 set ref 140* 142 length builtin function dcl 77 ref 408 416 420 430 449 455 457 578 590 595 595 611 615 618 622 642 644 648 651 656 659 663 lower_case_hex 000006 constant char(6) initial unaligned dcl 10-15 ref 426 lsep 2 based fixed bin(15,0) level 2 dcl 2-4 set ref 174 176* 388* 390* max_io_string_length constant fixed bin(17,0) initial dcl 112 ref 401 408 420 457 onchar_index 000521 automatic fixed bin(15,0) dcl 45 set ref 436* 590* 595* 629* 651* 656* 659 659 662* 662 663 663 663* 663 673* outfo based structure level 1 dcl 4-15 outprec 0(18) based fixed bin(17,0) level 2 packed unaligned dcl 4-15 set ref 475* 477* 493* outscale based fixed bin(17,0) level 2 packed unaligned dcl 4-15 set ref 474* 492* outscale_prec 000673 automatic fixed bin(35,0) dcl 4-8 set ref 474 475 477 481* 492 493 494* outtype 000671 automatic fixed bin(17,0) dcl 4-5 set ref 473* 475 481* 486* 488 488 494* p_ps_ptr parameter pointer dcl 41 ref 19 19 129 pack_ 0(07) 000674 automatic bit(1) level 2 packed unaligned dcl 6-3 set ref 486 pack_picture_ 000070 constant entry external dcl 9-3 ref 482 pic_buf 000522 automatic char(64) unaligned dcl 45 set ref 481 481 482 pic_ptr 000542 automatic pointer dcl 45 set ref 467* 468* 468 473 474 474 475 477 482 picture_image based structure level 1 dcl 8-6 pl1_stack_frame based structure level 1 dcl 3-6 plio2_get_util_$get_prep_ 000044 constant entry external dcl 85 ref 131 plio2_resig_ 000054 constant entry external dcl 85 ref 138 plio2_signal_$conversion_error_ 000046 constant entry external dcl 85 ref 595 plio2_signal_$s_ 000050 constant entry external dcl 85 ref 559 plio2_signal_$s_r_ 000052 constant entry external dcl 85 ref 503 522 prec 0(09) based fixed bin(8,0) level 2 packed unaligned dcl 8-6 ref 477 precision_ 0(24) 000674 automatic fixed bin(11,0) level 2 packed unaligned dcl 6-3 set ref 493 prep 35 based fixed bin(15,0) level 2 dcl 1-10 ref 131 ps based structure level 1 dcl 1-10 psp 000544 automatic pointer dcl 45 set ref 129* 131 131* 134 138* 140 140 142 142 152 152 153 153 155 155 157 158 158 162 162 164 164 164 165 165 169 169 171 171 172 172 174 176 182 182 184 188 188 193 193 196 196 208 208 210 215 219 223 227 229 229 229 231 241 246 246 251 255 265 269 274 274 282 282 288 288 291 291 301 301 303 303 303 303 305 305 309 319 321 326 332 350 354 354 360 360 363 363 365 365 365 374 374 376 376 376 376 378 378 383 385 388 388 388 390 398 462 462 463 463 465 467 468 482 485 488 490 500 503* 507 522* 533 535* 535 536 539 545 546 548 548 548 548 550 550 550 552 559* 585 587 595* put_copy_ 000056 constant entry external dcl 85 ref 535 reverse builtin function dcl 77 ref 656 rn_digit 000547 automatic char(1) dcl 45 set ref 431* 432 rn_value 000550 automatic fixed bin(15,0) dcl 45 set ref 432* 434 443 scale 0(18) based fixed bin(8,0) level 2 packed unaligned dcl 8-6 ref 474 scale_ 0(12) 000674 automatic fixed bin(11,0) level 2 packed unaligned dcl 6-3 set ref 492 scalefactor 1(09) based fixed bin(8,0) level 2 packed unaligned dcl 8-6 ref 474 scan_index 000551 automatic fixed bin(21,0) dcl 45 set ref 188* 191 208 210 223 224 227 231 233 235 241 243 245 354* 356 374 376 378 381 383 385 578* 579 582* 622* 623 625* 625 626 629 634* scan_start 000552 automatic fixed bin(21,0) dcl 45 set ref 184* 185 188 188 193 193 204* 210 223 224* 224 227 231 235* 235 241 245* 245 251 262* 265 275* 275 282 282 291 291 297* 303 305 309 319 321 326 350* 351 354 354 363 363 365 370* 376 378 383 385 585 587 search builtin function dcl 77 ref 188 282 354 423 stack_frame_p based pointer level 2 dcl 1-10 ref 467 start_copy 55 based fixed bin(15,0) level 2 dcl 1-10 set ref 536* string 26(01) based bit(1) level 3 packed unaligned dcl 1-10 ref 500 507 539 substr builtin function dcl 77 set ref 142 155 162 169 182 188 193 196 210 219 223 227 231 241 255 265 269 282 288 291 303 305 309 319 321 332 354 360 363 376 378 383 388 423* 426* 431 444 579 582 585 587 608 611 615 618 623 626 634 642 644 648 659 663 switch based structure level 2 dcl 2-4 targ_ptr 000554 automatic pointer dcl 45 set ref 488* 490* 494* text_base_ptr 46 based pointer level 2 dcl 3-6 ref 467 token_length 000556 automatic fixed bin(21,0) dcl 45 set ref 186* 219 233* 233 243* 243 255 269 332 352* 381* 381 399 401 token_start 000557 automatic fixed bin(21,0) dcl 45 set ref 185* 193 196 196 197* 217 219 220* 231 241 253 255 256* 267 269 270* 286 288 288 289* 330 332 333* 351* 358 360 360 361* 381 394 398 token_string 000560 automatic varying char(257) dcl 45 set ref 193* 193 196* 219* 223* 223 231* 231 241* 241 255* 269* 273* 273 288* 291* 291 332* 360* 363* 363 383* 383 408 413 420 423 430 431 438 454 455 457 578 579 582 602* 615* 621* 634* 634 638 648* 678* top_half 34 based bit(18) level 2 packed unaligned dcl 1-10 ref 468 type based fixed bin(8,0) level 2 in structure "picture_image" packed unaligned dcl 8-6 in procedure "get_value_list_" ref 473 type 000012 constant fixed bin(15,0) initial array dcl 7-1 in procedure "get_value_list_" ref 473 type_ 0(01) 000674 automatic fixed bin(6,0) level 2 packed unsigned unaligned dcl 6-3 set ref 486 unspec builtin function dcl 77 set ref 485* 485 v_bit_desc constant fixed bin(17,0) initial dcl 5-1 ref 414 447 488 v_char_desc constant fixed bin(17,0) initial dcl 5-1 ref 453 488 value_p 30 based pointer level 2 dcl 1-10 ref 462 482 488 490 varlength 1 based fixed bin(8,0) level 2 packed unaligned dcl 8-6 ref 475 verify builtin function dcl 77 ref 142 vp 52 based pointer level 2 dcl 1-10 set ref 462* xbuf based char(1000) unaligned dcl 2-80 ref 142 155 162 169 182 188 193 196 210 219 223 227 231 241 255 265 269 282 288 291 303 305 309 319 321 332 354 360 363 376 378 383 388 585 587 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. D_fixed_cplx_desc internal static fixed bin(17,0) initial dcl 5-1 D_fixed_real_desc internal static fixed bin(17,0) initial dcl 5-1 D_float_cplx_desc internal static fixed bin(17,0) initial dcl 5-1 D_float_real_desc internal static fixed bin(17,0) initial dcl 5-1 area_desc internal static fixed bin(17,0) initial dcl 5-1 assign_round_ 000000 constant entry external dcl 4-22 assign_truncate_ 000000 constant entry external dcl 4-22 assign_type_d 000000 constant entry external dcl 9-3 assign_type_p 000000 constant entry external dcl 9-3 bit_desc internal static fixed bin(17,0) initial dcl 5-1 char_to_numeric_ 000000 constant entry external dcl 4-22 d_fixed_cplx_desc internal static fixed bin(17,0) initial dcl 5-1 d_fixed_real_desc internal static fixed bin(17,0) initial dcl 5-1 d_float_cplx_desc internal static fixed bin(17,0) initial dcl 5-1 d_float_real_desc internal static fixed bin(17,0) initial dcl 5-1 entry_desc internal static fixed bin(17,0) initial dcl 5-1 expand_bit_chars internal static char(64) initial array unaligned dcl 10-17 file_desc internal static fixed bin(17,0) initial dcl 5-1 inclength based fixed bin(31,0) dcl 4-19 info based structure level 1 dcl 4-11 label_desc internal static fixed bin(17,0) initial dcl 5-1 offset_desc internal static fixed bin(17,0) initial dcl 5-1 outclength based fixed bin(31,0) dcl 4-20 picture_char_type internal static fixed bin(8,0) initial unaligned dcl 8-20 picture_complexfix_type internal static fixed bin(8,0) initial unaligned dcl 8-20 picture_complexflo_type internal static fixed bin(8,0) initial unaligned dcl 8-20 picture_realfix_type internal static fixed bin(8,0) initial unaligned dcl 8-20 picture_realflo_type internal static fixed bin(8,0) initial unaligned dcl 8-20 plio2_data_$badfsbp external static pointer dcl 1-82 plio2_data_$badjob external static bit(36) dcl 1-94 plio2_data_$fab2pstat external static pointer dcl 1-82 plio2_data_$fabpstat external static pointer dcl 1-82 plio2_data_$fsbpstat external static pointer dcl 1-82 plio2_data_$pliostringfsbp external static pointer dcl 1-82 plio2_data_$pspstat external static pointer dcl 1-82 plio2_data_$undef_file_sw external static bit(1) dcl 1-94 plio2_data_fsb_thread_ external static pointer initial dcl 1-91 pointer_desc internal static fixed bin(17,0) initial dcl 5-1 s_fixed_cplx_desc internal static fixed bin(17,0) initial dcl 5-1 s_fixed_real_desc internal static fixed bin(17,0) initial dcl 5-1 s_float_cplx_desc internal static fixed bin(17,0) initial dcl 5-1 s_float_real_desc internal static fixed bin(17,0) initial dcl 5-1 structure_desc internal static fixed bin(17,0) initial dcl 5-1 unpack_picture_ 000000 constant entry external dcl 9-3 validate_picture_ 000000 constant entry external dcl 9-3 NAMES DECLARED BY EXPLICIT CONTEXT. any_err 001644 constant label dcl 522 ref 512 517 conversion_error 002060 constant entry internal dcl 570 ref 344 conversion_error_for_RADIX_N 002165 constant entry internal dcl 592 ref 439 err163 001625 constant label dcl 507 ref 201 err171 001637 constant label dcl 515 ref 420 err172 001642 constant label dcl 519 ref 401 408 457 find_break 000541 constant label dcl 282 ref 298 find_break_nq 000745 constant label dcl 354 ref 371 finish 001127 constant label dcl 394 ref 260 294 367 440 get_value_list_ 000050 constant entry external dcl 19 init_scan 000136 constant label dcl 140 ref 149 159 166 177 no_assign 001560 constant label dcl 497 ref 638 plio2_gvl_ 000061 constant entry external dcl 19 raise_conversion 002166 constant label dcl 595 ref 630 652 668 674 raise_eof 001561 constant label dcl 500 ref 147 refill_buffer_ldi 001702 constant entry internal dcl 530 ref 146 200 259 293 366 rescan 000241 constant label dcl 188 ref 205 225 236 276 NAME DECLARED BY CONTEXT OR IMPLICATION. rtrim builtin function ref 610 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 3534 3626 3334 3544 Length 4222 3334 72 357 177 30 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME get_value_list_ 706 external procedure is an external procedure. on unit on line 138 68 on unit refill_buffer_ldi internal procedure shares stack frame of external procedure get_value_list_. conversion_error internal procedure shares stack frame of external procedure get_value_list_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 digits get_value_list_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME get_value_list_ 000100 BIT_STRING get_value_list_ 000101 bit256 get_value_list_ 000112 break get_value_list_ 000113 code get_value_list_ 000114 convert_index get_value_list_ 000115 erno get_value_list_ 000116 error_string get_value_list_ 000511 first_bit get_value_list_ 000512 first_char get_value_list_ 000514 in_ptr get_value_list_ 000516 iocbp get_value_list_ 000520 left get_value_list_ 000521 onchar_index get_value_list_ 000522 pic_buf get_value_list_ 000542 pic_ptr get_value_list_ 000544 psp get_value_list_ 000546 RADIX_FACTOR get_value_list_ 000547 rn_digit get_value_list_ 000550 rn_value get_value_list_ 000551 scan_index get_value_list_ 000552 scan_start get_value_list_ 000554 targ_ptr get_value_list_ 000556 token_length get_value_list_ 000557 token_start get_value_list_ 000560 token_string get_value_list_ 000670 intype get_value_list_ 000671 outtype get_value_list_ 000672 inscale_prec get_value_list_ 000673 outscale_prec get_value_list_ 000674 desc_ get_value_list_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_bit_temp call_ext_out_desc call_ext_out return_mac enable_op shorten_stack ext_entry int_entry any_to_any_truncate_set_support THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. assign_ iox_$get_chars iox_$get_line pack_picture_ plio2_get_util_$get_prep_ plio2_resig_ plio2_signal_$conversion_error_ plio2_signal_$s_ plio2_signal_$s_r_ put_copy_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$end_of_info error_table_$long_record error_table_$short_record LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 19 000045 129 000067 131 000073 134 000103 135 000107 136 000110 138 000111 140 000136 142 000144 144 000160 146 000161 147 000162 149 000164 152 000165 153 000170 155 000174 157 000202 158 000203 159 000204 162 000205 164 000207 165 000216 166 000217 169 000220 171 000222 172 000223 174 000224 176 000227 177 000231 180 000232 182 000233 184 000235 185 000237 186 000240 188 000241 191 000263 193 000264 196 000301 197 000314 200 000315 201 000316 204 000320 205 000322 208 000323 210 000326 215 000336 217 000337 219 000341 220 000352 223 000353 224 000371 225 000373 227 000374 229 000376 231 000405 233 000423 235 000425 236 000427 241 000430 243 000451 245 000455 246 000457 251 000460 253 000463 255 000465 256 000476 259 000477 260 000500 262 000502 265 000504 267 000513 269 000515 270 000526 273 000527 274 000536 275 000537 276 000540 282 000541 284 000563 286 000564 288 000566 289 000601 290 000602 291 000603 293 000615 294 000616 297 000620 298 000622 301 000623 303 000626 305 000646 309 000651 312 000661 313 000663 317 000665 319 000670 321 000702 326 000712 328 000715 330 000720 332 000722 333 000733 341 000734 343 000736 344 000740 348 000741 350 000742 351 000743 352 000744 354 000745 356 000767 358 000770 360 000772 361 001005 362 001006 363 001007 365 001021 366 001026 367 001027 370 001031 371 001033 374 001034 376 001037 378 001057 381 001062 383 001071 385 001107 388 001112 390 001125 394 001127 397 001131 398 001133 399 001143 401 001145 404 001147 405 001150 408 001152 411 001155 413 001160 414 001204 415 001207 416 001211 417 001213 420 001214 423 001222 426 001245 428 001251 430 001252 431 001261 432 001265 434 001302 436 001303 437 001305 438 001307 439 001314 440 001315 443 001316 444 001322 445 001342 447 001344 448 001346 449 001350 451 001352 453 001353 454 001355 455 001357 457 001361 462 001363 463 001367 465 001371 467 001372 468 001375 473 001401 474 001405 475 001417 477 001431 481 001436 482 001461 483 001475 485 001476 486 001500 488 001512 490 001524 492 001526 493 001532 494 001537 497 001560 500 001561 503 001565 504 001624 507 001625 511 001634 512 001636 515 001637 517 001641 519 001642 522 001644 524 001701 530 001702 533 001703 535 001707 536 001721 539 001724 541 001727 542 001732 545 001733 546 001735 548 001737 550 001762 552 002001 554 002005 557 002016 559 002020 560 002056 562 002057 570 002060 577 002061 578 002065 579 002075 582 002110 583 002120 584 002122 585 002131 587 002152 590 002160 592 002164 595 002166 600 002242 602 002245 603 002255 608 002256 610 002262 611 002300 613 002305 614 002307 615 002311 617 002322 618 002323 620 002331 621 002332 622 002333 623 002343 625 002347 626 002350 629 002355 630 002357 634 002360 636 002370 638 002372 641 002377 642 002400 644 002404 645 002415 647 002416 648 002420 649 002431 651 002432 652 002434 654 002435 656 002436 659 002454 662 002462 663 002463 668 002500 670 002501 671 002502 673 002507 674 002511 677 002512 678 002513 681 002523 ----------------------------------------------------------- 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