COMPILATION LISTING OF SEGMENT linus_print Compiled by: Multics PL/I Compiler, Release 33a, of May 30, 1990 Compiled at: ACTC Technologies Inc. Compiled on: 10/14/90 0918.1 mdt Sun Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1990 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1981 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 /****^ HISTORY COMMENTS: 15* 1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202), 16* audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): 17* Changed calls to assign_round_ from assign_ so that data is rounded. 18* END HISTORY COMMENTS */ 19 20 21 linus_print: 22 proc (sci_ptr, lcb_ptr); 23 24 25 26 /* HISTORY: 27* 28* 77-05-01 J. C. C. Jagernauth: Initially written. 29* 30* 79-12-19 Rickie E. Brinegar: Modified to output no data found message over 31* user_output instead of over error_output. 32* 33* 80-01-03 Rickie E. Brinegar: Modified to truncate blanks off of the right 34* hand end of the output line. 35* 36* 80-01-10 Rickie E. Brinegar: Modified to use mdbm_util_$(binary complex 37* fixed number string)_data_class entry points. 38* 39* 80-02-04 Rickie E. Brinegar: Modified to add the -no_end, -ne control 40* arguments. 41* 42* 80-04-10 Rickie E. Brinegar: Modified to remove certain loops which were 43* being called 5,000 times for each line printed. This increased the speed 44* of linus_print by 30 percent. 45* 46* 80-04-14 Rickie E. Brinegar: Modified to use a work area defined on 47* lcb.i_o_area_ptr instead of getting system free area. 48* 49* 80-06-01 Jim Gray: Modified to detect integer control argument args that 50* are too large, to correct -all, make -all and -max incompatible to fix 51* effect of arg ordering bug, and fix error given when -col_widths had no 52* additional argument given. 53* 54* 80-06-02 Jim Gray: Modified to make -cw and -cwt incompatible, fix the 55* detection of too many/few args for -cw/-max, detect p.q column width given 56* for strings, detect when max buffer length exceeded, and improve error 57* messages. 58* 59* 80-06-24 Jim Gray: Modified to add capabilty of printing fixed scaled 60* numbers, where column has not been specified. 61* 62* 80-10-21 Rickie E. Brinegar: The initialization of the buffers in the 63* declaration was changed to be done at the begining of the executable code, 64* and to use assignments of one buffer to another using the string psuedo 65* variable and builtin function. These changes were made as a performance 66* improvement and were suggested by Matt Pierret. 67* 68* 81-01-16 Rickie E. Brinegar: Added a check of the error code after the 69* call to linus_eval_set_func to catch error returns rather than letting 70* linus_print blow up ungracefully. 71* 72* 81-07-15 Rickie E. Brinegar: Removed the conversion and cleanup condition 73* handlers. 74* 75* 81-09-17 Rickie E. Brinegar: Changed the assignment of num_ptrs to 76* num_ptrs to be an assignment of arg_list.arg_count to num_ptrs later on in 77* the code to eliminate a size condition from occuring. 78* 79* 81-11-12 Rickie E. Brinegar: Added timing of this request and its 80* dsl_$retrieve call. 81* 82* 82-02-10 Paul W. Benjamin: ssu_ conversion 83* 84* 82-06-15 Dave J. Schimke: added short names to the MORE? responses 85* a = all, y = yes, n = no. 86* 87* 82-06-18 Dave J. Schimke: Modified internal procedure overflow_check to 88* avoid a stringsize condition when assign_ truncates. This occurred whenever 89* the -cw control arg was used to reduce the column widths. 90* 91* 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the 92* first retrieve to keep linus_table from getting lost when loading in the 93* incremental mode. This call can be eliminated when all modules call 94* linus_table for their retrievals. 95* 96* 83-01-11 Dave Schimke: Replace call to iox_$get_line and associated code in 97* the more_response internal proc with a call to linus_query. This fixes a ssu 98* conversion bug for invoke and answers TRs 12445 & 13342 (linus 73). Also 99* changed arg_len_bits.length to arg_len_bits.len. 100* 101* 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current 102* select expression is available 103**/ 104 1 1 /* BEGIN INCLUDE FILE linus_lcb.incl.pl1 -- jaw 8/30/77 */ 1 2 1 3 1 4 1 5 /****^ HISTORY COMMENTS: 1 6* 1) change(86-04-23,Dupuis), approve(86-05-23,MCR7188), audit(86-07-23,GWMay), 1 7* install(86-07-29,MR12.0-1106): 1 8* Added general_work_area_ptr and renamed sfr_ptr to 1 9* force_retrieve_scope_ptr. 1 10* END HISTORY COMMENTS */ 1 11 1 12 1 13 /* HISTORY: 1 14* 1 15* 78-09-29 J. C. C. Jagernauth: Modified for MR7.0. 1 16* 1 17* 81-05-11 Rickie E. Brinegar: added security bit and andministrator bit as 1 18* a part of the attribute level control work. 1 19* 1 20* 81-06-17 Rickie E. Brinegar: deleted the sd_ptr as a part of removing the 1 21* scope_data structure from LINUS. LINUS now depends totally on MRDS for 1 22* scope information. 1 23* 1 24* 81-11-11 Rickie E. Brinegar: added the timing bit and three fields for 1 25* retaining various vcpu times to be collected when in timing mode. The 1 26* times to be collected are: LINUS parsing time, LINUS processing time, and 1 27* MRDS processing time. 1 28* 1 29* 82-01-15 DJ Schimke: Added the build_increment and build_start fields as 1 30* part of the line numbering implementation. This allows for possible later 1 31* LINUS control of the build defaults. 1 32* 1 33* 82-03-01 Paul W. Benjamin: Removed linus_prompt_chars_ptr, as that 1 34* information is now retained by ssu_. Removed parse_timer as no longer 1 35* meaningful. Added linus_version. Added iteration bit. Added 6 entry 1 36* variables for ssu_ replaceable procedures. Added actual_input_iocbp. 1 37* 1 38* 82-06-23 Al Dupuis: Added subsystem_control_info_ptr, 1 39* subsystem_invocation_level, and selection_expression_identifier. 1 40* 1 41* 82-08-26 DJ Schimke: Added report_control_info_ptr, and 1 42* table_control_info_ptr. 1 43* 1 44* 82-10-19 DJ Schimke: Added ssu_abort_line. 1 45* 1 46* 83-06-06 Bert Moberg: Added print_search_order (pso) and no_optimize (no_ot) 1 47* 1 48* 83-04-07 DJ Schimke: Added temp_seg_info_ptr. 1 49* 1 50* 83-08-26 Al Dupuis: Added query_temp_segment_ptr. 1 51**/ 1 52 1 53 dcl 1 lcb aligned based (lcb_ptr), /* LINUS control block */ 1 54 2 db_index fixed bin (35), /* index of open data base, or 0 */ 1 55 2 rb_len fixed bin (21), /* length of request buffer */ 1 56 2 lila_count fixed bin (35), /* number of LILA text lines */ 1 57 2 lila_chars fixed bin (35), /* number of LILA source test chars */ 1 58 2 trans_id fixed bin (35), /* used by checkpoint and rollback facilities (MR7.0) */ 1 59 2 lila_fn char (32) unal, /* entry name of lila data file */ 1 60 2 prompt_flag bit (1) unal, /* on if in prompt mode */ 1 61 2 test_flag bit (1) unal, /* on if in test mode */ 1 62 2 new_version bit (1) unal init (1), /* on for new version data base (MR7.0) */ 1 63 2 secured_db bit (1) unal, /* on if the db is in a secure state */ 1 64 2 administrator bit (1) unal, /* on if the user is a db administrator */ 1 65 2 timing_mode bit (1) unal, /* on if timing is to be done */ 1 66 2 iteration bit (1) unal, /* interpret parens as iteration sets */ 1 67 2 pso_flag bit (1) unal, /* add print_search_order to select */ 1 68 2 no_ot_flag bit (1) unal, /* add no_optimize to select */ 1 69 2 reserved bit (27) unal, 1 70 2 liocb_ptr ptr, /* iocb ptr for lila file */ 1 71 2 rb_ptr ptr, /* ptr to request buffer */ 1 72 2 is_ptr ptr, /* iocb ptr for currentinput stream switch */ 1 73 2 cal_ptr ptr, /* ptr to current arg list for invoke (or null) */ 1 74 2 ttn_ptr ptr, /* pointer to table info structure */ 1 75 2 force_retrieve_scope_info_ptr ptr, /* structure pointer to force retrieve scope operation */ 1 76 2 lv_ptr ptr, /* pointer linus variables */ 1 77 2 si_ptr ptr, /* pointer to select_info structure */ 1 78 2 setfi_ptr ptr, /* pointer to set function information */ 1 79 2 sclfi_ptr ptr, /* pointer to user declared scalar fun. names */ 1 80 2 ivs_ptr ptr, /* pointer to stack of invoke iocb pointers */ 1 81 2 lit_ptr ptr, /* pointer to literal pool */ 1 82 2 lvv_ptr ptr, /* pointer to linus variable alloc. pool */ 1 83 2 rd_ptr ptr, /* point to readied files mode information (MR7.0) */ 1 84 2 rt_ptr ptr, /* point to table of relation names and their readied modes 1 85* (MR7.0) */ 1 86 2 actual_input_iocbp ptr, /* ptr to input while in macros */ 1 87 2 lila_promp_chars_ptr ptr, /* pointer to the prompt characters for lila */ 1 88 2 linus_area_ptr ptr, /* LINUS temporary segment pointer */ 1 89 2 lila_area_ptr ptr, /* LILA temporary segment pointer */ 1 90 2 i_o_area_ptr ptr, /* temporary segment pointer used by write, print, create_list */ 1 91 2 rel_array_ptr ptr, /* ptr to array of names rslt info structure 1 92* for current lila expression */ 1 93 2 unused_timer float bin (63), /* future expansion */ 1 94 2 request_time float bin (63), /* How much request time was spent 1 95* in LINUS. (-1 = user has just enabled 1 96* timing, do not report) */ 1 97 2 mrds_time float bin (63), /* How much time was spent in MRDS */ 1 98 2 build_increment fixed bin, /* default increment for build mode */ 1 99 2 build_start fixed bin, /* default start count for build mode */ 1 100 2 linus_version char (4), /* current version of LINUS */ 1 101 2 subsystem_control_info_ptr ptr, /* the same ptr passed by ssu_ to each request procedure */ 1 102 2 subsystem_invocation_level fixed bin, /* identifies this invocation of LINUS */ 1 103 2 selection_expression_identifier fixed bin, /* identifies the current processed selection expression */ 1 104 2 report_control_info_ptr ptr, /* pointer to linus_report_control_info structure */ 1 105 2 table_control_info_ptr ptr, /* pointer to linus_table control structure */ 1 106 2 temp_seg_info_ptr ptr, /* pointer to linus_temp_seg_mgr control structure */ 1 107 2 query_temp_segment_ptr ptr, /* points to temp seg used for manipulating query */ 1 108 2 general_work_area_ptr ptr, /* a freeing area for general use */ 1 109 2 word_pad (6) bit (36) unal, 1 110 /* procedures that will be optionally */ 1 111 /* replaced by the user. Saved so they */ 1 112 /* can be reinstated if desired. */ 1 113 2 ssu_abort_line entry options (variable), 1 114 2 ssu_post_request_line variable entry (ptr), 1 115 2 ssu_pre_request_line variable entry (ptr), 1 116 1 117 2 curr_lit_offset fixed bin (35), /* index of first free bit in lit. pool */ 1 118 2 curr_lv_val_offset fixed bin (35), /* index of first free bit lv. val. pool */ 1 119 2 static_area area (sys_info$max_seg_size - fixed (rel (addr (lcb.static_area))) + 1); 1 120 1 121 dcl lcb_ptr ptr; 1 122 1 123 /* END INCLUDE FILE linus_lcb.incl.pl1 */ 105 106 2 1 /* BEGIN INCLUDE FILE linus_char_argl.incl.pl1 -- jaw 2/11/77 */ 2 2 2 3 /* HISTORY: 2 4* 2 5* 82-02-05 Paul W. Benjamin: Changed arg_len to fixed bin (21). 2 6* 2 7**/ 2 8 2 9 dcl 1 char_argl aligned based (ca_ptr), /* structure for general char. arg. list */ 2 10 2 nargs fixed bin, /* number of args */ 2 11 2 arg (nargs_init refer (char_argl.nargs)), 2 12 3 arg_ptr ptr, /* ptr to first char. of arg */ 2 13 3 arg_len fixed bin (21); /* no. of chars. in arg */ 2 14 2 15 dcl ca_ptr ptr; 2 16 dcl nargs_init fixed bin; 2 17 2 18 /* END INCLUDE FILE linus_char_argl.incl.pl1 */ 107 108 3 1 /* BEGIN INCLUDE FILE linus_select_info.incl.pl1 */ 3 2 /* History: 77-07-29 J. A. Weeldreyer: Originally written. 3 3* Modified: 82-18-82 Dave Schimke: Added user_item.table_name 3 4**/ 3 5 dcl 1 select_info aligned based (si_ptr), /* info from LILA select clause */ 3 6 2 set_fn bit (1) unal, /* on if set fn to be applied */ 3 7 2 se_flags unal, /* flags pertaining to selection expr. */ 3 8 3 val_ret bit (1) unal, /* valid for retrieval */ 3 9 3 val_dtt bit (1) unal, /* valid for define_temp_table */ 3 10 3 val_del bit (1) unal, /* valid for delete */ 3 11 3 val_mod bit (1) unal, /* valid for modify */ 3 12 2 dup_flag bit (1) unal, /* on if dup explic. spec. somewhere */ 3 13 2 unique_flag bit (1) unal, /* on if unique explic. spec. somewhere */ 3 14 2 pad bit (29) unal, /* reserved */ 3 15 2 prior_sf_ptr ptr, /* pointer to set fns for prior eval. */ 3 16 2 se_ptr ptr, /* pointer to mrds selection expression */ 3 17 2 sel_items_ptr ptr, /* pointer to list of selected items */ 3 18 2 sel_items_len fixed bin, /* length in characters of list of selected items */ 3 19 2 se_len fixed bin (35), /* length of mrds sel. expr. */ 3 20 2 nsv_alloc fixed bin, /* no. of se. vals aloc. */ 3 21 2 nmi_alloc fixed bin, /* no. of mrds items alloc. */ 3 22 2 nui_alloc fixed bin, /* no. of user items alloc. */ 3 23 2 nsevals fixed bin, /* number of selection expr. vaules */ 3 24 2 n_mrds_items fixed bin, /* no. of items in mrds select list */ 3 25 2 n_user_items fixed bin, /* no. of items user will see */ 3 26 2 se_vals (nsv_init refer (select_info.nsv_alloc)), 3 27 3 arg_ptr ptr, 3 28 3 desc_ptr ptr, 3 29 2 mrds_item (nmi_init refer (select_info.nmi_alloc)), /* mrds select items */ 3 30 3 arg_ptr ptr, /* pointer to receiving field */ 3 31 3 bit_len fixed bin (35), /* bit length of receiving field */ 3 32 3 desc bit (36), /* descriptor for receiving field */ 3 33 3 assn_type fixed bin, /* type code for assign_ */ 3 34 3 assn_len fixed bin (35), /* length for assign_ */ 3 35 2 user_item (nui_init refer (select_info.nui_alloc)), /* user select item */ 3 36 3 name char (32) var, /* name for col. header */ 3 37 3 table_name char (32) var, /* name of containing linus table */ 3 38 3 item_type fixed bin, /* indicates type of item: 3 39* 1 => raw mrds, 3 40* 2 => expr. */ 3 41 3 rslt_desc bit (36), /* descriptor for expr. result */ 3 42 3 rslt_bit_len fixed bin (35), /* bit length of expr. result */ 3 43 3 rslt_assn_ptr ptr, /* pointer to expr. result storage loc. */ 3 44 3 rslt_assn_type fixed bin, /* assign_ type code of expr. result */ 3 45 3 rslt_assn_len fixed bin (35), /* assign_ length for expr. result */ 3 46 3 item_ptr ptr; /* pointer to item or expr. or applied set_func. structure */ 3 47 3 48 dcl (nsv_init, nmi_init, nui_init) fixed bin; 3 49 dcl si_ptr ptr; 3 50 3 51 /* END INCLUDE FILE linus_select_info.incl.pl1 */ 109 110 4 1 /* BEGIN INCLUDE FILE linus_arg_list.incl.pl1 -- jccj 4/15/77 */ 4 2 4 3 dcl 1 char_desc aligned based (char_ptr), /* Structure for character descriptors */ 4 4 2 fb_desc bit (36) aligned init ("100000100000000000000000000000100011"b), /* Fixed bin descriptor */ 4 5 2 n_chars fixed bin, 4 6 2 arr (n_chars_init refer (char_desc.n_chars)), 4 7 3 const bit (12) unal init ("101010100000"b), /* Constant part */ 4 8 3 var bit (24) unal; /* Variable part */ 4 9 4 10 dcl char_ptr ptr; 4 11 dcl n_chars_init fixed bin; 4 12 4 13 /* END INCLUDE FILE linus_arg_list.incl.pl1 */ 111 112 5 1 /* BEGIN mdbm_arg_list.incl.pl1 -- jaw 5/31/78 */ 5 2 /* the duplicate mrds_arg_list.incl.pl1 was eliminated by Jim Gray, Nov. 1979 */ 5 3 5 4 /* layout of argument list for IDS and DBM entries with options (variable) */ 5 5 5 6 dcl 1 arg_list based (al_ptr), 5 7 2 arg_count fixed bin (17) unal, /* 2 * no. of args. */ 5 8 2 code fixed bin (17) unal, /* 4 => normal, 8 => special */ 5 9 2 desc_count fixed bin (17) unal, /* 2 * no. of descriptors */ 5 10 2 pad fixed bin (17) unal, /* must be 0 */ 5 11 2 arg_des_ptr (num_ptrs) ptr; /* argument/descriptor pointer */ 5 12 5 13 dcl al_ptr ptr; 5 14 dcl num_ptrs fixed bin; 5 15 5 16 /* END mdbm_arg_list.incl.pl1 */ 5 17 113 114 6 1 /* BEGIN mdbm_descriptor.incl.pl1 -- jaw 5/31/78 */ 6 2 /* modified by Jim Gray - - Nov. 1979, to change type from fixed bin(5) to 6 3* unsigned fixed bin(6), so new packed decimal data types could be handled. 6 4* also the duplicate mrds_descriptor.incl.pl1 was eliminated. */ 6 5 6 6 dcl 1 descriptor based (desc_ptr), /* map of Multics descriptor */ 6 7 2 version bit (1) unal, /* DBM handles vers. 1 only */ 6 8 2 type unsigned fixed bin (6) unal, /* data type */ 6 9 2 packed bit (1) unal, /* on if data item is packed */ 6 10 2 number_dims bit (4) unal, /* dimensions */ 6 11 2 size, /* size for string data */ 6 12 3 scale bit (12) unal, /* scale for num. data */ 6 13 3 precision bit (12) unal, /* prec. for num. data */ 6 14 2 array_info (num_dims), 6 15 3 lower_bound fixed bin (35), /* lower bound of dimension */ 6 16 3 upper_bound fixed bin (35), /* upper bound of dimension */ 6 17 3 multiplier fixed bin (35); /* element separation */ 6 18 6 19 dcl desc_ptr ptr; 6 20 dcl num_dims fixed bin init (0) ; /* more useful form of number_dims */ 6 21 6 22 /* END mdbm_descriptor.incl.pl1 */ 6 23 6 24 115 116 117 dcl sci_ptr ptr; /* for ssu_ */ 118 119 dcl 1 one_line based (line_ptr), /* Format for one print line */ 120 2 num_items fixed bin, 121 2 item (select_info.n_user_items refer (one_line.num_items)), 122 3 len fixed bin (35), 123 3 ptr ptr; 124 125 dcl 1 out_line based (out_line_ptr), /* like one_line */ 126 2 num_items fixed bin, 127 2 item (select_info.n_user_items refer (out_line.num_items)), 128 3 len fixed bin (35), 129 3 ptr ptr; 130 131 dcl 1 user_item aligned based (user_item_ptr), /* valid when mrds item = user item */ 132 2 arg_ptr ptr, 133 2 bit_len fixed bin (35), 134 2 desc bit (36), 135 2 assn_type fixed bin, 136 2 assn_len fixed bin (35); 137 138 dcl 1 arg_len_bits based, /* Pick up length for descriptor */ 139 2 pad bit (12) unal, 140 2 len bit (24) unal; 141 142 dcl tmp_char char (char_argl.arg.arg_len (i)) 143 based (char_argl.arg.arg_ptr (i)); 144 145 dcl (he_flag, print_end, first_retrieve, search_for_mrds_item, cwt_flag, 146 cw_flag) bit (1); 147 148 dcl ( 149 e_ptr init (null), 150 out_line_ptr init (null), 151 source_ptr init (null), 152 prt_data_ptr init (null), 153 target_ptr init (null), 154 user_item_ptr init (null), 155 expr_results_ptr init (null), 156 stars_ptr init (null), 157 destination_ptr init (null), /* Points to the scalar function init (null), 158* set function or select_info structure */ 159 line_ptr init (null) 160 ) ptr; 161 162 dcl iox_$user_output ptr ext; 163 164 dcl (item_length, float_dec_len, icode, code, out_code, constant_max_lines, 165 max_lines) fixed bin (35); 166 167 dcl expr_results float dec (59); 168 dcl char_61 char (61); 169 dcl char_122 char (122); 170 171 dcl out_item char (out_line.item.len (l)) aligned 172 based (out_line.item.ptr (l)); 173 dcl picture_output char (one_line.item.len (l)) aligned 174 based (one_line.item.ptr (l)); 175 176 dcl long_message char (100); 177 dcl short_message char (8); 178 179 dcl (abs, addr, after, before, ceil, char, copy, fixed, index, length, log10, 180 ltrim, null, rel, rtrim, search, string, substr, vclock, verify) builtin; 181 182 dcl cleanup condition; 183 184 dcl offset (10) bit (1) based; 185 186 dcl ( 187 i, 188 j, 189 output_line_buf_index, 190 line_buf_index, 191 line_count, 192 out_line_index, 193 out_data_len, 194 prt_data_len, 195 target_type, 196 source_type, 197 another_len, 198 caller, /* 1 = from request processor, 199* 2 = from scalar function, 200* 3 = from set function */ 201 mrds_item_index, 202 temp, 203 cmpx_float_dec_type, 204 float_dec_type, 205 l 206 ) fixed bin; 207 208 dcl n_bytes fixed bin (21); /* for iox_ call */ 209 dcl num_bytes fixed bin (35); 210 211 dcl initial_mrds_vclock float bin (63); 212 213 dcl (function_err, fatal_func_err) condition; 214 215 dcl float_dec_59_desc bit (36) int static options (constant) 216 init ("100101000000000000000000000000111011"b); 217 dcl fix_of_scale (linus_data_$max_user_items) fixed bin 218 init ((linus_data_$max_user_items) 3); 219 dcl ioars_string (linus_data_$max_user_items) char (8) var 220 init ((linus_data_$max_user_items) (1)"^.3f"); 221 dcl ioars_len fixed bin (17); 222 dcl STARS char (100) int static options (constant) init ((100)"*"); 223 dcl DEFAULT_EXPR_SIZE fixed bin (5) int static options (constant) init (17); 224 dcl expr_head char (36) var; 225 dcl ANOTHER char (8) int static options (constant) init ("-another"); 226 dcl EXPR fixed bin (2) int static options (constant) init (2); 227 dcl stars_var char (one_line.item.len (l)) based (stars_ptr); 228 229 dcl ( 230 linus_data_$p_id, 231 linus_data_$max_user_items, 232 linus_data_$print_col_spaces, 233 linus_data_$pr_buff_len, 234 linus_error_$dup_ctl_args, 235 linus_error_$func_err, 236 linus_error_$incons_args, 237 linus_error_$integer_too_small, 238 linus_error_$inv_arg, 239 linus_error_$integer_too_large, 240 linus_error_$no_data, 241 linus_error_$no_db, 242 linus_error_$no_max_lines, 243 linus_error_$non_integer, 244 linus_error_$print_buf_ovfl, 245 linus_error_$ret_not_valid, 246 linus_error_$too_few_args, 247 linus_error_$too_many_args, 248 mrds_error_$tuple_not_found, 249 sys_info$max_seg_size 250 ) fixed bin (35) ext; 251 252 dcl all_seen bit (1); /* on => -all control arg already given */ 253 dcl max_seen bit (1); /* on => -max control alreay given */ 254 dcl temp_int fixed bin (35); /* temp_int for -max 0 check */ 255 dcl MRDS_ITEM fixed bin int static options (constant) init (1); 256 dcl temp_desc_ptr ptr; 257 dcl buffer_character_string char (out_line.item.len (l)) based; 258 dcl line_buf (linus_data_$pr_buff_len) char (1); 259 dcl temp_buf (linus_data_$pr_buff_len) char (1); 260 dcl out_buf (linus_data_$pr_buff_len) char (1); 261 dcl output_line_buf (linus_data_$pr_buff_len) char (1); 262 263 dcl linus_retrieve entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); 264 dcl linus_table$async_retrieval 265 entry (ptr, fixed bin (35)); 266 dcl linus_translate_query$auto entry (ptr, ptr); 267 dcl linus_eval_expr 268 entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); 269 dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); 270 dcl convert_status_code_ entry (fixed bin (35), char (8), char (100)); 271 dcl cu_$generate_call entry (entry, ptr); 272 dcl ioa_ entry options (variable); 273 dcl ioa_$ioa_switch entry options (variable); 274 dcl ioa_$rsnnl entry options (variable); 275 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); 276 dcl ( 277 mdbm_util_$binary_data_class, 278 mdbm_util_$complex_data_class, 279 mdbm_util_$fixed_data_class, 280 mdbm_util_$number_data_class, 281 mdbm_util_$string_data_class 282 ) entry (ptr) returns (bit (1)); 283 dcl dsl_$retrieve entry options (variable); 284 dcl work_area area (sys_info$max_seg_size) based (lcb.i_o_area_ptr); 285 dcl linus_define_area entry (ptr, char (6), fixed bin (35)); 286 dcl assign_round_ 287 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); 288 dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); 289 dcl ssu_$abort_line entry options (variable); 290 dcl ssu_$abort_subsystem entry options (variable); 291 dcl ssu_$arg_count entry (ptr, fixed bin); 292 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); 293 dcl ssu_$print_message entry options (variable); 294 295 ca_ptr, char_ptr, al_ptr, out_line_ptr, line_ptr = null; 296 297 on function_err go to continue; 298 on fatal_func_err call func_err; 299 300 expr_results_ptr = addr (expr_results); 301 stars_ptr = addr (STARS); 302 string (line_buf) = copy (" ", linus_data_$pr_buff_len); 303 string (out_buf), string (temp_buf), string (output_line_buf) = 304 string (line_buf); 305 num_dims = 1; 306 out_data_len, prt_data_len, code, line_count, icode = 0; 307 cwt_flag, cw_flag = "0"b; 308 first_retrieve, print_end, he_flag = "1"b; 309 constant_max_lines, max_lines = 10; /* Set default print lines */ 310 target_type = 43; /* Char * 2 */ 311 source_type = 44; /* Char_var * 2 */ 312 cmpx_float_dec_type = 24; 313 desc_ptr = addr (float_dec_59_desc); 314 float_dec_type = 2 * descriptor.type; 315 float_dec_len = 316 fixed (descriptor.size.scale || "000000"b || descriptor.size.precision) 317 ; 318 another_len = 8; /* There are 8 characters in "-another" */ 319 caller = 1; /* For linus_eval_expr */ 320 line_ptr = null; 321 prt_data_ptr = addr (output_line_buf (1)); /* Init */ 322 323 if lcb.db_index = 0 then 324 call error (linus_error_$no_db, ""); 325 if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ 326 if lcb.si_ptr = null then return; /* No good? Oh, well */ 327 destination_ptr = lcb.si_ptr; /* For linus_eval_expr */ 328 si_ptr = lcb.si_ptr; 329 if ^select_info.se_flags.val_ret then 330 call error (linus_error_$ret_not_valid, ""); 331 call linus_define_area (lcb.i_o_area_ptr, "I_O_", code); 332 if code ^= 0 then 333 call error (code, ""); 334 allocate one_line in (work_area); 335 allocate out_line in (work_area); 336 max_seen, all_seen = "0"b; 337 i = 1; 338 call ssu_$arg_count (sci_ptr, nargs_init); 339 if nargs_init ^= 0 then do; 340 allocate char_argl in (lcb.static_area); 341 on cleanup begin; 342 if ca_ptr ^= null 343 then free char_argl; 344 end; 345 do i = 1 to nargs_init; 346 call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); 347 end; 348 i = 1; 349 do while (i <= char_argl.nargs); 350 if tmp_char = "-no_header" | tmp_char = "-nhe" then 351 he_flag = "0"b; /* Set header flag */ 352 else if tmp_char = "-max" then do; 353 if max_seen then 354 call error (linus_error_$dup_ctl_args, "-max"); 355 if i = char_argl.nargs then 356 call error (linus_error_$no_max_lines, ""); 357 else if all_seen then 358 call error (linus_error_$incons_args, "-max and -all"); 359 else do; 360 i = i + 1; 361 if substr (tmp_char, 1, 1) = "-" then 362 call 363 error (linus_error_$no_max_lines, 364 "before " || tmp_char); 365 call integer_check ((char_argl.arg.arg_len (i))); 366 temp_int = fixed (tmp_char); 367 if temp_int = 0 then 368 call 369 error (linus_error_$integer_too_small, 370 "for -max LINES"); 371 constant_max_lines, max_lines = temp_int; /* Set if maximum print lines */ 372 i = i + 1; 373 if i ^> char_argl.nargs then 374 if substr (tmp_char, 1, 1) ^= "-" then 375 call 376 error (linus_error_$too_many_args, 377 "for -max LINES"); 378 i = i - 1; 379 max_seen = "1"b; 380 end; 381 end; 382 else if tmp_char = "-all" | tmp_char = "-a" then do; 383 if max_seen then 384 call error (linus_error_$incons_args, "-all and -max"); 385 max_lines = 999999999; 386 all_seen = "1"b; 387 end; 388 else if tmp_char = "-col_widths_trunc" | tmp_char = "-cwt" then do; 389 if cwt_flag then 390 call error (linus_error_$dup_ctl_args, "-col_width_trunc"); 391 if cw_flag then 392 call 393 error (linus_error_$incons_args, 394 "-col_width_trunc and -col_width"); 395 cwt_flag = "1"b; 396 call cw_specified; 397 end; 398 else if tmp_char = "-col_widths" | tmp_char = "-cw" then do; 399 if cwt_flag then 400 call 401 error (linus_error_$incons_args, 402 "-cold_width and -col_width_trunc"); 403 if cw_flag then 404 call error (linus_error_$dup_ctl_args, "-col_width"); 405 cw_flag = "1"b; 406 call cw_specified; 407 end; 408 else if tmp_char = "-no_end" | tmp_char = "-ne" then 409 print_end = "0"b; 410 else call error (linus_error_$inv_arg, tmp_char); 411 /* Print error */ 412 i = i + 1; 413 end; 414 end; 415 if ^cw_flag then /* make sure ioa control string is blank */ 416 do l = 1 to select_info.n_user_items; /* so that no scale adjustment is made */ 417 if ^(select_info.user_item.item_type (l) = EXPR | select_info.set_fn) 418 then ioars_string (l) = ""; 419 end; 420 421 call print_layout; /* Fix format for print data */ 422 if select_info.prior_sf_ptr ^= null then 423 call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode); 424 /* evaluate prior set functions */ 425 if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then 426 call error (icode, ""); 427 if select_info.set_fn then do; /* set function to be applied */ 428 call 429 linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1), 430 icode); 431 if icode = 0 then 432 call print_line; 433 end; 434 else do; 435 call linus_table$async_retrieval (lcb_ptr, icode); 436 if icode ^= 0 then 437 call error (icode, ""); 438 439 call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); 440 char_desc.arr.var (1) = addr (another_len) -> arg_len_bits.len; 441 /* Set up for additional retrievals */ 442 num_ptrs = arg_list.arg_count; 443 arg_list.arg_des_ptr (2) = addr (ANOTHER); 444 do while (icode = 0 & max_lines > line_count); 445 call print_line; 446 continue: 447 if lcb.timing_mode then 448 initial_mrds_vclock = vclock; 449 call cu_$generate_call (dsl_$retrieve, al_ptr); /* Retrieve "-another" */ 450 if lcb.timing_mode then 451 lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; 452 if constant_max_lines ^= 0 & max_lines = line_count & icode = 0 then 453 call more_response; 454 end; 455 end; 456 if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then 457 call error (icode, ""); 458 if first_retrieve then 459 call no_data; 460 if print_end then 461 call ioa_ ("(END)^/"); 462 463 exit: 464 if ca_ptr ^= null 465 then free char_argl; 466 return; 467 468 no_data: 469 proc; 470 call 471 convert_status_code_ (linus_error_$no_data, short_message, 472 long_message); 473 call ioa_$ioa_switch (iox_$user_output, "^/^a^/", long_message); 474 code = 0; 475 goto exit; 476 end no_data; 477 478 cw_specified: 479 proc; 480 481 dcl dot_flag bit (1); 482 483 out_line_index, line_buf_index = 1; 484 cw_flag = "1"b; /* Turn col_widths flag ON */ 485 do l = 1 to select_info.n_user_items; /* Initialize one_line structure */ 486 dot_flag = "0"b; /* init */ 487 i = i + 1; /* Go to next item in char_argl structure */ 488 if i > char_argl.nargs then 489 call error (linus_error_$too_few_args, "column widths"); 490 /* Input argument error */ 491 if substr (tmp_char, 1, 1) = "-" then 492 call 493 error (linus_error_$too_few_args, 494 "column widths before " || tmp_char); 495 temp = search (tmp_char, "."); /* search for user specified scale */ 496 if temp = 0 then do; 497 temp = char_argl.arg.arg_len (i); 498 if select_info.user_item.item_type (l) ^= EXPR & ^select_info.set_fn 499 then ioars_string (l) = ""; 500 end; 501 else do; 502 ioars_string (l) = 503 "^." 504 || substr (tmp_char, temp + 1, char_argl.arg.arg_len (i) - temp) 505 || "f"; 506 if verify (after (tmp_char, "."), "-0123456789") ^= 0 507 | length (after (tmp_char, ".")) > 4 508 | (index (after (tmp_char, "."), "-") ^= 0 509 & (index (substr (after (tmp_char, "."), 2), "-") ^= 0 510 | substr (after (tmp_char, "."), 1, 1) ^= "-")) then 511 call 512 error (linus_error_$non_integer, 513 "scale factor in column " || ltrim (char (l)) || " width"); 514 fix_of_scale (l) = fixed (after (tmp_char, ".")); 515 if fix_of_scale (l) < -128 | fix_of_scale (l) > 127 then 516 call 517 error (linus_error_$inv_arg, 518 "scale > 127, or < -128 in column " || ltrim (char (l)) 519 || " width"); 520 temp = temp - 1; /* number of column spaces or precision */ 521 dot_flag = "1"b; /* period found in this column specification */ 522 end; 523 call integer_check (temp); 524 out_line.item.len (l) = fixed (substr (tmp_char, 1, temp)); 525 if out_line.item.len (l) = 0 then 526 call 527 error (linus_error_$integer_too_small, 528 "column width argument " || ltrim (char (l))); 529 if dot_flag then do; 530 if select_info.user_item.item_type (l) = MRDS_ITEM then 531 temp_desc_ptr = 532 addr (select_info.user_item.item_ptr (l) -> user_item.desc); 533 else temp_desc_ptr = addr (select_info.user_item.rslt_desc (l)); 534 if ^mdbm_util_$number_data_class (temp_desc_ptr) then 535 call 536 error (linus_error_$inv_arg, 537 "scale in column " || ltrim (char (l)) 538 || " width for string data"); 539 out_line.item.len (l) = out_line.item.len (l) + 1; 540 /* for period */ 541 end; 542 out_line.item.ptr (l) = addr (out_buf (out_line_index)); 543 out_line_index = out_line_index + out_line.item.len (l); 544 out_data_len = 545 out_data_len + out_line.item.len (l) + linus_data_$print_col_spaces; 546 /* 547* Set up for output */ 548 if out_data_len > linus_data_$pr_buff_len - 1 then 549 call 550 error (linus_error_$print_buf_ovfl, 551 "column widths total > max of " 552 || ltrim (char (linus_data_$pr_buff_len - 1))); 553 end; 554 555 /* check for too many col_widths */ 556 557 i = i + 1; 558 if i ^> char_argl.nargs then 559 if substr (tmp_char, 1, 1) ^= "-" then 560 call error (linus_error_$too_many_args, tmp_char); 561 i = i - 1; 562 end cw_specified; 563 564 print_layout: 565 proc; 566 567 mrds_item_index = 0; 568 search_for_mrds_item = "0"b; 569 line_buf_index = 1; /* Init index to line buffer */ 570 do l = 1 to select_info.n_user_items; /* Find length of each item to be printed */ 571 mrds_item_index = mrds_item_index + 1; 572 one_line.item.len (l) = 0; 573 if select_info.user_item.item_type (l) = EXPR | select_info.set_fn 574 then do; 575 one_line.item.len (l) = 3; /* for F() */ 576 search_for_mrds_item = "1"b; 577 if mdbm_util_$number_data_class ( 578 addr (select_info.user_item.rslt_desc (l))) then do; 579 if cw_flag then 580 item_length = out_line.item.len (l); 581 else item_length = DEFAULT_EXPR_SIZE; 582 end; 583 else item_length = select_info.user_item.rslt_assn_len (l); 584 end; 585 else do; 586 if search_for_mrds_item then 587 do mrds_item_index = mrds_item_index 588 to select_info.n_mrds_items 589 while (select_info.user_item.item_ptr (l) 590 ^= addr (select_info.mrds_item (mrds_item_index))); 591 end; 592 call 593 calc_len ((select_info.mrds_item.desc (mrds_item_index)), 594 item_length); 595 search_for_mrds_item = "0"b; 596 end; 597 598 one_line.item.len (l) = 599 one_line.item.len (l) + length (select_info.user_item.name (l)); 600 /* Get number of characters in attribute 601* or function name */ 602 if one_line.item.len (l) < item_length then 603 one_line.item.len (l) = item_length; /* Set width of column 604* to larger of header or data */ 605 one_line.item.ptr (l) = addr (line_buf (line_buf_index)); 606 line_buf_index = line_buf_index + one_line.item.len (l); 607 prt_data_len = 608 prt_data_len + one_line.item.len (l) + linus_data_$print_col_spaces; 609 /* 610* Init for tmp_print_data */ 611 if prt_data_len > linus_data_$pr_buff_len - 1/* subtract one for newline character */ 612 then call 613 error (linus_error_$print_buf_ovfl, 614 "print line exceeds maximum length of " 615 || ltrim (char (linus_data_$pr_buff_len - 1))); 616 end; 617 end print_layout; 618 619 620 621 calc_len: 622 proc (descrip, length); 623 624 /* Calculate the length of a print field given a descriptor */ 625 626 dcl descrip bit (36); 627 dcl length fixed bin (35); 628 dcl prec_len fixed bin; 629 dcl scale_len fixed bin (11); 630 dcl fixed_bin_11_ovrly fixed bin (11) unal based; 631 632 633 desc_ptr = addr (descrip); /* Point to descriptor */ 634 prec_len = fixed (descriptor.size.precision); 635 if mdbm_util_$binary_data_class (desc_ptr) then 636 length = prec_len / 3 + 5; /* binary */ 637 else if mdbm_util_$number_data_class (desc_ptr) then 638 length = prec_len + 3; /* decimal */ 639 else if mdbm_util_$string_data_class (desc_ptr) then 640 length = fixed (descriptor.size.scale || descriptor.size.precision); 641 else length = 20; 642 if mdbm_util_$number_data_class (desc_ptr) then do; 643 if mdbm_util_$fixed_data_class (desc_ptr) then do; /* fixed */ 644 scale_len = addr (descriptor.size.scale) -> fixed_bin_11_ovrly; 645 /* get signed scale */ 646 if scale_len = 0 | (scale_len > 0 & prec_len >= scale_len) then 647 ; /* no scale_len factor */ 648 else if cw_flag & ioars_string (l) ^= "" then 649 ; /* use specified length instead */ 650 else length = length + ceil (log10 (abs (scale_len))); 651 /* largest scale will be f-128 to f+127 */ 652 end; 653 else length = length + 5; /* float */ 654 end; 655 if mdbm_util_$complex_data_class (desc_ptr) then 656 length = length * 2; 657 658 if cw_flag & ioars_string (l) ^= "" then /* length has been specified */ 659 if ^mdbm_util_$string_data_class (desc_ptr) then /* exclude string types */ 660 length = out_line.item.len (l); /* use specified length */ 661 end calc_len; 662 663 print_header: 664 proc; 665 666 dcl (type, j) fixed bin; 667 668 search_for_mrds_item, he_flag = "0"b; 669 mrds_item_index = 0; 670 do l = 1 to select_info.n_user_items; 671 mrds_item_index = mrds_item_index + 1; 672 out_item = ""; 673 item_length = length (select_info.user_item.name (l)); 674 target_ptr = out_line.item.ptr (l); 675 if select_info.user_item.item_type (l) = EXPR then do; 676 search_for_mrds_item = "1"b; /* the next data base user item will need to find desc */ 677 expr_head = "F(" || select_info.user_item.name (l) || ")"; 678 /* add F to tuple attribute */ 679 source_ptr = addr (expr_head); 680 item_length = item_length + 3; 681 end; 682 else if select_info.set_fn then 683 source_ptr = addr (select_info.user_item.name (l)); 684 else do; /* user item is selected from data base */ 685 source_ptr = addr (select_info.user_item.name (l)); 686 if search_for_mrds_item then /* the previous item was an expression */ 687 do mrds_item_index = mrds_item_index 688 to select_info.n_mrds_items 689 while (select_info.user_item.item_ptr (l) 690 ^= addr (select_info.mrds_item (mrds_item_index))); 691 end; 692 desc_ptr = addr (select_info.mrds_item.desc (mrds_item_index)); 693 search_for_mrds_item = "0"b; 694 type = descriptor.type; 695 if mdbm_util_$number_data_class (desc_ptr) & ioars_string (l) = "" 696 then 697 do j = 1 to out_line.item.len (l) - item_length; 698 target_ptr = addr (target_ptr -> offset (10)); 699 end; 700 end; 701 call 702 assign_round_ (target_ptr, target_type, item_length, source_ptr, 703 source_type, item_length); 704 end; 705 if ^cw_flag then 706 out_buf = line_buf; 707 call set_up_output; 708 call ioa_ (""); 709 call print_a_line; /* Print header */ 710 call ioa_ (""); 711 end print_header; 712 713 print_line: 714 proc; 715 716 do l = 1 to select_info.n_user_items; 717 if select_info.user_item.item_type (l) = EXPR | select_info.set_fn 718 then do; /* Evaluate expression */ 719 if ^select_info.set_fn then 720 call 721 linus_eval_expr (lcb_ptr, 722 select_info.user_item.item_ptr (l), destination_ptr, caller, 723 l, icode); 724 if icode ^= 0 then 725 call error (icode, ""); 726 picture_output = stars_var; /* init */ 727 if mdbm_util_$number_data_class ( 728 addr (select_info.user_item.rslt_desc (l))) then do; 729 /* this is really an expr 730* -- not char or string scalar function */ 731 if mdbm_util_$complex_data_class ( 732 addr (select_info.user_item.rslt_desc (l))) then do; 733 call 734 assign_round_ (expr_results_ptr, cmpx_float_dec_type, 735 float_dec_len, select_info.user_item.rslt_assn_ptr (l), 736 select_info.user_item.rslt_assn_type (l), 737 select_info.user_item.rslt_assn_len (l)); 738 call 739 ioa_$rsnnl (ioars_string (l), char_122, ioars_len, 740 expr_results); 741 end; 742 else do; 743 call 744 assign_round_ (expr_results_ptr, float_dec_type, float_dec_len, 745 select_info.user_item.rslt_assn_ptr (l), 746 select_info.user_item.rslt_assn_type (l), 747 select_info.user_item.rslt_assn_len (l)); 748 call 749 ioa_$rsnnl (ioars_string (l), char_61, ioars_len, 750 expr_results); 751 ioars_len = 752 length (before (char_61, ".")) + fix_of_scale (l) + 1; 753 end; 754 if ioars_len <= one_line.item.len (l) | cwt_flag then 755 call 756 ioa_$rsnnl (ioars_string (l), picture_output, ioars_len, 757 expr_results); 758 else /* adjust output format */ 759 if first_retrieve & ^cw_flag then do; /* adjust output format */ 760 temp = ioars_len - one_line.item.len (l); 761 prt_data_len = prt_data_len + temp; /* output buffer length */ 762 do i = l to select_info.n_user_items; 763 one_line.item.len (l) = one_line.item.len (l) + temp; 764 do j = 1 to temp while (l ^= select_info.n_user_items); 765 one_line.item.ptr (l + 1) = 766 addr (one_line.item.ptr (l + 1) -> offset (10)); 767 end; 768 end; 769 call 770 ioa_$rsnnl (ioars_string (l), picture_output, ioars_len, 771 expr_results); 772 end; 773 774 if cw_flag then 775 call overflow_check;/* check column width with data retrieved */ 776 777 end; 778 else do; /* output result of non-arithmetic scalar function */ 779 780 call 781 assign_round_ (one_line.item.ptr (l), target_type, 782 one_line.item.len (l), 783 select_info.user_item.rslt_assn_ptr (l), 784 select_info.user_item.rslt_assn_type (l), 785 select_info.user_item.rslt_assn_len (l)); 786 787 if cw_flag then 788 call overflow_check;/* check column width with data retrieved */ 789 790 end; 791 end; 792 else do; 793 user_item_ptr = select_info.user_item.item_ptr (l); 794 /* init user item structure */ 795 796 /* temp = floor (user_item.assn_type / 2); */ 797 if mdbm_util_$number_data_class (addr (user_item.desc)) 798 & ioars_string (l) ^= "" then do; /* make adjustment for specified scale */ 799 call 800 assign_round_ (expr_results_ptr, float_dec_type, float_dec_len, 801 user_item.arg_ptr, user_item.assn_type, user_item.assn_len); 802 803 call 804 ioa_$rsnnl (ioars_string (l), char_61, ioars_len, 805 expr_results); 806 ioars_len = 807 length (before (char_61, ".")) + fix_of_scale (l) + 1; 808 if ioars_len > one_line.item.len (l) & ^cwt_flag 809 /* output data does not fit 810* in the space areserved */ 811 then picture_output = stars_var; /* print asterisks */ 812 else /* prepare data for output */ 813 call 814 ioa_$rsnnl (ioars_string (l), picture_output, ioars_len, 815 expr_results); 816 end; 817 else call 818 assign_round_ (one_line.item.ptr (l), target_type, 819 one_line.item.len (l), user_item.arg_ptr, 820 user_item.assn_type, user_item.assn_len); 821 822 if cw_flag then 823 call overflow_check; 824 825 end; 826 end; 827 first_retrieve = "0"b; 828 if ^cw_flag then do; 829 out_buf = line_buf; 830 out_line = one_line; 831 end; 832 else prt_data_len = out_data_len; 833 if he_flag then do; /* print header */ 834 string (temp_buf) = string (out_buf); 835 call print_header; 836 string (out_buf) = string (temp_buf); 837 end; 838 call set_up_output; 839 call print_a_line; /* print one line of data */ 840 line_count = line_count + 1; 841 end print_line; 842 843 overflow_check: 844 proc; 845 846 847 dcl t1_char char (t1_len) based (t1_ptr); 848 dcl t1_len fixed bin (35); 849 dcl type fixed bin; 850 dcl t1_ptr ptr; 851 dcl stringsize condition; 852 853 t1_ptr = null; 854 855 if out_line.item.len (l) < one_line.item.len (l) then do; 856 t1_len = out_line.item.len (l) + 1; 857 allocate t1_char in (work_area); 858 t1_char = " "; 859 if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then 860 call 861 assign_round_ (t1_ptr, target_type, t1_len, 862 select_info.user_item.rslt_assn_ptr (l), 863 select_info.user_item.rslt_assn_type (l), 864 select_info.user_item.rslt_assn_len (l)); 865 else do; 866 on condition (stringsize) ; 867 call 868 assign_round_ (t1_ptr, target_type, t1_len, user_item.arg_ptr, 869 user_item.assn_type, user_item.assn_len); 870 revert stringsize; 871 end; 872 873 temp = one_line.item.len (l) - out_line.item.len (l); 874 user_item_ptr = select_info.user_item.item_ptr (l); 875 desc_ptr = addr (user_item.desc); 876 type = descriptor.type; 877 if mdbm_util_$string_data_class (addr (user_item.desc)) then do; 878 if substr (t1_char, t1_len) ^= " " then 879 if ^cwt_flag then 880 picture_output = stars_var; 881 out_item = substr (picture_output, 1, out_line.item.len (l)); 882 end; 883 else do; 884 if substr (picture_output, temp, 1) ^= " " then 885 if ^cwt_flag then 886 picture_output = stars_var; 887 out_item = substr (picture_output, temp + 1); 888 end; 889 end; 890 else do; 891 temp = out_line.item.len (l) - one_line.item.len (l); 892 substr (out_item, temp + 1) = picture_output; 893 end; 894 895 t1_ptr = null; 896 897 end overflow_check; 898 899 900 901 set_up_output: 902 proc; 903 904 /* Merge line_buf and output_line_buf leaving spaces between each column */ 905 906 out_line_index, output_line_buf_index = 1; /* Init */ 907 do l = 1 to out_line.num_items; /* Move data into output buffer for printing */ 908 addr (output_line_buf (output_line_buf_index)) 909 -> buffer_character_string = 910 addr (out_buf (out_line_index)) -> buffer_character_string; 911 out_line_index = out_line_index + out_line.item.len (l); 912 output_line_buf_index = 913 output_line_buf_index + out_line.item.len (l) 914 + linus_data_$print_col_spaces; 915 if output_line_buf_index > linus_data_$pr_buff_len - 1 916 /* subtract 1 for new line character */ 917 then call 918 error (linus_error_$print_buf_ovfl, 919 "print line exceeds maximum length of " 920 || ltrim (char (linus_data_$pr_buff_len - 1))); 921 end; 922 923 924 end set_up_output; 925 926 927 928 integer_check: 929 proc (no_of_intg); 930 931 dcl no_of_intg fixed bin; 932 933 /* Check for integer in char_argl */ 934 935 if verify (substr (tmp_char, 1, no_of_intg), "0123456789") ^= 0 then 936 call error (linus_error_$non_integer, ""); 937 else if no_of_intg > 9 then 938 call error (linus_error_$integer_too_large, ""); 939 940 end integer_check; 941 942 943 944 945 print_a_line: 946 proc; 947 948 dcl print_line_character_string char (prt_data_len) 949 based (addr (output_line_buf (1))); 950 dcl NEWLINE char (1) int static options (constant) init (" 951 "); 952 953 n_bytes = length (rtrim (print_line_character_string)) + 1; 954 output_line_buf (n_bytes) = NEWLINE; /* add newline character */ 955 call iox_$put_chars (iox_$user_output, prt_data_ptr, n_bytes, icode); 956 if icode ^= 0 then 957 call error (icode, ""); 958 959 num_bytes = n_bytes; 960 output_line_buf (n_bytes) = " "; 961 962 end print_a_line; 963 964 965 966 error: 967 proc (err_code, msg); 968 969 dcl err_code fixed bin (35); 970 dcl msg char (*); 971 972 if ca_ptr ^= null 973 then free char_argl; 974 call linus_convert_code (err_code, out_code, linus_data_$p_id); 975 if code = 0 976 then call ssu_$abort_line (sci_ptr, out_code, msg); 977 else call ssu_$abort_subsystem (sci_ptr, out_code, msg); 978 979 end error; 980 981 982 983 func_err: 984 proc; 985 986 987 call 988 linus_convert_code (linus_error_$func_err, out_code, linus_data_$p_id); 989 call ssu_$print_message (sci_ptr, out_code); 990 991 go to continue; 992 993 end func_err; 994 995 996 997 more_response: 998 proc; 999 dcl linus_query entry (ptr, char(*) var, char(*) var); 1000 dcl verify_more char (5) var; 1001 dcl more_test bit (1) aligned; 1002 dcl NL char(1) int static options (constant) init (" 1003 "); 1004 1005 more_test = "0"b; 1006 call linus_query (lcb_ptr, verify_more, NL||"More? "); 1007 do while (^more_test); 1008 more_test = "1"b; 1009 if verify_more = "all" | verify_more = "a" then 1010 max_lines = 999999999; 1011 else if verify_more = "yes" | verify_more = "y" then 1012 max_lines = max_lines + constant_max_lines; 1013 else if verify_more = "no" | verify_more = "n" then 1014 print_end = "0"b; /* do not print (END) */ 1015 else do; 1016 call linus_query (lcb_ptr, verify_more, "Please answer ""yes"", ""no"" or ""all""."||NL); 1017 more_test = "0"b; 1018 end; 1019 end; 1020 call ioa_ (""); 1021 end more_response; 1022 1023 end linus_print; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/14/90 0915.0 linus_print.pl1 >spec>install>1039>linus_print.pl1 105 1 07/29/86 1248.4 linus_lcb.incl.pl1 >ldd>include>linus_lcb.incl.pl1 107 2 11/23/82 1427.3 linus_char_argl.incl.pl1 >ldd>include>linus_char_argl.incl.pl1 109 3 09/16/83 1438.0 linus_select_info.incl.pl1 >ldd>include>linus_select_info.incl.pl1 111 4 03/27/82 0534.5 linus_arg_list.incl.pl1 >ldd>include>linus_arg_list.incl.pl1 113 5 10/14/83 1709.0 mdbm_arg_list.incl.pl1 >ldd>include>mdbm_arg_list.incl.pl1 115 6 10/14/83 1708.6 mdbm_descriptor.incl.pl1 >ldd>include>mdbm_descriptor.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. ANOTHER 000000 constant char(8) initial packed unaligned dcl 225 set ref 443 DEFAULT_EXPR_SIZE constant fixed bin(5,0) initial dcl 223 ref 581 EXPR constant fixed bin(2,0) initial dcl 226 ref 417 498 573 675 717 859 MRDS_ITEM constant fixed bin(17,0) initial dcl 255 ref 530 NEWLINE 010410 constant char(1) initial packed unaligned dcl 950 ref 954 NL 010410 constant char(1) initial packed unaligned dcl 1002 ref 1006 1016 STARS 010411 constant char(100) initial packed unaligned dcl 222 set ref 301 abs builtin function dcl 179 ref 650 addr builtin function dcl 179 ref 300 301 313 321 440 443 530 533 542 577 577 586 605 633 644 679 682 685 686 692 698 727 727 731 731 765 797 797 875 877 877 908 908 953 after builtin function dcl 179 ref 506 506 506 506 506 514 al_ptr 000110 automatic pointer dcl 5-13 set ref 295* 439* 442 443 449* all_seen 000377 automatic bit(1) packed unaligned dcl 252 set ref 336* 357 386* another_len 000334 automatic fixed bin(17,0) dcl 186 set ref 318* 440 arg 2 based structure array level 2 dcl 2-9 arg_count based fixed bin(17,0) level 2 packed packed unaligned dcl 5-6 ref 442 arg_des_ptr 2 based pointer array level 2 dcl 5-6 set ref 443* arg_len 4 based fixed bin(21,0) array level 3 dcl 2-9 set ref 346* 350 350 352 361 361 365 366 373 382 382 388 388 398 398 408 408 410 410 491 491 495 497 502 502 506 506 506 506 506 514 524 558 558 558 935 arg_len_bits based structure level 1 packed packed unaligned dcl 138 arg_list based structure level 1 unaligned dcl 5-6 arg_ptr based pointer level 2 in structure "user_item" dcl 131 in procedure "linus_print" set ref 799* 817* 867* arg_ptr 2 based pointer array level 3 in structure "char_argl" dcl 2-9 in procedure "linus_print" set ref 346* 350 350 352 361 361 366 373 382 382 388 388 398 398 408 408 410 491 491 495 502 506 506 506 506 506 514 524 558 558 935 arr 2 based structure array level 2 dcl 4-3 assign_round_ 000124 constant entry external dcl 286 ref 701 733 743 780 799 817 859 867 assn_len 5 based fixed bin(35,0) level 2 dcl 131 set ref 799* 817* 867* assn_type 4 based fixed bin(17,0) level 2 dcl 131 set ref 799* 817* 867* before builtin function dcl 179 ref 751 806 buffer_character_string based char packed unaligned dcl 257 set ref 908* 908 ca_ptr 000100 automatic pointer dcl 2-15 set ref 295* 340* 342 342 346 346 349 350 350 350 350 352 352 355 361 361 361 361 365 366 366 373 373 373 382 382 382 382 388 388 388 388 398 398 398 398 408 408 408 408 410 410 410 439* 463 463 488 491 491 491 491 495 495 497 502 502 502 506 506 506 506 506 506 506 506 506 506 514 514 524 524 558 558 558 558 558 558 935 935 972 972 caller 000335 automatic fixed bin(17,0) dcl 186 set ref 319* 719* ceil builtin function dcl 179 ref 650 char builtin function dcl 179 ref 506 515 525 534 548 611 915 char_122 000221 automatic char(122) packed unaligned dcl 169 set ref 738* char_61 000201 automatic char(61) packed unaligned dcl 168 set ref 748* 751 803* 806 char_argl based structure level 1 dcl 2-9 set ref 340 342 463 972 char_desc based structure level 1 dcl 4-3 char_ptr 000106 automatic pointer dcl 4-10 set ref 295* 439* 440 cleanup 000314 stack reference condition dcl 182 ref 341 cmpx_float_dec_type 000340 automatic fixed bin(17,0) dcl 186 set ref 312* 733* code 000155 automatic fixed bin(35,0) dcl 164 set ref 306* 331* 332 332* 474* 975 constant_max_lines 000157 automatic fixed bin(35,0) dcl 164 set ref 309* 371* 452 1011 convert_status_code_ 000072 constant entry external dcl 270 ref 470 copy builtin function dcl 179 ref 302 cu_$generate_call 000074 constant entry external dcl 271 ref 449 cw_flag 000124 automatic bit(1) packed unaligned dcl 145 set ref 307* 391 403 405* 415 484* 579 648 658 705 758 774 787 822 828 cwt_flag 000123 automatic bit(1) packed unaligned dcl 145 set ref 307* 389 395* 399 754 808 878 884 db_index based fixed bin(35,0) level 2 dcl 1-53 ref 323 desc 3 based bit(36) level 2 in structure "user_item" dcl 131 in procedure "linus_print" set ref 530 797 797 875 877 877 desc based bit(36) array level 3 in structure "select_info" dcl 3-5 in procedure "linus_print" set ref 592 692 desc_ptr 000114 automatic pointer dcl 6-19 set ref 313* 314 315 315 633* 634 635* 637* 639* 639 639 642* 643* 644 655* 658* 692* 694 695* 875* 876 descrip parameter bit(36) packed unaligned dcl 626 set ref 621 633 descriptor based structure level 1 unaligned dcl 6-6 destination_ptr 000146 automatic pointer initial dcl 148 set ref 148* 327* 719* dot_flag 000460 automatic bit(1) packed unaligned dcl 481 set ref 486* 521* 529 dsl_$retrieve 000120 constant entry external dcl 283 ref 449 449 e_ptr 000126 automatic pointer initial dcl 148 set ref 148* 439* err_code parameter fixed bin(35,0) dcl 969 set ref 966 974* expr_head 000365 automatic varying char(36) dcl 224 set ref 677* 679 expr_results 000161 automatic float dec(59) dcl 167 set ref 300 738* 748* 754* 769* 803* 812* expr_results_ptr 000142 automatic pointer initial dcl 148 set ref 148* 300* 733* 743* 799* fatal_func_err 000356 stack reference condition dcl 213 ref 298 first_retrieve 000121 automatic bit(1) packed unaligned dcl 145 set ref 308* 458 758 827* fix_of_scale 000364 automatic fixed bin(17,0) initial array dcl 217 set ref 217* 514* 515 515 751 806 fixed builtin function dcl 179 ref 315 366 514 524 634 639 fixed_bin_11_ovrly based fixed bin(11,0) packed unaligned dcl 630 ref 644 float_dec_59_desc 000011 constant bit(36) initial packed unaligned dcl 215 set ref 313 float_dec_len 000153 automatic fixed bin(35,0) dcl 164 set ref 315* 733* 743* 799* float_dec_type 000341 automatic fixed bin(17,0) dcl 186 set ref 314* 743* 799* function_err 000350 stack reference condition dcl 213 ref 297 he_flag 000117 automatic bit(1) packed unaligned dcl 145 set ref 308* 350* 668* 833 i 000322 automatic fixed bin(17,0) dcl 186 set ref 337* 345* 346* 346 346* 348* 349 350 350 350 350 352 352 355 360* 360 361 361 361 361 365 366 366 372* 372 373 373 373 378* 378 382 382 382 382 388 388 388 388 398 398 398 398 408 408 408 408 410 410 410 412* 412 487* 487 488 491 491 491 491 495 495 497 502 502 502 506 506 506 506 506 506 506 506 506 506 514 514 524 524 557* 557 558 558 558 558 558 558 561* 561 762* 935 935 i_o_area_ptr 64 based pointer level 2 dcl 1-53 set ref 331* 334 335 857 icode 000154 automatic fixed bin(35,0) dcl 164 set ref 306* 422* 425 425 425* 428* 431 435* 436 436* 439* 444 452 456 456 456* 719* 724 724* 955* 956 956* index builtin function dcl 179 ref 506 506 initial_mrds_vclock 000346 automatic float bin(63) dcl 211 set ref 446* 450 ioa_ 000076 constant entry external dcl 272 ref 460 708 710 1020 ioa_$ioa_switch 000100 constant entry external dcl 273 ref 473 ioa_$rsnnl 000102 constant entry external dcl 274 ref 738 748 754 769 803 812 ioars_len 000364 automatic fixed bin(17,0) dcl 221 set ref 738* 748* 751* 754 754* 760 769* 803* 806* 808 812* ioars_string 000364 automatic varying char(8) initial array dcl 219 set ref 219* 417* 498* 502* 648 658 695 738* 748* 754* 769* 797 803* 812* iox_$put_chars 000104 constant entry external dcl 275 ref 955 iox_$user_output 000010 external static pointer dcl 162 set ref 473* 955* item 2 based structure array level 2 in structure "out_line" unaligned dcl 125 in procedure "linus_print" item 2 based structure array level 2 in structure "one_line" unaligned dcl 119 in procedure "linus_print" item_length 000152 automatic fixed bin(35,0) dcl 164 set ref 579* 581* 583* 592* 602 602 673* 680* 680 695 701* 701* item_ptr based pointer array level 3 dcl 3-5 set ref 428* 530 586 686 719* 793 874 item_type based fixed bin(17,0) array level 3 dcl 3-5 ref 417 498 530 573 675 717 859 j 000323 automatic fixed bin(17,0) dcl 186 in procedure "linus_print" set ref 764* j 000511 automatic fixed bin(17,0) dcl 666 in procedure "print_header" set ref 695* l 000342 automatic fixed bin(17,0) dcl 186 set ref 415* 417 417* 485* 498 498 502 506 514 515 515 515 524 525 525 530 530 533 534 539 539 542 543 544* 570* 572 573 575 577 577 579 583 586 598 598 598 602 602 605 606 607* 648 658 658 670* 672 672 673 674 675 677 682 685 686 695 695* 716* 717 719 719* 726 726 726 727 727 731 731 733 733 733 738 743 743 743 748 751 754 754 754 754 754 760 762 763 763 764 765 765 769 769 769 769 780 780 780 780 780 793 797 803 806 808 808 808 808 812 812 812 812 817 817* 855 855 856 859 859 859 859 873 873 874 878 878 878 881 881 881 881 881 884 884 884 884 884 887 887 887 887 891 891 892 892 892 892 907* 908 908 911 912* lcb based structure level 1 dcl 1-53 lcb_ptr parameter pointer dcl 1-121 set ref 21 323 325 325* 326 327 328 331 334 335 340 422* 428* 435* 439* 446 450 450 450 719* 857 1006* 1016* len 2 based fixed bin(35,0) array level 3 in structure "out_line" dcl 125 in procedure "linus_print" set ref 524* 525 539* 539 543 544 579 658 672 695 855 856 873 881 881 887 891 892 908 908 911 912 len 0(12) based bit(24) level 2 in structure "arg_len_bits" packed packed unaligned dcl 138 in procedure "linus_print" ref 440 len 2 based fixed bin(35,0) array level 3 in structure "one_line" dcl 119 in procedure "linus_print" set ref 572* 575* 598* 598 602 602* 606 607 726 726 754 754 754 760 763* 763 769 769 780* 808 808 808 812 812 817* 855 873 878 878 881 884 884 884 887 891 892 length parameter fixed bin(35,0) dcl 627 in procedure "calc_len" set ref 621 635* 637* 639* 641* 650* 650 653* 653 655* 655 658* length builtin function dcl 179 in procedure "linus_print" ref 506 598 673 751 806 953 line_buf 000404 automatic char(1) array packed unaligned dcl 258 set ref 302* 303 605 705 829 line_buf_index 000325 automatic fixed bin(17,0) dcl 186 set ref 483* 569* 605 606* 606 line_count 000326 automatic fixed bin(17,0) dcl 186 set ref 306* 444 452 840* 840 line_ptr 000150 automatic pointer initial dcl 148 set ref 148* 295* 320* 334* 572 575 598 598 602 602 605 606 607 726 726 726 754 754 754 754 760 763 763 765 765 769 769 769 780 780 808 808 808 808 812 812 812 817 817 830 855 873 878 878 878 881 881 884 884 884 884 884 887 887 891 892 892 linus_convert_code 000126 constant entry external dcl 288 ref 974 987 linus_data_$max_user_items 000014 external static fixed bin(35,0) dcl 229 ref 217 217 219 219 linus_data_$p_id 000012 external static fixed bin(35,0) dcl 229 set ref 974* 987* linus_data_$pr_buff_len 000020 external static fixed bin(35,0) dcl 229 ref 258 259 260 261 302 548 548 611 611 915 915 linus_data_$print_col_spaces 000016 external static fixed bin(35,0) dcl 229 ref 544 607 912 linus_define_area 000122 constant entry external dcl 285 ref 331 linus_error_$dup_ctl_args 000022 external static fixed bin(35,0) dcl 229 set ref 353* 389* 403* linus_error_$func_err 000024 external static fixed bin(35,0) dcl 229 set ref 987* linus_error_$incons_args 000026 external static fixed bin(35,0) dcl 229 set ref 357* 383* 391* 399* linus_error_$integer_too_large 000034 external static fixed bin(35,0) dcl 229 set ref 937* linus_error_$integer_too_small 000030 external static fixed bin(35,0) dcl 229 set ref 367* 525* linus_error_$inv_arg 000032 external static fixed bin(35,0) dcl 229 set ref 410* 515* 534* linus_error_$no_data 000036 external static fixed bin(35,0) dcl 229 set ref 470* linus_error_$no_db 000040 external static fixed bin(35,0) dcl 229 set ref 323* linus_error_$no_max_lines 000042 external static fixed bin(35,0) dcl 229 set ref 355* 361* linus_error_$non_integer 000044 external static fixed bin(35,0) dcl 229 set ref 506* 935* linus_error_$print_buf_ovfl 000046 external static fixed bin(35,0) dcl 229 set ref 548* 611* 915* linus_error_$ret_not_valid 000050 external static fixed bin(35,0) dcl 229 set ref 329* linus_error_$too_few_args 000052 external static fixed bin(35,0) dcl 229 set ref 488* 491* linus_error_$too_many_args 000054 external static fixed bin(35,0) dcl 229 set ref 373* 558* linus_eval_expr 000066 constant entry external dcl 267 ref 719 linus_eval_set_func 000070 constant entry external dcl 269 ref 422 428 linus_query 000142 constant entry external dcl 999 ref 1006 1016 linus_retrieve 000060 constant entry external dcl 263 ref 439 linus_table$async_retrieval 000062 constant entry external dcl 264 ref 435 linus_translate_query$auto 000064 constant entry external dcl 266 ref 325 log10 builtin function dcl 179 ref 650 long_message 000260 automatic char(100) packed unaligned dcl 176 set ref 470* 473* ltrim builtin function dcl 179 ref 506 515 525 534 548 611 915 max_lines 000160 automatic fixed bin(35,0) dcl 164 set ref 309* 371* 385* 444 452 1009* 1011* 1011 max_seen 000400 automatic bit(1) packed unaligned dcl 253 set ref 336* 353 379* 383 mdbm_util_$binary_data_class 000106 constant entry external dcl 276 ref 635 mdbm_util_$complex_data_class 000110 constant entry external dcl 276 ref 655 731 mdbm_util_$fixed_data_class 000112 constant entry external dcl 276 ref 643 mdbm_util_$number_data_class 000114 constant entry external dcl 276 ref 534 577 637 642 695 727 797 mdbm_util_$string_data_class 000116 constant entry external dcl 276 ref 639 658 877 more_test 000567 automatic bit(1) dcl 1001 set ref 1005* 1007 1008* 1017* mrds_error_$tuple_not_found 000056 external static fixed bin(35,0) dcl 229 ref 425 456 mrds_item based structure array level 2 dcl 3-5 set ref 586 686 mrds_item_index 000336 automatic fixed bin(17,0) dcl 186 set ref 567* 571* 571 586* 586 586* 592 669* 671* 671 686* 686 686* 692 mrds_time 74 based float bin(63) level 2 dcl 1-53 set ref 450* 450 msg parameter char packed unaligned dcl 970 set ref 966 975* 977* n_bytes 000343 automatic fixed bin(21,0) dcl 208 set ref 953* 954 955* 959 960 n_mrds_items 16 based fixed bin(17,0) level 2 dcl 3-5 ref 586 686 n_user_items 17 based fixed bin(17,0) level 2 dcl 3-5 ref 334 334 335 335 415 485 570 670 716 762 764 name based varying char(32) array level 3 dcl 3-5 set ref 598 673 677 682 685 nargs based fixed bin(17,0) level 2 dcl 2-9 set ref 340* 342 349 355 373 463 488 558 972 nargs_init 000102 automatic fixed bin(17,0) dcl 2-16 set ref 338* 339 340 340 345 nmi_alloc 13 based fixed bin(17,0) level 2 dcl 3-5 ref 417 428 498 530 530 533 573 577 577 583 586 598 673 675 677 682 685 686 717 719 727 727 731 731 733 733 733 743 743 743 780 780 780 793 859 859 859 859 874 no_of_intg parameter fixed bin(17,0) dcl 931 ref 928 935 937 nsv_alloc 12 based fixed bin(17,0) level 2 dcl 3-5 ref 417 428 498 530 530 533 573 577 577 583 586 586 592 598 673 675 677 682 685 686 686 692 717 719 727 727 731 731 733 733 733 743 743 743 780 780 780 793 859 859 859 859 874 null builtin function dcl 179 ref 148 148 148 148 148 148 148 148 148 148 295 320 325 326 342 422 463 853 895 972 num_bytes 000344 automatic fixed bin(35,0) dcl 209 set ref 959* num_dims 000116 automatic fixed bin(17,0) initial dcl 6-20 set ref 305* 6-20* num_items based fixed bin(17,0) level 2 in structure "one_line" dcl 119 in procedure "linus_print" set ref 334* 830 num_items based fixed bin(17,0) level 2 in structure "out_line" dcl 125 in procedure "linus_print" set ref 335* 830 907 num_ptrs 000112 automatic fixed bin(17,0) dcl 5-14 set ref 442* offset based bit(1) array packed unaligned dcl 184 set ref 698 765 one_line based structure level 1 unaligned dcl 119 set ref 334 830 out_buf 000404 automatic char(1) array packed unaligned dcl 260 set ref 303* 542 705* 829* 834 836* 908 out_code 000156 automatic fixed bin(35,0) dcl 164 set ref 974* 975* 977* 987* 989* out_data_len 000330 automatic fixed bin(17,0) dcl 186 set ref 306* 544* 544 548 832 out_item based char dcl 171 set ref 672* 881* 887* 892* out_line based structure level 1 unaligned dcl 125 set ref 335 830* out_line_index 000327 automatic fixed bin(17,0) dcl 186 set ref 483* 542 543* 543 906* 908 911* 911 out_line_ptr 000130 automatic pointer initial dcl 148 set ref 148* 295* 335* 524 525 539 539 542 543 544 579 658 672 672 674 695 830 855 856 873 881 881 881 887 887 891 892 892 907 908 908 911 912 output_line_buf 000404 automatic char(1) array packed unaligned dcl 261 set ref 303* 321 908 953 954* 960* output_line_buf_index 000324 automatic fixed bin(17,0) dcl 186 set ref 906* 908 912* 912 915 picture_output based char dcl 173 set ref 726* 754* 769* 808* 812* 878* 881 884 884* 887 892 prec_len 000500 automatic fixed bin(17,0) dcl 628 set ref 634* 635 637 646 precision 0(24) based bit(12) level 3 packed packed unaligned dcl 6-6 ref 315 634 639 print_end 000120 automatic bit(1) packed unaligned dcl 145 set ref 308* 408* 460 1013* print_line_character_string based char packed unaligned dcl 948 ref 953 prior_sf_ptr 2 based pointer level 2 dcl 3-5 set ref 422 422* prt_data_len 000331 automatic fixed bin(17,0) dcl 186 set ref 306* 607* 607 611 761* 761 832* 953 prt_data_ptr 000134 automatic pointer initial dcl 148 set ref 148* 321* 955* ptr 4 based pointer array level 3 in structure "one_line" dcl 119 in procedure "linus_print" set ref 605* 726 754 765* 765 769 780* 808 812 817* 878 881 884 884 887 892 ptr 4 based pointer array level 3 in structure "out_line" dcl 125 in procedure "linus_print" set ref 542* 672 674 881 887 892 rslt_assn_len based fixed bin(35,0) array level 3 dcl 3-5 set ref 583 733* 743* 780* 859* rslt_assn_ptr based pointer array level 3 dcl 3-5 set ref 733* 743* 780* 859* rslt_assn_type based fixed bin(17,0) array level 3 dcl 3-5 set ref 733* 743* 780* 859* rslt_desc based bit(36) array level 3 dcl 3-5 set ref 533 577 577 727 727 731 731 rtrim builtin function dcl 179 ref 953 scale 0(12) based bit(12) level 3 packed packed unaligned dcl 6-6 set ref 315 639 644 scale_len 000501 automatic fixed bin(11,0) dcl 629 set ref 644* 646 646 646 650 sci_ptr parameter pointer dcl 117 set ref 21 325* 338* 346* 975* 977* 989* se_flags 0(01) based structure level 2 packed packed unaligned dcl 3-5 search builtin function dcl 179 ref 495 search_for_mrds_item 000122 automatic bit(1) packed unaligned dcl 145 set ref 568* 576* 586 595* 668* 676* 686 693* select_info based structure level 1 dcl 3-5 set_fn based bit(1) level 2 packed packed unaligned dcl 3-5 ref 417 427 498 573 682 717 719 859 short_message 000312 automatic char(8) packed unaligned dcl 177 set ref 470* si_ptr 000104 automatic pointer dcl 3-49 in procedure "linus_print" set ref 328* 329 334 334 335 335 415 417 417 422 422 427 428 485 498 498 530 530 533 570 573 573 577 577 583 586 586 586 592 598 670 673 675 677 682 682 685 686 686 686 692 716 717 717 719 719 727 727 731 731 733 733 733 743 743 743 762 764 780 780 780 793 859 859 859 859 859 874 si_ptr 34 based pointer level 2 in structure "lcb" dcl 1-53 in procedure "linus_print" ref 325 326 327 328 size 0(12) based structure level 2 packed packed unaligned dcl 6-6 source_ptr 000132 automatic pointer initial dcl 148 set ref 148* 679* 682* 685* 701* source_type 000333 automatic fixed bin(17,0) dcl 186 set ref 311* 701* ssu_$abort_line 000130 constant entry external dcl 289 ref 975 ssu_$abort_subsystem 000132 constant entry external dcl 290 ref 977 ssu_$arg_count 000134 constant entry external dcl 291 ref 338 ssu_$arg_ptr 000136 constant entry external dcl 292 ref 346 ssu_$print_message 000140 constant entry external dcl 293 ref 989 stars_ptr 000144 automatic pointer initial dcl 148 set ref 148* 301* 726 808 878 884 stars_var based char packed unaligned dcl 227 ref 726 808 878 884 static_area 144 based area level 2 dcl 1-53 ref 340 string builtin function dcl 179 set ref 302* 303 303* 303* 303* 834* 834 836* 836 stringsize 000104 stack reference condition dcl 851 ref 866 870 substr builtin function dcl 179 set ref 361 373 491 502 506 506 524 558 878 881 884 887 892* 935 t1_char based char packed unaligned dcl 847 set ref 857 858* 878 t1_len 000100 automatic fixed bin(35,0) dcl 848 set ref 856* 857 857 858 859* 867* 878 878 t1_ptr 000102 automatic pointer dcl 850 set ref 853* 857* 858 859* 867* 878 895* target_ptr 000136 automatic pointer initial dcl 148 set ref 148* 674* 698* 698 701* target_type 000332 automatic fixed bin(17,0) dcl 186 set ref 310* 701* 780* 817* 859* 867* temp 000337 automatic fixed bin(17,0) dcl 186 set ref 495* 496 497* 502 502 520* 520 523* 524 760* 761 763 764 873* 884 887 891* 892 temp_buf 000404 automatic char(1) array packed unaligned dcl 259 set ref 303* 834* 836 temp_desc_ptr 000402 automatic pointer dcl 256 set ref 530* 533* 534* temp_int 000401 automatic fixed bin(35,0) dcl 254 set ref 366* 367 371 timing_mode 15(05) based bit(1) level 2 packed packed unaligned dcl 1-53 ref 446 450 tmp_char based char packed unaligned dcl 142 set ref 350 350 352 361 361 366 373 382 382 388 388 398 398 408 408 410* 491 491 495 502 506 506 506 506 506 514 524 558 558* 935 type 0(01) based fixed bin(6,0) level 2 in structure "descriptor" packed packed unsigned unaligned dcl 6-6 in procedure "linus_print" ref 314 694 876 type 000510 automatic fixed bin(17,0) dcl 666 in procedure "print_header" set ref 694* type 000101 automatic fixed bin(17,0) dcl 849 in procedure "overflow_check" set ref 876* user_item based structure level 1 dcl 131 in procedure "linus_print" user_item based structure array level 2 in structure "select_info" dcl 3-5 in procedure "linus_print" user_item_ptr 000140 automatic pointer initial dcl 148 set ref 148* 793* 797 797 799 799 799 817 817 817 867 867 867 874* 875 877 877 val_ret 0(01) based bit(1) level 3 packed packed unaligned dcl 3-5 ref 329 var 2(12) based bit(24) array level 3 packed packed unaligned dcl 4-3 set ref 440* vclock builtin function dcl 179 ref 446 450 verify builtin function dcl 179 ref 506 935 verify_more 000564 automatic varying char(5) dcl 1000 set ref 1006* 1009 1009 1011 1011 1013 1013 1016* work_area based area dcl 284 ref 334 335 857 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. n_chars_init automatic fixed bin(17,0) dcl 4-11 nmi_init automatic fixed bin(17,0) dcl 3-48 nsv_init automatic fixed bin(17,0) dcl 3-48 nui_init automatic fixed bin(17,0) dcl 3-48 rel builtin function dcl 179 sys_info$max_seg_size external static fixed bin(35,0) dcl 229 NAMES DECLARED BY EXPLICIT CONTEXT. calc_len 004121 constant entry internal dcl 621 ref 592 continue 002146 constant label dcl 446 ref 297 991 cw_specified 002336 constant entry internal dcl 478 ref 396 406 error 007222 constant entry internal dcl 966 ref 323 329 332 353 355 357 361 367 373 383 389 391 399 403 410 425 436 456 488 491 506 515 525 534 548 558 611 724 915 935 937 956 exit 002263 constant label dcl 463 ref 475 func_err 007341 constant entry internal dcl 983 ref 298 integer_check 007056 constant entry internal dcl 928 ref 365 523 linus_print 000276 constant entry external dcl 21 more_response 007400 constant entry internal dcl 997 ref 452 no_data 002275 constant entry internal dcl 468 ref 458 overflow_check 006316 constant entry internal dcl 843 ref 774 787 822 print_a_line 007136 constant entry internal dcl 945 ref 709 839 print_header 004416 constant entry internal dcl 663 ref 835 print_layout 003534 constant entry internal dcl 564 ref 421 print_line 005021 constant entry internal dcl 713 ref 431 445 set_up_output 006726 constant entry internal dcl 901 ref 707 838 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 11274 11440 10457 11304 Length 12076 10457 144 421 615 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME linus_print 1040 external procedure is an external procedure. on unit on line 297 64 on unit on unit on line 298 88 on unit on unit on line 341 64 on unit no_data internal procedure shares stack frame of external procedure linus_print. cw_specified internal procedure shares stack frame of external procedure linus_print. print_layout internal procedure shares stack frame of external procedure linus_print. calc_len internal procedure shares stack frame of external procedure linus_print. print_header internal procedure shares stack frame of external procedure linus_print. print_line internal procedure shares stack frame of external procedure linus_print. overflow_check 96 internal procedure enables or reverts conditions. on unit on line 866 64 on unit set_up_output internal procedure shares stack frame of external procedure linus_print. integer_check internal procedure shares stack frame of external procedure linus_print. print_a_line internal procedure shares stack frame of external procedure linus_print. error 88 internal procedure is called during a stack extension. func_err internal procedure shares stack frame of on unit on line 298. more_response internal procedure shares stack frame of external procedure linus_print. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME linus_print 000100 ca_ptr linus_print 000102 nargs_init linus_print 000104 si_ptr linus_print 000106 char_ptr linus_print 000110 al_ptr linus_print 000112 num_ptrs linus_print 000114 desc_ptr linus_print 000116 num_dims linus_print 000117 he_flag linus_print 000120 print_end linus_print 000121 first_retrieve linus_print 000122 search_for_mrds_item linus_print 000123 cwt_flag linus_print 000124 cw_flag linus_print 000126 e_ptr linus_print 000130 out_line_ptr linus_print 000132 source_ptr linus_print 000134 prt_data_ptr linus_print 000136 target_ptr linus_print 000140 user_item_ptr linus_print 000142 expr_results_ptr linus_print 000144 stars_ptr linus_print 000146 destination_ptr linus_print 000150 line_ptr linus_print 000152 item_length linus_print 000153 float_dec_len linus_print 000154 icode linus_print 000155 code linus_print 000156 out_code linus_print 000157 constant_max_lines linus_print 000160 max_lines linus_print 000161 expr_results linus_print 000201 char_61 linus_print 000221 char_122 linus_print 000260 long_message linus_print 000312 short_message linus_print 000322 i linus_print 000323 j linus_print 000324 output_line_buf_index linus_print 000325 line_buf_index linus_print 000326 line_count linus_print 000327 out_line_index linus_print 000330 out_data_len linus_print 000331 prt_data_len linus_print 000332 target_type linus_print 000333 source_type linus_print 000334 another_len linus_print 000335 caller linus_print 000336 mrds_item_index linus_print 000337 temp linus_print 000340 cmpx_float_dec_type linus_print 000341 float_dec_type linus_print 000342 l linus_print 000343 n_bytes linus_print 000344 num_bytes linus_print 000346 initial_mrds_vclock linus_print 000364 ioars_len linus_print 000364 fix_of_scale linus_print 000364 ioars_string linus_print 000365 expr_head linus_print 000377 all_seen linus_print 000400 max_seen linus_print 000401 temp_int linus_print 000402 temp_desc_ptr linus_print 000404 line_buf linus_print 000404 out_buf linus_print 000404 output_line_buf linus_print 000404 temp_buf linus_print 000460 dot_flag cw_specified 000500 prec_len calc_len 000501 scale_len calc_len 000510 type print_header 000511 j print_header 000564 verify_more more_response 000567 more_test more_response overflow_check 000100 t1_len overflow_check 000101 type overflow_check 000102 t1_ptr overflow_check THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_e_as r_ne_as alloc_char_temp cat_realloc_chars call_ext_out_desc call_ext_out call_int_this_desc call_int_this return_mac fl2_to_fx1 tra_ext_1 alloc_auto_adj bound_ck_signal enable_op shorten_stack ext_entry int_entry int_entry_desc trunc_fx2 ceil_fl any_to_any_truncate_divide_fx1 log_base_10_ op_alloc_ op_freen_ vclock_mac THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. assign_round_ convert_status_code_ cu_$generate_call dsl_$retrieve ioa_ ioa_$ioa_switch ioa_$rsnnl iox_$put_chars linus_convert_code linus_define_area linus_eval_expr linus_eval_set_func linus_query linus_retrieve linus_table$async_retrieval linus_translate_query$auto mdbm_util_$binary_data_class mdbm_util_$complex_data_class mdbm_util_$fixed_data_class mdbm_util_$number_data_class mdbm_util_$string_data_class ssu_$abort_line ssu_$abort_subsystem ssu_$arg_count ssu_$arg_ptr ssu_$print_message THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. iox_$user_output linus_data_$max_user_items linus_data_$p_id linus_data_$pr_buff_len linus_data_$print_col_spaces linus_error_$dup_ctl_args linus_error_$func_err linus_error_$incons_args linus_error_$integer_too_large linus_error_$integer_too_small linus_error_$inv_arg linus_error_$no_data linus_error_$no_db linus_error_$no_max_lines linus_error_$non_integer linus_error_$print_buf_ovfl linus_error_$ret_not_valid linus_error_$too_few_args linus_error_$too_many_args mrds_error_$tuple_not_found LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 21 000272 6 20 000303 148 000304 217 000317 219 000340 258 000367 259 000376 260 000405 261 000414 738 000423 295 000425 297 000433 298 000452 300 000470 301 000472 302 000474 303 000513 305 000552 306 000555 307 000562 308 000564 309 000570 310 000573 311 000575 312 000577 313 000601 314 000603 315 000610 318 000625 319 000627 320 000631 321 000633 323 000635 325 000655 326 000675 327 000704 328 000706 329 000707 331 000727 332 000747 334 000765 335 001003 336 001021 337 001023 338 001025 339 001037 340 001041 341 001055 342 001071 344 001103 345 001104 346 001113 347 001133 348 001135 349 001137 350 001143 352 001162 353 001166 355 001207 357 001230 360 001256 361 001257 365 001322 366 001331 367 001350 371 001375 372 001400 373 001401 378 001436 379 001440 381 001442 382 001443 383 001453 385 001500 386 001502 387 001504 388 001505 389 001515 391 001542 395 001564 396 001566 397 001567 398 001570 399 001600 403 001622 405 001646 406 001650 407 001651 408 001652 410 001664 412 001704 413 001705 415 001706 417 001721 419 001752 421 001754 422 001755 425 001776 427 002017 428 002022 431 002050 433 002053 435 002054 436 002066 439 002104 440 002126 442 002131 443 002134 444 002137 445 002145 446 002146 449 002160 450 002175 452 002211 454 002221 456 002222 458 002243 460 002246 463 002263 466 002274 468 002275 470 002276 473 002311 474 002334 475 002335 478 002336 483 002337 484 002342 485 002344 486 002355 487 002356 488 002357 491 002405 495 002450 496 002471 497 002472 498 002476 500 002527 502 002530 506 002576 514 002745 515 003006 520 003076 521 003101 523 003103 524 003105 525 003131 529 003206 530 003211 533 003244 534 003251 539 003350 542 003361 543 003371 544 003377 548 003405 553 003472 557 003475 558 003476 561 003531 562 003533 564 003534 567 003535 568 003536 569 003537 570 003541 571 003551 572 003552 573 003555 575 003605 576 003610 577 003612 579 003633 581 003643 582 003645 583 003646 584 003667 586 003670 591 003736 592 003740 595 003754 598 003755 602 004004 605 004011 606 004017 607 004023 611 004031 616 004115 617 004120 621 004121 633 004123 634 004125 635 004130 637 004161 639 004202 641 004232 642 004235 643 004251 644 004265 646 004271 648 004276 650 004313 652 004332 653 004333 655 004340 658 004360 661 004415 663 004416 668 004417 669 004421 670 004422 671 004433 672 004434 673 004444 674 004467 675 004470 676 004477 677 004501 679 004535 680 004540 681 004544 682 004545 685 004554 686 004557 691 004626 692 004630 693 004642 694 004643 695 004647 698 004716 699 004722 701 004724 704 004745 705 004747 707 004774 708 004775 709 005006 710 005007 711 005020 713 005021 716 005022 717 005033 719 005064 724 005113 726 005131 727 005143 731 005200 733 005235 738 005306 741 005336 743 005337 748 005410 751 005440 754 005452 758 005520 760 005524 761 005532 762 005533 763 005543 764 005553 765 005567 767 005576 768 005600 769 005602 774 005641 777 005647 780 005650 787 005725 791 005733 793 005734 797 005741 799 005772 803 006014 806 006044 808 006056 812 006077 816 006132 817 006133 822 006160 826 006166 827 006170 828 006171 829 006173 830 006216 831 006247 832 006250 833 006252 834 006254 835 006272 836 006273 838 006311 839 006312 840 006313 841 006314 843 006315 853 006323 855 006325 856 006337 857 006343 858 006356 859 006362 866 006447 867 006464 870 006507 873 006510 874 006524 875 006545 876 006547 877 006553 878 006571 881 006625 882 006641 884 006642 887 006665 889 006700 891 006701 892 006707 895 006723 897 006725 901 006726 906 006727 907 006732 908 006741 911 006753 912 006760 915 006766 921 007052 924 007055 928 007056 935 007060 937 007115 940 007135 945 007136 953 007137 954 007154 955 007157 956 007174 959 007212 960 007214 962 007220 966 007221 972 007235 974 007247 975 007264 977 007314 979 007340 983 007341 987 007342 989 007356 991 007375 997 007400 1005 007401 1006 007402 1007 007433 1008 007436 1009 007440 1011 007455 1013 007474 1016 007510 1017 007546 1019 007550 1020 007551 1021 007562 ----------------------------------------------------------- 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