PNOTICE_linus.alm 10/27/88 1509.4r w 10/27/88 1509.4 3555 dec 1 "version 1 structure dec 2 "no. of pnotices dec 3 "no. of STIs dec 156 "lgth of all pnotices + no. of pnotices acc "Copyright, (C) Honeywell Information Systems Inc., 1988" acc "Copyright (c) 1988 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc." aci "C1LNSM0E0000" aci "C2LNSM0E0000" aci "C3LNSM0E0000" end  linus.pl1 11/20/86 1413.4r w 11/20/86 1145.0 356346 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-01-13,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Added call to ssu_$get_area and ssu_$release_area to have a general freeing area around for linus work, and renamed sfr_ptr to force_retrieve_scope_ptr. 2) change(86-01-13,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed version from 4.4. to 4.5 and removed the blast message. This new version makes the assign_values, del_scope, list_scope, list_values, open, and set_scope requests available as active requests. It also provides a new "opened_database" active request. END HISTORY COMMENTS */ linus: proc; /* DESCRIPTION: This is the top level procedure of the LINUS subsystem. This procedure does initialization, calls ssu_ to handle the request, and does termination. HISTORY: 77-04-01 J. A. Weeldreyer: Initially written. 78-11-01 J. C. C. Jagernauth: Modified to prevent quote stripping when modify is requested. 78-09-01 J. C. C. Jagernauth: Modified for MR7.0. 80-01-07 Rickie E. Brinegar: Modified to use linus_invoke$pop_all. 80-01-28 Rickie E. Brinegar: Modified to return to command level on the cleanup condition. 80-04-12 Rickie E. Brinegar: Modified to use linus_define_area instead of get_system_free_area_. 80-06-01 Jim Gray: Modified to take out free of variable in non-freeing area, and to fix quit handling so that a database open by linus, but not closed by it, would not blow linus of the water, upon quitting. 80-10-28 Rickie E. Brinegar: short name cls added to create_list. 80-10-31 Rickie E. Brinegar: short name dl added to delete. 80-11-03 Jim Gray: Modified to change delete_$ptr to hcs_$delentry_seg calls for performance. 80-11-10 Jim Gray: Modified to change delete_$path to hcs_$del_dir_tree and hcs_$delentry_file calls in order to improve performance. 81-02-03 Rickie E. Brinegar: Modified to use the corrected linus_rel_array include file. The unused declarations of delect_$(path ptr) were removed, and the rel builtin was added to the declarations. 81-02-24 Rickie E. Brinegar: Removed the linus_set entry from the declarations and set up the LINUS set request to call the linus_assign_values entry instead of the linus_set entry. This permits the set request to make use of the improvements made to the assign_values request. 81-04-10 Rickie E. Brinegar: Changed the linus version number from 2 to 3.0. 81-04-22 Rickie E. Brinegar: In one place, lcb.is_ptr (the pointer to the input stream) was being used instead of lcb.ivs_ptr (the pointer to the invoke stack). This was causing fatal process errors as pointed out in TR9545. This has now been corrected. 81-05-12 Rickie E. Brinegar: Modified the sub_error_ handler to replace "read_attr", "modify_attr", "append_tuple", and "delete_tuple" with "r", "m", "s", and "d" respectively in sub_error_info.info_string. This will keep the scope terminology in LINUS consistent. 81-07-07 Rickie E. Brinegar: Changed calls to release_area_ to calls to release_temp_segment_. This was done as a result of TR10233. LINUS and MRDS were not correctly freeing temporary segments. 81-07-13 Rickie E. Brinegar: Added a conversion condition trap. 81-09-17 Rickie E. Brinegar: Changed the checkin for a token starting with ".." to insure that the token was atleast two characters long before doing a substr. Corrected the order in which char_argl.nargs is incremented when processing the -argument control argument to increment nargs before making an assignment to the structure that depends on nargs as a limit. 81-09-28 Davids: modified the if statement that controled skipping of double quotes in the get_token proc. Also declared q_flag in that proc. This stops a subscriptrange condition from sometimes occuring. 81-11-12 Rickie E. Brinegar: Added code to keep track of and display the virtual cpu seconds used to determine what a request has been asked, how much time was spent in executing the request, broken down by how much time was spent in LINUS and how much time was spent in MRDS. 82-01-29 David J. Schimke: Added code to initialize two new variables (build_increment and build_start) in the linus control block. This is part of the implementation of the build mode for lila. 82-02-04 Paul W. Benjamin: ssu_ conversion. Roughly 25% of the code removed, the functionality being supplied by ssu_. The invoke request has been retained. The intent is to supply an exec_com request as well, but that implementation is not part of this change. 82-06-24 Al Dupuis: Added code to place sci_ptr in lcb.subsystem_control_info_ptr, and call to ssu_$get_invocation_level to stuff it in lcb.subsystem_invocation_level. 82-08-26 DJ Schimke: Added code to set report_control_info_ptr and table_control_info_ptr to null on linus initiation. Added code to tidy_up procedure to call linus_table$terminate if table_control_info_ptr is not null and to call linus_options$terminate if report_control_info_ptr is not null. 82-10-18 David J. Schimke: Added code to replace the ssu_$abort_line procedure with a linus_abort_line procedure which calls linus_convert_code before calling the standard abort_line procedure. Also fixed a bug which left the lcb lying around after linus terminated. 82-10-27 David J. Schimke: Modified the way linus controls the iteration to use the new ssu_$set_request_processor_options. Deleted the replacement procedures: execute_line, evaluate_active_string, invoke_request and unknown_request which were used to implement the original iteration control under ssu_. This also changed the way linus turned on the optional abbrev processing as this feature is also now part of the request processor options. Added code to execute a subsystem start_up exec_com using ssu_$execute_start_up. Added "-start_up", "-no_startup", "-no_start_up" and "-ns". 82-11-10 Al Dupuis: Changed linus version from 4.0 to 4.1. The major changes made from 4.0 to 4.1 were the inclusion of the report generator, the self-identify request, and the linus_abort_line procedure. 83-02-23 David J. Schimke: Deleted code in tidy_up internal procedure that tried to free the char_argl and macro_request areas after the lcb was already deleted. These were both allocated in the lcb.static area. Also deleted the timer_print call just before the linus exit, since the lcb is always gone by that time and lcb.timing_mode couldn't be checked anyway. 83-04-07 DJ Schimke: Added code to set temp_seg_info_ptr to null on linus initiation and to call linus_temp_seg_mgr$terminate in tidy_up if it is not null. 83-04-13 DJ Schimke: Added code to check icode and call com_err_ after calls to the various termination entry points so errors can be detected. 83-05-09 DJ Schimke: Added call to requote_string_ to protect command line macro arguments from quote stripping. This is in response to TR 15139. Also fixed the calls to com_err_ after termination entrys. The com_err_ calls were not in do groups so they were reporting the last error redundantly. 83-06-06 Bertley G. Moberg: Added support for -print_search_order and -no_optimize 83-06-13 Al Dupuis: Changed linus version from 4.1 to 4.2. The change made from 4.1 to 4.2 was the inclusion of the report writer display request's scrolling feature and a call to ssu_$print_blast to announce new features. 83-08-18 Al Dupuis: Changed version from 4.2 to 4.3. The chaneg made from 4.2 to 4.3 was the inclusion of new report writer features suggested by GM and Ford during the report writer controlled release exposure period. 83-08-26 Al Dupuis: Added code to get a temp segment for storing the query as it is being passed around between different requests and subroutines (i.e. qedx, print_query, save_query, linus_get_query, linus_put_query, etc. Added code to release the temp segment at termination. 83-10-03 Al Dupuis: Changed version from 4.3 to 4.4. Version 4.4 is the first version of the report writer that will go to general release, and also includes the input_query, print_query, etc. requests, as well as the write_data_file and store_from_data_file requests. 83-11-04 Al Dupuis: Rewrote the sub_error_ handler. 84-11-05 Al Dupuis: Added call to ssu_$add_request_table and ssu_$add_info_dir. */ %page; %include condition_info; %page; %include condition_info_header; %include linus_lcb; %page; %include cp_character_types; %page; %include definition; %page; %include linus_char_argl; %page; %include linus_rel_array; %page; %include object_info; %page; %include ssu_prompt_modes; %page; %include ssu_rp_options; %page; %include sub_error_info; dcl sci_ptr ptr; /* used in all ssu calls */ dcl ( i, j, nargs /* no. of args in linus command */ ) fixed bin; dcl ( acc_ptr init (null), /* pointer to acc string */ arg_ptr init (null), /* ptr to arg list to request processor */ ctl_ptr init (null), d_ptr init (null), /* pointer to a defn. block */ ent_ptr init (null), /* ptr to request processor entry */ lb_ptr init (null), /* pointer to base of linus_builtin_ */ ptr_sink init (null) /* sink for envir. ptr */ ) ptr; dcl code fixed bin (35); /* status code from subroutines */ dcl ( initial_linus_vclock, /* keep track of the initial vclock values */ initial_mrds_vclock ) float bin (63) int static; /* needs changed if linus allows recursion */ dcl ab bit (1); /* user wants abbrevs */ dcl bit18 bit (18) based; /* template */ dcl ctl_arg char (ctl_len) based (ctl_ptr); dcl ctl_len fixed bin (21); /* length of control arg */ dcl dname char (168); /* for calls to expand_pathname_ */ dcl ename char (32); /* & hcs_$initiate */ dcl function_entry entry variable; dcl function_name char (32) varying; dcl highest_numbered_subsystem_invocation fixed bin; /* for call to ssu_, unused at present */ dcl lb_bc fixed bin (24); /* bit count of builtin seg */ dcl lb_type fixed bin (2); /* seg type code for linus_builtin_ */ dcl macro_request char (macro_rq_len) based (macro_rq_ptr); /* macro request string */ dcl macro_rq_len fixed bin (21); /* length of macro request string */ dcl macro_rq_ptr ptr; /* pointer to macro request string */ dcl pf_arg_len fixed bin (21); /* length of profile arg */ dcl pf_arg_ptr ptr; /* ptr to profile arg */ dcl req_buf char (linus_data_$req_buf_len); /* the request buffer */ dcl rq_arg_len fixed bin (21); /* length of request arg */ dcl rq_arg_ptr ptr; /* ptr to request arg */ dcl start_up bit (1); /* execute start_up */ dcl lila_prompt_char char (32) varying based (lcb.lila_promp_chars_ptr); dcl 1 local_rpo aligned like rp_options; dcl ptr_desc bit (36) init ("100110100000000000000000000000000000"b); dcl fixed_bin_35_desc bit (36) init ("100000110000000000000000000000100011"b); dcl 1 obj_info aligned like object_info; dcl 1 acc aligned based (acc_ptr), /* template for acc string */ 2 len fixed bin (8) unal, 2 string char (0 refer (acc.len)) unal; dcl recursed bit (1) int static init ("0"b); /* flag to tell us if this is second time around */ dcl RW fixed bin (5) int static options (constant) init (01010b); dcl WHITESPACE_OR_QUOTE char (7) int static options (constant) init (" """); dcl LAST_POSITION_IN_THE_TABLE fixed bin internal static options (constant) init (9999); dcl my_name char (5) int static options (constant) init ("linus"); dcl ( SEG init ("011"b), TEXT init ("000"b) ) bit (3) int static options (constant); dcl ( error_table_$badopt, error_table_$inconsistent, error_table_$notadir, error_table_$noentry, linus_data_$max_range_items, linus_data_$req_buf_len, linus_data_$req_proc_id, linus_error_$abort, linus_error_$bad_builtin_obj, linus_error_$conv, linus_error_$dup_ctl_args, linus_error_$inval_ctl_arg, linus_error_$recursed, linus_error_$too_few_ctl_args, linus_rq_table_$linus_rq_table_, ssu_et_$request_line_aborted, ssu_et_$subsystem_aborted, sys_info$max_seg_size ) ext fixed bin (35); dcl ssu_info_directories_$standard_requests char (168) external; dcl ssu_request_tables_$standard_requests bit(36) aligned external; dcl iox_$user_input ptr ext static; dcl (cleanup, conversion, sub_error_) condition; dcl (addr, addrel, empty, fixed, null, ptr, rank, rel, rtrim, search, substr, vclock) builtin; /* Multics Subroutines */ dcl com_err_ entry options (variable); dcl continue_to_signal_ entry (fixed bin(35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$decode_entry_value entry (entry, ptr, ptr); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl get_pdir_ entry returns (char (168)); dcl hcs_$del_dir_tree entry (char (*), char (*), fixed bin (35)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); /* deletes segs without ref names */ dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)) ; dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl requote_string_ entry (char(*)) returns(char(*)); dcl ssu_$add_info_dir entry (ptr, char(*), fixed bin, fixed bin(35)); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin(35)); dcl ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ssu_$execute_start_up entry () options (variable); dcl ssu_$get_area entry (ptr, ptr, char(*), ptr); dcl ssu_$get_info_ptr entry (ptr) returns (ptr); dcl ssu_$get_invocation_count entry (ptr, fixed bin, fixed bin); dcl ssu_$get_procedure entry (ptr, char (*), entry, fixed bin (35)); dcl ssu_$get_request_processor_options entry (ptr, char(8), ptr, fixed bin(35)); dcl ssu_$listen entry (ptr, ptr, fixed bin (35)); dcl ssu_$print_message entry options (variable); dcl ssu_$release_area entry (ptr, ptr); dcl ssu_$set_ec_suffix entry (ptr, char (32)); dcl ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35)); dcl ssu_$set_prompt entry (ptr, char (64) varying); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl ssu_$set_request_processor_options entry (ptr, ptr, fixed bin(35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* LINUS/MRDS Subroutines */ dcl linus_abort_line entry() options(variable); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_invoke$pop_all entry (ptr, fixed bin (35)); dcl linus_invoke$pop_all_on_pi entry (ptr); dcl linus_thread_fn_list entry (ptr, entry, char (168) varying, char (32) varying, fixed bin (35)); dcl linus_builtin_ entry; dcl linus_define_area entry (ptr, char (6), fixed bin (35)); dcl linus_options$terminate entry (ptr, fixed bin (35)); dcl linus_table$terminate entry (ptr, fixed bin (35)); dcl linus_temp_seg_mgr$get_segment entry (ptr, char(*), char(*), ptr, fixed bin(35)); dcl linus_temp_seg_mgr$release_segment entry (ptr, char(*), ptr, fixed bin(35)); dcl linus_temp_seg_mgr$terminate entry (ptr, fixed bin(35)); dcl dsl_$close entry options (variable); sci_ptr = null; lcb_ptr = null; if recursed then do; /* if this is second time around */ call com_err_ (linus_error_$recursed, my_name); return; end; else do; on cleanup call tidy_up; /* so we leave no traces */ recursed = "1"b; /* remember we have arrived */ end; arg_ptr, ca_ptr, ent_ptr = null; /* initialize */ macro_rq_ptr, pf_arg_ptr, rq_arg_ptr = null; ab = "0"b; start_up = "1"b; /* execute start_up by default */ call hcs_$make_seg ("", unique_chars_ ("0"b) || ".lcb", "", RW, ptr_sink, code); /* make an LCB */ if ptr_sink = null then call error (code, "^/Creating LINUS Control Block"); ptr_sink -> lcb.linus_area_ptr, ptr_sink -> lcb.lila_area_ptr, ptr_sink -> lcb.i_o_area_ptr = null; ptr_sink -> lcb.lila_count, ptr_sink -> lcb.lila_chars, ptr_sink -> lcb.curr_lv_val_offset, ptr_sink -> lcb.curr_lit_offset, ptr_sink -> lcb.db_index = 0; /* initialize the LCB */ ptr_sink -> lcb.request_time, ptr_sink -> lcb.mrds_time = 0; ptr_sink -> lcb.prompt_flag = "1"b; /* default to prompt mode */ ptr_sink -> lcb.test_flag = "0"b; /* default is not test mode */ ptr_sink -> lcb.pso_flag = "0"b; /* default is to not print search order */ ptr_sink -> lcb.no_ot_flag = "0"b; /* default is to optimize */ ptr_sink -> lcb.cal_ptr, ptr_sink -> lcb.ttn_ptr, ptr_sink -> lcb.si_ptr, ptr_sink -> lcb.force_retrieve_scope_info_ptr, ptr_sink -> lcb.setfi_ptr, ptr_sink -> lcb.sclfi_ptr, ptr_sink -> lcb.lv_ptr, ptr_sink -> lcb.lvv_ptr, ptr_sink -> lcb.ivs_ptr, ptr_sink -> lcb.lit_ptr, ptr_sink -> lcb.liocb_ptr = null; ptr_sink -> lcb.is_ptr = iox_$user_input; /* init pointer to input stream */ ptr_sink -> lcb.rb_len = linus_data_$req_buf_len; ptr_sink -> lcb.lila_fn = ""; ptr_sink -> lcb.static_area = empty; ptr_sink -> lcb.build_increment = 10; ptr_sink -> lcb.build_start = 10; ptr_sink -> lcb.linus_version = "4.5"; /* SET LINUS VERSION */ ptr_sink -> lcb.iteration = "0"b; ptr_sink -> lcb.report_control_info_ptr = null; ptr_sink -> lcb.table_control_info_ptr = null; ptr_sink -> lcb.temp_seg_info_ptr = null; ptr_sink -> lcb.query_temp_segment_ptr = null; ptr_sink -> lcb.general_work_area_ptr = null; lcb_ptr = ptr_sink; ptr_sink = null; call ssu_$create_invocation ("linus", (lcb.linus_version), lcb_ptr, addr (linus_rq_table_$linus_rq_table_), ">doc>ss>linus", sci_ptr, code); if code ^= 0 then call error (code, ""); call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), LAST_POSITION_IN_THE_TABLE, code); if code ^= 0 then call error (code, "Unable to add the ssu_ standard requests."); call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, LAST_POSITION_IN_THE_TABLE, code); if code ^= 0 then call error (code, "Unable to add the ssu_ standard request info segs."); lcb.subsystem_control_info_ptr = sci_ptr; call ssu_$get_invocation_count (sci_ptr, lcb.subsystem_invocation_level, highest_numbered_subsystem_invocation); allocate lila_prompt_char in (lcb.static_area) set (lcb.lila_promp_chars_ptr); lila_prompt_char = "->"; num_of_rels_init = linus_data_$max_range_items; allocate linus_rel_array in (lcb.static_area); lcb.rel_array_ptr = linus_rel_array_ptr; linus_rel_array.num_of_rels = 0; call cu_$decode_entry_value (linus_builtin_, lb_ptr, ptr_sink); /* get pointer to linus_builtin_ object */ if lb_ptr ^= null then do; /* if found segment */ lb_ptr = ptr (lb_ptr, 0); /* point to base of seg */ call hcs_$status_mins (lb_ptr, lb_type, lb_bc, code); /* get bit count */ if code ^= 0 then call error (linus_error_$bad_builtin_obj, ""); call object_info_$brief (lb_ptr, lb_bc, addr (obj_info), code); /* get object data */ if code ^= 0 then call error (linus_error_$bad_builtin_obj, ""); do d_ptr = addrel (obj_info.defp, obj_info.defp -> bit18) /* search for class 3 defn for linus_builtin_ */ repeat addrel (obj_info.defp, d_ptr -> definition.value) while (addrel (obj_info.defp, d_ptr -> definition.symbol) -> acc.string ^= "linus_builtin_" & addrel (obj_info.defp, d_ptr -> definition.forward) -> bit18 ^= "0"b); end; if addrel (obj_info.defp, d_ptr -> definition.symbol) -> acc.string ^= "linus_builtin_" then call error (linus_error_$bad_builtin_obj, ""); do d_ptr = addrel (obj_info.defp, d_ptr -> definition.segname) /* look through entry points in this block */ repeat addrel (obj_info.defp, d_ptr -> definition.forward) while (d_ptr -> definition.class ^= SEG & d_ptr -> definition.forward ^= "0"b); if d_ptr -> definition.class = TEXT & ^d_ptr -> definition.flags.ignore & d_ptr -> definition.flags.entry then do; /* if external entry point */ acc_ptr = addrel (obj_info.defp, d_ptr -> definition.symbol); /* point to entry name */ if substr (acc.string, acc.len - 4, 5) = "_calc" then do; /* if calc entry */ function_name = substr (acc.string, 1, acc.len - 5); function_entry = cv_entry_ ("linus_builtin_$" || acc.string, null, code); if code ^= 0 then call error (code, "^/Converting builtin entry: " || function_name); call linus_thread_fn_list (lcb_ptr, function_entry, "linus_builtin_", function_name, code); /* thread function info into list */ if code ^= 0 then call error (code, ""); end; /* if true function entry */ end; /* if text entry */ end; /* entry point loop */ end; /* if builtin segment found */ if lcb.setfi_ptr = null then /* if did not find any builtins */ call error (linus_error_$bad_builtin_obj, ""); lcb.rb_ptr = addr (req_buf); on conversion call error (linus_error_$conv, ""); /* print error and reset for next request */ /* set up pi handler */ call ssu_$set_procedure (sci_ptr, "program_interrupt", linus_invoke$pop_all_on_pi, code); if code ^= 0 then call error (code, ""); call cu_$arg_count (nargs); /* see if we have args */ do i = 1 to nargs; call cu_$arg_ptr (i, ctl_ptr, ctl_len, code); if code ^= 0 then call error (code, ctl_arg); if ctl_arg = "-set_linus_prompt_string" | ctl_arg = "-slups" | ctl_arg = "-prompt" then do; if i >= nargs then call error (linus_error_$too_few_ctl_args, "^2/-set_linus_prompt_string requires a parameter"); i = i + 1; call cu_$arg_ptr (i, ctl_ptr, ctl_len, code); if code ^= 0 then call error (code, ctl_arg); call ssu_$set_prompt (sci_ptr, (ctl_arg)); end; else if ctl_arg = "-set_lila_prompt_string" | ctl_arg = "-slaps" then do; if i >= nargs then call error (linus_error_$too_few_ctl_args, "^2/-set_lila_prompt_string requires a parameter"); i = i + 1; call cu_$arg_ptr (i, ctl_ptr, ctl_len, code); if code ^= 0 then call error (code, ctl_arg); lila_prompt_char = ctl_arg; end; else if ctl_arg = "-no_prompt" | ctl_arg = "-npmt" then do; lcb.prompt_flag = "0"b; call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); end; else if ctl_arg = "-print_search_order" | ctl_arg = "-pso" then lcb.pso_flag = "1"b; else if ctl_arg = "-no_optimize" | ctl_arg = "-no_ot" then lcb.no_ot_flag = "1"b; else if ctl_arg = "-abbrev" | ctl_arg = "-ab" then ab = "1"b; else if ctl_arg = "-no_abbrev" | ctl_arg = "-nab" then ab = "0"b; else if ctl_arg = "-profile" | ctl_arg = "-pf" then do; if i >= nargs then call error (linus_error_$too_few_ctl_args, "^2/-profile requires a parameter"); i = i + 1; call cu_$arg_ptr (i, pf_arg_ptr, pf_arg_len, code); if code ^= 0 then call error (code, ctl_arg); ab = "1"b; end; else if ctl_arg = "-request" | ctl_arg = "-rq" then do; if ca_ptr ^= null then call error (error_table_$inconsistent, "^2/A LINUS macro cannot be specified in addition to -request."); if i >= nargs then call error (linus_error_$too_few_ctl_args, "^2/-request requires a parameter"); i = i + 1; call cu_$arg_ptr (i, rq_arg_ptr, rq_arg_len, code); if code ^= 0 then call error (code, ctl_arg); end; else if ctl_arg = "-iteration" | ctl_arg = "-it" then lcb.iteration = "1"b; else if ctl_arg = "-no_iteration" | ctl_arg = "-nit" then lcb.iteration = "0"b; else if ctl_arg = "-start_up" | ctl_arg = "-su" then start_up = "1"b; else if ctl_arg = "-no_startup" | ctl_arg = "-no_start_up" | ctl_arg = "-ns" | ctl_arg = "-nsu" then start_up = "0"b; else if ctl_arg = "-arguments" | ctl_arg = "-ag" then do; if ca_ptr = null then call error (linus_error_$inval_ctl_arg, "^2/A macro_name must be given before the -arguments control argument is vaild." ); if i >= nargs then call error (linus_error_$too_few_ctl_args, "^2/-arguments requires at least one parameter"); i = i + 1; j = 2; do while (i ^> nargs); char_argl.nargs = char_argl.nargs + 1; call cu_$arg_ptr (i, char_argl.arg.arg_ptr (j), char_argl.arg.arg_len (j), code); /* put arg info into structure */ if code ^= 0 then call error (code, "macro argument"); i = i + 1; j = j + 1; end; end; else if substr (ctl_arg, 1, 1) ^= "-" then do; if ca_ptr ^= null then call error (linus_error_$dup_ctl_args, "^2/Only one macro path may be given: " || ctl_arg); if rq_arg_ptr ^= null then call error (error_table_$inconsistent, "^2/A LINUS macro cannot be specified in addition to -request."); nargs_init = nargs - i + 1; if nargs_init > 1 then nargs_init = nargs_init - 1; allocate char_argl in (lcb.static_area); char_argl.nargs = 1; char_argl.arg.arg_ptr (1) = ctl_ptr; char_argl.arg.arg_len (1) = ctl_len; end; else call error (error_table_$badopt, ctl_arg); end; /* if macro args */ call ssu_$set_ec_suffix (sci_ptr, "lec"); /* setup for exec_coms */ /* The pre_request_line and post_request_line procedures may be replaced for timing mode where we have pre- and post- request procedures. The procedures that we will replace them with are in this module and we need to get the default procedures because they will be used when timing is turned off.*/ call ssu_$get_procedure (sci_ptr, "pre_request_line", lcb.ssu_pre_request_line, code); if code ^= 0 then call error (code, ""); call ssu_$get_procedure (sci_ptr, "post_request_line", lcb.ssu_post_request_line, code); if code ^= 0 then call error (code, ""); /* Setup linus_abort_line as replacement for the standard abort_line. Save the abort_line procedure, first, because linus_abort_line will call the standard ssu_abort_line. */ call ssu_$get_procedure (sci_ptr, "abort_line", lcb.ssu_abort_line, code); if code ^= 0 then call error (code, ""); call ssu_$set_procedure (sci_ptr, "abort_line", linus_abort_line, code); if code ^= 0 then call error (code, ""); /* Get the request_processor options so we can set up for abbrev processing and iteration. Linus iteration is off by default but ssu_ defaults to on. */ call ssu_$get_request_processor_options (sci_ptr, RP_OPTIONS_VERSION_1, addr(local_rpo), code); if code ^= 0 then call error (code, ""); if ^lcb.iteration /* don't interpret parens */ then do; /* as causing iteration */ local_rpo.language_info.non_standard_language = "1"b; local_rpo.language_info.character_types (rank ("(")) = NORMAL_CHARACTER; local_rpo.language_info.character_types (rank (")")) = NORMAL_CHARACTER; end; if ab = "1"b /* user wants abbrevs */ then do; if pf_arg_ptr ^= null /* user specified a profile */ then do; ctl_len = pf_arg_len; ctl_ptr = pf_arg_ptr; call expand_pathname_$add_suffix (ctl_arg, "profile", dname, ename, code); if code ^= 0 then call error (code, ctl_arg); call hcs_$initiate (dname, ename, "", 0, 0, local_rpo.abbrev_info.default_profile_ptr, code); if local_rpo.abbrev_info.default_profile_ptr = null then call error (code, rtrim (dname) || ">" || ename); end; local_rpo.abbrev_info.expand_request_lines = "1"b; end; call ssu_$set_request_processor_options (sci_ptr, addr(local_rpo), code); if code ^= 0 then call error (code, ""); if ca_ptr ^= null then do; /* macro given */ macro_rq_len = 6 + char_argl.nargs; do i = 1 to char_argl.nargs; macro_rq_len = macro_rq_len + char_argl.arg.arg_len (i) + 1; end; macro_rq_len = macro_rq_len * 2 +2; /* allow room for requoting */ allocate macro_request in (lcb.static_area); macro_request = "invoke"; do i = 1 to char_argl.nargs; ctl_ptr = char_argl.arg.arg_ptr (i); ctl_len = char_argl.arg.arg_len (i); if ctl_len = 0 then macro_request = rtrim(macro_request) || " """""; else if search (ctl_arg, WHITESPACE_OR_QUOTE) ^= 0 then call requote_arg (ctl_arg); else macro_request = rtrim(macro_request) || " " || ctl_arg; end; free char_argl; call ssu_$execute_line (sci_ptr, macro_rq_ptr, macro_rq_len, code); /* set up to take input from macro */ free macro_request; if code = ssu_et_$subsystem_aborted then do; call tidy_up; goto exit; end; else if code ^= 0 & code ^= ssu_et_$request_line_aborted then do; call error (linus_error_$abort, ""); return; end; end; on sub_error_ call sub_error_handler; call linus_define_area (lcb.lila_area_ptr, "LILA", code); if code ^= 0 then call error (code, ""); call linus_define_area (lcb.linus_area_ptr, "LINUS", code); if code ^= 0 then call error (code, ""); call linus_temp_seg_mgr$get_segment (lcb_ptr, "LINUS", "", lcb.query_temp_segment_ptr, code); if code ^= 0 then call error (code, "^/While trying to aquire a temp segment for the query."); call ssu_$get_area (sci_ptr, null, "general use area", lcb.general_work_area_ptr); if start_up then do; call ssu_$execute_start_up (sci_ptr, code); if code ^= 0 & code ^= error_table_$noentry then call error (code, "While executing start_up"); end; initial_linus_vclock = vclock; lcb.request_time, lcb.mrds_time = 0; if rq_arg_ptr ^= null /* execute the -rq stuff */ then do; call ssu_$execute_line (sci_ptr, rq_arg_ptr, rq_arg_len, code); if code = ssu_et_$subsystem_aborted then do; call tidy_up; goto exit; end; else if code ^= 0 /* nonfatal */ then call ssu_$print_message (sci_ptr, code); end; listen: call ssu_$listen (sci_ptr, iox_$user_input, code); if code ^= ssu_et_$subsystem_aborted then call error (linus_error_$abort, ""); /* if fatal error in handler */ call tidy_up; exit: return; timer_print: proc; call ioa_ ("^/LINUS time^13t= ^10.3f" || "^/MRDS time^13t= ^10.3f" || "^/Total time^13t= ^10.3f^/", lcb.request_time / 1000000, lcb.mrds_time / 1000000, (lcb.request_time + lcb.mrds_time) / 1000000); lcb.request_time, lcb.mrds_time = 0; end timer_print; tidy_up: proc; /* Procedure to clean up loose ends */ dcl icode fixed bin (35); dcl temp_index fixed bin (35); /* temp storage for database index */ if lcb.general_work_area_ptr ^= null then call ssu_$release_area (sci_ptr, lcb.general_work_area_ptr); if sci_ptr ^= null /* if there is an ssu_ invocation */ then call ssu_$destroy_invocation (sci_ptr); if lcb_ptr ^= null then do; /* if we have a LCB */ if lcb.is_ptr ^= iox_$user_input then do; /* if we were in macro */ lcb.prompt_flag = "0"b; /* make sure pop doesn't try and call ssu_! */ call linus_invoke$pop_all (lcb_ptr, icode); end; if lcb.db_index ^= 0 then do; /* if a data base open, close it */ temp_index = lcb.db_index; lcb.db_index = 0; on sub_error_ ; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$close (temp_index, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; revert sub_error_; end; if lcb.liocb_ptr ^= null then do; /* clean up the lila file */ call iox_$close (lcb.liocb_ptr, icode); call iox_$detach_iocb (lcb.liocb_ptr, icode); call iox_$destroy_iocb (lcb.liocb_ptr, icode); lcb.liocb_ptr = null; call hcs_$del_dir_tree (get_pdir_ (), lcb.lila_fn, icode); if icode = error_table_$notadir | icode = 0 then call hcs_$delentry_file (get_pdir_ (), lcb.lila_fn, icode); end; /* cleaning up lila file */ if lcb.linus_area_ptr ^= null then do; call release_temp_segment_ ("LINUS.LINUS.area", lcb.linus_area_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); lcb.linus_area_ptr = null; end; if lcb.lila_area_ptr ^= null then do; call release_temp_segment_ ("LINUS.LILA.area", lcb.lila_area_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); lcb.lila_area_ptr = null; end; if lcb.i_o_area_ptr ^= null then do; call release_temp_segment_ ("LINUS.I_O_.area", lcb.i_o_area_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); lcb.i_o_area_ptr = null; end; if lcb.table_control_info_ptr ^= null then do; call linus_table$terminate (lcb_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); end; if lcb.report_control_info_ptr ^= null then do; call linus_options$terminate (lcb_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); end; if lcb.query_temp_segment_ptr ^= null then do; call linus_temp_seg_mgr$release_segment (lcb_ptr, "LINUS", lcb.query_temp_segment_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); else; end; if lcb.temp_seg_info_ptr ^= null then do; call linus_temp_seg_mgr$terminate (lcb_ptr, icode); if icode ^= 0 then call com_err_ (icode, my_name); end; if lcb_ptr ^= null then do; call hcs_$delentry_seg (lcb_ptr, icode); /* delete the LCB */ if icode ^= 0 then call com_err_ (icode, my_name); lcb_ptr = null; end; else if ptr_sink ^= null then do; call hcs_$delentry_seg (ptr_sink, icode); if icode ^= 0 then call com_err_ (icode, my_name); ptr_sink = null; end; end; /* if we had an LCB */ recursed = "0"b; /* so we can be called again */ end tidy_up; error: proc (icode, msg_str); /* Error procedure, prints a message and cleans up */ dcl (icode, user_code) fixed bin (35); dcl msg_str char (*); call linus_convert_code (icode, user_code, linus_data_$req_proc_id); call com_err_ (user_code, my_name, msg_str); call tidy_up; go to exit; end error; requote_arg: proc(arg); dcl arg char(*) parm; macro_request = rtrim(macro_request) || " " || requote_string_(arg); end requote_arg; %page; sub_error_handler: proc; %skip(1); /* Find the sub_error_info structure and if it wasn't mrds that signalled it then continue to signal. Change appropriate mrds_error_ codes to linus_error_ codes and print the message. Do a non-local goto so the current request will have its cleanup handler invoked but won't print the error message we just printed. */ %skip(1); dcl 1 local_condition_info like condition_info; dcl seh_code fixed bin (35); %skip(1); condition_info_ptr = addr (local_condition_info); condition_info.version = condition_info_version_1; call find_condition_info_ (null (), condition_info_ptr, seh_code); if seh_code ^= 0 then do; call tidy_up; goto exit; end; %skip(1); sub_error_info_ptr = condition_info.info_ptr; if substr (sub_error_info.name, 1, 9) ^= "mrds_dsl_" & substr (sub_error_info.name, 1, 3) ^= "mu_" & substr (sub_error_info.name, 1, 4) ^= "mus_" then do; call continue_to_signal_ (seh_code); return; end; %skip(1); call linus_convert_code (sub_error_info.header.status_code, seh_code, linus_data_$req_proc_id); call ssu_$print_message (sci_ptr, seh_code, sub_error_info.header.info_string); %skip(1); goto listen; %skip(1); end sub_error_handler; pre_request_line: entry (bv_sci_ptr); /* This procedure is called prior to the execution of a request line. If the user has enabled timing mode, it initializes some timers and returns. */ dcl bv_sci_ptr ptr parameter; lcb_ptr = ssu_$get_info_ptr (bv_sci_ptr); if ^lcb.timing_mode then return; lcb.mrds_time = 0; initial_linus_vclock = vclock; return; post_request_line: entry (bv_sci_ptr); /* This procedure is called after a request line has been executed. If the user has timing mode on, it diddles some timers, prints some statistics and returns. */ lcb_ptr = ssu_$get_info_ptr (bv_sci_ptr); if ^lcb.timing_mode then return; if lcb.request_time = -1 /* user just turned on timing */ then do; lcb.request_time = 0; return; end; lcb.request_time = vclock - initial_linus_vclock - lcb.mrds_time; call timer_print; return; end linus;  linus_abort_line.pl1 10/24/88 1647.7r w 10/24/88 1400.4 46359 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_abort_line: proc () options (variable); /* This module replaces the standard ssu_$abort_line called from linus modules. It calls linus_convert_code to change appropriate error_codes to more meaningful linus error_codes and then calls ssu_$error_ with the new code. This allows the linus modules to simple call abort_line and any conversion can be done here. Known Bugs: Other Problems: History: Written - 08/19/82 - Dave Schimke */ %page; call cu_$arg_count (arg_count); if arg_count = 0 then do; /* there must be arguments */ RESIGNAL_NULL_POINTER: call sub_err_ (error_table_$null_info_ptr, "linus_abort_line", CANT_RESTART, null (), (0), "sci_ptr"); go to RESIGNAL_NULL_POINTER; end; call cu_$arg_list_ptr (arg_list_ptr); /* Get the sci_ptr, first argument */ call cu_$arg_ptr (1, arg_ptr, (0), (0)); call decode_descriptor_ (arg_list_ptr, 1, arg_type, arg_packed, arg_ndims, arg_size, arg_scale); if (arg_type ^= pointer_dtype) | (arg_packed ^= "0"b) | (arg_ndims ^= 0) then go to RESIGNAL_NULL_POINTER; /* not a pointer */ sci_ptr = arg_ptr -> based_pointer; /* got it */ lcb_ptr = ssu_$get_info_ptr (sci_ptr); if arg_count < 2 then /* no error code given */ goto EXIT; /* Pick up the error code argument */ call cu_$arg_ptr (2, arg_ptr, (0), (0)); call decode_descriptor_ (arg_list_ptr, 2, arg_type, arg_packed, arg_ndims, arg_size, arg_scale); if (arg_type = real_fix_bin_1_dtype) & (arg_packed = "0"b) then error_code = arg_ptr -> based_fb35; /* caller's code is a single-word fixed binary value */ else do; /* caller's code is something else: try to convert it */ if (arg_type >= bit_dtype) & (arg_type <= varying_char_dtype) then from_size = arg_size; else from_size = (262144 * arg_scale) + arg_size; to_size = 35; /* target is fixed binary (35) */ call assign_ (arg_ptr, (2 * arg_type + binary (arg_packed, 1)), from_size, addr (error_code), (2 * real_fix_bin_1_dtype), to_size); end; /* linus error code conversion */ if (error_code ^= 0) then do; call linus_convert_code (error_code, user_code, linus_data_$p_id); if error_code ^= user_code /* need to make new arg_list */ then do; arg_list_arg_count = arg_count; allocate arg_list set (new_arg_list_ptr); new_arg_list_ptr -> arg_list = arg_list_ptr -> old_arg_list; new_arg_list_ptr -> arg_list.arg_ptrs(2) = addr(user_code); arg_list_ptr = new_arg_list_ptr; end; end; EXIT: call cu_$generate_call (lcb.ssu_abort_line, arg_list_ptr); return; %page; dcl 1 old_arg_list like arg_list based (arg_list_ptr); dcl CANT_RESTART character (1) static options (constant) initial ("s"); dcl (new_arg_list_ptr, arg_list_ptr, arg_ptr) pointer; dcl arg_count fixed binary; dcl arg_list_arg_count fixed bin; dcl arg_type fixed binary; dcl arg_packed bit (1) aligned; dcl arg_ndims fixed binary; dcl arg_size fixed binary; dcl arg_scale fixed binary; dcl based_fb35 fixed binary (35) aligned based; dcl based_pointer pointer aligned based; dcl error_code fixed binary (35); dcl (from_size, to_size) fixed bin (35); dcl sci_ptr ptr; dcl user_code fixed binary (35); /* Entries */ dcl assign_ entry (pointer, fixed binary, fixed binary (35), pointer, fixed binary, fixed binary (35)); dcl cu_$arg_count entry (fixed binary); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl cu_$arg_list_ptr entry (pointer); dcl cu_$generate_call entry (entry, ptr); dcl decode_descriptor_ entry (pointer, fixed binary, fixed binary, bit (1) aligned, fixed binary, fixed binary, fixed binary); dcl error_table_$null_info_ptr fixed bin(35) ext static; dcl linus_convert_code entry (fixed bin(35), fixed bin(35), fixed bin(35)); dcl linus_data_$p_id fixed bin (35); dcl ssu_$get_info_ptr entry (ptr) returns(ptr); dcl sub_err_ entry() options(variable); dcl sys_info$max_seg_size fixed bin(35) ext static; dcl (addr, binary, fixed, null, rel) builtin; /* */ %page; %include arg_list; %page; %include std_descriptor_types; %page; %include linus_lcb; end linus_abort_line;  linus_assign_data.pl1 09/16/83 1805.4rew 09/16/83 1739.3 22320 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_assign_data: proc (desc, type, length); /* DESCRIPTION: This procedure returns the assign_ type code and length, given a descriptor. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 80-01-07 Rickie E. Brinegar: Modified to use mdbm_util_$string_data_class to determine which algorithm to use for the descriptor length. 80-06-24 Jim Gray : Modified to correctly extract negative scale factors from the descriptor. */ %include mdbm_descriptor; dcl ( a_len_ptr init (null), fbl_ptr init (null) ) ptr; dcl desc bit (36); dcl type fixed bin; dcl length fixed bin (35); dcl fixed_bin_11_ovrly fixed bin (11) unal based; dcl 1 arith_len aligned based (a_len_ptr), 2 scale fixed bin (17) unal, 2 prec fixed bin (17) unal; dcl 1 fb_len unal based (fbl_ptr), 2 q fixed bin (11) unal, 2 p fixed bin (11) unal; dcl (addr, fixed, null, string, substr) builtin; dcl mdbm_util_$string_data_class entry (ptr) returns (bit (1)); a_len_ptr = addr (length); /* initialize */ num_dims = 0; desc_ptr = addr (desc); type = 2 * descriptor.type + fixed (descriptor.packed); if ^mdbm_util_$string_data_class (desc_ptr) then do; fbl_ptr = addr (descriptor.size); arith_len.scale = addr (descriptor.size.scale) -> fixed_bin_11_ovrly; arith_len.prec = fixed (descriptor.size.precision); end; else length = fixed (string (descriptor.size)); /* if string data */ return; end linus_assign_data;  linus_assign_values.pl1 07/29/86 1045.3rew 07/29/86 0936.7 142506 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-04-02,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed to also work as an active request. Returns true if a value was retrieved, and false if one wasn't. END HISTORY COMMENTS */ linus_assign_values: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: Retrieved data are assigned to LINUS variables specified in the assign_values request. This capability allows information obtained from one retrieval to be used in subsequent data base accesses. The LINUS variables can also be passed as arguments to LINUS macros. HISTORY: 77-05-01 J. C. C. Jagernauth: Initially written. 80-01-09 Rickie E. Brinegar: Modified to pass linus_lila_alloc_lit a descriptor pointer instead of an assign_ descriptor type and eliminate the assign_ length parameter. 80-02-01 Rickie E. Brinegar: Renamed from linus_set. This was done to remove confusion with set functions and mathmatical sets. 80-02-15 Rickie E. Brinegar: Modified to use only one variable slot for set functions, instead of two. 80-07-07 Rickie E. Brinegar: Modified to check the number of variables slots already used instead just using the next slot. This was done to insure that we don't write all over ourselves. 81-01-15 Rickie E. Brinegar: Modified to not use the slot of the twentieth variable to allocate all variables after the twentieth variable is allocated. This involved changing the statement variables.var_info.name (variables.nvars) to be variables.var_info.name (j) instead. 81-02-09 Rickie E. Brinegar: Deleted lines containing variables.var_info.name (j) = temp_char, replacing them in check_linvar, the variables name manager. This was pointed out by TR9104. 81-02-10 Rickie E. Brinegar: Modified to properly use all variables until there are no more values to be assigned. This routine will be exited normally when 1) all of the variable names supplied are used up or 2) when there are no more tuples to be retrieved. This was the result of TR9101. 81-02-13 Rickie E. Brinegar: Modified to allocate bit arrays for each variable that a value is assigned to, and to free and reallocate those bit arrays when the descriptor of a new value does not match the descriptor of the value already assigned to that value. Also changed the call to assign_ to be straight assignments between two bit arrays. This work was done as a result of TR9103. 81-02-17 Rickie E. Brinegar: Added code to change varying strings to fixed strings the exact size being used. This is in response to TR9105. 81-06-25 Rickie E. Brinegar: Modified to set variables.var_info.assn_len from user_item.assn_len for non varying strings. 81-07-13 Rickie E. Brinegar: Removed trapping of the conversion condition. This has been relegated to the linus module. 81-09-21 Rickie E. Brinegar: Changed the assignment of num_ptrs to itself to an assignment of arg_list.arg_count to num_ptrs. This will eliminate subscript range conditions. 82-02-09 Paul W. Benjamin: ssu_ conversion 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the first retrieve to keep linus_table from getting lost when loading in the incremental mode. 83-08-30 Bert Moberg: Added call to linus_translate_query if no current select expression is available */ %include linus_lcb; %page; %include linus_arg_list; %page; %include linus_char_argl; %page; %include linus_select_info; %page; %include linus_variables; %page; %include mdbm_arg_list; %page; %include mdbm_descriptor; dcl sci_ptr ptr; /* for ssu_ */ dcl 1 char_descriptor based, 2 version bit (1) unal, 2 type unsigned fixed bin (6) unal, 2 packed bit (1) unal, 2 number_dims bit (4) unal, 2 length bit (24) unal; dcl 1 user_item aligned based (user_item_ptr), 2 arg_ptr ptr, 2 bit_len fixed bin (35), 2 desc bit (36), 2 assn_type fixed bin, 2 assn_len fixed bin (35); dcl EXPR fixed bin (2) int static options (constant) init (2); dcl cleanup condition; dcl first_char char (1) based (char_argl.arg.arg_ptr (k)); dcl temp_char char (char_argl.arg.arg_len (k)) based (char_argl.arg.arg_ptr (k)); dcl allocated bit (1); dcl active_request_flag bit (1) aligned; dcl first_tuple_retrieved bit (1) aligned; dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; dcl bit_array bit (variables.var_info (j).bit_len) based; dcl (caller, i, j, k) fixed bin; dcl temp_len fixed bin (23) unal; dcl (code, icode, out_code) fixed bin (35); dcl (addr, addrel, fixed, index, null, rel, substr, unspec) builtin; dcl varying_length fixed bin (35) based; dcl offset (10) bit (1) based; dcl ( e_ptr init (null), destination_ptr init (null), user_item_ptr init (null) ) ptr; dcl ( linus_data_$av_id, linus_data_$max_lvars, linus_error_$inv_lin_var, linus_error_$inv_linus_var, linus_error_$long_lv_name, linus_error_$no_db, linus_error_$no_var_list, linus_error_$ret_not_valid, linus_error_$var_stck_ovrflw, mrds_data_$max_id_len, mrds_error_$tuple_not_found, sys_info$max_seg_size ) fixed bin (35) ext; dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); dcl linus_retrieve entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_table$async_retrieval entry (ptr, fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl mdbm_util_$bit_data_class entry (ptr) returns (bit (1)); dcl mdbm_util_$get_data_bit_length entry (bit (36)) returns (fixed bin (35)); dcl mdbm_util_$varying_data_class entry (ptr) returns (bit (1)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); al_ptr, ca_ptr, char_ptr = null; caller = 1; /* for expression evaluator */ destination_ptr = lcb.si_ptr; /* for expression evaluator */ icode, code = 0; lv_ptr = lcb.lv_ptr; /* Init */ first_tuple_retrieved = "0"b; if lcb.db_index = 0 then call error (linus_error_$no_db, ""); call ssu_$return_arg (sci_ptr, nargs_init, active_request_flag, return_value_ptr, return_value_length); if active_request_flag then return_value = "false"; if nargs_init = 0 then call error (linus_error_$no_var_list, ""); allocate char_argl in (lcb.static_area); on cleanup begin; if ca_ptr ^= null then free char_argl; end; do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; do k = 1 to char_argl.nargs; /* Make sure that all linus variables begin with ! */ if index (substr (temp_char, 2), "!") ^= 0 then call error (linus_error_$inv_lin_var, temp_char); if first_char ^= "!" then call error (linus_error_$inv_linus_var, temp_char); char_argl.arg.arg_ptr (k) = addr (char_argl.arg.arg_ptr (k) -> offset (10)); /* skip ! */ char_argl.arg.arg_len (k) = char_argl.arg.arg_len (k) - 1; if char_argl.arg.arg_len (k) > mrds_data_$max_id_len then call error (linus_error_$long_lv_name, temp_char); end; if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ si_ptr = lcb.si_ptr; if ^select_info.se_flags.val_ret then call error (linus_error_$ret_not_valid, ""); /* valid for retrieve ? */ if lv_ptr = null then do; /* Make sure space has not already been allocated for linus variables */ nvars_init = linus_data_$max_lvars; /* Allocate space for maximum number of linus variables */ allocate variables in (lcb.static_area);/* Linus variables */ lcb.lv_ptr = lv_ptr; variables.nvars = 0; /* Initialize count of linus variables */ end; if select_info.prior_sf_ptr ^= null then call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode); if icode ^= 0 then call error (icode, ""); if select_info.set_fn then call apply_set_function; else do; call linus_table$async_retrieval (lcb_ptr, icode); if icode ^= 0 then call error (icode, ""); call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); /* Access data base */ end; /* Update linus variables structure */ if al_ptr ^= null then num_ptrs = arg_list.arg_count; if icode ^= 0 then call error (icode, ""); /* 81-02-10 Rickie E. Brinegar: code added */ first_tuple_retrieved = "1"b; k = 1; /* 81-02-10 Rickie E. Brinegar: added */ do while (icode = 0 & k ^> char_argl.nargs); /* 81-02-10 Rickie E. Brinegar: added While we have variable names left, continue to assign values if no error is encountered */ do i = 1 to select_info.n_user_items while (icode = 0 & k ^> char_argl.nargs); /* 81-02-10 Rickie E. Brinegar char_argl.nargs <= select_info.n_user_items & removed from the while clause. changed char_argl.nargs to select_info.n_user_items in the to clause. */ call check_linvars; /* check for previously defined linus variables */ if select_info.user_item.item_type (i) = EXPR | select_info.set_fn then do; if ^select_info.set_fn then call linus_eval_expr (lcb_ptr, select_info.user_item.item_ptr (i), destination_ptr, caller, i, icode); if icode = 0 then call assign_expr_lit; end; else do; user_item_ptr = select_info.user_item.item_ptr (i); if allocated & variables.var_info (j).desc ^= user_item.desc then do; free variables.var_info (j).var_ptr -> bit_array; allocated = "0"b; end; if ^allocated then do; variables.var_info.desc (j) = user_item.desc; call allocate_lit; end; if mdbm_util_$varying_data_class (addr (user_item.desc)) then unspec (variables.var_info (j).var_ptr -> bit_array) = unspec (addrel (user_item.arg_ptr, 1) -> bit_array); else unspec (variables.var_info (j).var_ptr -> bit_array) = unspec (user_item.arg_ptr -> bit_array); end; if icode = 0 then if select_info.set_fn then do; k = char_argl.nargs + 1; /* set up termination of the loop */ i = select_info.n_user_items + 1; icode = mrds_error_$tuple_not_found; end; else k = k + 1; end; if icode = 0 then call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); /* get next set of values */ end; if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then call error (icode, ""); else if active_request_flag then return_value = "true"; FINISH: return; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); if ca_ptr ^= null then free char_argl; if active_request_flag & ^first_tuple_retrieved & err_code = mrds_error_$tuple_not_found then goto FINISH; call linus_convert_code (err_code, out_code, linus_data_$av_id); /* Convert system error code */ call ssu_$abort_line (sci_ptr, out_code); end error; check_linvars: proc; allocated = "0"b; if variables.nvars > 0 then do; /* check for previously defined LINUS VARIABLES */ do j = 1 to variables.nvars while (variables.var_info.name (j) ^= temp_char); end; if j > variables.nvars_alloc then call error (linus_error_$var_stck_ovrflw, "linus_assign_values"); else if j > variables.nvars then do; /* find linus var or bump count */ variables.nvars = variables.nvars + 1; j = variables.nvars; variables.var_info.name (j) = temp_char; end; else allocated = "1"b; end; else do; j, variables.nvars = 1; variables.var_info.name (j) = temp_char; end; end check_linvars; apply_set_function: proc; call linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1), icode); if icode ^= 0 then call error (icode, ""); i, /* result is in first select info user item */ k = 1; /* only the first variable will be assigned */ call check_linvars; call assign_expr_lit; end apply_set_function; assign_expr_lit: proc; if allocated & variables.var_info (j).desc ^= select_info.user_item (i).rslt_desc then do; free variables.var_info (j).var_ptr -> bit_array; allocated = "0"b; end; if ^allocated then do; variables.var_info.desc (j) = select_info.user_item.rslt_desc (i); call allocate_lit; end; if mdbm_util_$varying_data_class ( addr (select_info.user_item (i).rslt_desc)) then unspec (variables.var_info (j).var_ptr -> bit_array) = unspec (addrel (select_info.user_item (i).rslt_assn_ptr, 1) -> bit_array); else unspec (variables.var_info (j).var_ptr -> bit_array) = unspec (select_info.user_item (i).rslt_assn_ptr -> bit_array); end assign_expr_lit; allocate_lit: proc; if mdbm_util_$varying_data_class (addr (variables.var_info (j).desc)) then do; if select_info.user_item.item_type (i) = EXPR | select_info.set_fn then variables.var_info (j).bit_len = select_info.user_item (i).rslt_assn_ptr -> varying_length; else variables.var_info (j).bit_len = user_item.arg_ptr -> varying_length; temp_len = variables.var_info (j).bit_len; unspec (addr (variables.var_info (j).desc) -> char_descriptor.length) = unspec (temp_len); if mdbm_util_$bit_data_class (addr (variables.var_info (j).desc)) then addr (variables.var_info (j).desc) -> descriptor.type = 19; else do; addr (variables.var_info (j).desc) -> descriptor.type = 21; variables.var_info (j).bit_len = variables.var_info (j).bit_len * 9; end; variables.var_info (j).assn_len = temp_len; end; else do; variables.var_info (j).bit_len = mdbm_util_$get_data_bit_length ((variables.var_info (j).desc)); if select_info.user_item.item_type (i) = EXPR | select_info.set_fn then variables.var_info (j).assn_len = select_info.user_item (i).rslt_assn_len; else variables.var_info (j).assn_len = user_item.assn_len; end; variables.var_info (j).assn_type = fixed (addr (variables.var_info (j).desc) -> descriptor.packed) + (2 * fixed (addr (variables.var_info (j).desc) -> descriptor.type)); allocate bit_array in (lcb.static_area) set (variables.var_info (j).var_ptr); end allocate_lit; end linus_assign_values;  linus_builtin_.pl1 10/14/90 0931.4rew 10/14/90 0915.0 87759 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-23,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Fixed rounding by changing calls from assign_ to assign_round_. END HISTORY COMMENTS */ linus_builtin_: proc; /* DESCRIPTION: This procedure contains entries that implement the LINUS set builtin functions. HISTORY: 77-06-01 J. C. C. Jagernauth: Intially written. 80-01-09 Rickie E. Brinegar: Modified to make use of the mdbm_util_$(complex number)_data_class entry points. 80-02-04 Rickie E. Brinegar: Modified to avoid a zero divide condition in avg_assign. 81-07-10 Rickie E. Brinegar: Modified to allow the use of character strings for avg and sum. This is in accordance with TR 9259. 83-01-25 Dave Schimke: Added code to initialize num_ptrs which is the extent of the arg_list.arg_desc array to fix a subscript range error. */ %include mdbm_arg_list; dcl 1 arg_descs aligned based (ad_ptr), 2 ndescs fixed bin, 2 desc (0 refer (arg_descs.ndescs)) bit (36); dcl assign_desc bit (36) based (arg_list.arg_des_ptr (2)); dcl rslt_desc bit (36) aligned; /* Output: result descriptor */ dcl data_out1 float dec (59) based (arg_list.arg_des_ptr (1)); dcl data_out2 complex float dec (59) based (arg_list.arg_des_ptr (1)); dcl data_in1 float dec (59); dcl data_in2 complex float dec (59); dcl FD59 bit (36) aligned int static options (constant) init ("100101000000000000000000000000111011"b); /* Float Decimal */ dcl CFD59 bit (36) aligned int static options (constant) init ("100110000000000000000000000000111011"b); /* Complex Float Decimal */ dcl FIB35 bit (36) aligned int static options (constant) init ("100000100000000000000000000000100011"b); dcl ( target_typeFD init (20), target_typeCFD init (24) ) fixed bin int static options (constant); dcl target_len fixed bin (35) int static options (constant) init (59); dcl source_type fixed bin; dcl source_len fixed bin (35); dcl count_rslt fixed bin (35) based (arg_list.arg_des_ptr (1)); dcl ad_ptr ptr; /* Input: points to input descriptors */ dcl count_calc fixed bin (35) int static init (0); dcl set_fn_real_flag fixed bin (2) int static init (0); dcl data_calc4 float dec (59) int static init (-99999999999999999999999999999999999999999999999999999999); dcl data_const4 float dec (59) int static options (constant) init (-99999999999999999999999999999999999999999999999999999999); dcl data_calc1 float dec (59) int static init (0); dcl data_calc2 complex float dec (59) int static init (0); dcl data_calc3 float dec (59) int static init (99999999999999999999999999999999999999999999999999999999); dcl data_const3 float dec (59) int static options (constant) init (99999999999999999999999999999999999999999999999999999999); dcl cu_$arg_list_ptr entry (ptr); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl linus_assign_data entry (bit (36), fixed bin, fixed bin (35)); dcl ( mdbm_util_$complex_data_class, mdbm_util_$number_data_class ) entry (ptr) returns (bit (1)); dcl addr builtin; return; /* Should never use linus_builtin_ entry */ count_calc: entry; /* Calc entry for the count set function */ num_ptrs = 0; count_calc = count_calc + 1; /* Perform count */ return; count_assign: entry; /* Assign entry for the count set function */ call cu_$arg_list_ptr (al_ptr); /* Get pointer to argument list */ count_rslt = count_calc; /* Assign result */ return; count_init: entry; /* Init for the this use of the count set function */ count_calc = 0; return; count_info: entry (ad_ptr, rslt_desc); /* Info entry for the count set function */ rslt_desc = FIB35; /* Always return a count. */ return; avg_calc: entry; /* Calc entry for the avg set function */ call avg_sum_calc; /* The avg and sum set functions use acommon procedure */ count_calc = count_calc + 1; /* Keep track of number of calls to calculate average value */ return; avg_assign: entry; /* Assign entry for the avg set function */ call cu_$arg_list_ptr (al_ptr); /* Get pointer to argument list */ if set_fn_real_flag = 1 then do; /* Assign real result */ if count_calc = 0 then data_out1 = 0; else data_out1 = data_calc1 / count_calc; end; else do; /* Else assign complex result */ if count_calc = 0 then data_out2 = 0; else data_out2 = data_calc2 / count_calc; end; return; avg_init: entry; /* Init for the this use of the avg set function */ count_calc, data_calc1, data_calc2, set_fn_real_flag = 0; return; avg_info: sum_info: entry (ad_ptr, rslt_desc); /* Info entry for the avg & sum set functions */ if arg_descs.ndescs ^= 1 then rslt_desc = "0"b; /* Must be one desriptor */ else if ^mdbm_util_$complex_data_class (addr (arg_descs.desc (1))) then rslt_desc = FD59; /* Result descriptor is Real Float Decimal (59) */ else rslt_desc = CFD59; /* Result descriptor is Complex Float Decimal (59) */ return; sum_calc: entry; /* Calc entry for the sum set function */ call avg_sum_calc; /* The avg and sum set functions use a common procedure */ return; sum_assign: entry; /* Assign entry for the sum set function */ call cu_$arg_list_ptr (al_ptr); /* Get pointer to argument list */ if set_fn_real_flag = 1 then data_out1 = data_calc1; /* Assign real result */ else data_out2 = data_calc2; /* Assign complex result */ return; sum_init: entry; /* Init for the this use of the sum set function */ data_calc1, data_calc2, set_fn_real_flag = 0; return; max_calc: entry; /* Calc entry for the max set function */ call cu_$arg_list_ptr (al_ptr); /* Get pointer to argument list */ num_ptrs = arg_list.arg_count; call linus_assign_data (assign_desc, source_type, source_len); call assign_round_ (addr (data_in1), target_typeFD, target_len, arg_list.arg_des_ptr (1), source_type, source_len); if data_calc4 < data_in1 then data_calc4 = data_in1; /* Find max value */ return; max_assign: entry; /* Assign entry for max set function */ call cu_$arg_list_ptr (al_ptr); data_out1 = data_calc4; /* Assign max value */ return; max_init: entry; /* Init for the this use of the max set function */ data_calc4 = data_const4; return; max_info: min_info: entry (ad_ptr, rslt_desc); /* Info entry for the max & min set functions */ if arg_descs.ndescs ^= 1 then rslt_desc = "0"b; /* Must be one descriptor. */ else do; if ^mdbm_util_$number_data_class (addr (arg_descs.desc (1))) then rslt_desc = "0"b; /* Type must be arithmetic */ else if ^mdbm_util_$complex_data_class (addr (arg_descs.desc (1))) then rslt_desc = FD59; /* Result descriptor is Real Float Decimal (59) */ else rslt_desc = "0"b; /* Complex Float Decimal is not valid */ end; return; min_calc: entry; /* Calc entry for the min set function */ call cu_$arg_list_ptr (al_ptr); /* Get pointer to the argument list */ num_ptrs = arg_list.arg_count; call linus_assign_data (assign_desc, source_type, source_len); call assign_round_ (addr (data_in1), target_typeFD, target_len, arg_list.arg_des_ptr (1), source_type, source_len); if data_calc3 > data_in1 then data_calc3 = data_in1; /* Find min value */ return; min_assign: entry; /* Assign entry for the min set function */ call cu_$arg_list_ptr (al_ptr); data_out1 = data_calc3; /* Assign min value */ return; min_init: entry; /* Init for this use of the min set function */ data_calc3 = data_const3; return; avg_sum_calc: proc; /* Calc procedure for both avg and sum entries. */ call cu_$arg_list_ptr (al_ptr); /* Get pointer to argument list */ num_ptrs = arg_list.arg_count; if set_fn_real_flag = 0 then do; /* First time through? */ if ^mdbm_util_$complex_data_class (arg_list.arg_des_ptr (2)) then set_fn_real_flag = 1; /* Type is real */ else set_fn_real_flag = 2; /* Type is complex */ end; call linus_assign_data (assign_desc, source_type, source_len); if set_fn_real_flag = 1 then do; call assign_round_ (addr (data_in1), target_typeFD, target_len, arg_list.arg_des_ptr (1), source_type, source_len); data_calc1 = data_calc1 + data_in1; /* Sum real values */ end; else do; call assign_round_ (addr (data_in2), target_typeCFD, target_len, arg_list.arg_des_ptr (1), source_type, source_len); data_calc2 = data_calc2 + data_in2; /* Sum complex values */ end; end avg_sum_calc; end linus_builtin_;  linus_canon_input.pl1 07/29/86 1045.3r w 07/29/86 0939.8 54756 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_canon_input: proc (lcb_ptr, lineptr, nread, code); /* DESCRIPTION: This procedure canonized an input line by removing comments and by substituting for macro arguments. Substitution for linus variables is left to the request handlers to eliminate possible conversions to character form. HISTORY: 77-06-01 J. A. Weeldreyer: Initially written. 78-04-01 J. A. Weeldreyer: Modified to properly handle /*'s in quoted strings -- April, 1978. 82-02-18 Paul W. Benjamin: ssu_ conversion. This procedure is now called only from the linus_invoke_ I/O module. Calling sequence altered to reflect the fact that the variables line, and line_array now refer to the line as read by iox_$get_line rather than something in the lcb. */ %include linus_lcb; %page; %include linus_char_argl; dcl lineptr ptr parameter; /* Input: ptr to input line. */ dcl nread fixed bin (21); /* Input/Output: No. of input chars. */ dcl code fixed bin (35); /* Output: status code */ dcl ( i, /* internal indices */ start_pos ) fixed bin; /* position in input line */ dcl arg_no fixed bin; /* specified arg no. */ dcl canon_line char (lcb.rb_len) var; /* place to build canonized line */ dcl line char (nread) based (lineptr); /* old input line */ dcl line_array (nread) char (1) unal based (lineptr); /* array view */ dcl in_quote bit (1) unal; dcl ( linus_error_$no_macro_arg, linus_error_$bad_macro_arg, linus_error_$bad_comment, linus_error_$exp_line_len, sys_info$max_seg_size ) fixed bin (35) ext; dcl (fixed, rel, addr, search, verify, index, null, length, substr) builtin; start_pos = 1; /* initialize */ canon_line = ""; in_quote = "0"b; do while (start_pos < nread); /* look through entire input line */ i = search (substr (line, start_pos), """%/"); /* look for possible arg or comment */ if i <= 0 then do; /* not found */ call add_to_line (addr (line_array (start_pos)), nread - start_pos + 1); /* add rest of line to output */ start_pos = nread; /* finished */ end; else do; /* found one */ call add_to_line (addr (line_array (start_pos)), i - 1); /* add scanned characters */ start_pos = start_pos + i - 1; /* index of char just found */ if line_array (start_pos) = """" then do; /* if possible start of end of quoted string */ in_quote = ^in_quote; call add_to_line (addr (line_array (start_pos)), 1); start_pos = start_pos + 1; end; else if line_array (start_pos) = "%" then do; /* if arg. */ if line_array (start_pos + 1) = "%" then do; /* just put in one % */ call add_to_line (addr (line_array (start_pos)), 1); start_pos = start_pos + 2; end; else do; /* if not double % */ if lcb.cal_ptr = null then call error (linus_error_$no_macro_arg); /* if no args defined for macro */ i = verify (substr (line, start_pos + 1), "0123456789"); /* look for end */ if i <= 1 then call error (linus_error_$bad_macro_arg); /* no number */ if line_array (start_pos + i) ^= "%" then call error (linus_error_$bad_macro_arg); /* no closing % */ arg_no = fixed (substr (line, start_pos + 1, i - 1)); /* isolate arg number */ ca_ptr = lcb.cal_ptr; /* get args for this macro */ if arg_no < 1 | arg_no > char_argl.nargs then /* must be in range */ call error (linus_error_$no_macro_arg); call add_to_line (char_argl.arg.arg_ptr (arg_no), char_argl.arg.arg_len (arg_no)); /* make subst. */ start_pos = start_pos + i + 1; /* first char. beyond % */ end; /* if not double % */ end; /* macro arg */ else if substr (line, start_pos, 2) = "/*" & ^in_quote then do; /* if comment */ i = index (substr (line, start_pos + 2), "*/"); /* look for end of comment */ if i <= 0 then call error (linus_error_$bad_comment); /* not found */ start_pos = start_pos + i + 3; /* first char beyond comment */ end; /* if comment */ else do; /* if was only / or slash-star in quote str. */ call add_to_line (addr (line_array (start_pos)), 1); /* add the / to the output */ start_pos = start_pos + 1; end; end; /* if spec char found */ end; /* main loop */ nread = length (canon_line); line = canon_line; code = 0; exit: return; add_to_line: proc (c_ptr, c_len); /* Procedure to add string to canon. line */ dcl c_ptr ptr; dcl c_len fixed bin (21); dcl c_string char (c_len) based (c_ptr); if length (canon_line) + c_len > lcb.rb_len then /* must stay in bounds */ call error (linus_error_$exp_line_len); canon_line = canon_line || c_string; end add_to_line; error: proc (cd); /* Error procedure */ dcl cd fixed bin (35); code = cd; go to exit; end error; end linus_canon_input;  linus_close.pl1 07/29/86 1045.3rew 07/29/86 0936.7 39438 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-01-13,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): 84-12-01 Al Dupuis: Renamed sfr_ptr to force_retrieve_scope_info_ptr and force_ret structure to forced_retrieve_scope_info. END HISTORY COMMENTS */ linus_close: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: The data base is closed in the user specified mode via a call to dsl_$close. Linus Command: close (c) HISTORY: 77-03-01 J. C. C. Jagernauth: Initially written. 78-09-01 J. C. C. Jagernauth: Modified for MR7.0. 80-06-01 Jim Gray : Modified to allow close to work even when database already closed outside of linus, without blowing up, and to clean up close processing. 81-11-06 Rickie E. Brinegar: Removed calls to linus_free_se as the selection expression is now allocated in the lila temporary segment. 82-02-09 Paul W. Benjamin: ssu_ conversion. 82-06-03 DJ Schimke: Added code to set si_ptr to null denying any succeeding opening access to the processed selection expression from this opening (TR phx13269). */ %include linus_lcb; %page; %include linus_forced_scope_info; %page; %include linus_ready_data; %page; %include linus_ready_table; %page; %include linus_temp_tab_names; %page; dcl sci_ptr ptr; /* for ssu_ */ dcl dsl_$close entry options (variable); /* MRDS Subroutine */ dcl ( linus_data_$c_id, /* Linus data */ linus_error_$no_db, /* Linus error code */ linus_error_$no_input_arg_reqd, mrds_data_$max_temp_rels, sys_info$max_seg_size ) ext fixed bin (35); dcl initial_mrds_vclock float bin (63); dcl cleanup condition; dcl i fixed bin; dcl (addr, fixed, null, rel, vclock) builtin; dcl nargs fixed; dcl (icode, code, out_code) fixed bin (35); dcl linus_print_error entry (fixed bin (35), char (*)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl ssu_$arg_count entry (ptr, fixed bin); on cleanup call clean_up; icode, code = 0; call ssu_$arg_count (sci_ptr, nargs); if nargs ^= 0 then call linus_print_error (linus_error_$no_input_arg_reqd, ""); /* No argument should be passed */ else if lcb.db_index = 0 then call linus_print_error (linus_error_$no_db, ""); else call main_close; main_close: proc; declare temp_index fixed bin (35); if lcb.db_index ^= 0 then do; temp_index = lcb.db_index; /* use force close philosophy */ lcb.db_index = 0; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$close (temp_index, icode); /* Try to close data base */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; end; if icode ^= 0 then do; call linus_convert_code (icode, out_code, linus_data_$c_id); /* Convert system error code */ call linus_print_error (out_code, ""); /* Print linus error */ end; if lcb.force_retrieve_scope_info_ptr ^= null then do; free lcb.force_retrieve_scope_info_ptr -> forced_retrieve_scope_info; lcb.force_retrieve_scope_info_ptr = null; end; lcb.si_ptr = null; /* delete processed selection expression */ if lcb.ttn_ptr ^= null then do; ttn_ptr = lcb.ttn_ptr; do i = 1 to mrds_data_$max_temp_rels; temp_tab_names (i) = ""; end; end; if lcb.rd_ptr ^= null then do; free lcb.rd_ptr -> ready_data; lcb.rd_ptr = null; end; if lcb.rt_ptr ^= null then do; free lcb.rt_ptr -> ready_table; lcb.rt_ptr = null; end; end main_close; clean_up: proc; call main_close; end clean_up; end linus_close;  linus_convert_code.pl1 09/16/83 1805.4rew 09/16/83 1739.3 26028 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_convert_code: proc (sys_code, user_code, caller_id); /* DESCRIPTION: This procedure translates certain error_table_ and mrds_error_ codes to more appropriate linus_error_ codes which would be more understandable to the LINUS user. HISTORY: 77-03-01 J. A. Weeldreyer: Initially written 82-10-19 D. J. Schimke: Added linus_error_$update_not_allowed and linus_error_$no_data. */ dcl ( sys_code, /* code to be converted */ user_code, /* converted code value */ caller_id ) fixed bin (35); /* id of caller */ dcl ( linus_error_$cant_open, linus_error_$mod_key_col, linus_error_$mult_updt_rows, linus_error_$no_data, linus_error_$upd_temp_tab, linus_error_$update_not_allowed, mrds_error_$mod_key_attr, mrds_error_$multiple_tuples_found, mrds_error_$upd_temp_rel, mrds_error_$update_not_allowed, mrds_error_$tuple_not_found, error_table_$noentry, mrds_error_$non_scope_ready, linus_error_$table_not_ready, linus_data_$o_id ) ext fixed bin (35); if sys_code = mrds_error_$non_scope_ready then user_code = linus_error_$table_not_ready; else if sys_code = error_table_$noentry & caller_id = linus_data_$o_id then user_code = linus_error_$cant_open; else if sys_code = mrds_error_$mod_key_attr then user_code = linus_error_$mod_key_col; else if sys_code = mrds_error_$multiple_tuples_found then user_code = linus_error_$mult_updt_rows; else if sys_code = mrds_error_$upd_temp_rel then user_code = linus_error_$upd_temp_tab; else if sys_code = mrds_error_$update_not_allowed then user_code = linus_error_$update_not_allowed; else if sys_code = mrds_error_$tuple_not_found then user_code = linus_error_$no_data; else user_code = sys_code; return; end linus_convert_code;  linus_convert_num_to_str.pl1 09/16/83 1805.4rew 09/16/83 1739.3 57627 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_convert_num_to_str: proc (value_ptr, desc_ptr, char_150_var_string, code); /* DESCRIPTION: The purpose of this program is to return a varying character string representation of a numeric value with leading and trailing zeros surpressed. If the input value is of type float or a fixed value with some scale other than 0, then at least a .0 will be returned in all cases. PARAMETERS: value_ptr a pointer to the value to be converted. desc_ptr a pointer to the descriptor of the value to be . converted. char_150_var_string the character stringing to be returned. code a standard return code. HISTORY: 80-02-18 Rickie E. Brinegar: Initially written. */ %include mdbm_arg_list; dcl ( desc_ptr, /* INPUT: pointer to the descriptor of the value to be converted. */ value_ptr ) ptr; /* INPUT: pointer to the value to be converted. */ dcl (append_len, i) fixed bin; dcl char_150 char (150); dcl char_150_var_string char (150) varying;/* OUTPUT: the converted value. */ dcl char_150_var_desc bit (36) init ("101011000000000000000000000010010110"b); dcl code fixed bin (35); /* OUTPUT: a standard return code. */ dcl char_75_var_string char (75) varying; dcl char_75_var_desc bit (36) init ("101011000000000000000000000001001011"b); dcl edit_string char (10) init ("^[^d^;^f^]"); dcl edit_string_desc bit (36) init ("101010100000000000000000000000001010"b); dcl (COMPLEX, INTEGER, FIXED) bit (1); dcl INTEGER_desc bit (36) init ("101001100000000000000000000000000001"b); dcl char_150_len fixed bin; dcl char_150_len_desc bit (36) init ("100000100000000000000000000000000001"b); dcl 1 desc based (desc_ptr), 2 flag bit (1), 2 type bit (6), 2 packed bit (1), 2 num_dim bit (4), 2 scale bit (12), 2 precision bit (12); dcl linus_error_$non_numeric_argument ext fixed bin (35); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); dcl mdbm_util_$number_data_class entry (ptr) returns (bit (1)); dcl mdbm_util_$complex_data_class entry (ptr) returns (bit (1)); dcl mdbm_util_$fixed_data_class entry (ptr) returns (bit (1)); i = 0; /* Initialize. */ append_len = 0; code = 0; COMPLEX = mdbm_util_$complex_data_class (desc_ptr); FIXED = mdbm_util_$fixed_data_class (desc_ptr); INTEGER = FIXED & fixed (desc.scale) = 0; if ^mdbm_util_$number_data_class (desc_ptr) then do; /* Was I called with a proper data type? */ code = linus_error_$non_numeric_argument; /* No. */ go to EXIT; end; num_ptrs = 10; /* Set up the argument list. */ allocate arg_list; arg_list.arg_count = 10; arg_list.desc_count = 10; arg_list.pad = 0; arg_list.code = 4; arg_list.arg_des_ptr (1) = addr (edit_string); arg_list.arg_des_ptr (2) = addr (char_150_var_string); arg_list.arg_des_ptr (3) = addr (char_150_len); arg_list.arg_des_ptr (4) = addr (INTEGER); arg_list.arg_des_ptr (5) = value_ptr; arg_list.arg_des_ptr (6) = addr (edit_string_desc); arg_list.arg_des_ptr (7) = addr (char_150_var_desc); arg_list.arg_des_ptr (8) = addr (char_150_len_desc); arg_list.arg_des_ptr (9) = addr (INTEGER_desc); arg_list.arg_des_ptr (10) = desc_ptr; call ioa_$general_rs (al_ptr, 1, 4, char_150, char_150_len, "1"b, "0"b); char_150_var_string = substr (char_150, 1, char_150_len); if INTEGER then /* Do I need to insure proper scaling? */ if COMPLEX then /* No, Do I need to get the imaginary part of a complex number? */ call get_imaginary; else /* No. */ go to EXIT; if FIXED then do; /* Do I have a scale to worry about? */ append_len = fixed (desc.scale) - (char_150_len - index (char_150_var_string, ".")); /* Yes. */ do i = 1 to append_len while (append_len > 0); char_150_var_string = char_150_var_string || "0"; end; end; if index (char_150_var_string, ".") = length (char_150_var_string) then /* If the last char is a "." */ char_150_var_string = substr (char_150_var_string, 1, char_150_len) || "0"; /* then add a "0" after it. */ if COMPLEX then call get_imaginary; EXIT: return; get_imaginary: proc; arg_list.arg_des_ptr (5) = addrel (value_ptr, 1); /* Update the argument list. */ call ioa_$general_rs (al_ptr, 1, 4, char_150, char_150_len, "1"b, "0"b); /* Get the character string. */ if substr (char_150, 1, 1) ^= "-" then char_75_var_string = "+" || substr (char_150, 1, char_150_len); else char_75_var_string = substr (char_150, 1, char_150_len); char_150_var_string = char_150_var_string || char_75_var_string; if INTEGER then do; char_150_var_string = char_150_var_string || "i"; go to EXIT; end; if FIXED then do; append_len = fixed (desc.scale) - (char_150_len - index (char_150_var_string, ".")); do i = 1 to append_len while (append_len > 0); char_75_var_string = char_75_var_string || "0"; char_150_var_string = char_150_var_string || "0"; end; end; if index (char_75_var_string, ".") = length (char_75_var_string) then char_150_var_string = char_150_var_string || "0"; char_150_var_string = char_150_var_string || "i"; end get_imaginary; end linus_convert_num_to_str;  linus_create_list.pl1 09/26/88 1304.4rew 09/26/88 1248.6 173007 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-12-08,Hergert), approve(88-09-20,MCR7995), audit(88-09-21,Blair), install(88-09-26,MR12.2-1119): Fixed bug that caused FPE when no data was found by MRDS. This happened because error was called when the error was detected (correctly), but error called ssu_abort_line which signalled cleanup which called cleanup which had already been called by error. We just null the file_info_ptr and ca_ptr now after cleanup. END HISTORY COMMENTS */ linus_create_list: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: Data retrieved from the data base are written to a multics file to be manipulated subsequently by LISTER. HISTORY: 77-09-01 J. C. C. Jagernauth: Originaly written. 78-08-01 J. C. C. Jagernauth: Modified to handle unlimited length output buffers. 79-12-19 Rickie E. Brinegar: Modified to trim all leading and trailing blanks using a one line modification suggestted by Chris Tavares. 80-01-15 Rickie E. Brinegar: Modified to use mdbm_util_$string_data_class. 80-03-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.i_o_area_ptr instead of getting system free area. 80-06-01 Jim Gray: Modified to correctly detect no db open, or no args given. 80-10-17 Rickie E. Brinegar: Corrected the calculation of the directory length in the input argument. 80-10-22 Rickie E. Brinegar: Modified to reuse the output_buffer and the target items pointed at by ti.ptr (l). Also removed the free_target_items procedure, as it was no longer needed. 80-10-27 Rickie E. Brinegar: Replaced the if statement to figure out the directory length and segment length and starting places of each with a call expand_pathname_. At the same time dir_name and seg_name were changed from based to automatic variables and from calculated lengths to char (168). 80-11-21 Rickie E. Brinegar: The acceptable control argument for field names was changed from -fieldnames to -field_names to agree with the documentation. This answers TR8415. 80-11-25 Rickie E. Brinegar: The call to lister_$get_fieldnames was modified to use lcb.i_o_area_ptr instead of the uninitialized area_ptr. As area_ptr was no longer referenced, it was deleted from the source. Also, if the extend control argument was used and the file did not exsist, it was not created. That has now been changed so that the file will be created if it does not exist. 81-09-21 Rickie E. Brinegar: Changed the assignment of num_ptrs to num_ptrs to be an assignment of arg_list.arg_count to num_ptrs. This avoids the subscript range condition. 81-10-09 Rickie E. Brinegar: Changed expand_pathname_ to expand_pathname_$add_suffix to allow for segements of the form a.b.lister. 81-11-06 Rickie E. Brinegar: Removed declaration of the unused after builtin. 81-11-16 Rickie E. Brinegar: Added timing of dsl calls. 82-02-09 Paul W. Benjamin: ssu_ conversion 82-02-19 Paul W. Benjamin: trapping linkage error when the site has no Lister. 82-06-21 Al Dupuis: Changed error msg from linkage_error trap noted above. Removed useless label, goto, and ssu_$abort_subsystem call. 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the first retrieve to keep linus_table from getting lost when loading in the incremental mode. This call can be eliminated when all modules call linus_table for their retrievals. 82-11-15 Dave Schimke: Removed unreferenced declaration of ssu_$abort_subsystem. 83-05-19 Dave Schimke: Modified to use mdbm_util_$define_area rather than linus_define_area so the work_area can be a freeing area. This is because lister allocates and frees in the area and therefore expects a freeing area. The structures allocated in work_area are not freed because the area is redefined by every module that uses this particular temp_segment. This is in response to TR14246. 83-05-19 Dave Schimke: Modified to use linus_data_$max_user_items as the bounds for field_names. It was incorrectly using linus_data_$max_lvars. This is in response to TR14054. Also changed the code to check for the correct number of field names given with the -field_names control_arg and insist on the -field_names when the select clause contains an expression. This makes the create_list request match its documentation. 83-08-30 Bert Moberg: Added call to linus_translate_query if no current select expression is available 83-09-12 Al Dupuis: Changed 83-05-19 fix above back to a non-freeing area, as the rest of linus that shares this area was not ready to deal with a freeing area. Lister now allocates and frees in it's own area. 83-10-11 Al Dupuis: Added else to if statement before collecting field names in the arg processing loop. Before this fix it found "-extend" and because there was no else it started executing the -field_names code. */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_select_info; %page; %include linus_arg_list; %page; %include mdbm_arg_list; dcl sci_ptr ptr; /* ssu_ needs this */ dcl 1 arg_len_bits based, /* Pick up length for descriptor */ 2 pad bit (12) unal, 2 length bit (24) unal; dcl 1 fieldname_info aligned based (fn_info_ptr), 2 version fixed bin, /* (INPUT) =1 */ 2 n_fieldnames fixed bin, /* (INPUT) number of fields in every record */ 2 name (n refer (fieldname_info.n_fieldnames)) char (32); /* (INPUT) actual field names. */ dcl 1 fn_info aligned based (fieldname_info_ptr), /* like fieldname_info */ 2 version fixed bin, 2 n_fieldnames fixed bin, 2 name (n refer (fn_info.n_fieldnames)) char (32); dcl 1 open_info aligned, 2 version fixed bin, /* =1 */ 2 flags aligned, 3 create bit (1) unal, /* ON ==> create file if not found */ 3 discard_records bit (1) unal, /* ON ==> throw away all records in file */ 3 assign_fieldnames bit (1) unal, /* ON ==> initialize fieldnames in file */ 3 mbz bit (33) unal, /* must be zero */ 2 fieldname_info_ptr ptr; /* ptr to fieldname_info structure */ /* NOTE: The flags are interrelated in the following way: If the file is successfully created (create=ON), then assign_fieldnames must be ON, and filename_info_ptr must point to a filename_info structure. The discard_records flag causes all existing records (if any) in the file to be thrown away. This flag does not depend on either of the other flags. The assign_fieldnames flag must be ON for newly created files, and may be ON for old files only if the discard_records flag is also ON. This flag causes new fieldnames to be stored in the file. The fieldname_info_ptr must point to a fieldname_info structure. */ dcl 1 record_info aligned based (rec_info_ptr), 2 version fixed bin, /* (INPUT) =1 */ 2 n_fields fixed bin, /* (INPUT) number of fields in this record */ 2 field (n refer (record_info.n_fields)) aligned, 3 field_ptr ptr, /* (INPUT) ptr to first char of Nth record */ 3 field_len fixed bin (21); /* (INPUT) len in chars of Nth record */ /* NOTE: This entry adds a new record to a lister file. The order of the fields is the same as the order in the fieldname_info structure (see lister_$open_file, or lister_$get_fieldnames). The number of fields in each record must match the number of fields in every other record in the file. If the file is full a non-zero code will be returned. If the number of fields is incorrect a non-zero code will be returned. Zero-length fields are OK. */ dcl 1 ti (select_info.n_user_items) aligned based (ti_ptr), 2 ptr ptr, 2 len fixed bin (35); dcl ANOTHER char (8) options (constant) int static init ("-another"); dcl path_name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1)); /* Pathname of output file */ dcl tmp_char char (char_argl.arg.arg_len (i)) based (char_argl.arg.arg_ptr (i)); /* Temp location */ dcl dir_name char (168); dcl seg_name char (168); dcl (clcb_extend, field_names, first_retrieve) bit (1) aligned; dcl ( destination_ptr init (null), /* Points to the scalar function, set function or select_info structure */ e_ptr init (null), env_ptr init (null), fieldname_info_ptr init (null), file_info_ptr init (null), fn_info_ptr init (null), out_buf_ptr init (null), rec_info_ptr init (null), ref_ptr init (null), ti_ptr init (null), user_item_ptr init (null) ) ptr; dcl ( another_len, caller, /* 1 = from the request processor, 2 = from a scalar function, 3 = from a set function */ i, l, n, n_bytes, ob_len, /* length of output buffer */ target_type ) fixed bin; dcl initial_mrds_vclock float bin (63); dcl test_entry entry variable; dcl (addr, fixed, null, rel, substr, vclock) builtin; dcl (code, icode, out_code) fixed bin (35); dcl 1 user_names aligned, 2 n_names fixed bin (35), 2 name (linus_data_$max_user_items) char (32) var; dcl ( error_table_$noentry, linus_data_$create_list_id, linus_data_$max_user_items, linus_error_$conv, linus_error_$inv_arg, linus_error_$inval_ctl_arg, linus_error_$lister_col_nums, linus_error_$lister_col_names, linus_error_$no_data, linus_error_$no_db, linus_error_$no_input_arg, linus_error_$ret_not_valid, mrds_error_$tuple_not_found, sys_info$max_seg_size ) fixed bin (35) ext; dcl (cleanup, conversion, linkage_error) condition; dcl cu_$decode_entry_value entry (entry, ptr, ptr); dcl cu_$generate_call entry (entry, ptr); dcl dsl_$retrieve entry options (variable); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_define_area entry (ptr, char(6), fixed bin(35)); dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); dcl linus_output$create_list entry (ptr, fixed bin (35), ptr, ptr, ptr, ptr, fixed bin, ptr, fixed bin, fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl linus_retrieve entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_table$async_retrieval entry (ptr, fixed bin (35)); dcl lister_$close_file entry (ptr, fixed bin (35)); dcl lister_$get_fieldnames entry (ptr, ptr, ptr, fixed bin (35)); dcl lister_$open_file entry (char (*), char (*), ptr, ptr, fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl work_area area (sys_info$max_seg_size) based (lcb.i_o_area_ptr); on linkage_error call ssu_$abort_line (sci_ptr, error_table_$noentry, "Your site hasn't purchased the Lister Facility."); test_entry = lister_$open_file; /* Test to see if these guys bought Lister */ revert linkage_error; icode, user_names.n_names, code = 0; field_names = "0"b; al_ptr, ca_ptr, char_ptr = null; on cleanup call clean_up; on conversion call error (linus_error_$conv, ""); if lcb.db_index = 0 then call error (linus_error_$no_db, ""); call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then call error (linus_error_$no_input_arg, ""); call linus_define_area (lcb.i_o_area_ptr, "I_O_", code); if code ^= 0 then call error (code, ""); open_info.flags.create, open_info.flags.discard_records, open_info.flags.assign_fieldnames = "1"b; clcb_extend = "0"b; n_bytes = 0; first_retrieve = "1"b; another_len = 8; target_type = 44; /* char var * 2 */ caller = 1; /* Init for linus_eval_expr */ if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ destination_ptr = lcb.si_ptr; /* Init for linus_eval_expr */ si_ptr = lcb.si_ptr; /* Activate select_info data */ allocate char_argl in (lcb.static_area); do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; i = 1; call expand_pathname_$add_suffix (path_name, "lister", dir_name, seg_name, icode); if icode ^= 0 then call error (icode, ""); if char_argl.nargs > 1 then do i = 2 to char_argl.nargs; if substr (tmp_char, 1, 1) = "-" then do; if tmp_char = "-extend" then do; open_info.flags.create, open_info.flags.assign_fieldnames, open_info.flags.discard_records = "0"b; clcb_extend = "1"b; end; else if tmp_char = "-fn" | tmp_char = "-field_names" then do; field_names = "1"b; do i = i + 1 to char_argl.nargs while (substr (tmp_char, 1, 1) ^= "-"); user_names.n_names = user_names.n_names + 1; if user_names.n_names > select_info.n_user_items then call error (0, "Too many field names were specified for the current selection expression."); user_names.name (user_names.n_names) = tmp_char; end; i = i - 1; /* pick up next item */ end; else call error (linus_error_$inval_ctl_arg, (tmp_char)); end; else call error (linus_error_$inv_arg, (tmp_char)); end; if ^select_info.se_flags.val_ret then call error (linus_error_$ret_not_valid, ""); allocate ti in (work_area); do l = 1 to select_info.n_user_items; ti.ptr (l) = null; end; call cu_$decode_entry_value (linus_create_list, ref_ptr, env_ptr); if ^field_names then do; n = select_info.n_user_items; do l = 1 to n; if select_info.user_item(l).item_type = 2 /* if expression */ then call error (0, "Field names must be supplied when the select clause ^/contains expressions. Use the -field_names control_arg."); end; end; else n = user_names.n_names; if n < select_info.n_user_items then call error (0, "Not enough field names were specified for the current selection expression."); allocate fieldname_info in (work_area); open_info.fieldname_info_ptr = fn_info_ptr; fieldname_info.version = 1; if ^field_names then do i = 1 to select_info.n_user_items; fieldname_info.name (i) = select_info.user_item.name (i); end; else do i = 1 to user_names.n_names; fieldname_info.name (i) = user_names.name (i); end; allocate record_info in (work_area); open_info.version, record_info.version = 1; open_info.flags.mbz = "0"b; call lister_$open_file (dir_name, seg_name, addr (open_info), file_info_ptr, icode); if icode = error_table_$noentry & clcb_extend then do; open_info.flags.create, open_info.flags.assign_fieldnames = "1"b; icode = 0; call lister_$open_file (dir_name, seg_name, addr (open_info), file_info_ptr, icode); end; if icode ^= 0 then call error (icode, ""); if clcb_extend then do; call lister_$get_fieldnames (file_info_ptr, lcb.i_o_area_ptr, fieldname_info_ptr, icode); if icode ^= 0 then call error (icode, ""); if fn_info.n_fieldnames ^= fieldname_info.n_fieldnames then call error (linus_error_$lister_col_nums, ""); do i = 1 to fn_info.n_fieldnames while (fn_info.name (i) = fieldname_info.name (i)); end; if i <= fn_info.n_fieldnames then call error (linus_error_$lister_col_names, ""); end; if select_info.prior_sf_ptr ^= null then call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode); if select_info.set_fn then do; call linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1), icode); if icode = 0 then do; call linus_output$create_list (lcb_ptr, linus_data_$create_list_id, file_info_ptr, rec_info_ptr, si_ptr, ti_ptr, target_type, out_buf_ptr, ob_len, icode); if icode ^= 0 then call error (icode, ""); end; end; else do; call linus_table$async_retrieval (lcb_ptr, icode); if icode ^= 0 then call error (icode, ""); call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); if al_ptr ^= null then num_ptrs = arg_list.arg_count; char_desc.arr.var (1) = addr (another_len) -> arg_len_bits.length; /* Get ready for "another" retrieve */ arg_list.arg_des_ptr (2) = addr (ANOTHER); if icode = 0 then first_retrieve = "0"b; do while (icode = 0); /* Retrieve all */ call linus_output$create_list (lcb_ptr, linus_data_$create_list_id, file_info_ptr, rec_info_ptr, si_ptr, ti_ptr, target_type, out_buf_ptr, ob_len, icode); if icode ^= 0 then call error (icode, ""); if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, al_ptr); /* Retrieve another */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); end; if icode ^= mrds_error_$tuple_not_found then call error (icode, ""); if first_retrieve then call error (linus_error_$no_data, ""); end; call clean_up; return; error: proc (err_code, msg); dcl err_code fixed bin (35); dcl msg char(*) var; call clean_up; call linus_convert_code (err_code, out_code, linus_data_$create_list_id); call ssu_$abort_line (sci_ptr, out_code, msg); end error; clean_up: proc; if ca_ptr ^= null then do; free char_argl; ca_ptr = null; end; if file_info_ptr ^= null then do; call lister_$close_file (file_info_ptr, icode); file_info_ptr = null; end; end clean_up; end linus_create_list;  linus_data_.cds 03/16/88 0829.2rew 03/15/88 1553.0 42561 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(86-10-03,Dupuis), approve(86-10-21,MCR7562), audit(86-10-22,Blair), install(86-10-23,MR12.0-1199): Added the lock_wait_time variable. 2) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-11,Blair), install(88-03-15,MR12.2-1036): Added the trace_every_n_tuples field. END HISTORY COMMENTS */ linus_data_: proc; /* DESCRIPTION: This procedure creates the linus_data_ database. HISTORY: 80-02-18 Rickie E. Brinegar: Converted from linus_data_.mexp to linus_data_.cds. 80-06-23 Jim Gray: Modified to make lit_string_size much larger, so that a reltion with many large attrs, will not cause "Unable to allocate literal string" error messages. 80-06-24 Rickie E. Brinegar: Modified to reduce Jim's much larger by half. 80-06-24 Jim Gray: Modified to make req_buf_len = 5000, so that linus could at least read as much as it can print. 81-06-30 Rickie E. Brinegar: Changed buf_len to 5000, so that LINUS store, modify, write and report have the same buffer size as print. */ %include cds_args; dcl 1 ld aligned, 2 av_id fixed bin (35) init (1), 2 buff_len fixed bin (35) init (5000), 2 c_id fixed bin (35) init (2), 2 chp_id fixed bin (35) init (3), 2 create_list_id fixed bin (35) init (4), 2 d_id fixed bin (35) init (5), 2 dcl_id fixed bin (35) init (6), 2 dfs_id fixed bin (35) init (7), 2 ds_id fixed bin (35) init (8), 2 dltt_id fixed bin (35) init (9), 2 dtt_id fixed bin (35) init (10), 2 e_id fixed bin (35) init (11), 2 eval_expr_id fixed bin (35) init (12), 2 eval_scal_func_id fixed bin (35) init (13), 2 eval_set_func_id fixed bin (35) init (14), 2 h_id fixed bin (35) init (15), 2 i_id fixed bin (35) init (16), 2 ldb_id fixed bin (35) init (17), 2 lila fixed bin (35) init (2), 2 lila_id fixed bin (35) init (18), 2 lit_string_size fixed bin (35) init (500000), 2 lock_wait_time fixed bin (35) init (900), 2 lrt_id fixed bin (35) init (19), 2 ls_id fixed bin (35) init (20), 2 lv_id fixed bin (35) init (21), 2 m_id fixed bin (35) init (22), 2 max_expr_items fixed bin (35) init (20), 2 max_invocs fixed bin (35) init (20), 2 max_leaf_vals fixed bin (35) init (10), 2 max_lvars fixed bin (35) init (20), 2 max_pred_stack_size fixed bin (35) init (20), 2 max_range_items fixed bin (35) init (20), 2 max_req_args fixed bin (35) init (100), 2 max_sclf_items fixed bin (35) init (20), 2 max_set_stack_size fixed bin (35) init (10), 2 max_user_items fixed bin (35) init (100), 2 o_id fixed bin (35) init (23), 2 p_id fixed bin (35) init (24), 2 print_col_spaces fixed bin (35) init (2), 2 report_id fixed bin (35) init (25), 2 req_buf_len fixed bin (35) init (5000), 2 req_proc_id fixed bin (35) init (26), 2 rlb_id fixed bin (35) init (27), 2 rt_id fixed bin (35) init (28), 2 s_id fixed bin (35) init (29), 2 set_id fixed bin (35) init (1), 2 set_mode_id fixed bin (35) init (30), 2 sfs_id fixed bin (35) init (31), 2 srm_id fixed bin (35) init (32), 2 ss_id fixed bin (35) init (33), 2 stk_depth fixed bin (35) init (50), 2 trace_every_n_tuples fixed bin (35) init (1000), 2 w_id fixed bin (35) init (34), 2 pr_buff_len fixed bin (35) init (5000); dcl 1 cdsa like cds_args; dcl code fixed bin (35); dcl (addr, null, size, string) builtin; dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl com_err_ entry options (variable); cdsa.sections.p (1) = addr (ld); cdsa.sections.len (1) = size (ld); cdsa.sections.struct_name (1) = "ld"; cdsa.seg_name = "linus_data_"; cdsa.num_exclude_names = 0; cdsa.exclude_array_ptr = null; string (cdsa.switches) = "0"b; cdsa.switches.have_text = "1"b; call create_data_segment_ (addr (cdsa), code); if code ^= 0 then call com_err_ (code, "linus_data_"); return; end linus_data_;  linus_declare.pl1 07/29/86 1045.3r w 07/29/86 0939.8 54891 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_declare: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: This procedure implements the LINUS declare request. There must be exactly two arguments supplied, namely function name and function type. Set functions are threaded into the set function list, and scalar functions are declared to MRDS and their names are threaded into a scalar function list. HISTORY: 77-06-01 J. A. Weeldreyer: Initially written. 80-10-17 Rickie E. Brinegar: changed hcs_$make_ptr for a combination of expand_pathname_ and cv_ptr_ inorder to allow for absolute pathnames in set functions. A similar change was made to mrds_dsl_declare to handle scalar functions. 80-11-03 Rickie E. Brinegar: cv_ptr_ changed to cv_entry_. 81-11-13 Rickie E. Brinegar: Added timing of dsl_$declare. 82-02-10 Paul W. Benjamin: ssu_ conversion 82-06-21 Al Dupuis: Following changes resulting from audit of ssu_ conversion. Remove kill/nokill comment from code as it was no longer meaningfull. Remove NO_KILL usage as it no longer had meaning either. */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_scal_fn_info; dcl sci_ptr ptr; /* for ssu_ */ dcl ( code, icode ) fixed bin (35); /* internal status code */ dcl initial_mrds_vclock float bin (63); dcl name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1)); /* function name */ dcl type char (char_argl.arg.arg_len (2)) based (char_argl.arg.arg_ptr (2)); /* function type */ dcl file_name char (168) varying; dcl (directory, entry_name) char (168); dcl ( linus_data_$dcl_id, linus_error_$bad_num_args, linus_error_$inv_fn_type, linus_error_$no_db, sys_info$max_seg_size ) fixed bin (35) ext; dcl cleanup condition; dcl (addr, fixed, null, rel, rtrim, vclock) builtin; dcl calc_entry entry variable; /* virtual entry to set function calc. entry */ dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl dsl_$declare entry (fixed bin (35), char (*), fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_thread_fn_list entry (ptr, entry, char (168) varying, char (32) varying, fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); sclfi_ptr, ca_ptr = null; /* initiallize */ on cleanup call tidy_up; if lcb.db_index = 0 then call error (linus_error_$no_db, ""); call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then call error (linus_error_$bad_num_args, ""); if nargs_init ^= 2 then /* must have correct no. args */ call error (linus_error_$bad_num_args, ""); allocate char_argl in (lcb.static_area); call ssu_$arg_ptr (sci_ptr, 1, char_argl.arg.arg_ptr (1), char_argl.arg.arg_len (1)); call ssu_$arg_ptr (sci_ptr, 2, char_argl.arg.arg_ptr (2), char_argl.arg.arg_len (2)); file_name = rtrim (name); if type = "set" then do; /* set function */ call expand_pathname_ (name, directory, entry_name, icode); if icode ^= 0 then call error (icode, name); calc_entry = cv_entry_ (rtrim (directory) || ">" || rtrim (entry_name) || "$" || rtrim (entry_name) || "_calc", null, icode); if icode ^= 0 then call error (icode, file_name || " calc. entry."); call linus_thread_fn_list (lcb_ptr, calc_entry, file_name, rtrim (entry_name), icode); /* put into fn. list */ if icode ^= 0 then call error (icode, name); end; /* if set function */ else if type = "scalar" then do; /* if scalar function */ if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$declare (lcb.db_index, name, icode); /* let MRDS know about it */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if icode ^= 0 then call error (icode, name); allocate scal_fn_info in (lcb.static_area); scal_fn_info.name = rtrim (entry_name); /* fill in scal_fn_info block */ scal_fn_info.fwd_ptr = lcb.sclfi_ptr; /* put at head of list */ lcb.sclfi_ptr = sclfi_ptr; end; /* if scalar function */ else call error (linus_error_$inv_fn_type, type); if ca_ptr ^= null then free char_argl; return; error: proc (cd, msg); /* error procedure */ dcl (cd, ucd) fixed bin (35); dcl msg char (*); call tidy_up; call linus_convert_code (cd, ucd, linus_data_$dcl_id); /* so LINUS user can understand */ call ssu_$abort_line (sci_ptr, ucd, msg); end error; tidy_up: proc; /* procedure to clean up allocated structures */ if sclfi_ptr ^= null then if sclfi_ptr ^= lcb.sclfi_ptr then free scal_fn_info; if ca_ptr ^= null then free char_argl; end tidy_up; end linus_declare;  linus_define_area.pl1 09/16/83 1805.4rew 09/16/83 1739.3 35883 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_define_area: procedure (defined_area_ptr, area_name, error_code); /* DESCRIPTION: This is a general routine to encapsulate the call to define_area_ and the initializing of the area_info structure needed for that call. Note that the area defined by this call must be deleted by a call to release_area_ to properly clean up any temp segments created. PARAMETERS: defined_area_ptr - - (input/output) pointer, points to the start of the area to be defined by this call. Also the address pointed by defined_area_ptr must be even(0 mod 2). If null, then it's value is assigned, and a temp segment for the area is created. area_name - - (input) char(6), a name for the area, it will be used with extensible areas to name added segments following the {unique_name}.MRDS error_code - - (output) fixed bin(35), 0 unless an error occured in the call to define_area_ HISTORY: 80-02-01 Jim Gray : Originally written. 80-02-02 R. Lackey: Modified to add define_area entry name. 80-03-10 Rickie E. Brinegar: Modified to create areas with the first component of linus (was formerly mrds_dsl_define_area). 81-07-07 Rickie E. Brinegar: Modified to call get_temp_segment_ if the input pointer was null. This was done so that LINUS could properly free temporary segments in the linus module's clean up handler. */ %include area_info; dcl addr builtin; dcl area_name char (6); /* name to be given to area and extended segs */ dcl define_area_ entry (ptr, fixed bin (35)); /* routine that defines an area */ dcl defined_area_ptr ptr; /* points to area to be defined */ dcl error_code fixed bin (35); /* error status encoding */ dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl 1 local_area_info like area_info; dcl null builtin; dcl rtrim builtin; dcl sys_info$max_seg_size fixed bin (35) ext; /* initialize the area_info, based on input parameters */ if defined_area_ptr = null then call get_temp_segment_ ("LINUS." || rtrim (area_name) || ".area", defined_area_ptr, error_code); local_area_info.version = 1; local_area_info.control.extend = "0"b; local_area_info.control.zero_on_alloc = "0"b; local_area_info.control.zero_on_free = "0"b; local_area_info.control.dont_free = "0"b; local_area_info.control.no_freeing = "1"b; local_area_info.control.system = "0"b; local_area_info.control.pad = "0"b; local_area_info.owner = "LINUS." || rtrim (area_name); local_area_info.n_components = 0; local_area_info.size = sys_info$max_seg_size; local_area_info.version_of_area = 1; local_area_info.areap = defined_area_ptr; local_area_info.allocated_blocks = 0; local_area_info.free_blocks = 0; local_area_info.allocated_words = 0; local_area_info.free_words = 0; /* now make the call to define the area according to the parameters */ call define_area_ (addr (local_area_info), error_code); return; end;  linus_delete.pl1 07/29/86 1045.3r w 07/29/86 0939.8 54495 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_delete: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: Selected rows are deleted from a single table in the data base. HISTORY: 77-05-14 J. C. C. Jagernauth: Intially written. 80-03-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.linus_area_ptr instead of getting system free area. 81-06-04 Rickie E. Brinegar: Modified to not pass arguments for return values to dsl_$delete. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-11-13 Rickie E. Brinegar: Added timing of dsl_$delete and changed the cu_$gen_call to cu_$generate_call. 82-02-10 Paul W. Benjamin: ssu_ conversion 82-09-03 Dave J. Schimke: Added a call to dsl_$get_pn to get the opening mode and report an error if user tries to delete with a retrieval opening. Declared mode, db_path, dsl_$get_path, and linus_error_$update_not_valid. This is in response to phx 13742. 82-11-15 Dave Schimke: Declared fixed and rel builtins. 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current select expression is available */ %include linus_lcb; %page; %include linus_select_info; %page; %include mdbm_arg_list; %page; %include linus_arg_list; dcl sci_ptr ptr; /* for ssu_ */ dcl nargs fixed; dcl (addr, fixed, null, rel, substr, vclock) builtin; dcl (desc, l) fixed bin; dcl (icode, out_code) fixed bin (35); dcl initial_mrds_vclock float bin (63); dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 length bit (24) unal; dcl db_path char (168) var; dcl mode char (20); dcl sel_expr char (select_info.se_len) based (select_info.se_ptr); dcl ( linus_data_$d_id, linus_error_$inv_for_delete, linus_error_$no_db, linus_error_$no_input_arg_reqd, linus_error_$update_not_allowed, sys_info$max_seg_size ) fixed bin (35) ext; dcl cu_$generate_call entry (entry, ptr); dcl dsl_$delete entry options (variable); dcl dsl_$get_pn entry (fixed bin (35), char (168) var, char (20), fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl work_area area (sys_info$max_seg_size) based (lcb.linus_area_ptr); al_ptr, char_ptr = null; icode = 0; if lcb.db_index = 0 then call error (linus_error_$no_db, ""); call dsl_$get_pn (lcb.db_index, db_path, mode, icode); if substr (mode, 1, 9) = "retrieval" | substr (mode, 11, 9) = "retrieval" then call error (linus_error_$update_not_allowed, ""); call ssu_$arg_count (sci_ptr, nargs); if nargs ^= 0 then call error (linus_error_$no_input_arg_reqd, ""); if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ si_ptr = lcb.si_ptr; if ^select_info.se_flags.val_del then call error (linus_error_$inv_for_delete, ""); if select_info.nsevals = 0 then do; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$delete (lcb.db_index, sel_expr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; end; else do; n_chars_init = 1; allocate char_desc in (work_area); /* 81-06-04 Rickie E. Brinegar: Start changed code ************************* */ desc = select_info.nsevals + 3; /* 81-06-04 Rickie E. Brinegar: End changed code *************************** */ num_ptrs = desc * 2; allocate arg_list in (work_area); arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc); /* Return code descriptor */ arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* Data base index */ arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc); /* Data base index descriptor */ arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */ arg_list.code = 4; arg_list.pad = 0; arg_list.arg_des_ptr (desc) = addr (icode); char_desc.arr.var (1) = addr (select_info.se_len) -> arg_len_bits.length; arg_list.arg_des_ptr (2) = select_info.se_ptr; arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (1)); do l = 1 to select_info.nsevals; arg_list.arg_des_ptr (2 + l) = select_info.se_vals.arg_ptr (l); arg_list.arg_des_ptr (2 + l + desc) = select_info.se_vals.desc_ptr (l); end; if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$delete, al_ptr); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; end; if icode ^= 0 then call error (icode, ""); return; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); call linus_convert_code (err_code, out_code, linus_data_$d_id); call ssu_$abort_line (sci_ptr, out_code); end error; end linus_delete;  linus_dltt.pl1 07/29/86 1045.3r w 07/29/86 0939.8 42336 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_dltt: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: Temporary tables are deleted by calling dsl_define_temp_rel with the negative value of the temporary table index. HISTORY: 77-06-01 J. C. C. Jagernauth: Initially written. 80-03-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.linus_area_ptr instead of getting system free area. 80-03-25 Rickie E. Brinegar: Modified from linus_dtt to linus_dltt. 81-02-03 Rickie E. Brinegar: Modified to return a zero return code after printing an error message. This prevents blowing away the user when he/she attempts to delete a temp table which does not exist. 81-11-13 Rickie E. Brinegar: Added timing of call to dsl_$define_temp_rel. 82-02-10 Paul W. Benjamin: ssu_ conversion */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_select_info; %page; %include linus_arg_list; %page; %include mdbm_arg_list; %page; %include linus_temp_tab_names; dcl sci_ptr ptr; /* for ssu_ */ dcl table_name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1)); dcl ( e_ptr init (null), env_ptr init (null) ) ptr; dcl cleanup condition; dcl (addr, fixed, null, rel, vclock) builtin; dcl (icode, code, out_code) fixed bin (35); dcl (i, l) fixed bin; dcl initial_mrds_vclock float bin (63); dcl ( linus_data_$dltt_id, linus_error_$no_db, linus_error_$no_input_arg, linus_error_$no_temp_tables, linus_error_$undef_temp_table, mrds_data_$max_temp_rels, sys_info$max_seg_size ) fixed bin (35) ext; dcl rel_index fixed bin (35); dcl dsl_$define_temp_rel entry options (variable); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); ca_ptr = null; icode, code = 0; if lcb.db_index = 0 then call error (linus_error_$no_db, ""); else do; call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then call error (linus_error_$no_input_arg, ""); end; rel_index = 0; /* Init for mrds define temp rel */ if lcb.ttn_ptr = null then call error (linus_error_$no_temp_tables, ""); ttn_ptr = lcb.ttn_ptr; allocate char_argl in (lcb.static_area); on cleanup begin; if ca_ptr ^= null then free char_argl; end; do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; i = 0; do l = 1 to mrds_data_$max_temp_rels while (i = 0); if temp_tab_names (l) = table_name then do; rel_index = 0 - l; /* redefine temporary tables */ i = 1; end; end; l = l - i; /* If I found it, then I am 1 (or i) beyond where I found it, so adjust */ if rel_index ^< 0 | l > mrds_data_$max_temp_rels then call error (linus_error_$undef_temp_table, table_name); if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$define_temp_rel (lcb.db_index, "", rel_index, code); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if code ^= 0 then call error (code, ""); temp_tab_names (l) = ""; exit: if ca_ptr ^= null then free char_argl; return; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); if ca_ptr ^= null then free char_argl; call linus_convert_code (err_code, out_code, linus_data_$dltt_id); call ssu_$abort_line (sci_ptr, out_code, string); end error; end linus_dltt;  linus_dtt.pl1 07/29/86 1045.3r w 07/29/86 0939.8 105471 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_dtt: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: Temporary tables are defined by calling dsl_define_temp_rel. This procedure will identify key columns and insert a "*" in the select_info structure as required. HISTORY: 77-06-01 J. C. C. Jagernauth: Initially written. 80-04-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.linus_area_ptr instead of getting system free area. 80-12-02 Rickie E. Brinegar: Entry points db_on and db_off added. 81-02-05 Rickie E. Brinegar: Changed to check the temporary relation name against the permanent relation names and to not allow the temporary relation name to duplicate a permanent relation name. 81-02-17 Rickie E. Brinegar: Added return statement for main entry. This had been neglected when the db_(on off) entry points were added. 81-02-20 Rickie E. Brinegar: Changed the calls to mdb_display_value_ to be calls to mdb_display_data_value$ptr. The latter allows more than 256 characters to be displayed. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-10-09 Rickie E. Brinegar: Modified to look for a the key attribute name with a space concatenated on the end of it to guarantee that it does not put the astericks in the middle of another string. This is in response to TR11720. 81-11-13 Rickie E. Brinegar: Added the timing of the dsl entries. 82-02-10 Paul W. Benjamin: ssu_ conversion 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current select expression is available */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_select_info; %page; %include linus_arg_list; %page; %include mdbm_arg_list; %page; %include linus_temp_tab_names; dcl sci_ptr ptr; /* for ssu_ */ dcl KEY char (1) options (constant) int static init ("*"); dcl sel_items char (select_info.sel_items_len) based (select_info.sel_items_ptr); dcl table_name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1)); dcl temp_char char (mrds_data_$max_token_size + 1) varying; dcl tmp_char char (char_argl.arg.arg_len (i)) based (char_argl.arg.arg_ptr (i)); dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 length bit (24); /* Length of argument for arg_list */ dcl (test, val_key) bit (1); dcl debug_switch bit (1) int static init ("0"b); dcl ( e_ptr init (null), env_ptr init (null), rslt_ptr init (null) ) ptr; dcl (addr, char, fixed, index, length, null, rel, rtrim, substr, vclock) builtin; dcl cleanup condition; dcl (code, icode, rel_index, out_code) fixed bin (35); dcl (curr_pos, desc, i, l) fixed bin; dcl initial_mrds_vclock float bin (63); dcl ( linus_data_$dtt_id, linus_error_$dtt_key_select, linus_error_$dtt_max_tabs, linus_error_$dtt_no_key, linus_error_$dtt_not_valid, linus_error_$no_db, linus_error_$no_input_arg, linus_error_$table_exist, mrds_data_$max_temp_rels, mrds_data_$max_token_size, mrds_error_$undef_rel, sys_info$max_seg_size ) fixed bin (35) ext; dcl cu_$generate_call entry (entry, ptr); dcl dsl_$define_temp_rel entry options (variable); dcl dsl_$get_rslt_info entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl mdb_display_data_value$ptr entry (ptr, ptr); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl work_area area (sys_info$max_seg_size) based (lcb.linus_area_ptr); val_key = "0"b; al_ptr, ca_ptr, char_ptr = null; icode, code = 0; if lcb.db_index = 0 then call error (linus_error_$no_db, ""); else do; call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then call error (linus_error_$no_input_arg, ""); end; allocate char_argl in (lcb.static_area); on cleanup begin; if ca_ptr ^= null then free char_argl; end; do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; if char_argl.nargs <= 1 then call error (linus_error_$dtt_no_key, ""); if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ si_ptr = lcb.si_ptr; /* Activate select_info structure */ if ^select_info.se_flags.val_dtt then call error (linus_error_$dtt_not_valid, ""); if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_rslt_info (lcb.db_index, table_name, lcb.linus_area_ptr, rslt_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if icode = 0 then icode = linus_error_$table_exist; if icode ^= mrds_error_$undef_rel then call error (icode, table_name); do i = 2 to char_argl.nargs; if char_argl.arg_len (i) > mrds_data_$max_token_size then call error (linus_error_$dtt_key_select, "^/" || tmp_char || " is longer than " || char (mrds_data_$max_token_size) || " characters."); temp_char = rtrim (tmp_char) || " "; curr_pos = 1; test = "0"b; do while (curr_pos <= select_info.sel_items_len & ^test); curr_pos = index (sel_items, temp_char); if curr_pos > 0 then do; curr_pos = curr_pos + length (temp_char) - 2; /* -1 for the added space and -1 for the add producing a value one to large */ val_key = "1"b; test = "1"b; if select_info.sel_items_len > curr_pos then sel_items = /* replace the blank following the attribute */ substr (sel_items, 1, curr_pos) || KEY || substr (sel_items, curr_pos + 2); else sel_items = substr (sel_items, 1, curr_pos) || KEY; end; else call error (linus_error_$dtt_key_select, "^/" || tmp_char); end; end; if ^val_key then call error (linus_error_$dtt_key_select, ""); rel_index = 0; /* Init for mrds define temp rel */ if lcb.ttn_ptr ^= null then do; ttn_ptr = lcb.ttn_ptr; do l = 1 to mrds_data_$max_temp_rels; if temp_tab_names (l) = table_name then rel_index = l; /* redefine temporary tables */ end; end; else do; allocate temp_tab_names in (lcb.static_area); lcb.ttn_ptr = ttn_ptr; do i = 1 to mrds_data_$max_temp_rels; temp_tab_names (i) = ""; end; end; desc = 4 + select_info.nsevals; /* There are 4 (+ se_vals) arguments in the call to define temp rel */ num_ptrs = desc * 2; /* Number of pointers in arg_list */ allocate arg_list in (work_area); /* System standard arg_list */ arg_list.arg_des_ptr (desc) = addr (icode); /* Pointer to return code */ n_chars_init = 1; /* Number to allocate */ allocate char_desc in (work_area); /* Character descriptors */ arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc); /* Return code descriptor */ arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* Data base index */ arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc); /* Data base index descriptor */ arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */ arg_list.code = 4; arg_list.pad = 0; /* Fill in remainder of arg_list */ char_desc.arr.var (1) = addr (select_info.se_len) -> arg_len_bits.length; /* Get length of selection expression */ arg_list.arg_des_ptr (2) = select_info.se_ptr; /* Pointer to selection expression */ arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (1)); /* Selection expression descriptor */ arg_list.arg_des_ptr (desc - 1) = addr (rel_index); /* Index returned by define_temp_rel */ arg_list.arg_des_ptr (num_ptrs - 1) = addr (char_desc.fb_desc); /* Index descriptor */ if select_info.nsevals ^= 0 then do l = 1 to select_info.nsevals; arg_list.arg_des_ptr (2 + l) = select_info.se_vals.arg_ptr (l); arg_list.arg_des_ptr (2 + l + desc) = select_info.se_vals.desc_ptr (l); end; if debug_switch then do; call ioa_ ("Selection expression:"); call mdb_display_data_value$ptr (select_info.se_ptr, addr (char_desc.arr (1))); end; if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$define_temp_rel, al_ptr); /* Call define_temp_rel */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if rel_index > mrds_data_$max_temp_rels then call error (linus_error_$dtt_max_tabs, ""); if icode = 0 then temp_tab_names (rel_index) = table_name; /* Save temporary table name */ else call error (icode, ""); do i = 2 to char_argl.nargs; if char_argl.arg_len (i) > mrds_data_$max_token_size then call error (linus_error_$dtt_key_select, "^/" || tmp_char || " is longer than " || char (mrds_data_$max_token_size) || " characters."); temp_char = rtrim (tmp_char) || "*"; curr_pos = 1; test = "0"b; curr_pos = index (sel_items, temp_char); if curr_pos > 0 then do; curr_pos = curr_pos + length (temp_char) - 2; /* -1 for the added "*" and -1 for the add producing a value one to large */ if select_info.sel_items_len > curr_pos then sel_items = /* replace the "*" following the attribute */ substr (sel_items, 1, curr_pos) || " " || substr (sel_items, curr_pos + 2); else sel_items = substr (sel_items, 1, curr_pos) || " "; end; else call error (linus_error_$dtt_key_select, "^/" || tmp_char); end; if ca_ptr ^= null then free char_argl; return; db_on: entry; /* Usage: linus_dtt$db_on Turns on a switch which cause the value of the current selection expression to be displayed at the terminal. */ debug_switch = "1"b; return; db_off: entry; /* Usage: linus_dtt$db_off Turns off the switch shich causes the value of the current selection expression to be displayed at the terminal. */ debug_switch = "0"b; return; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); if ca_ptr ^= null then free char_argl; call linus_convert_code (err_code, out_code, linus_data_$dtt_id); call ssu_$abort_line (sci_ptr, out_code, string); end error; end linus_dtt;  linus_error_.alm 11/05/86 1610.0r w 11/04/86 1038.5 135927 " *********************************************************** " * * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1981 * " * * " * * " *********************************************************** " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " LINUS Error Table 9/1/77 " 79-12-15 Rickie E. Brinegar: Modified to use et_macros and to eliminate " quotes from error messages (replaced with '), so not take as comments by " ALM. " 81-06-19 Rickie E. Brinegar: Removed the following unused codes: " cannot_ready, empty_col_value, inv_lila_set, lister_inv_ctrl_arg, " no_arg_string, no_mode, no_set_var_list, no_tabs_read, old_version, set, and " too_many_tabs. " 82-02-02 DJ Schimke: Added build_overflow for build mode " 82-02-02 DJ Schimke: Modified inv_lila_req to user tell about '?' help " feature rather than listing valid requests. " 82-24-08 Al Dupuis Added bad_option_identifier, bad_option_name, and " bad_option_value for report options. " 82-09-03 DJ Schimke: Added update_not_allowed for reporting attempts to " store, modify, or delete with only a "r" opening mode. " 83-18-02 Al Dupuis: Added bad_report_setup, bad_report_format, " and bad_report_display. " 83-08-08 Al Dupuis: Added bad_fkey_name and bad_fkey_sequence. " 83-08-29 Al Dupuis: Added no_current_query. " 83-09-30 Al Dupuis: Added bad_file_process. include et_macros et linus_error_ ec abort,abort, (Fatal error. LINUS session aborted.) ec bad_builtin_obj,badbobj, (There is an inconsistency in a LINUS builtin set function.) ec bad_comment,badcom, (A comment has been incorrectly specified.) ec bad_file_process,badflps, (An error has occured while processing the file.) ec bad_fkey_name,badfname, (An unacceptable scroll function name has been used.) ec bad_fkey_sequence,badfseq, (An unacceptable function key sequence has been used.) ec bad_inner_select,badisel, (The select clause for an inner LILA block can specify only one item.) ec bad_option_identifier,badoi, (An unacceptable option identifier has been used.) ec bad_option_name,badon, (An unacceptable option name has been used.) ec bad_option_value,badov, (An unacceptable option value has been used.) ec bad_macro_arg,badmarg, (Dummy argument incorrectly specified within macro.) ec bad_mode,badmode, (Unrecognized mode.) ec bad_num_args,badnargs, (Incorrect number of arguments has been specified for this request.) ec bad_report_display,badrpdi, (An error has occured while displaying the report.) ec bad_report_format,badrpfmt, (An error has ocurred while formatting the report.) ec bad_report_setup,badrpstp, (An error has ocurred while setting up the report.) ec bad_stmt_no,badstno, (An invalid LILA statement number has been specified.) ec build_overflow,bldovfl, (A build-generated line number exceeds the maximum of 9999.) ec cant_alloc_lit,cntallit, (LILA translator error -- unable to allocate literal.) ec cant_open,cantopen, (Unable to open database, check pathname and database access.) ec cant_ref_fun,cantrfun, (Cannot reference specified function.) ec const_expr_fn,conexfn, (An expression or scalar function has no variable arguments. Replace with a constant.) ec conv,conv, (A CONVERSION error occured.) ec dtt_key_select,dttkeyse, (A key column specified in the define temp table request is not one of the items selected by LILA.) ec dtt_max_tabs,dttmaxtb, (You have exceeded the maximum number of temporary tables allowed.) ec dtt_no_key,dttnokey, (No key column was specified for the define temp table request.) ec dtt_not_valid,dttnval, (The LILA expression is not valid for the define temporary table request.) ec dup_ctl_args,dupctlar, (Duplicate control arguments were encountered.) ec dup_row_des,duprwdes, (A row designator has been multiply defined.) ec early_end,earlyend, (The LILA expression has been prematurely terminated.) ec empty_file,emptfl, (Unexpected end of input stream.) ec exp_line_len,expllen, (A macro line has grown too large after argument substitution.) ec expr_not_alld,expnalld, (A select clause containing an expression is not allowed in a set operand.) ec expr_ovfl,exprovfl, (LILA translator error -- A table overflow has occurred while processing an expression.) ec expr_str,exprstr, (A string constant has been specified as an operand in an expression.) ec first_expr_item,ex_item, (An expression must begin with a column specification.) ec func_args_parens,funcparn, (Builtin function arguments must be enclosed by parentheses.) ec func_err,fn_err, (An error occured while evaluating a scalar function that was specified in the select clause.) ec ill_scp_op,illscpop, (Invalid LINUS scope operation.) ec incomplete_select,incsel, (A select clause is incomplete as specified.) ec incomplete_where,incwhere, (A where clause is incomplete as specified.) ec incons_args,inconarg, (Inconsistent control arguments have been specified for this request.) ec incons_fun,inconsfn, (Set function assign and calc entries are inconsistent.) ec integer_too_large,inttoolg, (An integer was given that exceeded the maximum allowable value.) ec integer_too_small,inttoosm, (An integer was given that was below the minimum allowable value.) ec inv_arg,inv_arg, (An invalid argument has been specified for a LINUS request.) ec inv_delim,invdelim, (The DELIMITER for the delimiter option was not specified.) ec inv_delimiter,inv_dm, (An invalid delimiter was specified within a LINUS request argument.) ec inv_expr,inv_expr, (An invalid LINUS expression was found.) ec inv_fn_type,invfntyp, (Function type must be either 'set' or 'scalar'.) ec inv_for_delete,invfrdel, (The LILA selection expression is not valid for delete.) ec inv_lila_req,invlireq, (Unrecognizable LILA request. Type '?' for a request list.) ec inv_lin_var,invlin, ('!' can occur only as the first character of a linus variable.) ec inv_linus_var,invlinvr, (All linus variables must begin with '!'.) ec inv_mod_expr,invmodex, (An invalid expression was found in the MODIFY request.) ec inv_mode,inv_md, (The mode specified is not valid.) ec inv_pathname,invpath, (The PATHNAME for the file option was not specified.) ec inv_req,inv_req, (Invalid LINUS request.) ec inv_sclf_args,invscfar, (The input arguments to a scalar function are invalid.) ec inv_sclf_use,invscfus, (A non-arithmetic scalar function cannot be used within a select clause expression.) ec inv_set_scope,inv_ss, (All scope definitions must be deleted before the set scope request is made.) ec inv_setfn_args,invsfarg, (The selected items are unacceptable as arguments to the specified set function.) ec inv_setfn_set,invsfset, (The specified LILA expression is not suitable as input to a set function.) ec inv_string_const,invstrco, (An invalid character or bit string constant has been found.) ec inv_table,inv_tab, (An incorrect table name was specified.) ec inv_token_type,inv_tt, (An invalid token type was found while parsing an expression.) ec inv_tup_var,inv_tvar, (All database items contained in an expression must be selected from the same table.) ec inval_ctl_arg,invcltar, (An invalid control argument has been given.) ec invalid_token,invtoken, (An unrecognizable token has been found.) ec linus_var_not_defined,lin_var, (The LINUS variable used was not previously defined.) ec lister_col_names,liscolnm, (The column names selected are not the same as the field names stored in the LISTER file.) ec lister_col_nums,liscolnu, (The number of items selected are not the same as the number of fields stored in the LISTER file.) ec long_id,longid, (An identifier longer than the maximum length has been specified.) ec long_lv_name,lglvnam, (A LINUS variable name longer than the maximum length has been specified.) ec max_req_args,maxrargs, (The maximum number of arguments for a request has been exceeded.) ec misplaced_select,miselect, (A select keyword has been detected in an invalid context.) ec misplaced_setop,missetop, (A set operator has been detected in an invalid context.) ec mod_key_col,modkey, (Modification of key column values is not permitted.) ec mod_not_valid,modnval, (The LILA expression is not valid for the modify request.) ec mrds_item_not_def,mrdsind, (A data base item specified in the MODIFY request expression was not selected via LILA.) ec mult_updt_rows,multupdt, (Update of column values from more than one row is not permitted.) ec no_comma,no_comma, (Scalar function arguments must be separated by commas.) ec no_current_query,noquery, (There are no query statements available.) ec no_data,no_data, (No data was found that satisfied the selection expression.) ec no_db,no_db, (There is no data base currently open.) ec no_from,nofrom, (No from clause has been specified.) ec no_input_arg,noinarg, (No input argument was specified for this LINUS request.) ec no_input_arg_reqd,noinargr, (No input argument was required for this LINUS request.) ec no_lila_data,nolidat, (There are no LILA statements upon which to act.) ec no_lila_expr_processed,nolilaep, (There is no LILA expression currently available.) ec no_linus_var,nolv, (There are currently no assigned values.) ec no_macro_arg,nomarg, (Required macro argument not supplied.) ec no_max_lines,nomaxlin, (The maximum line number was not specified in the PRINT request.) ec no_path,nopath, (Required pathname not specified.) ec no_report,norpt, (There is no report currently in progress.) ec no_scope,no_scope, (No scope is currently in force.) ec no_tab,no_tab, (No table name has been specified following a -table control argument.) ec no_table,notab, (No tables have been defined, probably due to an error in the from clause.) ec no_table_list,ntablist, (No table list has been specified in the from clause.) ec no_temp_tables,notmptbl, (No temporary tables exist.) ec no_var_list,novarls, (A variable list was not provided for the ASSIGN_VALUES request.) ec non_integer,non_intg, (A non integer argument was erroneously specified in a LINUS request.) ec non_numeric_argument,nonumarg, (An attempt was made to convert an non numeric argument from number to character format.) ec nonex_del,nonexdel, (An attempt has been made to delete a non-existent line.) ec null_input,null_in, (The NULL string in a modify is only permitted for character and varying bit strings.) ec one_dbitem_mod_expr,onedbime, (Only one data base item is allowed in each expression within the MODIFY request.) ec op_follow_lp,opfollp, (An operator follows a left parenthesis.) ec print_buf_ovfl,pr_ovfl, (The print request line buffer has overflowed.) ec r_scope_not_set,rscpnots, (The RETRIEVE scope operation was not set, so it cannot be deleted.) ec range_ovfl,rangovfl, (LILA translator error -- There has been an internal table overflow while processing a from clause.) ec recursed,recursed, (A previous LINUS session has not been terminated. Command rejected.) ec ret_not_valid,retnoval, (The LILA expression is not valid for retrieval.) ec scfn_nargs,scfnargs, (A scalar function invocation contains an incorrect number of arguments.) ec scfn_syntax,scfnsys, (A syntax error has been detected within a scalar function invocation.) ec sclf_null_arg,sclfnarg, (A NULL argument was found for a scalar function.) ec select_list_ovfl,sellovfl, (LILA translator error -- There has been an internal table overflow while processing a select clause.) ec select_syntax,selsyn, (A syntax error has been detected in a select clause.) ec setfn_nargs,sfnargs, (The number of selected items does not match the number of arguments required by the set function.) ec setfn_syntax,setfnsyn, (A syntax error has been detected within a set function invocation.) ec setop_ovfl,setovfl, (LILA translator error -- the set operator stack has overflowed.) ec syntax,syntax, (A syntax error has been detected.) ec table_exist,tabexist, (A table already exist with the given name.) ec table_not_ready,tabnotry, (Tables must be readied for scope_update or scope_retrieve before executing this request.) ec text_follows,texfollw, (Text follows the logical end of the LILA expression.) ec token_type_null,toktypnl, (A NULL token type was found in the expression parser for the select clause.) ec too_few_args,toofargs, (Not enough input arguments were specified for this LINUS request.) ec too_few_ctl_args,tfctlarg, (Too few control arguments were given.) ec too_few_sclf_args,fscfargs, (Too few arguments are being passed to a scalar function.) ec too_many_args,toomanya, (An invalid control argument or too many arguments were specified with this LINUS request.) ec too_many_dbs,open_dbs, (Only one data base at a time can be open during a LINUS session.) ec too_many_expr_items,expritms, (Too many items were used in an expression of a modify request.) ec too_many_invocs,toomanyi, (An attempt has been made to nest invokes too deeply.) ec too_many_sclf_args,sclfargs, (Too many arguments are being passed to a scalar function.) ec too_many_scp_ops,toomsop, (There are too many permit or prevent scope operators.) ec too_many_tables,manytbls, (Too many tables have been specified in the LILA from clause.) ec unalld_setop,unasetop, (A previous LILA block is not a valid set operand.) ec unbal_parens,unbalpar, (Parentheses do not balance.) ec unbal_quotes,ubalqts, (Quotes do not balance.) ec undef_col,undefcol, (A previously undefined column name has been encountered.) ec undef_id,undefid, (An unidentifiable identifier has been found.) ec undef_row_des,unrowdes, (A specified row designator has not been previously defined.) ec undef_tab,undeftab, (A specified table is not defined in the database.) ec undef_temp_table,undefttb, (The given temporary table is not currently defined.) ec union_compat,uncompat, (The items specified in this select clause are not union compatible with those previously specified.) ec upd_temp_tab,tempupdt, (Update operations are not permitted for temporary tables.) ec update_not_allowed,noupdate, (This operation is not valid for non-update openings.) ec var_stck_ovrflw,varstkov, (The maximum number of LINUS variables has been exceeded.) ec where_ovfl,whereovf, (LILA translator error -- There has been an internal table overflow while processing a where clause.) ec where_syntax,wheresyn, (A syntax error has been detected in a where clause.) end  linus_eval_expr.pl1 10/14/90 0931.4rew 10/14/90 0915.0 73494 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-23,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls to assign_round_ from assign_ so that selected expressions will be rounded instead of truncated. END HISTORY COMMENTS */ linus_eval_expr: proc (lcb_ptr, ex_ptr, destination_ptr, caller, index, icode); /* DESCRIPTION: Evaluate LINUS expressions. HISTORY: 77-07-01 J. C. C. Jagernauth: Initially written. 80-01-10 Rickie E. Brinegar: Modified to use the mdbm_util_$(complex number)_data_class entry points. 81-07-13 Rickie E. Brinegar: Removed trapping of conversion conditions. This is now relegated to the higher level routines. 81-10-09 Rickie E. Brinegar: changed stack from a based variable to an automatic variable to avoid area problems. */ %include linus_lcb; %page; %include linus_expression; %page; %include linus_select_info; %page; %include linus_set_fn; %page; %include linus_scal_fn; dcl 1 stack aligned, /* Operand stack aligned */ 2 nelems fixed bin, 2 operand (expression.nelems), 3 ptr ptr, 3 real real float dec (59), 3 cmpx complex float dec (59); dcl ( SCAL_FUNC init (3), OPERATOR init (15), CMPX_ASSN_TYPE init (24), REAL_ASSN_TYPE init (20) ) fixed bin int static options (constant); dcl EVAL_ITEM_ASSN_LENGTH init (59) fixed bin (35) int static options (constant); dcl ( stk_ptr init (null), destination_ptr, /* Points to scalar function, set function or select_info structure */ eval_item_assn_ptr init (null) ) ptr; dcl ( i, caller, /* 1 = from request processor, 2 = from scalar function, 3 = from set function */ eval_item_assn_type, index ) fixed bin; dcl icode fixed bin (35); dcl arith_scal_fn bit (1); /* 1 = arithmetic scalar function */ dcl cmpx bit (1); /* "1" = complex; "0" = real */ dcl ( linus_error_$inv_sclf_use, linus_error_$inv_expr ) fixed bin (35) ext; dcl linus_eval_scal_func entry (ptr, ptr, fixed bin (35)); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl ( mdbm_util_$complex_data_class, mdbm_util_$number_data_class ) entry (ptr) returns (bit (1)); dcl (addr, null) builtin; icode = 0; si_ptr, linus_set_fn_ptr, sclf_ptr, stk_ptr = null (); arith_scal_fn = "1"b; /* assume arith scalar function */ cmpx = "0"b; /* Init to real */ eval_item_assn_type = REAL_ASSN_TYPE; /* Init to real assign_ type */ stack.nelems = 0; if mdbm_util_$number_data_class (addr (expression.rslt_desc)) & mdbm_util_$complex_data_class (addr (expression.rslt_desc)) then do; cmpx = "1"b; /* Complex */ eval_item_assn_type = CMPX_ASSN_TYPE; end; do i = 1 to expression.nelems while (icode = 0); if expression.elem.type (i) = OPERATOR then call calculate; /* Evaluate */ else do; if expression.elem.type (i) = SCAL_FUNC then call linus_eval_scal_func (lcb_ptr, expression.elem.fn_ptr (i), icode); if icode = 0 & mdbm_util_$number_data_class (addr (expression.elem.desc)) then do; stack.nelems = stack.nelems + 1; /* Push item onto stack */ if cmpx then /* Type is complex */ stack.operand.ptr (stack.nelems), eval_item_assn_ptr = addr (stack.operand.cmpx (stack.nelems)); else stack.operand.ptr (stack.nelems), eval_item_assn_ptr = addr (stack.operand.real (stack.nelems)); call assign_round_ (eval_item_assn_ptr, eval_item_assn_type, EVAL_ITEM_ASSN_LENGTH, expression.elem.assn_ptr (i), expression.elem.assn_type (i), expression.elem.assn_len (i)); end; else if expression.nelems = 1 then do; /* expression should contain only one item */ arith_scal_fn = "0"b; si_ptr = destination_ptr; call assign_round_ (select_info.user_item.rslt_assn_ptr (index), select_info.user_item.rslt_assn_type (index), select_info.user_item.rslt_assn_len (index), expression.elem.assn_ptr (1), expression.elem.assn_type (1), expression.elem.assn_len (1)); end; else call error (linus_error_$inv_sclf_use); end; end; if icode ^= 0 then call error (icode); if cmpx then eval_item_assn_ptr = addr (stack.operand.cmpx (1)); else eval_item_assn_ptr = addr (stack.operand.real (1)); if arith_scal_fn then go to store_rslt (caller); else go to exit; store_rslt (1): si_ptr = destination_ptr; /* The request processor called */ call assign_round_ (select_info.user_item.rslt_assn_ptr (index), select_info.user_item.rslt_assn_type (index), select_info.user_item.rslt_assn_len (index), eval_item_assn_ptr, eval_item_assn_type, EVAL_ITEM_ASSN_LENGTH); go to exit; store_rslt (2): sclf_ptr = destination_ptr; /* A scalar function called */ call assign_round_ (scal_fn.arg.assn_ptr (index), scal_fn.arg.assn_type (index), scal_fn.arg.assn_len (index), eval_item_assn_ptr, eval_item_assn_type, EVAL_ITEM_ASSN_LENGTH); go to exit; store_rslt (3): linus_set_fn_ptr = destination_ptr; /* A set function called */ call assign_round_ (linus_set_fn.arg.assn_ptr (index), linus_set_fn.arg.assn_type (index), linus_set_fn.arg.assn_len (index), eval_item_assn_ptr, eval_item_assn_type, EVAL_ITEM_ASSN_LENGTH); exit: return; calculate: proc; /* Perform arithmetic operation on the two items on top of the operand stack */ if stack.nelems < 2 then call error (linus_error_$inv_expr); /* operation cannot be performed if stack does not have 2 items */ go to case (expression.elem.op_code (i)); case (1): if cmpx then /* ADD */ stack.operand.cmpx (stack.nelems - 1) = stack.operand.cmpx (stack.nelems - 1) + stack.operand.cmpx (stack.nelems); else stack.operand.real (stack.nelems - 1) = stack.operand.real (stack.nelems - 1) + stack.operand.real (stack.nelems); go to calculate_exit; case (2): if cmpx then /* SUBTRACT */ stack.operand.cmpx (stack.nelems - 1) = stack.operand.cmpx (stack.nelems - 1) - stack.operand.cmpx (stack.nelems); else stack.operand.real (stack.nelems - 1) = stack.operand.real (stack.nelems - 1) - stack.operand.real (stack.nelems); go to calculate_exit; case (3): if cmpx then /* MULTIPLY */ stack.operand.cmpx (stack.nelems - 1) = stack.operand.cmpx (stack.nelems - 1) * stack.operand.cmpx (stack.nelems); else stack.operand.real (stack.nelems - 1) = stack.operand.real (stack.nelems - 1) * stack.operand.real (stack.nelems); go to calculate_exit; case (4): if cmpx then /* DIVIDE */ stack.operand.cmpx (stack.nelems - 1) = stack.operand.cmpx (stack.nelems - 1) / stack.operand.cmpx (stack.nelems); else stack.operand.real (stack.nelems - 1) = stack.operand.real (stack.nelems - 1) / stack.operand.real (stack.nelems); calculate_exit: stack.nelems = stack.nelems - 1; /* Pop 1 item */ end calculate; error: proc (err_code); dcl err_code fixed bin (35); icode = err_code; go to exit; end error; end linus_eval_expr;  linus_eval_scal_func.pl1 10/14/90 0931.4rew 10/14/90 0915.0 31842 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-23,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls from assign_ to assign_round_ so that data extracted from scalar functions is rounded. END HISTORY COMMENTS */ linus_eval_scal_func: proc (lcb_ptr, sclf_ptr, icode); /* DESCRIPTION: Evaluate scalar functions. HISTORY: 77-07-01 J. C. C. Jagernuath: Initially written. 78-03-01 J. C. C. Jagernauth: Modified to recognize the function_err condition. 81-07-13 Rickie E. Brinegar: Removed conversion condition trapping. This is now relegated to higher level routines. */ %include linus_lcb; %page; %include linus_scal_fn; dcl (i, caller) fixed bin; dcl icode fixed bin (35); dcl linus_data_$eval_scal_func_id fixed bin (35) ext; dcl destination_ptr ptr; dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl cu_$gen_call entry (ptr, ptr); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); icode = 0; caller = 2; /* Inform eval_expr that a scalar function called */ destination_ptr = sclf_ptr; /* Result of eval_expr must be placed in the scalar function structure */ do i = 1 to scal_fn.nargs while (icode = 0); go to case (scal_fn.arg.type (i)); case (3): call linus_eval_scal_func (lcb_ptr, scal_fn.arg.ef_ptr (i), icode); /* Process scalar function */ go to case (6); case (4): call linus_eval_set_func (lcb_ptr, scal_fn.arg.ef_ptr (i), icode); /* Process setfunction */ go to case (6); case (5): call linus_eval_expr (lcb_ptr, scal_fn.arg.ef_ptr (i), destination_ptr, caller, i, icode); /* Process expression */ case (1): case (2): case (6): if icode = 0 then if scal_fn.arg.must_convert (i) then call assign_round_ (scal_fn.arg.arg_assn_ptr (i), scal_fn.arg.arg_assn_type (i), scal_fn.arg.arg_assn_len (i), scal_fn.arg.assn_ptr (i), scal_fn.arg.assn_type (i), scal_fn.arg.assn_len (i)); /* Convert */ end; if icode ^= 0 then call error (icode); call cu_$gen_call (scal_fn.entry_ptr, scal_fn.arg_list_ptr); /* Call scalar function */ exit: ; error: proc (err_code); dcl (err_code, out_code) fixed bin (35); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_print_error entry (fixed bin (35), char (*)); call linus_convert_code (err_code, out_code, linus_data_$eval_scal_func_id); call linus_print_error (out_code, ""); go to exit; end error; end linus_eval_scal_func;  linus_eval_set_func.pl1 10/14/90 0931.4rew 10/14/90 0915.0 63459 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-23,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls from assign_ to assign_round_. END HISTORY COMMENTS */ linus_eval_set_func: proc (lcb_ptr, linus_set_fn_ptr, icode); /* DESCRIPTION: Evaluate LINUS set functions. HISTORY: 77-07-01 J. C. C. Jagernauth: Initially written. 81-02-03 Rickie E. Brinegar: The addr builtin was added to the declarations. 81-07-13 Rickie E. Brinegar: The trapping of the conversion condition was removed. This is now relegated to higher level routines. 81-09-17 Rickie E. Brinegar: Changed the initialization of num_ptrs from 0 to arg_list.arg_count to eliminate subscript range conditions. 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the retrieve to keep linus_table from getting lost when loading in the incremental mode. */ %include linus_lcb; %page; %include linus_set_fn; %page; %include mdbm_arg_list; dcl err_flag bit (1); dcl (caller, i) fixed bin; dcl icode fixed bin (35); dcl func_code fixed bin (35) based (arg_list.arg_des_ptr (arg_list.arg_count / 2)); dcl initial_mrds_vclock float bin (63); dcl ( destination_ptr init (null), save_se_desc_ptr init (null), save_se_ptr init (null) ) ptr; dcl (addr, null, vclock) builtin; dcl ( linus_data_$eval_set_func_id, mrds_error_$tuple_not_found, sys_info$max_seg_size ) fixed bin (35) ext; dcl ANOTHER char (8) int static options (constant) init ("-another"); dcl another_len bit (36) int static options (constant) init ("101010110000000000000000000000001000"b); dcl 1 null_arg_list aligned, 2 arg_count fixed bin (17) unsigned unal init (0), 2 pad1 bit (1) unal init ("0"b), 2 call_type fixed bin (18) unsigned unal init (4), 2 desc_count fixed bin (17) unsigned unal init (0), 2 pad2 bit (19) unal init ("0"b); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl cu_$generate_call entry (entry, ptr); dcl dsl_$retrieve entry options (variable); dcl linus_table$async_retrieval entry (ptr, fixed bin (35)); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl linus_eval_scal_func entry (ptr, ptr, fixed bin (35)); al_ptr = linus_set_fn.rtrv_al_ptr; /* Get arg list for retrieve */ num_ptrs = arg_list.arg_count; save_se_ptr = arg_list.arg_des_ptr (2); save_se_desc_ptr = arg_list.arg_des_ptr (arg_list.arg_count / 2 + 2); caller = 3; /* Inform eval_expr that a set function called */ destination_ptr = linus_set_fn_ptr; /* The result of eval_expr must be placed in the set function structure */ icode, func_code = 0; err_flag = "0"b; if linus_set_fn.prior_ptr ^= null () then call linus_eval_set_func (lcb_ptr, linus_set_fn.prior_ptr, icode); if icode ^= 0 then call error (icode); call linus_table$async_retrieval (lcb_ptr, icode); if icode ^= 0 then call error (icode); if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, linus_set_fn.rtrv_al_ptr); /* Retrieve data */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if func_code = mrds_error_$tuple_not_found then err_flag = "1"b; arg_list.arg_des_ptr (2) = addr (ANOTHER); /* Set up for another retrieve */ arg_list.arg_des_ptr (arg_list.arg_count / 2 + 2) = addr (another_len); if linus_set_fn.init_entry_set then call cu_$generate_call (linus_set_fn.init_entry, addr (null_arg_list)); do while (func_code = 0 & icode = 0); do i = 1 to linus_set_fn.nargs; go to case (linus_set_fn.arg.type (i)); case (3): call linus_eval_scal_func (lcb_ptr, linus_set_fn.arg.ef_ptr (i), icode); /* Process scalar function */ go to case (6); case (4): call linus_eval_set_func (lcb_ptr, linus_set_fn.arg.ef_ptr (i), icode) ; /* Process set function */ go to case (6); case (5): call linus_eval_expr (lcb_ptr, linus_set_fn.arg.ef_ptr (i), destination_ptr, caller, i, icode);/* expr */ case (1): case (2): case (6): if icode = 0 then if linus_set_fn.arg.must_convert (i) then call assign_round_ (linus_set_fn.arg.arg_assn_ptr (i), linus_set_fn.arg.arg_assn_type (i), linus_set_fn.arg.arg_assn_len (i), linus_set_fn.arg.assn_ptr (i), linus_set_fn.arg.assn_type (i), linus_set_fn.arg.assn_len (i)); /* Convert */ end; call cu_$generate_call (linus_set_fn.calc_entry, linus_set_fn.calc_al_ptr); /* call calc entry of set function */ if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, linus_set_fn.rtrv_al_ptr); /* Retrieve another */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); end; if func_code = mrds_error_$tuple_not_found then func_code = 0; if func_code ^= 0 then call error (func_code); if icode ^= 0 then call error (icode); call cu_$generate_call (linus_set_fn.assign_entry, linus_set_fn.assign_al_ptr); /* call assign entry of set function */ if linus_set_fn.fwd_ptr ^= null () then call linus_eval_set_func (lcb_ptr, linus_set_fn.fwd_ptr, icode); /* evaluate set function at this level */ if icode ^= 0 then call error (icode); exit: ; arg_list.arg_des_ptr (2) = save_se_ptr; arg_list.arg_des_ptr (arg_list.arg_count / 2 + 2) = save_se_desc_ptr; error: proc (err_code); dcl (err_code, out_code) fixed bin (35); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_print_error entry (fixed bin (35), char (*)); if err_flag then icode = mrds_error_$tuple_not_found; else do; call linus_convert_code (err_code, out_code, linus_data_$eval_set_func_id); call linus_print_error (out_code, ""); icode = 0; end; go to exit; end error; end linus_eval_set_func;  linus_invoke.pl1 07/29/86 1045.3r w 07/29/86 0939.8 109260 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_invoke: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: This request specifies that the requests contained in the designated macro segment are to be executed. Arguments are optionally passed to the macro. This feature provides the capability to invoke a pre-defined series of LINUS requests. HISTORY: 77-06-01 J. C. C. Jagernuath: Initially written. 80-01-04 Rickie E. Brinegar: Modified to add the pop_all entry point. 80-01-15 Rickie E. Brinegar: to return an error message when the number of invokes exceed linus_data_$max_invocs. 82-02-11 Paul W. Benjamin: ssu_ conversion. 82-06-21 Al Dupuis: removed unreferenced variable iox_$user_io. 82-08-31 DJ Schimke: Replaced the calls to the undocumented entrypoint syn_$syn_attach_ with a calls to iox_$attach_ptr. Declared iox_$attach_ptr and attach_description and added the iocb include file. This is in response to phx13314. */ %include iocb; %page; %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_invoc_stack; %page; %include ssu_prompt_modes; dcl sci_ptr ptr; /* for ssu_ */ dcl STREAM_INPUT fixed bin options (constant) int static init (1); dcl path_name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1)); dcl argument char (char_argl.arg.arg_len (l)) based (char_argl.arg.arg_ptr (l)); dcl lcbpa char (16); dcl lcbpl fixed bin (21); dcl macro_path char (168); dcl macro_arg char (mac_len) based (mac_ptr); dcl popped_on_pi bit (1); dcl scipa char (16); dcl scipl fixed bin (21); dcl static_sci_ptr ptr int static; /* Change this if linus allows recursion */ dcl temp_lcb_ptr ptr; dcl tmp_char char (char_argl.arg.arg_len (l + 1)) based (char_argl.arg.arg_ptr (l + 1)); dcl attach_description char (37); /* "syn_ "||sw_name */ dcl sw_name char (32); dcl dot_linus char (6); dcl ( iocb_ptr init (null), ref_ptr init (null), mac_ptr init (null), env_ptr init (null), tmp_ptr init (null) ) ptr; dcl (l, i) fixed bin; dcl (addr, before, fixed, null, rel, substr) builtin; dcl (icode, code, mac_len, out_code) fixed bin (35); dcl ( error_table_$not_attached, linus_error_$no_input_arg, linus_error_$too_many_invocs, sys_info$max_seg_size, linus_data_$i_id, linus_data_$max_invocs ) fixed bin (35) ext; dcl cleanup condition; dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl cu_$decode_entry_value entry (entry, ptr, ptr); dcl ioa_$rsnnl entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$move_attach entry (ptr, ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$abort_subsystem entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$get_info_ptr entry (ptr) returns (ptr); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl iox_$user_input ext ptr; ca_ptr = null; mac_len, icode = 0; on cleanup call clean_up; static_sci_ptr = sci_ptr; call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then call error (linus_error_$no_input_arg, ""); if lcb.ivs_ptr ^= null then do; ivs_ptr = lcb.ivs_ptr; /* No need to allocate invoke structure */ if invoc_stack.ninvocs ^< linus_data_$max_invocs then call error (linus_error_$too_many_invocs, ""); end; else do; allocate invoc_stack in (lcb.static_area); /* Invoke stack needs to be allocated */ lcb.ivs_ptr = ivs_ptr; invoc_stack.ninvocs = 0; end; dot_linus = " "; /* Append .linus to pathname if necessary */ allocate char_argl in (lcb.static_area); do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; if char_argl.arg.arg_len (1) > 6 then dot_linus = substr (path_name, char_argl.arg.arg_len (1) - 5); if dot_linus ^= ".linus" then macro_path = path_name || ".linus"; else macro_path = path_name; call cu_$decode_entry_value (linus_invoke, ref_ptr, env_ptr); sw_name = unique_chars_ ("0"b) || ".linus_invoke";/* Unique switch name */ call ioa_$rsnnl ("^p", lcbpa, lcbpl, lcb_ptr); call ioa_$rsnnl ("^p", scipa, scipl, sci_ptr); call iox_$attach_name (sw_name, iocb_ptr, "linus_invoke_ " || macro_path || " " || substr (lcbpa, 1, lcbpl) || " " || substr (scipa, 1, scipl), ref_ptr, icode); if icode ^= 0 then call error (icode, before (macro_path, " ")); call iox_$open (iocb_ptr, STREAM_INPUT, "0"b, icode); if icode ^= 0 then call error (icode, before (macro_path, " ")); if invoc_stack.ninvocs = 0 /* save actual attachment of user_input */ then do; /* if we are grabbing it away */ sw_name = unique_chars_ ("0"b) || ".linus_input"; /* another unique switch */ /* creating a new switch */ call iox_$find_iocb (sw_name, lcb.actual_input_iocbp, icode); if icode ^= error_table_$not_attached & icode ^= 0 then call error (icode, "Creating IO control block."); call iox_$move_attach (iox_$user_input, lcb.actual_input_iocbp, icode); if icode ^= 0 then call error (icode, "Moving attachment of user input."); end; else do; call iox_$detach_iocb (iox_$user_input, icode); if icode ^= 0 then call error (icode, "Detaching user input."); end; attach_description = "syn_ " || iocb_ptr -> iocb.name; call iox_$attach_ptr (iox_$user_input, attach_description, ref_ptr, icode); if icode ^= 0 then call error (icode, "Attaching user input."); invoc_stack.ninvocs = invoc_stack.ninvocs + 1; /* Push invoke stack */ invoc_stack.invoc.iocb_ptr (invoc_stack.ninvocs) = lcb.is_ptr; lcb.is_ptr = iocb_ptr; invoc_stack.invoc.arg_ptr (invoc_stack.ninvocs) = lcb.cal_ptr; if char_argl.nargs = 1 then lcb.cal_ptr = null; else do; /* Prepare optional arguments for macro segment */ nargs_init = char_argl.nargs - 1; allocate char_argl in (lcb.static_area) set (tmp_ptr); do l = 1 to nargs_init; tmp_ptr -> char_argl.nargs = l; mac_len, tmp_ptr -> char_argl.arg.arg_len (l) = char_argl.arg.arg_len (l + 1); allocate macro_arg in (lcb.static_area); macro_arg = tmp_char; tmp_ptr -> char_argl.arg.arg_ptr (l) = mac_ptr; mac_ptr = null; end; lcb.cal_ptr = tmp_ptr; tmp_ptr = null; end; call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); /* turn off prompting */ if ca_ptr ^= null then free char_argl; return; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); call clean_up; call linus_convert_code (err_code, out_code, linus_data_$i_id); call ssu_$abort_line (sci_ptr, out_code, string); end error; clean_up: proc; dcl i fixed bin; if mac_ptr ^= null then free macro_arg; if tmp_ptr ^= null then do; do i = 1 to tmp_ptr -> char_argl.nargs; mac_ptr = tmp_ptr -> char_argl.arg.arg_ptr (i); mac_len = tmp_ptr -> char_argl.arg.arg_len (i); free macro_arg; end; free tmp_ptr -> char_argl; end; if ca_ptr ^= null then free char_argl; end clean_up; pop: entry (lcb_ptr, code); /* Pop invoke stack */ code = 0; ivs_ptr = lcb.ivs_ptr; if lcb.cal_ptr ^= null then do; do i = 1 to lcb.cal_ptr -> char_argl.nargs; mac_len = lcb.cal_ptr -> char_argl.arg.arg_len (i); mac_ptr = lcb.cal_ptr -> char_argl.arg.arg_ptr (i); free macro_arg; end; free lcb.cal_ptr -> char_argl; /* Free current argument list */ end; call iox_$close (lcb.is_ptr, icode); if icode ^= 0 then call error (icode, ""); else call iox_$detach_iocb (lcb.is_ptr, icode); if icode ^= 0 then call error (icode, ""); lcb.cal_ptr = invoc_stack.invoc.arg_ptr (invoc_stack.ninvocs); /* Pop pointer to argument list */ lcb.is_ptr = invoc_stack.invoc.iocb_ptr (invoc_stack.ninvocs); /* Pop pointer to input stream */ call iox_$detach_iocb (iox_$user_input, code); if code = 0 then do; if lcb.is_ptr ^= iox_$user_input then do; attach_description = "syn_ " || lcb.is_ptr -> iocb.name; call iox_$attach_ptr (iox_$user_input, attach_description, ref_ptr, code); end; else do; call iox_$move_attach (lcb.actual_input_iocbp, iox_$user_input, code); if code = 0 then call iox_$destroy_iocb (lcb.actual_input_iocbp, code); end; end; invoc_stack.ninvocs = invoc_stack.ninvocs - 1; if invoc_stack.ninvocs = 0 then do; free invoc_stack; lcb.ivs_ptr = null; end; return; pop_all_on_pi: /* called by ssu_ pi handler */ entry (sci_ptr); temp_lcb_ptr = ssu_$get_info_ptr (sci_ptr); popped_on_pi = "1"b; goto common_pop_all; pop_all: entry (lcb_ptr, code); /* Throw away the invoke stack */ code = 0; temp_lcb_ptr = lcb_ptr; popped_on_pi = "0"b; common_pop_all: if temp_lcb_ptr -> lcb.is_ptr ^= iox_$user_input then do; call iox_$close (temp_lcb_ptr -> lcb.is_ptr, icode); /* close and detach the current stream */ call iox_$detach_iocb (temp_lcb_ptr -> lcb.is_ptr, icode); temp_lcb_ptr -> lcb.is_ptr = iox_$user_input; if temp_lcb_ptr -> lcb.cal_ptr ^= null then do; ca_ptr = temp_lcb_ptr -> lcb.cal_ptr; do l = 1 to char_argl.nargs; free argument; end; free char_argl; temp_lcb_ptr -> lcb.cal_ptr = null; end; if temp_lcb_ptr -> lcb.ivs_ptr ^= null then do; ivs_ptr = temp_lcb_ptr -> lcb.ivs_ptr; do i = 2 to invoc_stack.ninvocs; call iox_$close (invoc_stack.invoc.iocb_ptr (i), icode); call iox_$detach_iocb (invoc_stack.iocb_ptr (i), icode); if invoc_stack.invoc.arg_ptr (i) ^= null then do; ca_ptr = invoc_stack.invoc.arg_ptr (i); do l = 1 to char_argl.nargs; free argument; end; free char_argl; end; end; free invoc_stack; temp_lcb_ptr -> lcb.ivs_ptr = null; end; call iox_$detach_iocb (iox_$user_input, icode); if icode = 0 then call iox_$move_attach (temp_lcb_ptr -> lcb.actual_input_iocbp, iox_$user_input, icode); if icode = 0 then call iox_$destroy_iocb (temp_lcb_ptr -> lcb.actual_input_iocbp, icode); if icode = 0 then do; if temp_lcb_ptr -> lcb.prompt_flag then call ssu_$set_prompt_mode (static_sci_ptr, PROMPT | DONT_PROMPT_AFTER_NULL_LINES | PROMPT_IF_TYPEAHEAD); end; else if popped_on_pi then call ssu_$abort_subsystem (sci_ptr, icode); else code = icode; end; end linus_invoke;  linus_invoke_.pl1 07/29/86 1045.3r w 07/29/86 0939.8 116847 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_invoke_: proc; /* This is the IO module that is used when a LINUS macro has been invoked via the LINUS invoke request. The user_input IO switch is attached through this module to a segment. When an get_line operation is done (by ssu_$listen or by linus_lila) 2 items of interest occur: 1) argument substitution occurs and 2) if at end of file (error_table_$end_of_info) the attachment is changed (via linus_invoke$pop) back to either another file or user_i/o. Beyond that there is nothing outstanding here, just an ordinary, pain in the backside to code and debug, IO module. It should be noted that this is NOT a general purpose IO module. It knows its caller intimately and therefore does not account for as many error situations as a general purpose IO module would. Written 82-02-22 by Paul W. Benjamin 82-03-18 DJ Schimke: Fixed bug which caused linus to blow up when a macro didn't end in a new_line character. Problem was in linus_invoke_get_line which checked for et$_end_of_info but not for et$_short_record. Fixed a stringrange error resulting from adding the NL to the get_line buffer. 82-08-31 DJ Schimke: Replaced the call to the undocumented entrypoint syn_$syn_attach_ with a call to iox_$attach_ptr. Declared iox_$attach_ptr and codeptr builtin. This is in response to phx13314. Also replaced call to old entrypoint iox_$attach_ioname with call to iox_$attach_name and replaced the declaration of iox_$attach_ioname with iox_$attach_name. */ /* Parameters */ /* These are all standard in iox_$XXX calls */ dcl iocbp ptr parameter; dcl option (*) char (*) varying parameter; dcl ignore_this bit (1) aligned parameter; /* will always be ""b */ dcl code fixed bin (35) parameter; dcl mode fixed bin parameter; dcl bufptr ptr parameter; dcl buflen fixed bin (21) parameter; dcl nread fixed bin (21) parameter; /* Automatic */ dcl attach_data_ptr ptr; dcl attach_descrip_len fixed bin; dcl attach_descrip_ptr ptr; dcl dummy_code fixed bin (35); dcl mask bit (36) aligned; dcl prompt char (64) varying; dcl rq_name char (32); dcl sci_ptr ptr; dcl source_iocbp ptr; dcl switch_name char (32); dcl 1 ti aligned, /* data structure for terminate_process_. */ 2 version fixed bin, 2 code fixed bin (35); /* Based */ dcl buf char (nread) based (bufptr); dcl 1 attach_descrip based (attach_descrip_ptr), 2 length fixed bin, 2 string char (attach_descrip_len refer (attach_descrip.length)); dcl 1 attach_data based (attach_data_ptr), 2 lcb_ptr ptr, 2 sci_ptr ptr, 2 source_iocbp ptr; /* Builtin */ dcl (addr, codeptr, fixed, length, null, rel, search, substr) builtin; /* Condition */ dcl (any_other, cleanup) condition; /* Constant */ dcl NL char (1) internal static options (constant) init (" "); /* Entries */ dcl continue_to_signal_ entry (fixed bin (35)); dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl ioa_$nnl entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$propagate entry (ptr); dcl linus_canon_input entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl linus_invoke$pop entry (ptr, fixed bin (35)); dcl ssu_$get_prompt entry (ptr) returns (char (64) varying); dcl ssu_$get_request_name entry (ptr) returns (char (32)); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl terminate_process_ entry (char (*), ptr); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* External */ dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; dcl error_table_$unable_to_do_io fixed bin (35) ext static; dcl iox_$user_input ptr ext static; dcl iox_$user_io ptr ext static; dcl linus_data_$max_invocs ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* Internal Static */ dcl 1 static_open_descrip internal static, 2 length fixed bin (17) init (12), 2 string char (12) init ("stream_input"); /* Include */ %include iocb; %include linus_lcb; %include linus_invoc_stack; %include ssu_prompt_modes; linus_invoke_attach: entry (iocbp, option, ignore_this, code); if iocbp -> iocb.attach_descrip_ptr ^= null then do; code = error_table_$not_detached; return; end; source_iocbp = null; attach_descrip_ptr = null; attach_data_ptr = null; on cleanup call janitor; switch_name = "linus_invoke_." || unique_chars_ (""b) || "_"; /* make unique switchname */ call iox_$attach_name (switch_name, source_iocbp, "vfile_ " || option (1), codeptr (linus_invoke_), code); if code ^= 0 then do; call janitor; return; end; lcb_ptr = cv_ptr_ ((option (2)), code); /* get lcbptr */ if code ^= 0 then do; call janitor; return; end; attach_descrip_len = 14 + length (option (1)); allocate attach_descrip in (lcb.static_area); attach_descrip.string = "linus_invoke_ " || option (1); allocate attach_data in (lcb.static_area); attach_data.lcb_ptr = lcb_ptr; attach_data.sci_ptr = cv_ptr_ ((option (3)), code); /* & get sci_ptr */ /* & put both in attach data (need 'em later) */ if code ^= 0 then do; call janitor; return; end; attach_data.source_iocbp = source_iocbp; call iox_$open (source_iocbp, 1, "0"b, code); /* may as well open now, too */ if code ^= 0 then do; call janitor; return; end; mask = ""b; on any_other call all_hell_broke_loose; /* this is all standard stuff */ call hcs_$set_ips_mask (""b, mask); /* when diddling iocb */ iocbp -> iocb.open = linus_invoke_open; iocbp -> iocb.detach_iocb = linus_invoke_detach; iocbp -> iocb.attach_descrip_ptr = attach_descrip_ptr; iocbp -> iocb.attach_data_ptr = attach_data_ptr; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); code = 0; return; janitor: proc; if source_iocbp ^= null then do; call iox_$close (source_iocbp, dummy_code); call iox_$detach_iocb (source_iocbp, dummy_code); call iox_$destroy_iocb (source_iocbp, dummy_code); end; if attach_descrip_ptr ^= null then free attach_descrip; if attach_data_ptr ^= null then free attach_data; end janitor; linus_invoke_open: entry (iocbp, mode, ignore_this, code); if iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr ^= null then do; code = error_table_$not_closed; return; end; mask = ""b; on any_other call all_hell_broke_loose; call hcs_$set_ips_mask (""b, mask); iocbp -> iocb.actual_iocb_ptr -> iocb.get_line = linus_invoke_get_line; iocbp -> iocb.actual_iocb_ptr -> iocb.close = linus_invoke_close; iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (static_open_descrip); call iox_$propagate (iocbp -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; linus_invoke_get_line: entry (iocbp, bufptr, buflen, nread, code); lcb_ptr = iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> attach_data.lcb_ptr; sci_ptr = iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> attach_data.sci_ptr; call iox_$get_line (iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> attach_data.source_iocbp, bufptr, buflen, nread, code); if code = error_table_$end_of_info | code = error_table_$short_record then do; if nread > 0 /* file didn't end in NL */ then do; if nread = buflen then code = error_table_$long_record; else do; code = 0; nread = nread + 1; substr (buf, nread, 1) = NL; call to_pop_or_not_to_pop; /* reset 'cause we WERE at EOF */ end; return; end; call to_pop_or_not_to_pop; if lcb.is_ptr ^= iox_$user_input /* read from previous macro */ then call iox_$get_line (iocbp, bufptr, buflen, nread, code); else do; rq_name = ssu_$get_request_name (sci_ptr); if rq_name = "" /* called by ssu_$listen */ then do; if lcb.prompt_flag /* prompt if appropriate */ then do; prompt = ssu_$get_prompt (sci_ptr); call ioa_$nnl (prompt, "0"b, 1); end; code = 0; /* fake blank line */ nread = 1; buf = " "; end; else if rq_name = "lila" /* lila would like a blank line here, too */ then do; code = 0; nread = 1; buf = " "; end; /* Must have been in an editor or something, * just do another read */ else call iox_$get_line (iocbp, bufptr, buflen, nread, code); end; return; end; if search (buf, "%/") > 0 /* arguments or comments */ then call linus_canon_input (lcb_ptr, bufptr, nread, code); return; to_pop_or_not_to_pop: proc; if lcb.ivs_ptr ^= null then if lcb.ivs_ptr -> invoc_stack.ninvocs > 0 then do; if lcb.prompt_flag & lcb.ivs_ptr -> invoc_stack.ninvocs = 1 then call ssu_$set_prompt_mode (sci_ptr, PROMPT | DONT_PROMPT_AFTER_NULL_LINES | PROMPT_IF_TYPEAHEAD); call linus_invoke$pop (lcb_ptr, code); /* reset to previous input stream */ end; else do; if lcb.prompt_flag then call ssu_$set_prompt_mode (sci_ptr, PROMPT | DONT_PROMPT_AFTER_NULL_LINES | PROMPT_IF_TYPEAHEAD); call iox_$detach_iocb (iox_$user_input, code); if code ^= 0 then return; call iox_$attach_ptr (iox_$user_input, "syn_ user_i/o", codeptr (linus_invoke_), code); if code ^= 0 then return; lcb.is_ptr = iox_$user_input; end; end to_pop_or_not_to_pop; linus_invoke_close: entry (iocbp, code); call iox_$close (iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> attach_data.source_iocbp, code); mask = ""b; on any_other call all_hell_broke_loose; call hcs_$set_ips_mask (""b, mask); iocbp -> iocb.actual_iocb_ptr -> iocb.open = linus_invoke_open; iocbp -> iocb.actual_iocb_ptr -> iocb.detach_iocb = linus_invoke_detach; iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null; call iox_$propagate (iocbp -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); return; linus_invoke_detach: entry (iocbp, code); attach_data_ptr = iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; attach_descrip_ptr = iocbp -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr; lcb_ptr = attach_data_ptr -> attach_data.lcb_ptr; source_iocbp = attach_data_ptr -> attach_data.source_iocbp; call iox_$detach_iocb (attach_data_ptr -> attach_data.source_iocbp, code); mask = ""b; on any_other call all_hell_broke_loose; call hcs_$set_ips_mask (""b, mask); iocbp -> iocb.attach_descrip_ptr = null; call iox_$propagate (iocbp -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); revert any_other; call janitor; return; all_hell_broke_loose: proc; if mask /* If we are in critical section of manipulating */ then do; ti.version = 0; /* the iocb, then kill the process when a fault */ ti.code = error_table_$unable_to_do_io; /* comes unexpectedly. */ call terminate_process_ ("fatal_error", addr (ti)); end; call continue_to_signal_ (0); /* otherwise pass on the error. */ end all_hell_broke_loose; end linus_invoke_;  linus_lila.pl1 07/29/86 1045.3r w 07/29/86 0939.8 285678 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila: proc (sci_ptr_parm, lcb_ptr_parm); %skip(3); dcl lcb_ptr_parm ptr parm; dcl sci_ptr_parm ptr parm; %skip(1); /* DESCRIPTION: This procedure functions as an extremely simple-minded editor, used in entering and manipulating lila expressions. This editor looks very much like a subset of the editor in the basic system, and uses a vfile_ keyed sequential file to hold the text. The contents of this file are retained from one invocation of lila to the next, and the file is refreshed only if a -new control argument is specified in the LINUS "lila" request or the LILA "new" request is specified. HISTORY: 77-04-01 J. A. Weeldreyer: Initially written. 79-12-04 Rickie E. Brinegar: Modified to return to linus request level when a macro is invoked with too few arguments. 80-04-12 Rickie E. Brinegar: Modified to use linus_define_area instead of get_system_free_area_. 81-02-03 Rickie E. Brinegar: removed unreferenced variable sex. Added rel builtin to the declarations. 81-04-10 Rickie E. Brinegar: changed linus version number from 2 to 3.0. 81-07-14 Rickie E. Brinegar: added conversion condition trap. 81-10-07 Rickie E. Brinegar: changed linus_translate to linus_lila_translate to make it a LILA module as only LILA calls it. 81-11-06 Rickie E. Brinegar: Removed the calls to linus_free_se as the allocation of the selection expression is now in the lila temporary segment instead of the lcb.static area. 82-01-29 DJ Schimke: Implemented build mode (automatic line numbering). Added build, last_line_num, and write_line (pulled from process_line) internal procedures. This is in response to PFS 4.9.5 for MR10. 82-02-01 DJ Schimke: Added "new" request to delete the existing LILA file. This was added to compliment the build request. 82-02-03 DJ Schimke: Added "list_requests" and "?" requests to help the user. Changed the inv_lila_req error message to inform the user about "?". Added "sv" short name to save request for convenience. 82-02-08 Paul W. Benjamin: Conversion of LINUS (not lila) to ssu_. 82-06-22 DJ Schimke: Changed lila to not abort the linus invocation when the get_line calls return a linus_err_$no_macro_arg error code. 82-08-30 DJ Schimke: Modified lila build mode prompt to contain an asterisk at the end rather than a space if the line which is being input will overwrite an existing text line. Also improved the build (request & ctl_arg) parameter processing code to eliminate a logic error and clean it up. 82-12-06 DJ Schimke: Modified lila to not prompt if the prompt string is just blanks (null character string). Also added the -prompt and -no_prompt control args which override the currrent subsystem prompting flag. Fixes an annoying problem when using the new exec_com facility in linus. 83-02-10 DJ Schimke: Removed a call to linus_canon which was meant to be removed as part of the ssu conversion. Because the calling sequence for linus_canon was changed as part of the ssu conversion, we were getting fault tag 1 errors.The linus_invoke_ module calls linus_canon to expand macro args so this module no longer needs to worry about them. 83-03-24 DJ Schimke: Added code to set lcb.si_ptr to null when a user tries to proc with a null lila file. 83-08-23 Al Dupuis: Added the initialize_lila_file entry as part of the input_query work. The main entry point used to use sci_ptr and lcb_ptr as parms instead of the automatic ptrs they should have been, so I changed it so the parms are now declared explicitely and moved to the auto ptrs. 83-08-30 Bert Moberg: Added code for the translate_query request work. */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_rel_array; dcl sci_ptr ptr; /* for ssu_ */ dcl ( nread, /* number of chars in input line */ rec_len, /* no. of chars in lila record */ read_len ) fixed bin (21); /* no. of chars read from lila file */ dcl cmd_len fixed bin; dcl ( ref_ptr init (null), /* referencing ptr for calls */ ica_ptr init (null), /* ptr to char_argl for invoke */ acmd_ptr init (null), /* for escaping to command processor */ siocb_ptr init (null), /* save iocb pointer */ env_ptr init (null) ) ptr; /* sink for environment ptr */ dcl ( code, /* status code */ icode ) fixed bin (35); /* internal status code */ dcl aligned_cmd char (cmd_len) based (acmd_ptr); dcl arg char (char_argl.arg.arg_len (arg_index)) based (char_argl.arg.arg_ptr (arg_index)); /* input arg */ dcl arg_index fixed bin; /* arg index */ dcl atd char (173); /* save attach desc */ dcl build_increment fixed bin; /* current increment */ dcl build_mode bit (1); /* on if in build mode */ dcl next_build_line pic "9999"; /* next automatic line number*/ dcl chars (nread) char (1) unal based (lcb.rb_ptr); /* another version of request */ dcl control_arg bit (1) unal; /* control arg flag */ dcl done bit (1) unal; /* completion flag */ dcl lila_prompt_flag bit (1) unal; /* -prompt/-no_prompt flag */ dcl i fixed bin; /* index for do */ dcl key pic "9999"; /* line number */ dcl key_var char (256) var; /* var. version of line no. */ dcl parameter fixed bin; /* parameter to request or control arg */ dcl parameter_number fixed bin; /* parameter index */ dcl prompt_char char (32) varying based (lcb.lila_promp_chars_ptr); dcl req_index fixed bin (17); /* loop index */ dcl request char (nread) based (lcb.rb_ptr); /* input line */ dcl request_count fixed bin init (11) int static options (constant); dcl 1 request_table (request_count) aligned, /* table of requests and short names */ /* Must be changed whenever requests are added. */ 2 name char (15) var init (".", "?", "build", "execute", "invoke", "list_requests", "list", "new", "proc", "quit", "save"), 2 short char (5) var init ("", "", "", "e", "i", "lr", "ls", "", "", "q", "sv"), 2 summary char (60) var init ("Print the current lila status.", "List all lila request names.", "Enter build mode to insert/overwrite text.", "Execute a Multics command line.", "Invoke the specified Linus macro.", "List brief information on lila requests.", "List the current file.", "Delete all text from the current lila file.", "Process the current lila file.", "Leave LILA.", "Save the current text into the specified linus macro." ); dcl token char (15) var; /* first token in lila line */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl 1 list_buf aligned, 2 key char (4) unal, 2 data char (256) unal; dcl WHT_SPC char (3) int static options (constant) init (" "); /* NL, SP, HT */ dcl NO_KILL fixed bin (35) int static options (constant) init (0); dcl KILL fixed bin (35) int static options (constant) init (1); dcl NL char (1) int static options (constant) init (" "); dcl BOF fixed bin int static options (constant) init (-1); dcl KSU fixed bin int static options (constant) init (10); dcl SO fixed bin int static options (constant) init (2); dcl ( error_table_$end_of_info, error_table_$no_record, linus_data_$lila_id, linus_error_$bad_stmt_no, linus_error_$build_overflow, linus_error_$conv, linus_error_$integer_too_large, linus_error_$integer_too_small, linus_error_$inv_arg, linus_error_$inv_lila_req, linus_error_$no_db, linus_error_$no_lila_data, linus_error_$no_macro_arg, linus_error_$no_path, linus_error_$nonex_del, linus_error_$non_integer, linus_error_$bad_num_args, sys_info$max_seg_size ) ext fixed bin (35); dcl ( iox_$user_input, iox_$user_output ) ptr ext; dcl (cleanup, conversion) condition; dcl (addr, after, bin, char, divide, before, fixed, index, length, ltrim, mod, null, rel, rtrim, search, substr, string, verify) builtin; /* Multics Subroutines */ dcl cu_$cp entry (ptr, fixed bin, fixed bin (35)); dcl cu_$decode_entry_value entry (entry, ptr, ptr); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$nnl entry options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$delete_record entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$read_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl get_pdir_ entry returns (char (168)); dcl ssu_$abort_line entry options (variable); dcl ssu_$abort_subsystem entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* LINUS/MRDS Subroutines */ dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_invoke$pop_all entry (ptr, fixed bin (35)); dcl linus_print_error entry (fixed bin (35), char (*)); dcl linus_translate_query$proc entry (ptr, fixed bin (35)); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; build_mode = "0"b; /* initialize */ lila_prompt_flag = lcb.prompt_flag; ica_ptr, siocb_ptr = null; call cu_$decode_entry_value (linus_lila, ref_ptr, env_ptr); /* for later calls */ on cleanup call tidy_up; on conversion call error (linus_error_$conv, "", NO_KILL); ca_ptr = null; if lcb.db_index = 0 then call error (linus_error_$no_db, "", NO_KILL); call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init ^= 0 /* if have arg */ then do; allocate char_argl in (lcb.static_area); do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; do arg_index = 1 to char_argl.nargs; /* request arg loop */ if arg = "-new" then do; /* if -new, must start with new file */ if lcb.liocb_ptr = null /* no old file */ then call init_lila_file;/* just make new one */ else if lcb.lila_count > 0 then call delete_old_file; /* delete old data */ end; /* -new */ else if arg = "-no_prompt" then lila_prompt_flag = "0"b; /* if -no_prompt */ else if arg = "-prompt" then lila_prompt_flag = "1"b; /* if -prompt */ else if arg = "-build" then do; /* if -build */ build_increment = lcb.build_increment; /* default */ next_build_line = 0; /* init */ parameter_number = 1; control_arg = "0"b; do while ((arg_index + 1 <= char_argl.nargs) & (^control_arg)); arg_index = arg_index + 1; /* look at next arg */ parameter = cv_dec_check_ (arg, code); if code ^= 0 then do; control_arg = "1"b; arg_index = arg_index - 1; end; else do; /* have parameters */ if (parameter < 1) then call error (linus_error_$integer_too_small, arg, NO_KILL); if (parameter > 9999) then call error (linus_error_$integer_too_large, arg, NO_KILL); if parameter_number = 1 then next_build_line = parameter; else if parameter_number = 2 then build_increment = parameter; else call error (linus_error_$bad_num_args, "^/""-build"" allows a maximum of two parameters. " || arg, NO_KILL); /* no third parameter allowed */ parameter_number = parameter_number + 1; end; /* have parameters */ end; /* do while */ build_mode = "1"b; end; /* if -build */ else call error (linus_error_$inv_arg, arg, NO_KILL); end; /* request loop */ end; /* if have arg */ if build_mode then call set_build_start ("0"b); if lcb.liocb_ptr = null then /* if no lila file */ call init_lila_file; /* make one */ done = "0"b; /* init completion flag */ code = 0; do while (^done); /* until user types end */ if build_mode then call build; /* building */ if lila_prompt_flag then do; /* if prompting */ if lcb.is_ptr = iox_$user_input & prompt_char ^= "" then call ioa_$nnl ("^a ", prompt_char); end; call iox_$get_line (iox_$user_input, lcb.rb_ptr, lcb.rb_len, nread, icode); /* read next line */ if icode = linus_error_$no_macro_arg then /* if no_macro arg */ call error (icode, "reading LILA build text", NO_KILL); else if icode ^= 0 then /* if other error */ call error (icode, "reading LILA text", KILL); else call process_line; /* if OK */ if lcb.is_ptr ^= iox_$user_input & code ^= 0 then do; call linus_invoke$pop_all (lcb_ptr, icode); call tidy_up; end; end; /* main LILA loop */ code = 0; exit: if ca_ptr ^= null then free char_argl; if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code); return; %page; initialize_lila_file: entry ( lcb_ptr_parm /* input: ptr to the linus control block */ ); %skip(3); lcb_ptr = lcb_ptr_parm; sci_ptr = lcb.subsystem_control_info_ptr; if lcb.liocb_ptr = null () then call init_lila_file; else call delete_old_file; lcb.lila_chars = 0; lcb.lila_count = 0; %skip(1); return; error: proc (icode, msg, fatal_flag); /* Error procedure, calls convert_code and print_error and then returns. */ dcl (ucode, icode, fatal_flag) fixed bin (35); dcl msg char (*); if lcb.is_ptr ^= iox_$user_input then call linus_invoke$pop_all (lcb_ptr, code); call linus_convert_code (icode, ucode, linus_data_$lila_id); code = fatal_flag; call tidy_up; if fatal_flag = NO_KILL then call ssu_$abort_line (sci_ptr, ucode, msg); else call ssu_$abort_subsystem (sci_ptr, ucode, msg); end error; tidy_up: proc; /* procedure to clean up if interrupted */ if (icode ^= 0 | code ^= 0) & ^lcb.prompt_flag then call linus_print_error (0, "Returning to linus request level."); if ca_ptr ^= null then free char_argl; if siocb_ptr ^= null then do; /* if open save switch */ call iox_$close (siocb_ptr, icode); call iox_$detach_iocb (siocb_ptr, icode); end; end tidy_up; process_line: proc; /* Procedure to process a LILA input line */ dcl (i, j) fixed bin; i = verify (request, WHT_SPC); /* search for first data */ if i <= 0 then return; /* was null line */ j = search (substr (request, i), WHT_SPC); /* look for end of token */ if j <= 0 then j = nread - i + 1; /* was at end of request */ else j = j - 1; token = substr (request, i, j); /* isolate line no. or request */ if token >= "0" & token <= "9999" then do; /* token may be number */ if verify (token, "0123456789") ^= 0 /* if not really numeric */ | length (token) > 4 then do; /* or too many digits */ call linus_print_error (linus_error_$bad_stmt_no, (token)); return; end; key = fixed (token); /* canonize to 4 digits */ i = i + j; /* first char beyond stmt no. */ j = verify (substr (request, i), WHT_SPC); /* search for data following stmt no. */ if j <= 0 then do; /* no more data, is delete */ call iox_$seek_key (lcb.liocb_ptr, (key), rec_len, icode); /* find the line */ if icode ^= 0 then /* if not found */ call linus_print_error (linus_error_$nonex_del, (token)); else do; /* found the line, delete it */ lcb.si_ptr = null; /* force new proc */ call iox_$delete_record (lcb.liocb_ptr, icode); if icode ^= 0 then /* problems */ call error (icode, "", KILL); lcb.lila_chars = lcb.lila_chars - rec_len; /* decr. char count */ lcb.lila_count = lcb.lila_count - 1; /* decrement line count */ end; /* line deletion */ end; /* delete operation */ else call write_line ((key), addr (chars (i)), nread - i + 1); /* source line specified */ end; /* if key is possible number */ else if token = "." then /* user wants reassurance */ call ioa_ ("linus version ^a (lila)", lcb.linus_version); else if token = "list" | token = "ls" then do; /* user wants list of file */ if lcb.lila_count <= 0 then /* no lines in file */ call linus_print_error (linus_error_$no_lila_data, request); else call list_file (iox_$user_output); /* there is data, list it */ end; /* list command */ else if token = "proc" then do; /* user wants to translate */ call linus_translate_query$proc (lcb_ptr, code); /* create MRDS selection expression */ if code ^= 0 then go to exit; end; /* processing end */ else if token = "quit" | token = "q" then done = "1"b; else if token = "invoke" | token = "i" then do; /* process invoke request */ call ssu_$execute_line (sci_ptr, lcb.rb_ptr, nread, icode); if icode ^= 0 then go to exit; ica_ptr = null; end; /* invoke */ else if token = "save" | token = "sv" then do; /* process save */ if lcb.lila_count <= 0 then call linus_print_error (linus_error_$no_lila_data, request); else do; /* if have lines to save */ call get_token; if j > 0 then do; /* if path supplied */ if substr (request, i + j - 6, 6) = ".linus" then /* if suffix spec. */ atd = "vfile_ " || substr (request, i, j); else atd = "vfile_ " || substr (request, i, j) || ".linus"; call iox_$attach_name (unique_chars_ ("0"b) || ".lila_save", siocb_ptr, atd, ref_ptr, icode); if icode ^= 0 then call soft_error (icode, atd); call iox_$open (siocb_ptr, SO, "0"b, icode); if icode ^= 0 then call soft_error (icode, atd); call list_file (siocb_ptr); /* list into save file */ call iox_$close (siocb_ptr, icode); if icode ^= 0 then call soft_error (icode, atd); call iox_$detach_iocb (siocb_ptr, icode); if icode ^= 0 then call soft_error (icode, atd); siocb_ptr = null; end; /* if path supplied */ else call soft_error (linus_error_$no_path, (token)); end; /* if have lines to save */ end; /* save */ else if token = "e" | token = "execute" | index (token, "..") = 1 then do; cmd_len = nread; allocate aligned_cmd in (work_area); if index (token, "..") = 1 then token = ".."; aligned_cmd = ltrim (after (request, rtrim (token))); call cu_$cp (acmd_ptr, cmd_len, icode); acmd_ptr = null; end; else if token = "build" then do; /* build request */ build_increment = lcb.build_increment; /* default */ next_build_line = 0; /* init */ call get_token; parameter_number = 1; do while (j > 0); /* while we have parameters */ parameter = cv_dec_check_ (substr (request, i, j), code); if code ^= 0 then call soft_error (linus_error_$non_integer, substr (request, i, j)); if (parameter < 1) then call soft_error (linus_error_$integer_too_small, substr (request, i, j)); if (parameter > 9999) then call soft_error (linus_error_$integer_too_large, substr (request, i, j)); if parameter_number = 1 then next_build_line = parameter; else if parameter_number = 2 then build_increment = parameter; else call soft_error (linus_error_$bad_num_args, "^/""build"" allows a maximum of two parameters. " || substr (request, i, j)); /* no third parameter allowed */ call get_token; parameter_number = parameter_number + 1; end; /* have parameters */ build_mode = "1"b; call set_build_start ("1"b); end; /* build request */ else if token = "new" then do; /* new file request */ if lcb.lila_count > 0 then call delete_old_file; /* delete old text file */ end; else if token = "?" then do; /* list requests */ call ioa_ ("^/Available lila requests:^/"); /* in 3 columns */ do req_index = 1 to divide (request_count, 3, 17) * 3 by 3; call ioa_ ( "^a^[^s^;, ^a^]^[^25t^a^[^s^;, ^a^]^[^50t^a^[^s^;, ^a^]^]^]", request_table.name (req_index), (request_table.short (req_index) = ""), request_table.short (req_index), (req_index + 1 <= request_count), request_table.name (req_index + 1), (request_table.short (req_index + 1) = ""), request_table.short (req_index + 1), (req_index + 2 <= request_count), request_table.name (req_index + 2), (request_table.short (req_index + 2) = ""), request_table.short (req_index + 2)); end; if mod (request_count, 3) = 2 then call ioa_ ("^a^[^s^;, ^a^]^25t^a^[^s^;, ^a^]", request_table.name (req_index), (request_table.short (req_index) = ""), request_table.short (req_index), request_table.name (req_index + 1), (request_table.short (req_index + 1) = ""), request_table.short (req_index + 1)); if mod (request_count, 3) = 1 then call ioa_ ("^a^[^s^;, ^a^]", request_table.name (req_index), (request_table.short (req_index) = ""), request_table.short (req_index)); call ioa_ ( "^/Type ""list_requests"" for a short description of the requests.^/" ); end; else if token = "list_requests" | token = "lr" then do; /* list requests briefly */ call ioa_ ("^/Summary of lila requests:"); call ioa_ ( "^/Use "".. COMMAND_LINE"" to escape a command line to Multics.^/") ; do req_index = 1 to request_count; call ioa_ ("^a^[^s^;, ^a^]^20t^a", request_table.name (req_index), (request_table.short (req_index) = ""), request_table.short (req_index), request_table.summary (req_index)); end; call ioa_ ( "^/Type ""help"" at LINUS request level for more information.^/"); end; else /* invalid LILA request */ call linus_print_error (linus_error_$inv_lila_req, (" bad request: " || token)); list_file: proc (iocb_ptr); /* Procedure to write the LILA file to a stream file */ dcl iocb_ptr ptr; call iox_$position (lcb.liocb_ptr, BOF, 0, icode);/* to start of file */ if icode ^= 0 then call error (icode, "", KILL); do while (icode = 0); /* read and print each line */ string (list_buf) = " "; /* clear the print line */ call iox_$read_key (lcb.liocb_ptr, key_var, rec_len, icode); if icode = 0 then do; call iox_$read_record (lcb.liocb_ptr, addr (list_buf.data), rec_len, read_len, icode); if icode = 0 then do; list_buf.key = key_var; call ioa_$ioa_switch (iocb_ptr, "^a", before (string (list_buf), NL)); end; /* printing line */ end; /* reading line data */ end; /* loop through file */ if icode ^= error_table_$end_of_info then call error (icode, "", KILL); end list_file; get_token: proc; /* Procedure to get index and length of next token in request */ i = i + j; /* first char past token */ if i <= nread then do; /* if still within request */ j = verify (substr (request, i), WHT_SPC); /* first char of next token */ if j > 0 then do; /* if found another token */ i = i + j - 1; /* ditto */ j = search (substr (request, i), WHT_SPC); /* get length */ if j <= 0 then j = nread - i + 1; else j = j - 1; end; /* if found another token */ end; /* if still within request */ else j = 0; end get_token; soft_error: proc (cd, msg); /* Procedure to fail very softly */ dcl (cd, ucd) fixed bin (35); dcl msg char (*); call linus_convert_code (cd, ucd, linus_data_$lila_id); call linus_print_error (ucd, msg); go to pl_exit; end soft_error; pl_exit: end process_line; init_lila_file: proc; /* Procedure to create and init a keyed seq. file to contain lila statements. */ lcb.lila_fn = unique_chars_ ("0"b) || ".lila"; /* name of file */ call iox_$attach_name (unique_chars_ ("0"b) || ".lila_switch", lcb.liocb_ptr, "vfile_ " || before (get_pdir_ (), " ") || ">" || lcb.lila_fn, ref_ptr, icode); if icode ^= 0 then call error (icode, "", KILL); call iox_$open (lcb.liocb_ptr, KSU, "0"b, icode); if icode ^= 0 then call error (icode, "", KILL); else do; /* init */ call write_line ((1), addr (chars (1)), 0); call delete_old_file; end; end init_lila_file; delete_old_file: proc; /* Procedure to delete existing lines from a lila file */ lcb.si_ptr = null; /* force new proc */ call iox_$position (lcb.liocb_ptr, BOF, 0, icode);/* start from BOF */ if icode ^= 0 then call error (icode, "", KILL); do while (icode = 0); /* delete all lines */ call iox_$delete_record (lcb.liocb_ptr, icode); end; if icode ^= error_table_$no_record then call error (icode, "", KILL); lcb.lila_chars, lcb.lila_count = 0; /* indicate true line and char count */ end delete_old_file; write_line: proc (source_key, source_ptr, source_len); /* procedure to insert a new lila source line */ /* (or replace an old lila source line) */ dcl source_key pic "9999" parameter; /* line number */ dcl source_ptr ptr parameter; /* ptr to input string */ dcl source_len fixed bin (21) parameter; /* length of input string */ lcb.si_ptr = null; /* force new proc */ call iox_$seek_key (lcb.liocb_ptr, (source_key), rec_len, icode); /* see if line exists */ if icode = 0 then do; /* line exists, change it */ call iox_$rewrite_record (lcb.liocb_ptr, source_ptr, source_len, icode); if icode ^= 0 then call error (icode, "", KILL); lcb.lila_chars = lcb.lila_chars - rec_len + source_len; end; /* changing line */ else if icode = error_table_$no_record then do; /* is new line, write it */ call iox_$write_record (lcb.liocb_ptr, source_ptr, source_len, icode); if icode ^= 0 then call error (icode, "", KILL); lcb.lila_chars = lcb.lila_chars + source_len; lcb.lila_count = lcb.lila_count + 1; /* increment line count */ end; /* writing new line */ else call error (icode, "", KILL); /* problems */ end write_line; build: proc; /* procedure to handle input during "build" */ do while (build_mode); if lcb.is_ptr = iox_$user_input then do; /* prompt */ call iox_$seek_key (lcb.liocb_ptr, (next_build_line), rec_len, icode); if icode = 0 then call ioa_$nnl ("^a*", next_build_line); /* line exists */ else call ioa_$nnl ("^a ", next_build_line); end; call iox_$get_line (iox_$user_input, lcb.rb_ptr, lcb.rb_len, nread, icode); /* read next line */ if icode = linus_error_$no_macro_arg then /* if no_macro arg */ call error (icode, "reading build text", NO_KILL); else if icode ^= 0 then /* if other error */ call error (icode, "reading build text", KILL); if verify (request, WHT_SPC) > 0 then do; /* wasn't null line */ if substr (request, 1, nread - 1) = "." then build_mode = "0"b; /* done */ else do; /* build input line */ nread = nread + 1; request = " " || substr (request, 1, nread - 1); call write_line ((next_build_line), addr (chars (1)), nread); /* write the line */ if next_build_line + build_increment > 9999 then do; /* line number grew too big */ build_mode = "0"b; /* must stop */ call linus_print_error (linus_error_$build_overflow, char (next_build_line + build_increment)); end; else next_build_line = next_build_line + build_increment; /* increment automatic line */ end; /* build input line */ end; end; end build; last_line_num: proc returns (pic "9999"); /* Procedure to return the last (largest) line number in the current lila */ /* selection expression. */ dcl line_number pic "9999"; dcl line_number_key char (256) var; dcl EOF fixed bin int static options (constant) init (+1); if lcb.lila_count = 0 then line_number = 0; else do; call iox_$position (lcb.liocb_ptr, EOF, 0, icode); if icode ^= 0 then call error (icode, "", NO_KILL); call iox_$position (lcb.liocb_ptr, 0, -1, icode); if icode ^= 0 then call error (icode, "", NO_KILL); call iox_$read_key (lcb.liocb_ptr, line_number_key, rec_len, icode); if icode ^= 0 then call error (icode, "", NO_KILL); line_number = bin (line_number_key); end; return (line_number); end last_line_num; set_build_start: proc (request); dcl request bit(1) unal parm; if next_build_line = 0 then do; next_build_line = last_line_num (); if next_build_line + build_increment <= 9999 then next_build_line = next_build_line + build_increment; /* default start is offset from current largest line num */ else do; /* error */ build_mode = "0"b; if ^request then call error (0, "The build increment (" || ltrim (char (build_increment)) || ") is too large.", NO_KILL); call linus_print_error (linus_error_$integer_too_large, "The build increment (" || ltrim (char (build_increment)) || ") is too large."); return; end; end; end set_build_start; end linus_lila;  linus_lila_alloc_lit.pl1 07/29/86 1045.3r w 07/29/86 0939.8 29448 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_alloc_lit: proc (lcb_ptr, desc_ptr, lit_ptr, bit_len); /* DESCRIPTION: Procedure to allocate space for a literal in the literal string, given a descriptor pointer. A pointer and bit are returned. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 80-01-09 Rickie E. Brinegar: to accept a descriptor pointer rather than an assign_ descriptor type, and eliminate the need of a length parameter. 81-02-24 Rickie E. Brinegar: the set entry point was removed. Both linus_set and linus_assign_values (the only two modules that referenced that entry point) were modified to do their own allocation and freeing. 81-11-06 Rickie E. Brinegar: Removed unreferenced mod builtin function. */ %include linus_lcb; %page; %include linus_lit_string; dcl (desc_ptr, lit_ptr) ptr; /* INPUT POINTERS */ dcl bit_len fixed bin (35); dcl desc bit (36) based (desc_ptr); dcl initial_mrds_vclock float bin (63); dcl mdbm_util_$align_data_item entry (ptr, fixed bin (35)) returns (fixed bin (35)); dcl mdbm_util_$get_data_bit_length entry (bit (36)) returns (fixed bin (35)); dcl ( linus_data_$lit_string_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl (null, addr, fixed, rel, vclock) builtin; dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); if lcb.lit_ptr = null then do; /* if literal pool not yet allocated */ allocate lit_string in (work_area); lit_string = "0"b; lcb.curr_lit_offset = 0; end; if lcb.timing_mode then initial_mrds_vclock = vclock; lcb.curr_lit_offset = lcb.curr_lit_offset + mdbm_util_$align_data_item (desc_ptr, lcb.curr_lit_offset); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); lit_ptr = addr (lit_array (lcb.curr_lit_offset)); if lcb.timing_mode then initial_mrds_vclock = vclock; bit_len = mdbm_util_$get_data_bit_length (desc); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if lcb.curr_lit_offset + bit_len - 1 > linus_data_$lit_string_size then lit_ptr = null; else lcb.curr_lit_offset = lcb.curr_lit_offset + bit_len; /* keep offset current */ return; end linus_lila_alloc_lit;  linus_lila_block.pl1 07/29/86 1045.3rew 07/29/86 0936.9 138735 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-01-13,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): 84-12-28 Matthew Pierret: Changed to use linus_lila_tokens_ external variables instead of hard-coding reserved words into the code. END HISTORY COMMENTS */ linus_lila_block: proc (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, code); /* DESCRIPTION: This procedure is the top level procedure for the translation of a LILA block. It calls linus_lila_from, linus_lila_select, and linus_lila_where to process the from, select, and where clauses respectively. Then, if invoked to process an outer block, it combines the translated clauses to form one mrds selection expression for the LILA block. HISTORY: 77-01-01 J. A. Weeldreyer: Initially written. 78-02-01 J. A. Weeldreyer: Modified to properly locate from clause. 78-08-01 J. A. Weeldreyer: Modified to properly handle row desig. scope. 80-04-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-12-03 Rickie E. Brinegar: sel_offset changed from ms_len_init + 3 to ms_len_init + 2. 81-06-29 Rickie E. Brinegar: Modified to properly identify the from tokens correct place. This is in response to TR10068. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 83-06-06 Bertley G. Moberg: Added support for print_search_order and no_optimize */ %include linus_lcb; %page; %include linus_ls_block; %page; %include linus_ls_header; %page; %include linus_mrds_block; %page; %include linus_source; %page; %include linus_token_data; dcl ( code, /* Output: status code */ icode, /* internal status code */ cur_pos, /* string index for from */ sel_offset, sel_length, sel_cur_pos, where_cur_pos, /* save index */ i, /* internal string indexes */ j ) fixed bin (35); /* length of error source line */ dcl hold_dflt_ri fixed bin; /* save area for prev. default range item */ dcl rs_ptr ptr; dcl temp_thd ptr; dcl ( b_cnt, /* bracket level count */ rs_len_init, /* length of range string */ rs_nargs_init, /* no. temp rels in range string */ ind, /* internal indexes */ arg_ind ) fixed bin; dcl ( found, /* on if from found */ inner ) bit (1); /* on if this is for inner block */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl 1 sel_tok_data aligned like token_data; dcl 1 where_tok_data aligned like token_data; dcl 1 range_string aligned based (rs_ptr), /* temp holding area for inner block ranges */ 2 str_len fixed bin, 2 nargs fixed bin, 2 string char (rs_len_init refer (range_string.str_len)) var, 2 arg_ptr (rs_nargs_init refer (range_string.nargs)) ptr, 2 desc_ptr (rs_nargs_init refer (range_string.nargs)) ptr, 2 thread ptr; dcl BLOCK fixed bin int static options (constant) init (4); dcl DELIMS char (7) int static options (constant) init ("{}() "); dcl ( linus_data_$max_pred_stack_size, linus_data_$max_range_items, linus_error_$no_from, mrds_data_$max_select_items, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl ( linus_lila_tokens_$differ, linus_lila_tokens_$from, linus_lila_tokens_$inter, linus_lila_tokens_$union, linus_lila_tokens_$where ) char (32) varying ext; dcl (addr, fixed, null, index, length, rel, search, substr) builtin; dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_from entry (ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_select entry (ptr, ptr, bit (1), ptr, fixed bin (35)); dcl linus_lila_where entry (ptr, ptr, bit (1), ptr, fixed bin (35)); inner = "0"b; /* initialize */ lsb_ptr, mblk_ptr = null; if ls_header.cur_ptr -> ls_block.type = BLOCK then do; /* this is inner block */ lsb_ptr = ls_header.cur_ptr; /* point to block stack frame */ inner = "1"b; /* remember is inner block */ hold_dflt_ri = ls_block.dflt_ritem; /* save prev. default */ ls_block.ib_level = ls_block.ib_level + 1; end; /* if inner */ else do; /* is outer, must setup block stack frame */ allocate ls_block in (work_area); ls_block.nritems, /* initialize */ ls_block.ib_level, ls_block.nrs_chars, ls_block.nselects, ls_block.pred_pcnt, ls_block.nterms, ls_block.nrange_args, ls_block.dflt_ritem, ls_block.nprops, ls_block.term_op, ls_block.nterms = 0; ls_block.type = BLOCK; ls_block.leaf_ptr (1), ls_block.leaf_ptr (2), ls_block.fwd_ptr, ls_block.rs_hd_ptr, ls_block.term_hd_ptr = null; ls_block.tup_var, ls_block.mrds_var, ls_block.rel_name, ls_block.sel_items = ""; ls_block.back_ptr = ls_header.cur_ptr; /* thread into lila stack */ ls_header.cur_ptr -> ls_block.fwd_ptr = lsb_ptr; ls_header.cur_ptr = lsb_ptr; end; /* if outer block */ sel_tok_data = token_data; /* save for select clause processing */ token_data.key = NULL; sel_cur_pos, cur_pos = ls_header.cur_pos; /* init for from search */ found = "0"b; do while (^found & cur_pos < lcb.lila_chars); /* search for "from" */ i = search (substr (source_str, cur_pos), "{}"); /* scan for brackets */ if i > 0 then /* if found */ if source_array (cur_pos + i - 1) = "{" then do; /* if start of lower level */ j = scan_from (cur_pos, i); /* look for from before { */ if j > 0 then do; /* found it */ found = "1"b; cur_pos = cur_pos + j - 1; /* position to "f" */ end; /* if found before { */ else do; /* if not found before { */ b_cnt = 1; /* init. bracket level count */ do while (b_cnt > 0 & lcb.lila_chars > cur_pos); /* search for end of lower level */ cur_pos = cur_pos + i; /* first beyond { */ i = search (substr (source_str, cur_pos), "{}"); /* look for brackets */ if i > 0 then do; /* if bracket found */ if source_array (cur_pos + i + 1) = "{" then b_cnt = b_cnt + 1; else b_cnt = b_cnt - 1; /* adjust bracket count */ cur_pos = cur_pos + i; /* first beyond bracket */ end; /* if bracket found */ else cur_pos = lcb.lila_chars; /* bracket not found, set to end of source */ end; /* scan past inner blocks */ end; /* if not found before { */ end; /* if found { */ else call final_scan (i); /* if found }, must find from before */ else do; /* found no bracket, look through rest of string for from */ i = lcb.lila_chars - cur_pos + 1; call final_scan (i); end; /* no brackets */ end; /* search loop */ if ^found then /* didnt find from */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$no_from, ""); else do; /* from was found, process from clause */ ls_header.cur_pos = cur_pos; call linus_lila_from (lcb_ptr, lsh_ptr, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); where_tok_data = token_data; /* save for start of where */ where_cur_pos = ls_header.cur_pos; end; /* if from found */ token_data = sel_tok_data; /* set for processing select clause */ ls_header.cur_pos = sel_cur_pos; call linus_lila_select (lcb_ptr, lsh_ptr, inner, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); if found then do; /* if we proc. from clause, load tok. data for where */ token_data = where_tok_data; ls_header.cur_pos = where_cur_pos; end; /* if had from clause */ if token_data.key = WHERE then do; /* if have where clause */ call linus_lila_where (lcb_ptr, lsh_ptr, inner, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); end; /* if where clause exists */ rs_nargs_init, /* init. for stringing range for current block */ rs_len_init = 0; do i = ls_block.nritems by -1 to 1 while (ls_block.range_items.level (i) >= ls_block.ib_level); /* only for current block */ rs_len_init = rs_len_init + 4 + length (ls_block.range_items.mrds_var (i)) + length (ls_block.range_items.rel_name (i)); if ls_block.range_items.arg_ptr (i) ^= null then rs_nargs_init = rs_nargs_init + 1; end; if ls_block.ib_level = 0 then ind = 1; else ind = i + 1; allocate range_string in (work_area); /* bild the range string */ range_string.thread = ls_block.rs_hd_ptr; /* thread it in */ ls_block.rs_hd_ptr = rs_ptr; range_string.string = ""; arg_ind = 0; do i = ind to ls_block.nritems; /* add each item to stirng */ range_string.string = range_string.string || "(" || ls_block.range_items.mrds_var (i) || " " || ls_block.range_items.rel_name (i) || ") "; if ls_block.range_items.arg_ptr (i) ^= null then do; /* if temp rel */ arg_ind = arg_ind + 1; range_string.arg_ptr (arg_ind) = ls_block.range_items.arg_ptr (i); range_string.desc_ptr (arg_ind) = ls_block.range_items.desc_ptr (i); end; end; /* adding items to string */ ls_block.nritems = ind - 1; /* reset counters */ ls_block.nrs_chars = ls_block.nrs_chars + rs_len_init; ls_block.ib_level = ls_block.ib_level - 1; if ^inner then do; /* if outer block, put together mrds block */ ms_len_init = ls_block.nrs_chars + 7; /* calc. length of full mrds block */ if lcb.pso_flag then ms_len_init = ms_len_init + 5; /* for "-pso " */ if lcb.no_ot_flag then ms_len_init = ms_len_init + 7; /* for "-no_ot " */ ms_len_init = ms_len_init + 12; /* for -select and opt. -dup */ sel_offset = ms_len_init + 2; /* char index of first select term */ do i = 1 to ls_block.nselects; /* calc len. of select clause */ ms_len_init = ms_len_init + length (ls_block.sel_items (i)) + 2; end; sel_length = ms_len_init - sel_offset + 2; if ls_block.nterms = 1 then do; /* if have pred. */ ms_len_init = ms_len_init + 8 + length (ls_block.term_hd_ptr -> mrds_block.mrds_string); nval_args_init = ls_block.nrange_args + ls_block.term_hd_ptr -> mrds_block.nval_args; end; else nval_args_init = ls_block.nrange_args; allocate mrds_block in (work_area); /* space for full mrds block */ arg_ind = 0; mrds_block.fwd_ptr = null; mrds_block.sel_offset = sel_offset; mrds_block.sel_length = sel_length; mrds_block.mrds_string = "-range "; /* build the whole block */ if lcb.pso_flag then mrds_block.mrds_string = mrds_block.mrds_string || "-pso "; if lcb.no_ot_flag then mrds_block.mrds_string = mrds_block.mrds_string || "-no_ot "; do rs_ptr = ls_block.rs_hd_ptr repeat temp_thd while (rs_ptr ^= null); /* pick up range strings */ do i = 1 to range_string.nargs; mrds_block.val_args.arg_ptr (i + arg_ind) = range_string.arg_ptr (i); mrds_block.val_args.desc_ptr (i + arg_ind) = range_string.desc_ptr (i); end; arg_ind = arg_ind + range_string.nargs; mrds_block.mrds_string = mrds_block.mrds_string || range_string.string; temp_thd = range_string.thread; rs_ptr = null; end; /* adding range */ mrds_block.mrds_string = mrds_block.mrds_string || "-select "; do i = 1 to ls_block.nselects; mrds_block.mrds_string = mrds_block.mrds_string || " " || ls_block.sel_items (i) || " "; end; if ls_block.nterms = 1 then do; /* if have pred */ i = ls_block.nrange_args; mrds_block.mrds_string = mrds_block.mrds_string || " -where " || ls_block.term_hd_ptr -> mrds_block.mrds_string; do j = i + 1 to ls_block.term_hd_ptr -> mrds_block.nval_args + i; mrds_block.val_args.arg_ptr (j) = ls_block.term_hd_ptr -> mrds_block.val_args.arg_ptr (j - i); mrds_block.val_args.desc_ptr (j) = ls_block.term_hd_ptr -> mrds_block.val_args.desc_ptr (j - i); end; ls_block.term_hd_ptr = null; /* don't need this mrds_block */ end; /* if had pred */ ls_block.back_ptr -> ls_block.fwd_ptr = null; /* unthread and free block stack frame */ ls_header.cur_ptr = ls_block.back_ptr; lsb_ptr = null; end; /* if outer block */ else ls_block.dflt_ritem = hold_dflt_ri; /* restore prev. default if inner block */ code = 0; /* made it */ exit: return; scan_from: proc (start, len) returns (fixed bin (35)); /* Procedure to dcan for from which precedes select and where in given sub string */ dcl (from_pos, i, start, len) fixed bin (35); from_pos = scan_kwd (linus_lila_tokens_$from); /* look for a from */ if from_pos > 0 then do; /* if found */ i = scan_kwd (linus_lila_tokens_$where); /* look for where */ if i > 0 then if from_pos > i then from_pos = 0; /* from must precede where */ i = scan_kwd (linus_lila_tokens_$inter); if i > 0 then if from_pos > i then from_pos = 0; /* must also precede inter */ i = scan_kwd (linus_lila_tokens_$differ); if i > 0 then if from_pos > i then from_pos = 0; /* must also precede differ */ i = scan_kwd (linus_lila_tokens_$union); if i > 0 then if from_pos > i then from_pos = 0; /* must also precede union */ end; /* if from found */ return (from_pos); scan_kwd: proc (kwd) returns (fixed bin (35)); /* Procedure to find isolated occurence of specified string */ dcl kwd char (*) varying; dcl (i, j, klen) fixed bin (35); found = "0"b; /* init */ klen = length (kwd); i = start; do while (i < start + len - 1 & ^found); j = index (substr (source_str, i, start + len - i), kwd); /* look for kwd */ if j > 0 then /* if key word string found */ if index (DELIMS, source_array (i + j - 2)) ^= 0 /* must be prec. and followed by delimiters */ & index (DELIMS, source_array (i + j + klen - 1)) ^= 0 then do; if i ^= start then j = i - start + j; found = "1"b; end; else i = i + j; /* keep looking */ else i = start + len; /* not there, get out of loop */ end; /* search loop */ if ^found then j = 0; return (j); end scan_kwd; end scan_from; final_scan: proc (len); /* Procedure to scan final part of string */ dcl (len, i) fixed bin (35); i = scan_from (cur_pos, len); if i <= 0 then cur_pos = lcb.lila_chars; /* get out of loop */ else do; /* found it */ cur_pos = cur_pos + i - 1; found = "1"b; end; end final_scan; end linus_lila_block;  linus_lila_build_expr_str.pl1 07/29/86 1045.3r w 07/29/86 0939.8 161811 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_build_expr_str: proc (lcb_ptr, lsh_ptr, td_ptr, ex_ptr, ex_var, code); /* DESCRIPTION: This procedure translates a linus expression into an equivalent MRDS expression, suitable for inclusion in a MRDS -where clause. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 78-04-01 J. A. Weeldreyer: Modified to give better diagnostics for constant expr. and scalar fun. 78-08-01 J. A. Weeldreyer: Modified to conform to new token data. 80-04-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-12-01 Rickie E. Brinegar: Modified to remove the un referenced linus_select_info.incl.pl1 file. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-11-02 DJ Schimke: Modified to allow constants to be first operand of an expression rather than just attributes. Modified internal procedure reduce to eliminate possible stringrange condition. */ %include linus_lcb; %page; %include linus_ls_header; %page; %include linus_ls_block; %page; %include linus_mrds_block; %page; %include linus_variables; %page; %include linus_token_data; %page; %include linus_ef_data; %page; %include linus_set_fn; %page; %include mdbm_descriptor; dcl ( code, /* Output: status code */ icode ) fixed bin (35); /* internal status code */ dcl ( nops, /* curr. no. of stacked arith ops. */ nitems, /* curr. no. of stacked operands */ local_pcnt, /* to keep paren count for this expr. */ i ) fixed bin; /* internal index */ dcl ( done, /* completion flag */ expr_flag, /* on if expr. allowed */ atom_flag, /* on if atom allowed */ aop_flag, /* on if arith op allowed */ lp_flag, /* on if ( allowed */ rp_flag, /* on if ) allowed */ end_flag ) bit (1) unal; /* on if end of expr. allowed */ dcl ( ex_ptr, /* Output: pointer to mrds_block for expr. */ exp_hd_ptr, lss_ptr /* pointer to ls_set structure */ ) ptr; /* ptr to top of operand stack */ dcl ex_var char (*); /* var name for expr. */ dcl ( variable, /* variable name */ master_var ) char (32); /* master variable for comparison */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl token char (token_data.length) based (token_data.t_ptr); dcl 1 expr_data aligned like ef_data; dcl 1 op_stack (linus_data_$max_expr_items) aligned, /* operator stack */ 2 p_cnt fixed bin (17) unal, 2 key fixed bin (17) unal; dcl ( PAREN init (1), END init (2), OP init (3) ) int static fixed bin options (constant); dcl op_prec (8:11) fixed bin (8) unal int static options (constant) init (2, 2, 1, 1); dcl mrds_op (8:11) char (3) int static options (constant) init (" * ", " / ", " + ", " - "); dcl ( linus_data_$max_expr_items, linus_data_$max_range_items, linus_data_$max_pred_stack_size, linus_error_$inv_expr, linus_error_$unbal_parens, linus_error_$expr_str, linus_error_$expr_ovfl, linus_error_$inv_tup_var, linus_error_$const_expr_fn, mrds_data_$max_select_items, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, addrel, fixed, length, null, rel, substr) builtin; dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_set_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_build_scfn_str entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); mblk_ptr, /* initialize */ exp_hd_ptr = null; nops, num_dims, local_pcnt, nitems = 0; master_var = ""; lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; expr_flag, /* set state flags */ lp_flag = "1"b; aop_flag, rp_flag, atom_flag, end_flag = "0"b; done = "0"b; /* init loop control flag */ do while (^done); /* main processing loop */ if token_data.key = NULL then do; /* if need to get new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; go to token_proc (token_data.key); token_proc (0): /* null */ token_proc (12): /* table name */ token_proc (13): /* row table pair */ token_proc (14): /* union */ token_proc (15): /* inter */ token_proc (16): /* differ */ token_proc (17): /* row designator */ token_proc (18): /* { */ token_proc (19): /* } */ token_proc (20): /* select */ token_proc (21): /* ^ */ token_proc (22): /* & */ token_proc (23): /* | */ token_proc (24): /* = */ token_proc (25): /* ^= */ token_proc (26): /* > */ token_proc (27): /* >= */ token_proc (28): /* < */ token_proc (29): /* <= */ token_proc (30): /* from */ token_proc (31): /* where */ token_proc (32): /* dup */ token_proc (33): /* unique */ token_proc (34): /* , */ if ^end_flag then /* if cant end yet */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); call finish; /* finish up expr. and put in mrds_block */ done = "1"b; go to next; token_proc (1): /* ) */ if ^rp_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); if ls_block.pred_pcnt <= 0 then /* no matching ( */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$unbal_parens, token); if local_pcnt <= 0 then /* if paren belongs to higher level */ if end_flag then do; /* if we can end here */ call finish; done = "1"b; end; else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$unbal_parens, token); else do; /* if valid paren. */ call reduce (PAREN); /* perform any nec. stack reduction */ ls_block.pred_pcnt = ls_block.pred_pcnt - 1; /* decr. par. count */ local_pcnt = local_pcnt - 1; rp_flag, /* reset state flags */ end_flag, aop_flag = "1"b; expr_flag, atom_flag, lp_flag = "0"b; token_data.key = NULL; /* force new token */ end; /* if valid paren */ go to next; token_proc (2): /* column spec. */ if ^atom_flag & ^expr_flag then /* is not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); call check_var ((token_data.mvar)); /* make sure we have no more than one var. */ call set_ord_block (token_data.mvar || "." || token); /* make a mrds block and stack it */ if expr_flag then end_flag = "0"b; /* cant have end with only one operand */ else end_flag = "1"b; atom_flag, /* reset other state flags */ expr_flag, lp_flag = "0"b; aop_flag, rp_flag = "1"b; token_data.key = NULL; go to next; token_proc (3): /* linus variable */ if ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); lv_ptr = lcb.lv_ptr; /* look for info on curr. value */ do i = 1 to variables.nvars while (token ^= variables.var_info.name (i)); end; /* guaranteed to find it */ call set_val_block (variables.var_info.var_ptr (i), addr (variables.var_info.desc (i))); /* make and stack mrds block */ token_data.key = NULL; /* force new token */ expr_flag, atom_flag, lp_flag = "0"b; end_flag, rp_flag, aop_flag = "1"b; go to next; /* **** 11/2/81 DJ Schimke: BEGIN CHANGE *************************************/ token_proc (4): /* constant */ if ^atom_flag & ^expr_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); /* **** 11/2/81 DJ Schimke: END CHANGE ***************************************/ if substr (token, 1, 1) = """" /* if is string constant */ | substr (token, 1, 1) = "(" then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$expr_str, token); call set_ord_block (token); /* make and stack mrds block */ token_data.key = NULL; /* force new token */ expr_flag, /* reset state flags */ atom_flag, lp_flag = "0"b; end_flag, rp_flag, aop_flag = "1"b; go to next; token_proc (5): /* set function */ if ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); call linus_lila_set_fn (lcb_ptr, lsh_ptr, td_ptr, addr (expr_data), icode); /* process the set fn. */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); call set_val_block (expr_data.assn_ptr, addr (expr_data.ef_ptr -> linus_set_fn.rslt_desc)); /* make and stack mrds block */ atom_flag, /* reset state flags */ expr_flag, lp_flag = "0"b; rp_flag, aop_flag, end_flag = "1"b; go to next; token_proc (6): /* scalar function */ if ^expr_flag & ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); variable = ""; call linus_lila_build_scfn_str (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, variable, icode); /* make mrds string */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); call check_var (variable); /* ensure consistency */ mrds_block.fwd_ptr = exp_hd_ptr; /* chain into operand stack */ exp_hd_ptr = mblk_ptr; mblk_ptr = null; nitems = nitems + 1; expr_flag, /* reset state flags, allow end if scal_fn only operand */ atom_flag, lp_flag = "0"b; end_flag, rp_flag, aop_flag = "1"b; go to next; token_proc (7): /* ( */ if ^lp_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); ls_block.pred_pcnt = ls_block.pred_pcnt + 1; /* merely incr. count */ local_pcnt = local_pcnt + 1; token_data.key = NULL; /* force new token, leave state flags as they are */ go to next; token_proc (8): /* * */ token_proc (9): /* / */ token_proc (10): /* + */ token_proc (11): /* - */ if ^aop_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, token); if nops > 0 then /* see if need to reduce for lower prec. op */ if op_stack.p_cnt (nops) = ls_block.pred_pcnt then if op_prec (token_data.key) <= op_prec (op_stack.key (nops)) then call reduce (OP); if nops >= linus_data_$max_expr_items then /* if overflow */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$expr_ovfl, "") ; nops = nops + 1; /* stack the operator */ op_stack.key (nops) = token_data.key; op_stack.p_cnt (nops) = ls_block.pred_pcnt; token_data.key = NULL; /* force new token */ expr_flag, /* reset state flags */ end_flag, aop_flag, rp_flag = "0"b; atom_flag, lp_flag = "1"b; go to next; next: end; /* main processing loop */ ex_var = master_var; /* pass info to caller */ ex_ptr = exp_hd_ptr; code = 0; return; reduce: proc (type); /* Procedure to reduce items in expr. stacks. Three types of reduction are provided: (a) for lower prec. operator, (b) for right parenthesis, and (c) final reduction. */ dcl type fixed bin; dcl done bit (1) init ("0"b); if type = END then do while (nops > 0 & nitems > 1); call combine; /* reduce entire stack */ end; /* 81-11-02 DJ Schimke: BEGIN CHANGE ************************************** */ /* done flag prevents stringrange when nops = 0 */ else if type = PAREN then do while (nops > 0 & nitems > 1 & ^done); if op_stack.p_cnt (nops) = ls_block.pred_pcnt then call combine; /* reduce within paren. */ else done = "1"b; end; else do while (nops > 0 & nitems > 1 & ^done); if op_stack.p_cnt (nops) = ls_block.pred_pcnt & op_prec (token_data.key) <= op_prec (op_stack.key (nops)) then call combine; /* reduce for lower prec. oper. */ else done = "1"b; end; /* 81-11-02 DJ Schimke: END CHANGE ************************************** */ combine: proc; /* procedure to combine top two operands and top operator into one mrds block, and replace them in the stack. */ dcl (b1p, b2p) ptr; dcl i fixed bin; b2p = exp_hd_ptr; /* top operand */ b1p = b2p -> mrds_block.fwd_ptr; /* prev. operand */ ms_len_init = 5 + length (b1p -> mrds_block.mrds_string) /* set up and fill in mrds block for combination */ + length (b2p -> mrds_block.mrds_string); nval_args_init = b1p -> mrds_block.nval_args + b2p -> mrds_block.nval_args; allocate mrds_block in (work_area); mrds_block.fwd_ptr = b1p -> mrds_block.fwd_ptr; /* replace top two terms */ mrds_block.mrds_string = "(" || b1p -> mrds_block.mrds_string || mrds_op (op_stack.key (nops)) || b2p -> mrds_block.mrds_string || ")"; do i = 1 to b1p -> mrds_block.nval_args; /* args from first operand */ mrds_block.val_args.arg_ptr (i) = b1p -> mrds_block.val_args.arg_ptr (i); mrds_block.val_args.desc_ptr (i) = b2p -> mrds_block.val_args.desc_ptr (i); end; do i = b1p -> mrds_block.nval_args + 1 to mrds_block.nval_args; /* args from second operand */ mrds_block.val_args.arg_ptr (i) = b2p -> mrds_block.val_args.arg_ptr (i - b1p -> mrds_block.nval_args); mrds_block.val_args.desc_ptr (i) = b2p -> mrds_block.val_args.desc_ptr (i - b1p -> mrds_block.nval_args); end; nops = nops - 1; /* reset counts */ nitems = nitems - 1; exp_hd_ptr = mblk_ptr; /* chain in new operand */ mblk_ptr = null; b1p = null; b2p = null; end combine; end reduce; check_var: proc (var); /* Procedure to ensure that expr. uses only one tuple variable */ dcl var char (*); if var = "" then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$const_expr_fn, ""); if master_var = "" then /* if first time */ master_var = var; else if var ^= master_var then /* not same */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_tup_var, var) ; end check_var; set_ord_block: proc (str); /* procedure to fill in a mrds block for operand with no values */ dcl str char (*); ms_len_init = length (str); nval_args_init = 0; allocate mrds_block in (work_area); mrds_block.fwd_ptr = exp_hd_ptr; mrds_block.mrds_string = str; exp_hd_ptr = mblk_ptr; mblk_ptr = null; nitems = nitems + 1; if token_data.must_free then token_data.t_ptr = null; end set_ord_block; set_val_block: proc (arg_ptr, desc_ptr); /* Procedure to fill in and stack a mrds block for an operand with one value */ dcl (arg_ptr, desc_ptr) ptr; dcl is_var (22) bit (1) int static unal options (constant) init ((19) (1)"0"b, "1"b, "0"b, "1"b); ms_len_init = 3; nval_args_init = 1; allocate mrds_block in (work_area); mrds_block.fwd_ptr = exp_hd_ptr; mrds_block.mrds_string = ".V."; if is_var (desc_ptr -> descriptor.type) then mrds_block.val_args.arg_ptr (1) = addrel (arg_ptr, 1); else mrds_block.val_args.arg_ptr (1) = arg_ptr; mrds_block.val_args.desc_ptr (1) = desc_ptr; exp_hd_ptr = mblk_ptr; mblk_ptr = null; nitems = nitems + 1; end set_val_block; finish: proc; /* Procedure to put finishing touches on the mrds expr. */ dcl bp ptr; call reduce (END); /* do final reduction */ if nops ^= 0 | nitems ^= 1 then /* didnt work out */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_expr, ""); bp = exp_hd_ptr; if substr (bp -> mrds_block.mrds_string, 1, 1) = "(" then do; /* can replace outer () with [] */ substr (bp -> mrds_block.mrds_string, 1, 1) = "["; substr (bp -> mrds_block.mrds_string, length (bp -> mrds_block.mrds_string), 1) = "]"; end; /* if mere replacement */ else do; /* no outer (), must reallocate */ ms_len_init = length (bp -> mrds_block.mrds_string) + 2; nval_args_init = bp -> mrds_block.nval_args; allocate mrds_block in (work_area); mrds_block.fwd_ptr = bp -> mrds_block.fwd_ptr; mrds_block.val_args = bp -> mrds_block.val_args; mrds_block.mrds_string = "[" || bp -> mrds_block.mrds_string || "]"; exp_hd_ptr = mblk_ptr; mblk_ptr = null; end; /* if had to reallocate */ end finish; end linus_lila_build_expr_str;  linus_lila_build_expr_tab.pl1 10/14/90 0931.4rew 10/14/90 0915.0 248832 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): 85-04-24 Al Dupuis: To correct a subscriptrange when expressions like "select a+b from temporary_relation" were being processed. 2) change(90-04-23,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls to assign_round_ from assign_ so that data is rounded. END HISTORY COMMENTS */ linus_lila_build_expr_tab: proc (lcb_ptr, lsh_ptr, td_ptr, ed_ptr, code); /* DESCRIPTION: This procedure is an Operator Precedence parser that is used by the select clause translator. HISTORY: 77-08-01 J. C. C. Jagernauth: Initially written. 78-04-01 J. C. C. Jagernauth: Modified to update ls_set when new mrds items are encountered and eliminate the internal procedure "set_table_name". 78-06-01 J. C. C. Jagernauth: Modified to verify that expressions begin with column specifications. 78-08-01 J. A. Weeldreyer: Modified to conform to new token data. 79-02-01 J. C. C. Jagernauth: Modified to access version 4 resultant information. 80-01-08 Rickie E. Brinegar: Modified to pass linus_lila_alloc_lit a descriptor pointer instead of an assign_ descriptor type and eliminate the assign_ length parameter. 80-04-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-09-16 Rickie E. Brinegar: modified to use linus_rel_array instead of making calls to dsl_$get_rslt_info. 81-02-03 Rickie E. Brinegar: The rel builtin was added to the declarations. Changed to use the modified linus_rel_array structure. 81-06-19 Rickie E. Brinegar: Removed calls to dsl_$get_(temp rslt)_desc. 81-07-13 Rickie E. Brinegar: Removed trapping of the conversion condition. This is now relegated to higher level routines. 81-09-17 Rickie E. Brinegar: Moved the incrementing of stack.nargs from shift_function to both shift_setf and shift_sclf to eliminate subscript range conditions. 81-11-06 Rickie E. Brinegar: Removed mdbm_util_$number_data_class as it was only being used in conjunction with mdbm_util_$complex_data_class, which makes all of the necessary determinations without the need of checking to see if it is in the number data class. Added the unspec builtin to intialize the ef_data structure. 82-02-09 Bertley G. Moberg: To allow expressions as the last element in a scalar function argument list ********* COMMENTS ABOUT CODE TO BE DELETED ********* The code marked for deletion was inserted to make sure that all expressions begin with a column specification ********* END DELETED CODE COMMENTS ********* */ %include linus_lcb; %page; %include linus_expression; %page; %include linus_ef_data; %page; %include linus_ls_block; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_rel_array; %page; %include linus_token_data; %page; %include linus_variables; %page; %include mrds_rslt_info; dcl expr_type (11) fixed bin (4) unal int static options (constant) init ( /* Map token key to type or op_code */ 0, 6, /* Data base item */ 2, /* linus variable */ 1, /* constant */ 4, /* set function */ 3, /* scalar function */ 0, 3, /* multiply */ 4, /* divide */ 1, /* add */ 2); /* subtract */ dcl CHAR_DESC bit (36) aligned; dcl REAL_FD bit (36) aligned; dcl CMPX_FD bit (36) aligned; dcl FD59 bit (36) aligned int static options (constant) init ("100101000000000000000000000000111011"b); /* Float decimal */ dcl CFD59 bit (36) aligned int static options (constant) init ("100110000000000000000000000000111011"b); /* Complex float decimal */ dcl ( EXPR_SET_FN init (4), OPERATOR init (15), EXPR_SCAL_FN init (3) ) fixed bin (4) int static options (constant); dcl prec_relations (0:11, 0:11) fixed bin (4) int static options (constant) init (/* 1 = reduce_op [( .> ) E op_code E ] 2 = reduce_paren [( .= ) (E)] 3 = shift_token [( <. )] 4 = end of expression [variable followed by variable] 5 = reduce_var [reduce to E] 6 = call set func. then shift_setf 7 = call scalar func. then shift_sclf no need to push expression stack. 8 = error [LP followed by invalid token] 9 = make sure the first token shifted is not an operator or RP 10 = make sure you are not reducing E + "" 11 = end of expression the generic term "variable" is used to represent one of the following: column specification linus variable constant set function result scalar function result ROW and COLUMN names correspond in the table below */ 11, 11, (3) 3, 6, 7, 3, (4) 9, /* NULL 11 11 3 3 3 6 7 3 9 9 9 9 */ (12) 2, /* RP 2 2 2 2 2 2 2 2 2 2 2 2 */ (5) ((2) 5, (6) 4, (4) 5), /* COL_SPEC 5 5 4 4 4 4 4 4 5 5 5 5 */ /* LINUS_VAR 5 5 4 4 4 4 4 4 5 5 5 5 */ /* CONST 5 5 4 4 4 4 4 4 5 5 5 5 */ /* SET_FN 5 5 4 4 4 4 4 4 5 5 5 5 */ /* SCAL_FN 5 5 4 4 4 4 4 4 5 5 5 5 */ 8, 9, (3) 3, 6, 7, 3, (4) 9, /* LP 8 9 3 3 3 6 7 3 9 9 9 9 */ (2) (10, 1, (3) 3, 6, 7, 3, (4) 1), /* STAR 10 1 3 3 3 6 7 3 1 1 1 1 */ /* DIV 10 1 3 3 3 6 7 3 1 1 1 1 */ (2) (10, 1, (3) 3, 6, 7, (3) 3, (2) 1)); /* PLUS 10 1 3 3 3 6 7 3 3 3 1 1 */ /* MINUS 10 1 3 3 3 6 7 3 3 3 1 1 */ dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 length bit (24) unal; /* arg_len for system standard argument list */ dcl 1 stack aligned based (sk_ptr), 2 nargs fixed bin, 2 token_data (linus_data_$stk_depth refer (stack.nargs)), 3 key fixed bin (17) unal, 3 must_free bit (1) unal, 3 reduced bit (1) unal, /* On if item has been reduced */ 3 reserved bit (16) unal, 3 length fixed bin (35), 3 t_ptr ptr, 3 desc bit (36), 3 bit_length fixed bin (35), 3 assn_ptr ptr, 3 assn_type fixed bin, 3 assn_len fixed bin (35), 3 fn_ptr ptr, /* Pointer to function structure */ 3 type fixed bin (4) unal, 3 op_code fixed bin (3) unal; dcl token_item char (token_data.length) based (token_data.t_ptr); /* For shifting */ dcl (i, j, source_type, target_type, temp_token_key, temp_stack_key, tos_key) fixed bin; /* Points to first terminal on top of the work stack */ dcl (bit_len, code, cs_len, icode, source_length, target_length) fixed bin (35); dcl constant_string char (cs_len) based (cs_ptr); dcl ( test, /* ********* BEGIN DELETE ********* */ first_token, /* ********* END DELETE ********* */ cmpx ) bit (1); dcl (addr, bit, fixed, null, rel, search, substr, unspec) builtin; dcl ( cs_ptr init (null), lit_ptr init (null), sk_ptr init (null) ) ptr; dcl 1 ef_d like ef_data; dcl ( linus_data_$max_expr_items, linus_data_$max_pred_stack_size, linus_data_$max_range_items, linus_data_$max_set_stack_size, linus_data_$stk_depth, linus_error_$expr_ovfl, linus_error_$first_expr_item, linus_error_$inv_expr, linus_error_$inv_tup_var, linus_error_$op_follow_lp, linus_error_$select_list_ovfl, linus_error_$token_type_null, mrds_data_$max_token_size, mrds_data_$max_select_items, sys_info$max_seg_size ) fixed bin (35) ext; dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl linus_assign_data entry (bit (36), fixed bin, fixed bin (35)); dcl linus_lila_alloc_lit entry (ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_scal_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_set_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl mdbm_util_$complex_data_class entry (ptr) returns (bit (1)); dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); sk_ptr, ex_ptr, cs_ptr, rslt_ptr = null; linus_rel_array_ptr = lcb.rel_array_ptr; unspec (ef_d) = "0"b; CHAR_DESC = "101010100000000000000000000000000000"b; REAL_FD = "100101000000000000000000000000000000"b; CMPX_FD = "100110000000000000000000000000000000"b; nelems_init = linus_data_$stk_depth; /* For expression structure allocation */ ef_data.nmrds_items, icode, code, tos_key = 0; /* Top of stack item that is not reduced */ ef_data.var_name = ""; cmpx, test = "0"b; first_token = "1"b; lv_ptr = lcb.lv_ptr; /* Init linus_variables */ allocate stack in (work_area); unspec (stack) = "0"b; stack.nargs = 0; /* Work stack is empty */ allocate expression in (work_area); unspec (expression) = "0"b; expression.nelems = 0; /* Expression stack is empty */ lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; /* ********* BEGIN DELETE ********* */ if token_data.key > RP & token_data.key < SET_FN then do; first_token = "0"b; /* we have the first token */ if token_data.key ^= COL_SPEC then /* first token of expression must be column spec */ call error (linus_error_$first_expr_item, ""); end; /* ********* END DELETE ********* */ do while (^test); /* MAIN LOOP */ if token_data.key > MINUS then temp_token_key = NULL; /* invalid token */ else temp_token_key = token_data.key; /* good token */ if tos_key = 0 then temp_stack_key = 0; else temp_stack_key = stack.token_data.key (tos_key); /* take key off stack */ go to case (prec_relations (temp_stack_key, temp_token_key)); case (1): call reduce_op; /* E op E is on work stack */ go to end_case; case (2): call reduce_paren; /* (E) is on work stack */ go to end_case; case (3): call shift_token; /* place token on work stack */ call get_token; go to end_case; case (4): call reduce_var; /* end of expression -- variable followed by variable */ if tos_key > 1 then call reduce_op; /* After this call only E should be on work stack */ test = "1"b; /* Exit */ go to end_case; case (5): call reduce_var; /* place variable on expression stack */ go to end_case; case (6): call linus_lila_set_fn (lcb_ptr, lsh_ptr, td_ptr, addr (ef_d), icode); /* build set function table */ call update_efdata; call shift_setf; /* Push set function result on work stack */ call get_token; go to end_case; case (7): call linus_lila_scal_fn (lcb_ptr, lsh_ptr, td_ptr, addr (ef_d), icode); /* build scalar function table */ call update_efdata; call shift_sclf; /* Push scalar function result on work stack */ call get_token; go to end_case; case (8): call error (linus_error_$inv_expr, ""); /* LP followed by invalid token */ go to end_case; case (9): if tos_key = stack.nargs then /* make sure the first token shifted is not an operator or RP */ call error (linus_error_$op_follow_lp, ""); else do; call shift_token; /* then place token on work stack */ call get_token; end; go to end_case; case (10): if tos_key = stack.nargs then /* make sure you are not reducing E + "" */ call error (linus_error_$inv_expr, ""); else call reduce_op; /* E op E is on work stack */ go to end_case; case (11): test = "1"b; /* end of expression */ end_case: end; /* END MAIN LOOP */ if ^(stack.nargs = 1 & stack.token_data.reduced (1)) then /* Make sure expression was good */ call error (linus_error_$inv_expr, ""); if expression.nelems = 1 then expression.rslt_desc = expression.elem.desc (1); /* only one item in expression */ else if cmpx then expression.rslt_desc = CFD59; /* Init to complex float decimal 59 */ else expression.rslt_desc = FD59; /* Init to float decimal 59 */ ef_data.ef_ptr = ex_ptr; /* pass pointer to expression structure */ ef_data.desc = expression.rslt_desc; /* pass expression info in ef_data structure */ call linus_assign_data ((ef_data.desc), ef_data.assn_type, ef_data.assn_len) ; call linus_lila_alloc_lit (lcb_ptr, addr (ef_data.desc), ef_data.assn_ptr, ef_data.bit_length); sk_ptr = null; rslt_ptr = null; get_token: proc; call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if token_data.key = NULL then call error (linus_error_$token_type_null, ""); /* ********* BEGIN DELETE ********* */ if first_token then /* is this first data token ? */ if token_data.key > RP & token_data.key < SET_FN then do; first_token = "0"b; if token_data.key ^= COL_SPEC then call error (linus_error_$first_expr_item, ""); end; /* ********* END DELETE ********* */ if icode ^= 0 then call error (icode, ""); end get_token; update_efdata: proc; if ef_d.var_name ^= "" then do; if ef_data.var_name = "" then ef_data.var_name = ef_d.var_name; if ef_data.var_name ^= ef_d.var_name then call error (linus_error_$inv_tup_var, ""); end; ef_data.bit_length = ef_d.bit_length; ef_data.desc = ef_d.desc; ef_data.assn_ptr = ef_d.assn_ptr; ef_data.assn_type = ef_d.assn_type; ef_data.assn_len = ef_d.assn_len; ef_data.ef_ptr = ef_d.ef_ptr; if ef_data.nmrds_items >= linus_data_$max_expr_items then call error (linus_error_$expr_ovfl, ""); if ef_d.nmrds_items ^= 0 then do i = 1 to ef_d.nmrds_items; ef_data.nmrds_items = ef_data.nmrds_items + 1; ef_data.mrds_items.attr_name (ef_data.nmrds_items) = ef_d.mrds_items.attr_name (i); ef_data.mrds_items.domain_name (ef_data.nmrds_items) = ef_d.mrds_items.domain_name (i); ef_data.mrds_items.bit_length (ef_data.nmrds_items) = ef_d.mrds_items.bit_length (i); ef_data.mrds_items.desc (ef_data.nmrds_items) = ef_d.mrds_items.desc (i); ef_data.mrds_items.assn_ptr (ef_data.nmrds_items) = ef_d.mrds_items.assn_ptr (i); ef_data.mrds_items.assn_type (ef_data.nmrds_items) = ef_d.mrds_items.assn_type (i); ef_data.mrds_items.assn_len (ef_data.nmrds_items) = ef_d.mrds_items.assn_len (i); end; end update_efdata; shift_token: proc; /* Push token data onto work stack */ stack.nargs = stack.nargs + 1; /* push work stack */ tos_key = stack.nargs; /* set top of stack index */ stack.token_data.fn_ptr (stack.nargs) = null; stack.token_data.reduced (stack.nargs) = "0"b; if token_data.key > LP then do; /* Item is an operator */ stack.token_data.type (stack.nargs) = OPERATOR; stack.token_data.op_code (stack.nargs) = expr_type (token_data.key); end; else do; /* item is not an operator */ stack.token_data.op_code (stack.nargs) = NULL; stack.token_data.type (stack.nargs) = expr_type (token_data.key); end; if token_data.key = LINUS_VAR then call shift_linus_var; else if token_data.key = CONST then call shift_const; else if token_data.key = COL_SPEC then call shift_col_spec; call shift_comm; end shift_token; shift_sclf: proc; /* push scalar function data onto work stack */ token_data.key = 6; /* reset key */ stack.nargs = stack.nargs + 1; stack.token_data.type (stack.nargs) = EXPR_SCAL_FN; /* type is known */ stack.token_data.fn_ptr (stack.nargs) = ef_data.ef_ptr; call shift_function; end shift_sclf; shift_setf: proc; /* push set function data onto work stack */ token_data.key = 5; /* reset key */ stack.nargs = stack.nargs + 1; stack.token_data.type (stack.nargs) = EXPR_SET_FN; stack.token_data.fn_ptr (stack.nargs) = ef_data.ef_ptr; call shift_function; end shift_setf; reduce_op: proc; /* E op_code E is on top of the work stack */ call push_expression; tos_key = tos_key - 2; stack.nargs = stack.nargs - 2; /* point to E */ end reduce_op; reduce_paren: proc; /* (E) is on top of the work stack */ stack.token_data.reduced (tos_key), stack.token_data.reduced (tos_key - 2) = "1"b; /* pushed */ tos_key = tos_key - 3; stack.nargs = stack.nargs - 2; end reduce_paren; reduce_var: proc; /* a variable is on the work stack */ call push_expression; /* place variable on expression stack */ tos_key = tos_key - 1; end reduce_var; push_expression: proc; /* Data is removed from the work stack and pushed onto the expression stack */ stack.token_data.reduced (tos_key) = "1"b; /* Set flag to indicate that item was pushed */ expression.nelems = expression.nelems + 1; /* Point to new top of stack */ expression.elem.type (expression.nelems) = stack.token_data.type (tos_key); /* Push data */ expression.elem.op_code (expression.nelems) = stack.token_data.op_code (tos_key); if expression.elem.type (expression.nelems) ^= OPERATOR then do; expression.elem.desc (expression.nelems) = stack.token_data.desc (tos_key); expression.elem.bit_length (expression.nelems) = stack.token_data.bit_length (tos_key); expression.elem.assn_ptr (expression.nelems) = stack.token_data.assn_ptr (tos_key); expression.elem.assn_type (expression.nelems) = stack.token_data.assn_type (tos_key); expression.elem.assn_len (expression.nelems) = stack.token_data.assn_len (tos_key); expression.elem.fn_ptr (expression.nelems) = stack.token_data.fn_ptr (tos_key); end; if stack.token_data.must_free (tos_key) then stack.token_data.t_ptr = null; if mdbm_util_$complex_data_class ( addr (expression.elem.desc (expression.nelems))) then cmpx = "1"b; end push_expression; shift_function: proc; /* push token data onto work stack */ tos_key = stack.nargs; stack.token_data.op_code (stack.nargs) = NULL; stack.token_data.reduced (stack.nargs) = "0"b; call shift_common (ef_data.desc, ef_data.bit_length, ef_data.assn_ptr, ef_data.assn_type, ef_data.assn_len); end shift_function; shift_common: proc (desc, bit_length, assn_ptr, assn_type, assn_len); dcl desc bit (36) aligned; dcl (bit_length, assn_len) fixed bin (35); dcl assn_ptr ptr; dcl assn_type fixed bin; stack.token_data.desc (stack.nargs) = desc; stack.token_data.bit_length (stack.nargs) = bit_length; stack.token_data.assn_ptr (stack.nargs) = assn_ptr; stack.token_data.assn_type (stack.nargs) = assn_type; stack.token_data.assn_len (stack.nargs) = assn_len; call shift_comm; end shift_common; shift_comm: proc; stack.token_data.key (stack.nargs) = token_data.key; stack.token_data.must_free (stack.nargs) = token_data.must_free; stack.token_data.length (stack.nargs) = token_data.length; stack.token_data.t_ptr (stack.nargs) = token_data.t_ptr; end shift_comm; shift_linus_var: proc; do i = 1 to variables.nvars while (variables.var_info.name (i) ^= token_item); end; /* find linus variable */ call shift_common (variables.var_info.desc (i), variables.var_info.bit_len (i), variables.var_info.var_ptr (i), variables.var_info.assn_type (i), variables.var_info.assn_len (i)); end shift_linus_var; shift_const: proc; dcl 1 token_data_temp like token_data; dcl first_char char (1) based (token_data_temp.t_ptr); dcl offset (10) bit (1) based; dcl repl_factor char (repl_len) based (repl_ptr); dcl constant_desc bit (36); dcl one_repl_ch char (1) based (orc_ptr); dcl one_source_ch char (1) based (osc_ptr); dcl ( ci_ptr init (null), repl_ptr init (null), orc_ptr init (null), osc_ptr init (null), source_ptr init (null) ) ptr; dcl k fixed bin; dcl repl_flag bit (1); dcl (repl_fac, repl_len, ci_len) fixed bin (35); dcl RIGHT_PAREN char (1) int static options (constant) init (")"); dcl LEFT_PAREN char (1) int static options (constant) init ("("); dcl QUOTE char (1) int static options (constant) init (""""); dcl BIT_DESC bit (36) init ("101001100000000000000000000000000000"b); token_data_temp = token_data; repl_flag = "0"b; source_length = token_data.length; source_ptr = token_data.t_ptr; if (search (token_item, "i")) > 0 then constant_desc = CMPX_FD; else constant_desc = REAL_FD; addr (constant_desc) -> arg_len_bits.length = substr (bit (token_data.length), 12, 24); /* set length of float dec descriptor */ if first_char = LEFT_PAREN then do; repl_flag = "1"b; /* there is a replication factor */ repl_ptr, token_data.t_ptr = addr (token_data.t_ptr -> offset (10)); do j = 2 to token_data.length while (first_char ^= RIGHT_PAREN); token_data.t_ptr = addr (token_data.t_ptr -> offset (10)); end; repl_len = j - 2; token_data.length = token_data.length - j; token_data.t_ptr = addr (token_data.t_ptr -> offset (10)); token_data_temp = token_data; repl_fac = fixed (repl_factor); end; if first_char = QUOTE then do; ci_ptr, token_data_temp.t_ptr = addr (token_data_temp.t_ptr -> offset (10)); do j = 2 to token_data_temp.length while (first_char ^= QUOTE); token_data_temp.t_ptr = addr (token_data_temp.t_ptr -> offset (10)); end; ci_len = token_data_temp.length - 2; if j = token_data_temp.length then constant_desc = CHAR_DESC; else do; ci_len = token_data_temp.length - 1; constant_desc = BIT_DESC; end; addr (constant_desc) -> arg_len_bits.length = addr (ci_len) -> arg_len_bits.length; source_ptr = ci_ptr; source_length = ci_len; if repl_flag then do; source_length, cs_len = repl_fac * ci_len; addr (constant_desc) -> arg_len_bits.length = addr (cs_len) -> arg_len_bits.length; allocate constant_string in (work_area); source_ptr, orc_ptr = cs_ptr; do j = 1 to repl_fac; /* to number of replication factor */ osc_ptr = ci_ptr; do k = 1 to ci_len; /* one for each character in string */ one_repl_ch = one_source_ch; orc_ptr = addr (orc_ptr -> offset (10)); osc_ptr = addr (osc_ptr -> offset (10)); end; end; end; end; call linus_assign_data (constant_desc, target_type, target_length); /* returns type and length */ call linus_lila_alloc_lit (lcb_ptr, addr (constant_desc), lit_ptr, bit_len); /* returns pointer to literal pool and bit length */ addr (CHAR_DESC) -> arg_len_bits.length = substr (bit (token_data.length), 12, 24); /* set length of char descriptor */ call linus_assign_data ((CHAR_DESC), source_type, source_length); /* returns type and length */ call assign_round_ (lit_ptr, target_type, target_length, source_ptr, source_type, source_length); call shift_common ((constant_desc), bit_len, lit_ptr, target_type, target_length); if cs_ptr ^= null then do; cs_ptr = null; cs_ptr = null; end; end shift_const; shift_col_spec: proc; dcl (i, j) fixed bin; dcl rel_name char (32); do i = 1 to ls_block.nselects while (token_data.mvar || "." || token_item ^= ls_block.sel_items (i)); end; /* check if already selected */ if ef_data.var_name = " " then ef_data.var_name = token_data.mvar; if token_data.mvar ^= ef_data.var_name then call error (linus_error_$inv_tup_var, ""); if i <= ls_block.nselects then do; call shift_common (ls_set.domain_info.desc (i), ls_set.domain_info.bit_length (i), ls_set.domain_info.assn_ptr (i), ls_set.domain_info.assn_type (i), ls_set.domain_info.assn_len (i)); end; else do; /* get rel_name from ls_block */ do i = 1 to ls_block.nritems while (token_data.mvar ^= ls_block.range_items.mrds_var (i)); end; if ls_block.range_items.rel_name (i) = ".V." then rel_name = linus_rel_array.rels.rel_name (ls_block.range_items.rel_index (i)); else rel_name = ls_block.range_items.rel_name (i); do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rel_name); end; rslt_ptr = linus_rel_array.rels.rslt_info_ptr (j); do j = 1 to rslt_info.num_attr while (token_item ^= rslt_info.attr.attr_name (j)); end; /* find info for attribute selected */ call linus_assign_data ((rslt_info.attr.descriptor (j)), source_type, source_length); call linus_lila_alloc_lit (lcb_ptr, addr (rslt_info.attr.descriptor (j)), lit_ptr, bit_len); call shift_common (rslt_info.attr.descriptor (j), bit_len, lit_ptr, source_type, source_length); /* pass mrds items data in ef_data and update ls_block & ls_set */ ef_data.nmrds_items = ef_data.nmrds_items + 1; if ls_block.nselects >= mrds_data_$max_select_items then call error (linus_error_$select_list_ovfl, ""); else do; ls_block.nselects = ls_block.nselects + 1; ls_block.sel_items (ls_block.nselects) = token_data.mvar || "." || token_item; end; ls_set.nselects = ls_set.nselects + 1; if ls_set.nselects > mrds_data_$max_select_items then call error (linus_error_$select_list_ovfl, ""); ef_data.mrds_items.attr_name (ef_data.nmrds_items) = token_item; ls_set.domain_info.bit_length (ls_set.nselects), ef_data.mrds_items.bit_length (ef_data.nmrds_items) = bit_len; ls_set.domain_info.assn_ptr (ls_set.nselects), ef_data.mrds_items.assn_ptr (ef_data.nmrds_items) = lit_ptr; ls_set.domain_info.assn_type (ls_set.nselects), ef_data.mrds_items.assn_type (ef_data.nmrds_items) = source_type; ls_set.domain_info.assn_len (ls_set.nselects), ef_data.mrds_items.assn_len (ef_data.nmrds_items) = source_length; ls_set.domain_info.desc (ls_set.nselects), ef_data.mrds_items.desc (ef_data.nmrds_items) = rslt_info.attr.descriptor (j); ls_set.domain_info.name (ls_set.nselects), ef_data.mrds_items.domain_name (ef_data.nmrds_items) = rslt_info.attr.domain_name (j); end; end shift_col_spec; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); call linus_lila_error (lcb_ptr, lsh_ptr, err_code, string); end error; end linus_lila_build_expr_tab;  linus_lila_build_scfn_str.pl1 07/29/86 1045.3r w 07/29/86 0939.8 139635 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_build_scfn_str: proc (lcb_ptr, lsh_ptr, td_ptr, fn_ptr, fn_var, code); /* DESCRIPTION: This procedure translates a linus scalar function into an equivalent MRDS scalar function string, suitable for inclusion in a MRDS -where clause. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 78-04-01 J. A. Weeldreyer: Modified to give better diagnostics for constant expr. of scalar fun. 78-08-02 J. A. Weeldreyer: Modified to conform to new token data. 80-03-13 Rickie E. Brinegar: Modified to base a work area on lcb.lila_area_ptr instead of getting system free area. 81-06-17 Rickie E. Brinegar: Modified to remove calls to dsl_v1_$get_fn_info. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. */ %include linus_lcb; %page; %include linus_ls_header; %page; %include linus_ls_block; %page; %include linus_token_data; %page; %include linus_set_fn; %page; %include linus_ef_data; %page; %include linus_mrds_block; %page; %include linus_variables; %page; %include mrds_scalfn_info; %page; %include mdbm_descriptor; dcl ( code, /* Output: return code */ icode, /* internal status code */ temp_pos ) fixed bin (35); /* current pos. for look-ahead */ dcl ( nargs, /* current fn. arg count */ i ) fixed bin; /* internal index */ dcl initial_mrds_vclock float bin (63); dcl ( done, /* completion flag */ lp_flag, /* on if need opening paren. */ rp_flag, /* on if closing paren OK */ comma_flag, /* on if comma OK */ arg_flag ) bit (1) unal; /* on if arg OK */ dcl ( fn_ptr, /* Output: ptr to mrds block for fun. */ fn_hd_ptr, lss_ptr /* pointer to ls_set structure */ ) ptr; /* pointer to last of fn. args */ dcl fn_var char (*); /* Output: var. name for fn. */ dcl ( variable, /* variable name */ master_var ) char (32); /* master variable for comparison */ dcl fn_name char (32) var; /* name of function */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl token char (token_data.length) based (token_data.t_ptr); dcl 1 temp_tok aligned like token_data; /* for look-ahead */ dcl temp_token char (temp_tok.length) based (temp_tok.t_ptr); /* for look-ahead */ dcl 1 expr_data aligned like ef_data; dcl ( linus_error_$scfn_syntax, linus_error_$inv_tup_var, linus_error_$scfn_nargs, linus_error_$const_expr_fn, linus_data_$lila_id, linus_data_$max_range_items, linus_data_$max_pred_stack_size, linus_data_$max_expr_items, mrds_data_$max_select_items, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, addrel, fixed, length, null, rel, vclock) builtin; dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_set_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_build_expr_str entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl linus_lila_build_scfn_str entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl dsl_$get_fn_info entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35)); sfi_ptr, /* initialize */ fn_hd_ptr, mblk_ptr = null; master_var = ""; num_dims, nargs = 0; lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; fn_name = token; /* save function name from passed in token */ token_data.key = NULL; /* force new token */ lp_flag = "1"b; /* init. state flags */ arg_flag, comma_flag, rp_flag = "0"b; done = "0"b; /* init completion flag */ do while (^done); /* main processing loop */ if token_data.key = NULL then do; /* if need new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; go to token_proc (token_data.key); token_proc (0): /* null */ token_proc (8): /* * */ token_proc (9): /* / */ token_proc (10): /* + */ token_proc (11): /* - */ token_proc (12): /* table name */ token_proc (13): /* row table pair */ token_proc (14): /* union */ token_proc (15): /* inter */ token_proc (16): /* differ */ token_proc (17): /* row designator */ token_proc (18): /* { */ token_proc (19): /* } */ token_proc (20): /* select */ token_proc (21): /* ^ */ token_proc (22): /* & */ token_proc (23): /* | */ token_proc (24): /* = */ token_proc (25): /* ^= */ token_proc (26): /* > */ token_proc (27): /* >= */ token_proc (28): /* < */ token_proc (29): /* <= */ token_proc (30): /* from */ token_proc (31): /* where */ token_proc (32): /* dup */ token_proc (33): /* unique */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token) ; /* we should never see these */ done = "1"b; go to next; token_proc (1): /* ) */ if ^rp_flag then /* not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); call finish; /* finish the MRDS scal fn. string */ done = "1"b; token_data.key = NULL; go to next; token_proc (2): /* column spec. */ if ^arg_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); temp_pos = ls_header.cur_pos; call linus_lila_get_token (lcb_ptr, lsh_ptr, temp_pos, addr (temp_tok), icode); /* look ahead at next token */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, temp_token); if temp_tok.key >= STAR & temp_tok.key <= MINUS then /* if is really expr. */ call process_expr; /* go process it */ else do; /* is really column spec. */ call check_var ((token_data.mvar));/* make sure tup. var. is consistent */ call set_ord_arg (token_data.mvar || "." || token); /* make mrds block and add to arg list */ token_data.key = NULL; /* force new token */ end; /* if column spec. */ comma_flag, rp_flag = "1"b; /* can now accept ) */ arg_flag = "0"b; go to next; token_proc (3): /* linus variable */ if ^arg_flag then /* not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); lv_ptr = lcb.lv_ptr; /* get linus var. info */ do i = 1 to variables.nvars while (token ^= variables.var_info.name (i)); end; /* guaranteed to find it */ call set_val_arg (variables.var_info.var_ptr (i), addr (variables.var_info.desc (i))); /* add to arg list */ token_data.key = NULL; comma_flag, rp_flag = "1"b; arg_flag = "0"b; go to next; token_proc (4): /* constant */ if ^arg_flag then /* not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); call set_ord_arg (token); /* add to arg list */ token_data.key = NULL; comma_flag, rp_flag = "1"b; arg_flag = "0"b; go to next; token_proc (5): /* set function */ if ^arg_flag then /* not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); call linus_lila_set_fn (lcb_ptr, lsh_ptr, td_ptr, addr (expr_data), icode); /* translate the set fn. */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); call set_val_arg (expr_data.assn_ptr, addr (expr_data.ef_ptr -> linus_set_fn.rslt_desc)); /* add to arg list */ comma_flag, rp_flag = "1"b; arg_flag = "0"b; go to next; token_proc (6): /* scalar function */ if ^arg_flag then /* not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); variable = ""; call linus_lila_build_scfn_str (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, variable, icode); /* translate the fn. */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); call check_var (variable); /* see if tup var consist. */ mrds_block.fwd_ptr = fn_hd_ptr; /* chain fn. into arg list */ fn_hd_ptr = mblk_ptr; mblk_ptr = null; nargs = nargs + 1; comma_flag, rp_flag = "1"b; arg_flag = "0"b; go to next; token_proc (7): /* ( */ if lp_flag then do; /* if opening ( */ lp_flag, /* reset state flags */ comma_flag, rp_flag = "0"b; arg_flag = "1"b; token_data.key = NULL; end; else if arg_flag then do; /* if expr. */ call process_expr; rp_flag = "1"b; end; else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); go to next; token_proc (34): /* , */ if comma_flag then do; rp_flag, comma_flag = "0"b; arg_flag = "1"b; token_data.key = NULL; end; else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_syntax, token); go to next; next: end; /* main processing loop */ fn_var = master_var; /* pass info back to caller */ fn_ptr = fn_hd_ptr; code = 0; return; check_var: proc (var); /* Procedure to ensure that scal. fn. uses only one tuple variable */ dcl var char (*); if var = "" then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$const_expr_fn, ""); if master_var = "" then /* if first time */ master_var = var; else if var ^= master_var then /* not same */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_tup_var, var) ; end check_var; finish: proc; /* Procedure to finish up the MRDS function string */ dcl ucode fixed bin (35); if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_fn_info (lcb.db_index, (fn_name), lcb.lila_area_ptr, sfi_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if icode ^= 0 then do; /* trouble getting info for fn. */ call linus_convert_code (icode, ucode, linus_data_$lila_id); call linus_lila_error (lcb_ptr, lsh_ptr, ucode, (fn_name)); end; if scalfn_info.nargs > 0 then /* if fixed arg fun. */ if nargs ^= scalfn_info.nargs then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$scfn_nargs, (fn_name)); sfi_ptr = null; do while (nargs > 1); /* put all args into one arg list string */ call combine; end; ms_len_init = length (fn_hd_ptr -> mrds_block.mrds_string) + length (fn_name) + 3; nval_args_init = fn_hd_ptr -> mrds_block.nval_args; /* alloc. and fill in final fn. string */ allocate mrds_block in (work_area); mrds_block.fwd_ptr = null; mrds_block.mrds_string = fn_name || " (" || fn_hd_ptr -> mrds_block.mrds_string || ")"; mrds_block.val_args = fn_hd_ptr -> mrds_block.val_args; fn_hd_ptr = null; fn_hd_ptr = mblk_ptr; mblk_ptr = null; combine: proc; /* Procedure to combine top two strings in list into one */ dcl (b1p, b2p) ptr; dcl i fixed bin; b2p = fn_hd_ptr; /* top operand */ b1p = b2p -> mrds_block.fwd_ptr; /* prev. operand */ ms_len_init = 1 + length (b1p -> mrds_block.mrds_string) /* set up and fill in mrds block for combination */ + length (b2p -> mrds_block.mrds_string); nval_args_init = b1p -> mrds_block.nval_args + b2p -> mrds_block.nval_args; allocate mrds_block in (work_area); mrds_block.fwd_ptr = b1p -> mrds_block.fwd_ptr; /* replace top two terms */ mrds_block.mrds_string = b1p -> mrds_block.mrds_string || " " || b2p -> mrds_block.mrds_string; do i = 1 to b1p -> mrds_block.nval_args; /* args from first operand */ mrds_block.val_args.arg_ptr (i) = b1p -> mrds_block.val_args.arg_ptr (i); mrds_block.val_args.desc_ptr (i) = b2p -> mrds_block.val_args.desc_ptr (i); end; do i = b1p -> mrds_block.nval_args + 1 to mrds_block.nval_args; /* args from second operand */ mrds_block.val_args.arg_ptr (i) = b2p -> mrds_block.val_args.arg_ptr (i - b1p -> mrds_block.nval_args); mrds_block.val_args.desc_ptr (i) = b2p -> mrds_block.val_args.desc_ptr (i - b1p -> mrds_block.nval_args); end; nargs = nargs - 1; fn_hd_ptr = mblk_ptr; /* chain in new operand */ mblk_ptr = null; b1p = null; b2p = null; end combine; end finish; set_ord_arg: proc (str); /* procedure to fill in a mrds block for arg with no values */ dcl str char (*); ms_len_init = length (str); nval_args_init = 0; allocate mrds_block in (work_area); mrds_block.fwd_ptr = fn_hd_ptr; mrds_block.mrds_string = str; fn_hd_ptr = mblk_ptr; mblk_ptr = null; nargs = nargs + 1; if token_data.must_free then token_data.t_ptr = null; end set_ord_arg; set_val_arg: proc (arg_ptr, desc_ptr); /* Procedure to fill in and stack a mrds block for an operand with one value */ dcl (arg_ptr, desc_ptr) ptr; dcl is_var (22) bit (1) int static unal options (constant) init ((19) (1)"0"b, "1"b, "0"b, "1"b); ms_len_init = 3; nval_args_init = 1; allocate mrds_block in (work_area); mrds_block.fwd_ptr = fn_hd_ptr; mrds_block.mrds_string = ".V."; if is_var (desc_ptr -> descriptor.type) then mrds_block.val_args.arg_ptr (1) = addrel (arg_ptr, 1); else mrds_block.val_args.arg_ptr (1) = arg_ptr; mrds_block.val_args.desc_ptr (1) = desc_ptr; fn_hd_ptr = mblk_ptr; mblk_ptr = null; nargs = nargs + 1; end set_val_arg; process_expr: proc; /* Procedure to translate an expression and add to arg. list. */ variable = ""; call linus_lila_build_expr_str (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, variable, icode); /* trans. the expr. */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); call check_var (variable); /* ensure tup. var. consist. */ mrds_block.fwd_ptr = fn_hd_ptr; /* chain to arg. list */ fn_hd_ptr = mblk_ptr; mblk_ptr = null; nargs = nargs + 1; end process_expr; end linus_lila_build_scfn_str;  linus_lila_error.pl1 07/29/86 1045.3r w 07/29/86 0939.8 22185 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_error: proc (lcb_ptr, lsh_ptr, code, message); /* DESCRIPTION: This procedure prints an error diagnostic and signals the linus_lila_error_ condition, allowing linus_lila_translate to cleanup and terminate. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. */ %include linus_lcb; %page; %include linus_ls_header; %page; %include linus_source; dcl (code, sbeg, slen) fixed bin (35); dcl lno fixed bin; dcl message char (*); dcl shorti char (8) aligned; dcl msg char (100) aligned; dcl iox_$error_output ptr ext; dcl sys_info$max_seg_size fixed bin (35) ext; dcl substr builtin; dcl linus_lila_error_ condition; dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl ioa_$ioa_switch entry options (variable); ls_header.trans_failed = "1"b; /* if we ever handle more than 1 error */ do lno = 1 to lcb.lila_count - 1 while (ls_header.cur_pos > ls_header.line_data.last_char (lno)); end; /* determine line number of error line */ sbeg = ls_header.line_data.last_char (lno - 1) + 1; slen = ls_header.line_data.last_char (lno) - ls_header.line_data.last_char (lno - 1); call convert_status_code_ (code, shorti, msg); call ioa_$ioa_switch (iox_$error_output, "^/ERROR IN LINE ^a.^/^a^/^a^/^a", ls_header.line_data.lno (lno), msg, message, substr (source_str, sbeg, slen)); signal linus_lila_error_; return; end linus_lila_error;  linus_lila_from.pl1 07/29/86 1045.3r w 07/29/86 0939.9 84834 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_from: proc (lcb_ptr, lsh_ptr, td_ptr, code); /* DESCRIPTION: This procedure translates the FROM clause of a LILA block into a tuple variable and relation name which can be added to a MRDS -range clause. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 78-02-01 J. A. Weeldreyer: Modified to correctly recognize tables and row designators defined in outer blocks. 78-07-01 J. A. Weeldreyer: Modified to assign generated variables to all tables in from list. 79-02-01 J. C. C. Jagernauth: Modified to access version 4 resultant information. 80-01-08 Rickie E. Brinegar: Modified to pass linus_lila_alloc_lit a ptr to a descriptor instead of an assign_ descriptor type and eliminate the assign_ length parameter. 80-04-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-09-15 Rickie E. Brinegar: Modified to use linus_rel_array instead of dsl_$get_rslt_info. 81-02-03 Rickie E. Brinegar: The rel builtin was added to the declarations. Modified to use the new linus_rel_array structure. 81-10-07 Rickie E. Brinegar: Changed to set ls_header.from_token to "1"b on entry and reset ls_header.from_token to "0"b on exit. This is in response to TR11628. */ %include linus_lcb; %page; %include linus_ls_block; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_rel_array; %page; %include linus_temp_tab_names; %page; %include linus_token_data; %page; %include mrds_rslt_info; dcl ( code, /* Output: status code */ icode ) fixed bin (35); /* internal status code */ dcl gen_var char (6); /* generated variable */ dcl i fixed bin; /* internal index */ dcl token char (token_data.length) based (token_data.t_ptr); /* value of token */ dcl tab_found bit (1); dcl FB35_DESC bit (36) int static options (constant) init ("100000100000000000000000000000100011"b); dcl ( linus_data_$max_pred_stack_size, linus_data_$max_range_items, linus_data_$max_set_stack_size, linus_error_$cant_alloc_lit, linus_error_$no_from, linus_error_$no_table_list, linus_error_$range_ovfl, linus_error_$undef_tab, mrds_data_$max_select_items, mrds_data_$max_temp_rels, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, fixed, index, null, rel, substr) builtin; dcl linus_lila_alloc_lit entry (ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); ls_header.from_token = "1"b; linus_rel_array_ptr = lcb.rel_array_ptr; lsb_ptr = ls_header.cur_ptr; /* init */ lss_ptr = ls_block.back_ptr; if token_data.key = NULL then do; /* must get new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); end; if token_data.key ^= FROM then /* must have from keyword */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$no_from, token); call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); /* get first item in from list */ tab_found = "0"b; /* init */ do while (token_data.key = ROW_TAB_PAIR | token_data.key = TAB_NAME | token_data.key = ROW_DES | token_data.key = COL_SPEC); /* loop through table list */ tab_found = "1"b; /* remember found at least one table */ if token_data.key = ROW_TAB_PAIR then do; /* is a table list */ i = index (token, ":"); /* find separater */ call add_range_item (substr (token, 1, i - 1), substr (token, 1, i - 1), substr (token, i + 1)); end; /* if row tab pair */ else if token_data.key = TAB_NAME then do; /* if table name */ call make_var; /* generate variable */ call add_range_item (token, gen_var, token); /* add to range list */ end; else if token_data.key = COL_SPEC then do; /* if column spec. */ i = index (token, "."); /* isolate column name */ call check_rel_name (substr (token, i + 1, token_data.length - i)); /* see if col. name is a table */ call make_var; call add_range_item (substr (token, i + 1, token_data.length - i), gen_var, substr (token, i + 1, token_data.length - i)); end; /* if column spec. */ else do; /* if row desig. */ call check_rel_name (token); /* see if relation name */ call make_var; call add_range_item (token, gen_var, token); end; /* if row desig. */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); /* get first token after list */ end; /* table list loop */ if ^tab_found then /* if found no table */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$no_table_list, token); /* if no table list or name */ code = 0; /* made it */ exit: ls_header.from_token = "0"b; return; make_var: proc; /* Procedure to generate tuple variable when not explecitily specified */ dcl char_num pic "99999"; ls_set.var_ind = ls_set.var_ind + 1; char_num = ls_set.var_ind; gen_var = "V" || char_num; end make_var; check_rel_name: proc (rel_name); /* Procedure to validate a relation name; does not return if not valid */ dcl rel_name char (*); dcl (i, j) fixed bin; do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rel_name); end; if j > linus_rel_array.num_of_rels then do; /* not in db., check temp rels. */ if lcb.ttn_ptr = null then /* no temps defined */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$undef_tab, token); ttn_ptr = lcb.ttn_ptr; do i = 1 to mrds_data_$max_temp_rels while (temp_tab_names (i) ^= token); /* search temp table names */ end; if i > mrds_data_$max_temp_rels then /* not found */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$undef_tab, token); end; /* checking temp rels */ end check_rel_name; add_range_item: proc (lvar, mvar, rel); /* Procedure to create a range item, given a tup.var and relation */ dcl l_ptr ptr; dcl (lvar, mvar, rel) char (*); dcl i fixed bin; dcl fb35 fixed bin (35) based; dcl bit_len fixed bin (35); if ls_block.nritems >= linus_data_$max_range_items then /* if will overflow */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$range_ovfl, token); ls_block.nritems = ls_block.nritems + 1; /* incr. item count */ ls_block.range_items.tup_var (ls_block.nritems) = lvar; /* store var name */ ls_block.range_items.mrds_var (ls_block.nritems) = mvar; ls_block.range_items.level (ls_block.nritems) = ls_block.ib_level; if token_data.temp_tab then do; /* if is temp table */ ls_block.range_items.rel_name (ls_block.nritems) = ".V."; ttn_ptr = lcb.ttn_ptr; do i = 1 to mrds_data_$max_temp_rels while (temp_tab_names (i) ^= rel); end; /* search for tab name */ call linus_lila_alloc_lit (lcb_ptr, addr (FB35_DESC), l_ptr, bit_len); /* alloc fixed bin(lcb_ptr, bit_len) */ if l_ptr = null then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, rel); ls_block.range_items.rel_index (ls_block.nritems), l_ptr -> fb35 = i; /* fill in temp rel index */ ls_block.nrange_args = ls_block.nrange_args + 1; /* cant overflow because nritems checked */ ls_block.range_items.arg_ptr (ls_block.nritems) = l_ptr; ls_block.range_items.desc_ptr (ls_block.nritems) = addr (FB35_DESC); end; /* if temp table */ else do; ls_block.range_items.rel_name (ls_block.nritems) = rel; ls_block.range_items.rel_index (ls_block.nritems) = 0; ls_block.range_items.arg_ptr (ls_block.nritems), ls_block.range_items.desc_ptr (ls_block.nritems) = null; end; ls_block.dflt_ritem = ls_block.nritems; /* update current default */ end add_range_item; end linus_lila_from;  linus_lila_get_token.pl1 07/29/86 1045.3rew 07/29/86 0937.0 331137 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-01-13,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): 84-12-28 Matthew Pierret: Changed to use linus_lila_tokens_ external variables instead of hard-coding reserved words into the code. END HISTORY COMMENTS */ linus_lila_get_token: proc (lcb_ptr, lsh_ptr, start_pos, td_ptr, code); /* DESCRIPTION: This procedure is the lexical analizer for the LILA translator. It isolates the next token after the start_pos, returns its key and a pointer to and length of its value. The start_pos is adjusted to the first character following the token just isolated. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 77-12-01 J. A. Weeldreyer: Modified to correctly parse complex arith. constants. 78-02-01 J. A. Weeldreyer: Modified to better handle hyphenated idents. 78-06-01 J. A. Weeldreyer: Modified to properly detect keywords. 78-07-01 J. A. Weeldreyer: Modified to properly parse row designators. 78-07-01 J. A. Weeldreyer: Modified to properly parse linus variables. 79-02-01 J. C. C. Jagernauth: Modified to access version 4 resultant information. 80-04-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 81-01-14 Rickie E. Brinegar: Modified to use linus_rel_array instead of using the resultant model. 81-02-02 Rickie E. Brinegar: moved the internal static debug_switch from the db_on entry to the main entry. 81-02-03 Rickie E. Brinegar: the builtins char, fixed and rel were added to the declarations. The unused variables i, k, rindex were removed from various procedures. The valid_rel procedure was modified to add temp_rels to the linus_rel_array structure by the LINUS temp_table_name. 81-06-03 Rickie E. Brinegar: Modified to remember temporary tables as a result of TR9817. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-10-05 Rickie E. Brinegar: Changed the valid_attr procedure to use ls_block.range_items.rel_index (tv_index) as a subscript for temp_tab_names when instead of tv_index. This alleviates the losing of temporary tables when they do not appear in the order that they are defined in. This is in response to TRs 11494, 11626 and 11645 81-10-07 Rickie E. Brinegar: Modified the ident_proc proc to only check for valid relations when being called by linus_lila_from (ls_header.from_token = "1"b). This is in response to TR11628. 81-10-19 Rickie E. Brinegar: Modified the error proc to set ls_header.cur_pos to cur_pos before returning to the caller. This permits linus_lila_error to correctly determine the line that the error occurred in. This is in response to TR8988. 81-10-30 DJ Schimke: Modified is_const internal function to use verify instead of index. 81-11-05 DJ Schimke: Modified to permit unary operators in constants. This includes both leading +- signs and parenthesized constants. Declared first_op and first_dp. This is in response to TR6446. 81-11-25 Rickie E. Brinegar: Modified to time calls to MRDS (dsl_ calls). 83-06-16 DJ Schimke: Modified to permit single constants as arguments to functions. This amounts to letting (1) through as an expression rather than as a constant. This is in response to TR15411. */ %include linus_lcb; %page; %include linus_ls_block; %page; %include linus_ls_header; %page; %include linus_rel_array; %page; %include linus_set_fn_info; %page; %include linus_source; %page; %include linus_temp_tab_names; %page; %include linus_token_data; %page; %include linus_variables; %page; %include mrds_rslt_info; dcl ( code, /* Output: status code */ cur_pos, /* current position in string */ i, /* internal index */ icode, /* internal status code */ j, /* internal index */ start_pos /* Input/Output: position at which to start scan */ ) fixed bin (35); dcl initial_mrds_vclock float bin (63); dcl found bit (1); dcl ARITH_CHARS char (16) int static options (constant) init (".eib0123456789+-"); dcl CONS_PREC char (9) int static options (constant) init ("(,+-*/<>="); dcl ARITH_START char (14) int static options (constant) init (".0123456789+-("); dcl DELIMS char (3) int static options (constant) init (" "); dcl ID_CHARS char (64) int static options (constant) init ( "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-"); dcl BLOCK fixed bin int static options (constant) init (4); dcl debug_switch bit (1) int static init ("0"b); dcl sfi_ptr ptr; /* pointer to scalfn_info structure */ dcl ( linus_data_$max_pred_stack_size, linus_data_$max_range_items, linus_error_$dup_row_des, linus_error_$inv_string_const, linus_error_$invalid_token, linus_error_$linus_var_not_defined, linus_error_$long_id, linus_error_$long_lv_name, linus_error_$unbal_parens, linus_error_$undef_col, linus_error_$undef_id, linus_error_$undef_row_des, linus_error_$undef_tab, mrds_data_$max_id_len, mrds_data_$max_select_items, mrds_data_$max_temp_rels, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl (linus_lila_tokens_$first_chars, linus_lila_tokens_$differ, linus_lila_tokens_$dup, linus_lila_tokens_$from, linus_lila_tokens_$inter, linus_lila_tokens_$select, linus_lila_tokens_$union, linus_lila_tokens_$unique, linus_lila_tokens_$where) char (32) varying ext; dcl (addr, collate, char, fixed, index, length, null, rel, search, substr, translate, vclock, verify) builtin; dcl dsl_$get_fn_info entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35)); dcl dsl_$get_rslt_info entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35)); dcl dsl_$get_temp_info entry (fixed bin (35), fixed bin (35), ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl first_op fixed bin; /* position of first unary operator in a constant */ dcl first_dp fixed bin; /* position of first decimal point in a constant */ ttn_ptr = lcb.ttn_ptr; linus_rel_array_ptr = lcb.rel_array_ptr; rslt_ptr = null; if start_pos > lcb.lila_chars then /* nothing left */ token_data.key = NULL; else do; /* if have something left */ i = verify (substr (source_str, start_pos), DELIMS); /* skip white space */ if i > 0 then do; /* if possible token */ cur_pos = start_pos + i - 1; /* first char of poss. token */ go to char_proc (index (collate (), source_array (cur_pos))); /* see what we have */ char_proc (1): /* special characters */ char_proc (2): char_proc (3): char_proc (4): char_proc (5): char_proc (6): char_proc (7): char_proc (8): char_proc (9): char_proc (10): char_proc (11): char_proc (12): char_proc (13): char_proc (14): char_proc (15): char_proc (16): char_proc (17): char_proc (18): char_proc (19): char_proc (20): char_proc (21): char_proc (22): char_proc (23): char_proc (24): char_proc (25): char_proc (26): char_proc (27): char_proc (28): char_proc (29): char_proc (30): char_proc (31): char_proc (32): char_proc (33): /* space */ char_proc (36): /* # */ char_proc (37): /* $ */ char_proc (38): /* % */ char_proc (40): /* ' */ char_proc (59): /* : */ char_proc (60): /* ; */ char_proc (64): /* ? */ char_proc (65): /* @ */ char_proc (92): /* [ */ char_proc (93): /* \ */ char_proc (94): /* ] */ char_proc (96): /* _ */ char_proc (97): /* ` */ char_proc (127): /* ~ */ char_proc (128): /* PAD */ token_data.length = 1; /* so user knows what caused problem */ token_data.t_ptr = addr (source_array (cur_pos)); token_data.must_free = "0"b; call error (linus_error_$invalid_token); /* none of these chars. can start a token */ char_proc (34): /* ! */ token_data.key = LINUS_VAR; /* this is a linus variable */ token_data.must_free = "0"b; /* wont alloc. */ cur_pos = cur_pos + 1; /* first char past ! */ token_data.t_ptr = addr (source_array (cur_pos)); i = verify (substr (source_str, cur_pos), ID_CHARS); /* find end of token */ if i <= 0 then i = lcb.lila_chars - cur_pos + 2; token_data.length = i - 1; if lcb.lv_ptr = null then /* if no variables defined */ call error (linus_error_$linus_var_not_defined); lv_ptr = lcb.lv_ptr; if variables.nvars <= 0 then /* if no variables */ call error (linus_error_$linus_var_not_defined); do j = 1 to variables.nvars while (variables.var_info.name (j) ^= substr (source_str, cur_pos, token_data.length)); /* look for var. */ end; if j > variables.nvars then do; /* if didn't find it */ i = index (substr (source_str, cur_pos, token_data.length), "-"); /* look for imbedded hyphen */ if i <= 0 then call error (linus_error_$linus_var_not_defined); /* not there */ token_data.length = i - 1; /* found one, check first part */ do j = 1 to variables.nvars while (variables.var_info.name (j) ^= substr (source_str, cur_pos, token_data.length)); end; if j > variables.nvars then call error (linus_error_$linus_var_not_defined); end; /* if didn't find it first time */ if token_data.length > mrds_data_$max_id_len then /* if too long */ call error (linus_error_$long_lv_name); start_pos = cur_pos + token_data.length; /* adjust scan start pos. */ go to exit; /* end ! */ char_proc (35): /* " */ token_data.key = CONST; /* this is a string constant */ token_data.must_free = "0"b; /* not allocating */ token_data.t_ptr = addr (source_array (cur_pos)); found = "0"b; /* init for end search */ cur_pos = cur_pos + 1; token_data.length = 1; i = index (substr (source_str, cur_pos), """"); /* look for next " */ do while (i > 0 & ^found); /* search for single quote */ token_data.length = token_data.length + i; /* increment length */ cur_pos = cur_pos + i; /* first char beyond */ if cur_pos > lcb.lila_chars then found = "1"b; /* single quote at end of string */ else if source_array (cur_pos) = """" then do; cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; if cur_pos <= lcb.lila_chars then i = index (substr (source_str, cur_pos), """"); else i = 0; end; /* if double " */ else found = "1"b; /* if single " */ end; /* single " search loop */ if ^found then call error (linus_error_$inv_string_const); if cur_pos ^> lcb.lila_chars then if source_array (cur_pos) = "b" then do; /* if bit string */ cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; end; start_pos = cur_pos; go to exit; /* end " */ char_proc (39): /* & */ call set_token (AND, 1); /* return AND token */ go to exit; char_proc (41): /* ( */ token_data.key = LP; /* assume LP unless proven other */ i = verify (substr (source_str, cur_pos + 1), "0123456789"); /* is possible string const */ if source_array (cur_pos + i) = ")" & i > 1 then do; /* good chance of string const */ j = verify (substr (source_str, cur_pos + i + 1), DELIMS); /* skip white space */ if source_array (cur_pos + i + j) = """" then do; /* have string const */ token_data.key = CONST; token_data.length = i + j + 1; /* init for quote search loop */ token_data.t_ptr = addr (source_array (cur_pos)); cur_pos = cur_pos + i + j + 1; found = "0"b; i = index (substr (source_str, cur_pos), """"); /* find next quote */ do while (i > 0 & ^found); /* until we find a single quote */ token_data.length = token_data.length + i; /* incr. length */ cur_pos = cur_pos + i; /* first char beyond */ if cur_pos > lcb.lila_chars then call error (linus_error_$inv_string_const); if source_array (cur_pos) = """" then do; /* if double quote */ cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; if cur_pos <= lcb.lila_chars then i = index (substr (source_str, cur_pos), """"); else i = 0; /* terminate if past end of string */ end; /* if double quote */ else do; /* if single quote */ found = "1"b; cur_pos = cur_pos + i; token_data.length = token_data.length + i; end; /* if single quote */ end; /* single quote search loop */ if ^found then call error (linus_error_$inv_string_const); if source_array (cur_pos) = "b" then do; /* if bit string */ cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; end; token_data.must_free = "0"b; start_pos = cur_pos; end; /* if string const */ end; /* if good chance */ i = verify (substr (source_str, cur_pos + 1), ARITH_CHARS || DELIMS); if source_array (cur_pos + i) = ")" then do; /* possible arith constant */ first_op = search (substr (source_str, cur_pos + 1, i), "+-"); /* find first unary operator */ if first_op ^= 0 & search (substr (source_str, cur_pos + first_op + 1, i - first_op), "+-") = 0 & search (substr (source_str, cur_pos + 1, first_op), "1234567890") = 0 then do; /* valid unary */ first_dp = index (substr (source_str, cur_pos + 1, i), "."); /* find first period */ if search ( substr (source_str, cur_pos + first_dp + 1, i - first_dp), ".") = 0 then call arith_const; end; /* is valid unary */ end; /* possible arith constant */ if token_data.key = LP then call set_token (LP, 1); /* if wasn't const */ go to exit; /* end ( */ char_proc (42): /* ) */ call set_token (RP, 1); go to exit; char_proc (43): /* * */ call set_token (STAR, 1); go to exit; char_proc (44): /* + */ if is_const () = "1"b then call arith_const; /* is arith const = "1"b */ else call set_token (PLUS, 1);/* is operator */ go to exit; char_proc (45): /* , */ call set_token (COMMA, 1); go to exit; char_proc (46): /* - */ if is_const () = "1"b then call arith_const; else call set_token (MINUS, 1); go to exit; char_proc (47): /* . */ char_proc (49): /* 0 */ char_proc (50): /* 1 */ char_proc (51): /* 2 */ char_proc (52): /* 3 */ char_proc (53): /* 4 */ char_proc (54): /* 5 */ char_proc (55): /* 6 */ char_proc (56): /* 7 */ char_proc (57): /* 8 */ char_proc (58): /* 9 */ /* these characters begin an arith. const. */ call arith_const; go to exit; char_proc (48): /* / */ call set_token (DIV, 1); go to exit; char_proc (61): /* < */ if source_array (cur_pos + 1) = "=" then call set_token (LE, 2); else call set_token (LT, 1); go to exit; char_proc (62): /* = */ call set_token (EQ, 1); go to exit; char_proc (63): /* > */ if source_array (cur_pos + 1) = "=" then call set_token (GE, 2); else call set_token (GT, 1); go to exit; char_proc (66): /* A */ char_proc (67): /* B */ char_proc (68): /* C */ char_proc (69): /* D */ char_proc (70): /* E */ char_proc (71): /* F */ char_proc (72): /* G */ char_proc (73): /* H */ char_proc (74): /* I */ char_proc (75): /* J */ char_proc (76): /* K */ char_proc (77): /* L */ char_proc (78): /* M */ char_proc (79): /* N */ char_proc (80): /* O */ char_proc (81): /* P */ char_proc (82): /* Q */ char_proc (83): /* R */ char_proc (84): /* S */ char_proc (85): /* T */ char_proc (86): /* U */ char_proc (87): /* V */ char_proc (88): /* W */ char_proc (89): /* X */ char_proc (90): /* Y */ char_proc (91): /* Z */ call ident_proc; /* determine identifier type, and set up token data */ go to exit; char_proc (98): /* a */ char_proc (99): /* b */ char_proc (100): /* c */ char_proc (101): /* d */ char_proc (102): /* e */ char_proc (103): /* f */ char_proc (104): /* g */ char_proc (105): /* h */ char_proc (106): /* i */ char_proc (107): /* j */ char_proc (108): /* k */ char_proc (109): /* l */ char_proc (110): /* m */ char_proc (111): /* n */ char_proc (112): /* o */ char_proc (113): /* p */ char_proc (114): /* q */ char_proc (115): /* r */ char_proc (116): /* s */ char_proc (117): /* t */ char_proc (118): /* u */ char_proc (119): /* v */ char_proc (120): /* w */ char_proc (121): /* x */ char_proc (122): /* y */ char_proc (123): /* z */ if verify (substr (source_str, cur_pos, 1), linus_lila_tokens_$first_chars) ^= 0 then do; call ident_proc; /* determine identifier type, and set up token data */ go to exit; end; else do; i = verify (substr (source_str, cur_pos + 1), ID_CHARS); if substr (source_str, cur_pos, i) = linus_lila_tokens_$from then call set_token (FROM, length(linus_lila_tokens_$from)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$select then call set_token (SELECT, length(linus_lila_tokens_$select)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$where then call set_token (WHERE, length(linus_lila_tokens_$where)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$differ then call set_token (DIFFER, length(linus_lila_tokens_$differ)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$dup then call set_token (DUP, length(linus_lila_tokens_$dup)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$inter then call set_token (INTER, length(linus_lila_tokens_$inter)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$unique then call set_token (UNIQUE, length(linus_lila_tokens_$unique)); else if substr (source_str, cur_pos, i) = linus_lila_tokens_$union then call set_token (UNION, length (linus_lila_tokens_$union)); else call ident_proc; end; go to exit; char_proc (95): /* ^ */ if source_array (cur_pos + 1) = "=" then call set_token (NE, 2); else call set_token (NOT, 1); go to exit; char_proc (124): /* { */ call set_token (LB, 1); go to exit; char_proc (125): /* | */ call set_token (OR, 1); go to exit; char_proc (126): /* } */ call set_token (RB, 1); go to exit; exit: end; /* token section */ else do; /* ran out of tokens */ token_data.key = NULL; start_pos = lcb.lila_chars + 1; end; end; /* if something to do */ code = 0; if debug_switch then do; if cur_pos >= 1 & start_pos > cur_pos then call ioa_ ("Token: ""^a""", substr (source_str, cur_pos, start_pos - cur_pos)); else call ioa_ ("Token: start_pos = ^i; cur_pos = ^i", start_pos, cur_pos); call ioa_ ("^2-key = ^i", token_data.key); call ioa_$nnl ("^2-Flags: "); if ^token_data.must_free then call ioa_$nnl ("^^"); call ioa_$nnl ("must_free,"); if ^token_data.temp_tab then call ioa_$nnl ("^^"); call ioa_ ("temp_tab"); call ioa_ ("^2-mvar = ""^a""^/^2-lvar = ""^a""", mvar, lvar); call ioa_ ("^2-length = ^i", token_data.length); call ioa_ ("^2-t_ptr = ^p", token_data.t_ptr); end; /* if debug_switch */ real_exit: ; return; db_on: entry; /* Usage: linus_lila_get_token$db_on Turns on a switch which causes the value of the current token to be displayed at the terminal. */ debug_switch = "1"b; return; db_off: entry; /* Usage: linus_lila_get_token$db_off Turns off the switch which causes the value of the current token to be displayed at the terminal. */ debug_switch = "0"b; return; set_token: proc (key, length); /* Procedure to set up token_data given a key value and token length */ dcl (key, length) fixed bin; token_data.key = key; token_data.length = length; token_data.temp_tab, token_data.must_free = "0"b; /* didn't allocate */ token_data.mvar, token_data.lvar = ""; token_data.t_ptr = addr (source_array (cur_pos)); start_pos = cur_pos + length; end set_token; set_id_token: proc (key, mvar, lvar, length); /* Procedure to set up an ident. token data */ dcl (key, length) fixed bin; dcl (mvar, lvar) char (32) var; token_data.key = key; token_data.length = length; token_data.temp_tab, token_data.must_free = "0"b; /* didn't allocate */ token_data.t_ptr = addr (source_array (cur_pos)); token_data.mvar = mvar; token_data.lvar = lvar; start_pos = cur_pos + length; end set_id_token; set_tab_name: proc (temp_flag, length); /* procedure to set up table name token */ dcl length fixed bin; dcl temp_flag bit (1); token_data.key = TAB_NAME; token_data.length = length; token_data.must_free = "0"b; token_data.t_ptr = addr (source_array (cur_pos)); token_data.temp_tab = temp_flag; token_data.mvar, token_data.lvar = ""; start_pos = cur_pos + length; end set_tab_name; is_const: proc returns (bit (1)); /* Procedure to determine if token at cur_pos is an arithmetic constant or is an operator. */ dcl i fixed bin; dcl flag bit (1); if verify (source_array (cur_pos + 1), ARITH_START) = 0 then do; /* possible const. */ do i = cur_pos - 1 to 1 by -1 while (verify (source_array (i), DELIMS) = 0); end; /* search for end of prev token */ if i < 1 then flag = "1"b; /* first token, must be const */ else if verify (source_array (i), CONS_PREC) = 0 then flag = "1"b; /* if predecessor forces constant */ else flag = "0"b; /* is operator */ end; /* possible constant */ else flag = "0"b; /* if no chance of constant */ return (flag); end is_const; arith_const: proc; /* Procedure to isolate an arithmetic constant, and set up the resulting token data */ dcl i fixed bin; /* length of constant */ dcl j fixed bin; /* location of LP */ token_data.key = CONST; token_data.t_ptr = addr (source_array (cur_pos)); token_data.must_free = "0"b; i = verify (substr (source_str, cur_pos + 1), ARITH_CHARS); if i <= 0 then i = lcb.lila_chars - cur_pos + 1; else if source_array (cur_pos + i - 1) = "+" /* see if ended with operator */ | source_array (cur_pos + i - 1) = "-" then i = i - 1; j = index (substr (source_str, cur_pos), "("); /* find lp position (if any)*/ if (j = 1) | (j = 2 & search (substr (source_str, cur_pos, 2), "-+") = 1) then do; /* constant enclosed in parentheses */ i = index (substr (source_str, cur_pos), ")"); /* must end in matching parentheses */ if search (substr (source_str, cur_pos + j, i - j - 1), "()") ^= 0 then call error (linus_error_$unbal_parens); /* no others allowed */ if j = 1 then substr (source_str, cur_pos, i) = substr (source_str, cur_pos + 1, i - 1); else substr (source_str, cur_pos, i) = source_array (cur_pos) || substr (source_str, cur_pos + 2, i - 2); /* strip out lp */ substr (source_str, cur_pos, i) = translate (substr (source_str, cur_pos, i), "", " +)"); /* strip out spaces, rp, and plus */ end; /* enclosed constant */ token_data.length = i; /* set length constant */ token_data.mvar, token_data.lvar = ""; start_pos = cur_pos + i; end arith_const; ident_proc: proc; /* Procedure to determine identifier type. The following items are checked for, in the order specified: row_designator, relation name, column name, set function, scalar function. */ dcl (i, j, k, vindex) fixed bin; dcl temp_flag bit (1); dcl f_choice char (i) based (addr (source_array (cur_pos))); dcl s_choice char (j) based (addr (source_array (cur_pos))); dcl ip_character_string_length fixed bin; dcl ip_character_string char (ip_character_string_length) based (addr (source_array (cur_pos + i + 1))); j = 0; /* init */ i = verify (substr (source_str, cur_pos), ID_CHARS); /* find end of id. */ if i <= 0 then i = lcb.lila_chars - cur_pos + 1; else i = i - 1; /* i is length */ token_data.length = i; /* init. token in case of error */ token_data.t_ptr = addr (source_array (cur_pos)); token_data.must_free = "0"b; if i > mrds_data_$max_id_len then do; /* too long, may have hidden - */ j = index (substr (source_str, cur_pos, i), "-"); if j <= 0 then call error (linus_error_$long_id); /* is bad */ if j > mrds_data_$max_id_len then call error (linus_error_$long_id); /* if first part too long */ else do; /* first part ok */ i = j - 1; j = 0; end; end; /* if orig. id. too long */ else j = index (substr (source_str, cur_pos, i), "-"); /* see if there is second choice */ if j > 0 then j = j - 1; /* yes, set true length */ lsb_ptr = ls_header.cur_ptr; /* point to current lila stack frame */ if ls_block.type = BLOCK then do; /* if in lila block */ if source_array (cur_pos + i) = ":" then do; /* row tab pair */ if valid_var (f_choice, vindex) then call error (linus_error_$dup_row_des); /* was prev. defined */ j = verify (substr (source_str, cur_pos + i + 1), ID_CHARS); /* isolate rel name */ ip_character_string_length = j - 1; if ^valid_rel (ip_character_string, temp_flag) then call error (linus_error_$undef_tab); call set_token (ROW_TAB_PAIR, i + j); /* is valid row tab pair */ token_data.temp_tab = temp_flag; /* remember if it was a temp table */ end; /* if : */ else if ls_block.nritems > 0 then do; /* if range started */ if source_array (cur_pos + i) = "." then do; /* possible col. spec. */ if source_array (cur_pos + i + 1) = "*" then /* select. of entire tuple */ if valid_var (f_choice, vindex) then do; call set_id_token (ROW_DES, ls_block.range_items.mrds_var (vindex), ls_block.range_items.tup_var (vindex), i); start_pos = start_pos + 2; /* adjust beyond * */ end; else call error (linus_error_$undef_row_des); else do; /* if not entire tuple */ do k = ls_block.nritems by -1 to 1 while (f_choice ^= ls_block.range_items.tup_var (k)); end; /* look for tuple var. */ if k < 1 then call error (linus_error_$undef_row_des); vindex = k; /* save var. index */ j = verify (substr (source_str, cur_pos + i + 1), ID_CHARS); /* get attr. name */ if j <= 0 then j = lcb.lila_chars - cur_pos - i; ip_character_string_length = j - 1; if ^valid_attr (vindex, ip_character_string) then do; /* may be - */ k = index (substr (source_str, cur_pos + i + 1, j - 1), "-"); if k <= 0 then call error (linus_error_$undef_col); ip_character_string_length = k - 1; if ^valid_attr (vindex, ip_character_string) then call error (linus_error_$undef_col); j = k; /* first part ok */ end; /* failed first attr. choice */ cur_pos = cur_pos + i + 1; call set_id_token (COL_SPEC, ls_block.range_items.mrds_var (vindex), ls_block.range_items.tup_var (vindex), j - 1); end; /* if not entire tuple */ end; /* if col. spec. */ else if ls_header.from_token then do; if valid_rel (f_choice, temp_flag) then call set_tab_name (temp_flag, i); else if valid_rel (s_choice, temp_flag) then call set_tab_name (temp_flag, j); else call error (linus_error_$undef_tab); end; else if valid_attr (0, f_choice) then call set_col_spec (i); else if valid_var (f_choice, vindex) then call set_id_token (ROW_DES, ls_block.range_items.mrds_var (vindex), ls_block.range_items.tup_var (vindex), i); else if valid_rel (f_choice, temp_flag) then call set_tab_name (temp_flag, i); else if valid_set_fn (f_choice) then call set_token (SET_FN, i); else if valid_scal_fn (f_choice) then call set_token (SCAL_FN, i); else if valid_attr (0, s_choice) then call set_col_spec (j); else if valid_var (s_choice, vindex) then call set_id_token (ROW_DES, ls_block.range_items.mrds_var (vindex), ls_block.range_items.tup_var (vindex), j); else if valid_rel (s_choice, temp_flag) then call set_tab_name (temp_flag, j); else call error (linus_error_$undef_id); end; /* if have range start */ else if valid_rel (f_choice, temp_flag) then /* if first item in range */ call set_tab_name (temp_flag, i); else call error (linus_error_$undef_id); end; /* if in lila block */ else if valid_set_fn (f_choice) then call set_token (SET_FN, i); else call error (linus_error_$undef_id); valid_rel: proc (rel_name, temp_flag) returns (bit (1)); /* Procedure to determine if a relation is defined in the database */ dcl rel_name char (*); dcl (result, temp_flag) bit (1); dcl (i, j) fixed bin (35); temp_flag, result = "0"b; if length (rel_name) > 0 then do; /* make sure is non-null */ do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rel_name); end; if j ^> linus_rel_array.num_of_rels then result = "1"b; if ^result & linus_rel_array.num_of_rels < linus_data_$max_range_items then do; /* not referenced, check database */ rslt_ptr = null; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_rslt_info (lcb.db_index, rel_name, lcb.lila_area_ptr, rslt_ptr, icode); /* see if defined in db. */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if icode = 0 then do; /* was found in db */ result = "1"b; linus_rel_array.num_of_rels = linus_rel_array.num_of_rels + 1; linus_rel_array.rels.rel_name (linus_rel_array.num_of_rels) = rel_name; linus_rel_array.rels .rslt_info_ptr (linus_rel_array.num_of_rels) = rslt_ptr; rslt_ptr = null; end; end; /* data base search */ if ^result & linus_rel_array.num_of_rels < linus_data_$max_range_items then do; /* not found, check temps */ if ttn_ptr ^= null then do; /* if temps defined */ do i = 1 to mrds_data_$max_temp_rels while (temp_tab_names (i) ^= rel_name); end; /* search through temp tab table */ if i <= mrds_data_$max_temp_rels then do; /* if found */ if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_temp_info (lcb.db_index, i, lcb.lila_area_ptr, rslt_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if icode = 0 then do; linus_rel_array.num_of_rels = linus_rel_array.num_of_rels + 1; linus_rel_array.rels .rel_name (linus_rel_array.num_of_rels) = rel_name; linus_rel_array.rels .rslt_info_ptr (linus_rel_array.num_of_rels) = rslt_ptr; rslt_ptr = null; result, temp_flag = "1"b; end; end; end; /* if temps defined */ end; /* temps search */ end; /* if non-null */ return (result); end valid_rel; valid_attr: proc (tv_index, attr_name) returns (bit (1)); /* Procedure to determine if an attribute is defined in the specified relation. If tv_index is zero, the current default relation is chosen */ dcl rname char (32); dcl attr_name char (*); dcl result bit (1); dcl (i, j, tv_index) fixed bin; result = "0"b; icode = 0; if tv_index <= 0 then tv_index = ls_block.dflt_ritem; if tv_index > 0 then do; rslt_ptr = null; rname = ls_block.range_items.rel_name (tv_index); if rname = ".V." then do; rname = char (ls_block.range_items.rel_index (tv_index)); do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= temp_tab_names (ls_block.range_items.rel_index (tv_index))); end; end; else do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rname); end; if j ^> linus_rel_array.num_of_rels then do; /* if found */ rslt_ptr = linus_rel_array.rels.rslt_info_ptr (j); do i = 1 to rslt_info.num_attr while (attr_name ^= rslt_info.attr.attr_name (i)); end; /* search for attr info */ if i <= rslt_info.num_attr then result = "1"b; /* found it */ end; /* found rel */ rslt_ptr = null; end; /* search for rel info */ return (result); end valid_attr; valid_var: proc (var_name, i) returns (bit (1)); /* Procedure to determine is a tuple variable has been defined */ dcl var_name char (*); dcl result bit (1); dcl i fixed bin; result = "0"b; if ls_block.type = BLOCK then /* need search only if in block */ if ls_block.nritems > 0 then do; /* if some range items defined */ do i = ls_block.nritems by -1 to 1 while (var_name ^= ls_block.range_items.tup_var (i)); end; /* search for tuple var */ if i >= 1 then result = "1"b; /* was found */ end; return (result); end valid_var; valid_set_fn: proc (fn_name) returns (bit (1)); /* Procedure to determine if a set function is defined */ dcl fn_name char (*); dcl result bit (1); result = "0"b; do linus_set_fn_info_ptr = lcb.setfi_ptr repeat linus_set_fn_info.fwd_ptr while (linus_set_fn_info.fwd_ptr ^= null & linus_set_fn_info.name ^= fn_name); end; /* search for set fn name */ if linus_set_fn_info.name = fn_name then result = "1"b; return (result); end valid_set_fn; valid_scal_fn: proc (fn_name) returns (bit (1)); /* Procedure to determine if a scalar function has been defined */ dcl fn_name char (*); dcl result bit (1); if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_fn_info (lcb.db_index, fn_name, lcb.lila_area_ptr, sfi_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if icode = 0 then result = "1"b; else result = "0"b; return (result); end valid_scal_fn; end ident_proc; set_col_spec: proc (length); /* Procedure to create a tuple var . attr token */ dcl length fixed bin; token_data.must_free = "0"b; /* not allocated this time */ token_data.key = COL_SPEC; token_data.t_ptr = addr (source_array (cur_pos)); token_data.length = length; token_data.mvar = ls_block.range_items.mrds_var (ls_block.dflt_ritem); token_data.lvar = ls_block.range_items.tup_var (ls_block.dflt_ritem); start_pos = cur_pos + length; end set_col_spec; error: proc (cd); /* Error procedure */ dcl cd fixed bin (35); code = cd; ls_header.cur_pos = cur_pos; go to real_exit; end error; end linus_lila_get_token;  linus_lila_scal_fn.pl1 10/14/90 0931.4rew 10/14/90 0915.0 217440 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls to assign_round_ from assign_ so that data is rounded. END HISTORY COMMENTS */ linus_lila_scal_fn: proc (lcb_ptr, lsh_ptr, td_ptr, ed_ptr, code); /* HISTORY: 77-08-01 J. C. C. Jagernauth: Initially written. 78-04-01 J. C. C. Jagernauth: Modified to update ls_set when new mrds items are encountered, to properly handle non-arithmetic scalar functions, and to properly handle recursively invoked scalar functions. 78-08-01 J. A. Weeldreyer: Modified to conform to new token data. 79-02-01 J. C. C. Jagernauth: Modified to access version 4 resultant information. 80-01-08 Rickie E. Brinegar: Modified to pass linus_lila_alloc_lit a descriptor pointer instead of an assign_ descriptor type and to do away with the assign_ length. 80-04-11 Rickie E. Brinegar: Modified to correctly check the number of arguments to a scalar function. 80-04-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-09-16 Rickie E. Brinegar: Modified to use linus_rel_array to obtain relation information instead of calling dsl_$get_rslt_info. 81-02-03 Rickie E. Brinegar: Modified to use the modified linus_rel_array structure. Added the rel builtin to the declarations. 81-06-17 Rickie E. Brinegar: Modified to not call dsl_v1_$get_fn_info. 81-06-19 Rickie E. Brinegar: Removed calls to dsl_$get_(rslt temp)_desc. 81-07-13 Rickie E. Brinegar: Removed the trapping of the conversion condition. This is now relegated to higher level modules. 82-01-04 Bert Moberg: Fixed searching for temp relation names 82-06-24 DJ Schimke: renamed variable "offset" to "bit_offset" and internal procedure "constant" to "process_constant" so these names are not confused with pl1 builtins and keywords. */ %include linus_lcb; %page; %include linus_ef_data; %page; %include linus_ls_block; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_rel_array; %page; %include linus_scal_fn; %page; %include linus_temp_tab_names; %page; %include linus_token_data; %page; %include linus_variables; %page; %include mdbm_arg_list; %page; %include mrds_rslt_info; %page; %include mrds_scalfn_info; dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 length bit (24) unal; /* arg length for system standard arg list */ dcl 1 arg_descs aligned based (ad_ptr), 2 ndescs fixed bin, 2 desc (ndescs_init refer (arg_descs.ndescs)) bit (36); dcl ndescs_init fixed bin; dcl ( ( SETFN init (4) ), ( SCALFN init (3) ), ( EXPR init (5) ), ( BITVAR init (20) ), ( CHARVAR init (22) ), ( CONSTANT init (1) ), ( LINVAR init (2) ), ( DATABASE init (6) ) ) fixed bin int static options (constant); dcl QUOTE char (1) int static options (constant) init (""""); dcl LEFT_PAREN char (1) int static options (constant) init ("("); dcl RIGHT_PAREN char (1) int static options (constant) init (")"); dcl ( ( PTR_DESC init ("100110100000000000000000000000000000"b) ), ( CMPX_FD init ("100110000000000000000000000000000000"b) ), ( REAL_FD init ("100101000000000000000000000000000000"b) ), ( BIT_DESC init ("101001100000000000000000000000000000"b) ), ( CHAR_DESC init ("101010100000000000000000000000000000"b) ), ( BIT36_DESC init ("101001100000000000000000000000100100"b) ) ) bit (36); dcl 1 token_data_temp like token_data; /* for temporary storage of token data */ dcl token_item char (must_free_len) based (must_free_ptr); dcl first_char char (1) based (token_data_temp.t_ptr); dcl bit_offset (10) bit (1) based; dcl repl_factor char (repl_len) based (repl_ptr); dcl constant_desc bit (36); dcl constant_string char (cs_len) based (cs_ptr); dcl one_repl_ch char (1) based (orc_ptr); dcl one_source_ch char (1) based (osc_ptr); dcl (i, j, k, temp, target_type, source_type) fixed bin; dcl temp_desc bit (36) based; dcl (cur_pos_temp, bit_len, cs_len, ci_len, repl_fac, repl_len, must_free_len, target_length, icode, code, source_length) fixed bin (35); dcl initial_mrds_vclock float bin (63); dcl (expression_test, check_min_num_of_args, get_comma, repl_flag) bit (1); dcl (addr, addrel, fixed, null, rel, search, substr, vclock) builtin; dcl ( NULL_PTR init (null), ad_ptr init (null), ci_ptr init (null), cs_ptr init (null), lit_ptr init (null), must_free_ptr init (null), orc_ptr init (null), osc_ptr init (null), repl_ptr init (null), source_ptr init (null) ) ptr; dcl 1 ef_d like ef_data; dcl ( linus_data_$max_expr_items, linus_data_$max_pred_stack_size, linus_data_$max_range_items, linus_data_$max_sclf_items, linus_data_$max_set_stack_size, linus_error_$expr_ovfl, linus_error_$func_args_parens, linus_error_$inv_sclf_args, linus_error_$inv_token_type, linus_error_$inv_tup_var, linus_error_$no_comma, linus_error_$sclf_null_arg, linus_error_$select_list_ovfl, linus_error_$too_few_sclf_args, linus_error_$too_many_sclf_args, mrds_data_$max_select_items, mrds_data_$max_temp_rels, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl cu_$ptr_call entry options (variable); dcl dsl_$get_fn_info entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35)); dcl linus_assign_data entry (bit (36), fixed bin, fixed bin (35)); dcl linus_lila_alloc_lit entry (ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_build_expr_tab entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_set_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); NULL_PTR, cs_ptr, sfi_ptr, sclf_ptr, ad_ptr, al_ptr = null; linus_rel_array_ptr = lcb.rel_array_ptr; ttn_ptr = lcb.ttn_ptr; icode, ef_data.nmrds_items, code = 0; ef_data.var_name = ""; must_free_len = token_data.length; must_free_ptr = token_data.t_ptr; token_data_temp = token_data; lv_ptr = lcb.lv_ptr; lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_fn_info (lcb.db_index, token_item, lcb.lila_area_ptr, sfi_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if icode ^= 0 then call error (icode, ""); /* ok to continue */ check_min_num_of_args = "1"b; if scalfn_info.nargs = 0 then do; nsclf_args_init = linus_data_$max_sclf_items; check_min_num_of_args = "0"b; end; else nsclf_args_init = scalfn_info.nargs; allocate scal_fn in (work_area); scal_fn.nargs = 0; call get_token; if icode ^= 0 then call error (icode, ""); if token_data.key ^= LP then call error (linus_error_$func_args_parens, ""); scal_fn.entry_ptr = scalfn_info.entry_ptr; /* init function entry pointer */ call get_token; do while (token_data.key ^= RP & token_data.key ^= NULL); if token_data.key = COMMA then call error (linus_error_$sclf_null_arg, ""); /* comma is an invalid token */ scal_fn.nargs = scal_fn.nargs + 1; scal_fn.arg.ef_ptr (scal_fn.nargs) = null; get_comma = "1"b; /* skip comma */ if scalfn_info.info_ent_ptr = null then do; call main_loop; call assign_var; end; else do; call main_loop; scal_fn.arg.must_convert (scal_fn.nargs) = "0"b; /* No conversion necessary */ end; if get_comma then call get_token; if ^(token_data.key = RP | token_data.key = NULL) then if token_data.key = COMMA then call get_token; /* comma is scal_func arg delimeter */ else call error (linus_error_$no_comma, ""); if scal_fn.nargs > nsclf_args_init then do; /* too many arguments are being passed */ token_data.key = NULL; call error (linus_error_$too_many_sclf_args, ""); end; end; if scal_fn.nargs < nsclf_args_init & check_min_num_of_args then do; token_data.key = NULL; call error (linus_error_$too_few_sclf_args, ""); end; if token_data.key = NULL then call error (linus_error_$sclf_null_arg, ""); else token_data.key = NULL; num_ptrs = scal_fn.nargs * 2 + 2; /* number of args * 2 */ allocate arg_list in (work_area); scal_fn.arg_list_ptr = al_ptr; arg_list.pad = 0; arg_list.arg_count, arg_list.desc_count = num_ptrs; arg_list.code = 4; do i = 1 to scal_fn.nargs; /* set argument and descriptor pointers in arg_list */ k = scal_fn.nargs + 1 + i; if scal_fn.arg.must_convert (i) then do; arg_list.arg_des_ptr (i) = scal_fn.arg.arg_assn_ptr (i); arg_list.arg_des_ptr (k) = addr (scal_fn.arg.arg_desc (i)); call var_desc ((scal_fn.arg.arg_desc (i))); end; else do; arg_list.arg_des_ptr (i) = scal_fn.arg.assn_ptr (i); arg_list.arg_des_ptr (k) = addr (scal_fn.arg.desc (i)); call var_desc ((scal_fn.arg.desc (i))); end; end; if scalfn_info.info_ent_ptr = null then scal_fn.rslt_desc = scalfn_info.rslt_desc; else do; ndescs_init = scal_fn.nargs; /* pass descriptors to info entry to obtain result desc */ allocate arg_descs in (work_area); do i = 1 to arg_descs.ndescs; arg_descs.desc (i) = arg_list.arg_des_ptr (i + 1 + ndescs_init) -> temp_desc; end; call cu_$ptr_call (scalfn_info.info_ent_ptr, ad_ptr, scal_fn.rslt_desc); /* get result descriptor */ end; if ad_ptr ^= null then ad_ptr = null; ef_data.ef_ptr = sclf_ptr; if scal_fn.rslt_desc = "0"b then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_sclf_args, (scalfn_info.name)); ef_data.desc = scal_fn.rslt_desc; /* set ef data */ call linus_assign_data ((scal_fn.rslt_desc), ef_data.assn_type, ef_data.assn_len); call linus_lila_alloc_lit (lcb_ptr, addr (scal_fn.rslt_desc), ef_data.assn_ptr, ef_data.bit_length); arg_list.arg_des_ptr (arg_list.desc_count) = addr (scal_fn.rslt_desc); k = arg_list.desc_count / 2; arg_list.arg_des_ptr (k) = ef_data.assn_ptr; call var_desc ((scal_fn.rslt_desc)); sfi_ptr = null; cs_ptr = null; main_loop: proc; if ^(token_data.key > NULL & token_data.key < TAB_NAME) then call error (linus_error_$inv_token_type, token_item); else do; expression_test = "0"b; if token_data.key = SET_FN then do; call linus_lila_set_fn (lcb_ptr, lsh_ptr, td_ptr, addr (ef_d), icode); if icode ^= 0 then call error (icode, ""); call update_efdata; scal_fn.arg.type (scal_fn.nargs) = SETFN; call init_sclf_source ((ef_d.desc), ef_d.assn_ptr, ef_d.assn_type, ef_d.assn_len, ef_d.ef_ptr); end; else if token_data.key = SCAL_FN then do; call linus_lila_scal_fn (lcb_ptr, lsh_ptr, td_ptr, addr (ef_d), icode) ; if icode ^= 0 then call error (icode, ""); call update_efdata; scal_fn.arg.type (scal_fn.nargs) = SCALFN; call init_sclf_source ((ef_d.desc), ef_d.assn_ptr, ef_d.assn_type, ef_d.assn_len, ef_d.ef_ptr); end; else if token_data.key = LP then call build_expr; else do; call expression_check; if expression_test then call build_expr; /* look ahead for expression */ else do; /* LIN_VAR, CONST or COL_SPEC -- init ef_data structure */ if token_data.key = COL_SPEC then call sclf_col_spec; /* database item */ else if token_data.key = LINUS_VAR then do; scal_fn.arg.type (scal_fn.nargs) = LINVAR; do i = 1 to variables.nvars while (variables.var_info.name (i) ^= token_item); end; call init_sclf_source (variables.var_info.desc (i), variables.var_info.var_ptr (i), variables.var_info.assn_type (i), variables.var_info.assn_len (i), NULL_PTR); end; else if token_data.key = CONST then call process_constant; /* constant */ end; end; end; end main_loop; var_desc: proc (desc); /* find varying strings and bump arg_list ptr */ dcl desc bit (36); temp = fixed (substr (desc, 2, 6)); if temp = BITVAR | temp = CHARVAR then arg_list.arg_des_ptr (i) = addrel (arg_list.arg_des_ptr (i), 1); end var_desc; build_expr: proc; call linus_lila_build_expr_tab (lcb_ptr, lsh_ptr, td_ptr, addr (ef_d), icode); if icode ^= 0 then call error (icode, ""); get_comma = "0"b; /* build_expr routine stops at comma */ call update_efdata; scal_fn.arg.type (scal_fn.nargs) = EXPR; call init_sclf_source ((ef_d.desc), ef_d.assn_ptr, ef_d.assn_type, ef_d.assn_len, ef_d.ef_ptr); end build_expr; update_efdata: proc; if ef_d.var_name ^= "" then do; if ef_data.var_name = "" then ef_data.var_name = ef_d.var_name; if ef_data.var_name ^= ef_d.var_name then call error (linus_error_$inv_tup_var, ""); end; if ef_data.nmrds_items >= linus_data_$max_expr_items then call error (linus_error_$expr_ovfl, ""); if ef_d.nmrds_items ^= 0 then do i = 1 to ef_d.nmrds_items; ef_data.nmrds_items = ef_data.nmrds_items + 1; ef_data.mrds_items.attr_name (ef_data.nmrds_items) = ef_d.mrds_items.attr_name (i); ef_data.mrds_items.domain_name (ef_data.nmrds_items) = ef_d.mrds_items.domain_name (i); ef_data.mrds_items.bit_length (ef_data.nmrds_items) = ef_d.mrds_items.bit_length (i); ef_data.mrds_items.desc (ef_data.nmrds_items) = ef_d.mrds_items.desc (i); ef_data.mrds_items.assn_ptr (ef_data.nmrds_items) = ef_d.mrds_items.assn_ptr (i); ef_data.mrds_items.assn_type (ef_data.nmrds_items) = ef_d.mrds_items.assn_type (i); ef_data.mrds_items.assn_len (ef_data.nmrds_items) = ef_d.mrds_items.assn_len (i); end; end update_efdata; sclf_col_spec: proc; /* database item */ dcl (i, j) fixed bin; dcl rel_name char (32); scal_fn.arg.type (scal_fn.nargs) = DATABASE; /* set item type */ do i = 1 to ls_block.nselects while (token_data.mvar || "." || token_item ^= ls_block.sel_items (i)); end; /* see if item has already been selected */ if ef_data.var_name = "" then ef_data.var_name = token_data.mvar; else if token_data.mvar ^= ef_data.var_name then call error (linus_error_$inv_tup_var, ""); if i <= ls_block.nselects then do; call init_sclf_source (ls_set.domain_info.desc (i), ls_set.domain_info.assn_ptr (i), ls_set.domain_info.assn_type (i), ls_set.domain_info.assn_len (i), NULL_PTR); end; else do; /* get relation name */ do i = 1 to ls_block.nritems while (token_data.mvar ^= ls_block.range_items.mrds_var (i)); end; if ls_block.range_items.rel_name (i) = ".V." then rel_name = temp_tab_names (ls_block.range_items.rel_index (i)); else rel_name = ls_block.range_items.rel_name (i); do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rel_name); end; rslt_ptr = linus_rel_array.rels.rslt_info_ptr (j); do j = 1 to rslt_info.num_attr while (token_item ^= rslt_info.attr.attr_name (j)); end; /* get info for attribute selected */ call linus_assign_data ((rslt_info.attr.descriptor (j)), source_type, source_length); /* returns assign type and length */ call linus_lila_alloc_lit (lcb_ptr, addr (rslt_info.attr.descriptor (j)), lit_ptr, bit_len); /* allocate in literal pool */ call init_sclf_source (rslt_info.attr.descriptor (j), lit_ptr, source_type, source_length, NULL_PTR); if ls_block.nselects >= mrds_data_$max_select_items then call error (linus_error_$select_list_ovfl, ""); else do; ls_block.nselects = ls_block.nselects + 1; ls_block.sel_items (ls_block.nselects) = token_data.mvar || "." || token_item; end; ls_set.nselects = ls_set.nselects + 1; /* update ls_set */ if ls_set.nselects > mrds_data_$max_select_items then call error (linus_error_$select_list_ovfl, ""); ef_data.nmrds_items = ef_data.nmrds_items + 1; /* pass mrds item info in ef_data */ ef_data.mrds_items.attr_name (ef_data.nmrds_items) = token_item; ls_set.domain_info.bit_length (ls_set.nselects), ef_data.mrds_items.bit_length (ef_data.nmrds_items) = bit_len; ls_set.domain_info.assn_ptr (ls_set.nselects), ef_data.mrds_items.assn_ptr (ef_data.nmrds_items) = lit_ptr; ls_set.domain_info.assn_type (ls_set.nselects), ef_data.mrds_items.assn_type (ef_data.nmrds_items) = source_type; ls_set.domain_info.assn_len (ls_set.nselects), ef_data.mrds_items.assn_len (ef_data.nmrds_items) = source_length; ls_set.domain_info.desc (ls_set.nselects), ef_data.mrds_items.desc (ef_data.nmrds_items) = rslt_info.attr.descriptor (j); ls_set.domain_info.name (ls_set.nselects), ef_data.mrds_items.domain_name (ef_data.nmrds_items) = rslt_info.attr.domain_name (j); end; end sclf_col_spec; init_sclf_source: proc (source_desc, source_ptr, source_type, source_len, fn_ptr); dcl source_desc bit (36) aligned; dcl (source_ptr, fn_ptr) ptr; dcl source_type fixed bin; dcl source_len fixed bin (35); scal_fn.arg.desc (scal_fn.nargs) = source_desc; scal_fn.arg.assn_ptr (scal_fn.nargs) = source_ptr; scal_fn.arg.assn_type (scal_fn.nargs) = source_type; scal_fn.arg.assn_len (scal_fn.nargs) = source_len; scal_fn.arg.ef_ptr (scal_fn.nargs) = fn_ptr; end init_sclf_source; /* set assign data in scalar function structure */ assign_var: proc; scal_fn.arg.must_convert (scal_fn.nargs) = "1"b; /* must convert */ call linus_assign_data ((scalfn_info.arg_desc (scal_fn.nargs)), target_type, target_length); call linus_lila_alloc_lit (lcb_ptr, addr (scalfn_info.arg_desc (scal_fn.nargs)), lit_ptr, bit_len); /* allocate in literal pool */ scal_fn.arg.arg_desc (scal_fn.nargs) = scalfn_info.arg_desc (scal_fn.nargs); scal_fn.arg.arg_assn_type (scal_fn.nargs) = target_type; scal_fn.arg.arg_assn_len (scal_fn.nargs) = target_length; scal_fn.arg.arg_assn_ptr (scal_fn.nargs) = lit_ptr; end assign_var; get_token: proc; if token_data.must_free then /* must free */ must_free_ptr = null; call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call error (icode, ""); must_free_len = token_data.length; must_free_ptr = token_data.t_ptr; end get_token; expression_check: proc; cur_pos_temp = ls_header.cur_pos; /* save current token data */ token_data_temp = token_data; call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); must_free_len = token_data.length; must_free_ptr = token_data.t_ptr; if icode ^= 0 then call error (icode, ""); if token_data.key > LP & token_data.key < TAB_NAME then /* an expression was found */ expression_test = "1"b; else expression_test = "0"b; if token_data.must_free then /* reset token data */ must_free_ptr = null; ls_header.cur_pos = cur_pos_temp; token_data = token_data_temp; must_free_len = token_data.length; must_free_ptr = token_data.t_ptr; end expression_check; error: proc (err_code, string); dcl err_code fixed bin (35); dcl string char (*); call linus_lila_error (lcb_ptr, lsh_ptr, err_code, string); end error; process_constant: proc; scal_fn.arg.type (scal_fn.nargs) = CONSTANT; token_data_temp = token_data; repl_flag = "0"b; source_length = token_data.length; source_ptr = token_data.t_ptr; if (search (token_item, "i")) ^= NULL then constant_desc = CMPX_FD; else constant_desc = REAL_FD; addr (constant_desc) -> arg_len_bits.length = addr (token_data.length) -> arg_len_bits.length; if first_char = LEFT_PAREN then do; repl_flag = "1"b; /* there is a replication factor */ repl_ptr, token_data.t_ptr = addr (token_data.t_ptr -> bit_offset (10)); do j = 2 to token_data.length while (first_char ^= RIGHT_PAREN); token_data.t_ptr = addr (token_data.t_ptr -> bit_offset (10)); end; repl_len = j - 2; token_data.length = token_data.length - j; token_data.t_ptr = addr (token_data.t_ptr -> bit_offset (10)); token_data_temp = token_data; repl_fac = fixed (repl_factor); end; if first_char = QUOTE then do; ci_ptr, token_data_temp.t_ptr = addr (token_data_temp.t_ptr -> bit_offset (10)); do j = 2 to token_data_temp.length while (first_char ^= QUOTE); token_data_temp.t_ptr = addr (token_data_temp.t_ptr -> bit_offset (10)); end; ci_len = token_data_temp.length - 2; if j = token_data_temp.length then constant_desc = CHAR_DESC; else do; ci_len = token_data_temp.length - 1; constant_desc = BIT_DESC; end; addr (constant_desc) -> arg_len_bits.length = addr (ci_len) -> arg_len_bits.length; source_ptr = ci_ptr; source_length = ci_len; if repl_flag then do; source_length, cs_len = repl_fac * ci_len; addr (constant_desc) -> arg_len_bits.length = addr (cs_len) -> arg_len_bits.length; allocate constant_string in (work_area); source_ptr, orc_ptr = cs_ptr; do j = 1 to repl_fac; /* to number of replication factor */ osc_ptr = ci_ptr; do k = 1 to ci_len; /* one for each character in string */ one_repl_ch = one_source_ch; orc_ptr = addr (orc_ptr -> bit_offset (10)); osc_ptr = addr (osc_ptr -> bit_offset (10)); end; end; end; end; addr (CHAR_DESC) -> arg_len_bits.length = addr (source_length) -> arg_len_bits.length; call linus_assign_data ((CHAR_DESC), source_type, source_length); /* returns type & length */ call linus_assign_data (constant_desc, target_type, target_length); call linus_lila_alloc_lit (lcb_ptr, addr (constant_desc), lit_ptr, bit_len); call assign_round_ (lit_ptr, target_type, target_length, source_ptr, source_type, source_length); call init_sclf_source ((constant_desc), lit_ptr, target_type, target_length, NULL_PTR); cs_ptr = null; end process_constant; end linus_lila_scal_fn;  linus_lila_select.pl1 07/29/86 1045.3r w 07/29/86 0939.9 207756 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_select: proc (lcb_ptr, lsh_ptr, inner, td_ptr, code); /* DESCRIPTION: This procedure processes the select clause of a LILA block. If this is an inner LILA block, the second leaf of a predicate term is created. If this is an outer block, a list of selected items is created in the lila stack for the block. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 78-03-01 J. A. Weeldreyer: Modified to detect invalid tokens in select clause. 78-04-01 J. A. Weeldreyer: Modified to give better diagnostics for constant expresions or scalar functions. 78-06-01 J. A. Weeldreyer: Modified to disallow update of temp tables. 78-08-01 J. A. Weeldreyer: Modified to conform to new token data. 79-02-01 J. C. C. Jagernauth: Modified to access version 4 resultant information. 80-01-08 Rickie E. Brinegar: modified to pass linus_lila_alloc_lit a descriptor pointer rather than an assign_ descriptor type and to eliminate the assign_ length parameter. 80-04-13 Rickie E. Brinegar: to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-06-23 Jim Gray: to capture select * with >1 table in from clause. 80-09-15 Rickie E. Brinegar: Modified to not call dsl_$get_rstl_info but to use the linus_rel_array instead. 81-02-03 Rickie E. Brinegar: Added the temp table names. Changed add_sel_tuple to use the temp tuple names instead of temp table indices with the char builtin used on them. Added the rel builtin to the declarations. Removed the unused entry points dsl(_ v1_)$get_(rslt temp)_info. 81-06-19 Rickie E. Brinegar: Removed the use of lcb.new_version and the copying of descriptors returned by dsl_$get_(temp rslt)_info into the rslt_info structure as the routine that returns the rslt_info structure has been modified to fill in the descriptors in the rslt_info_structure. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 82-11-28 Dave Schimke: Added code to the internal proc add_sel_item to also save the table name for each column in select_info.user_item.table_name. This is for use in the default column names generated by linus_table. 83-07-14 Dave Schimke: Changed select_info.user_item.table_name (added above) to contain the name of the tuple variable used in the selection expression rather than the actual database table name. This was requested by users during the report_writer controlled release. 83-08-18 Al Dupuis: Fixed a bug caused by the above change (83-07-14) in the add_sel_tuple procedure. Rather than take it from ls_block.range_items.tup_var (i), it only takes it from there when mvar is set to something like "V00001". The variable mvar contains the correct tuple variable in all other cases. */ %include linus_lcb; %page; %include linus_ef_data; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_ls_block; %page; %include linus_mrds_block; %page; %include linus_rel_array; %page; %include linus_select_info; %page; %include linus_temp_tab_names; %page; %include linus_token_data; %page; %include mrds_rslt_info; %page; %include mdbm_att_desc; dcl ( code, /* Output: status code */ icode, /* internal status code */ bit_len_sink, /* repository for unused bit length */ temp_cur_pos ) fixed bin (35); /* temp curr. pos. for look ahead */ dcl ( inner, /* Input: on if inner LILA block */ lb_flag, /* on if left bracket OK */ sel_flag, /* on if "select" OK */ end_flag, /* on if select list end OK */ un_dup_flag, /* on if unique or dup OK */ item_flag, /* on if select item OK */ done ) bit (1); /* completion indicator */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl token char (token_data.length) based (token_data.t_ptr); dcl 1 tok_data aligned like token_data; dcl 1 expr_data aligned like ef_data; dcl MRDS fixed bin int static options (constant) init (1); dcl SEL_EXPR fixed bin int static options (constant) init (2); dcl ( linus_data_$max_pred_stack_size, linus_data_$max_range_items, linus_data_$max_expr_items, linus_data_$max_set_stack_size, linus_error_$bad_inner_select, linus_error_$cant_alloc_lit, linus_error_$const_expr_fn, linus_error_$expr_not_alld, linus_error_$incomplete_select, linus_error_$no_table, linus_error_$select_list_ovfl, linus_error_$select_syntax, linus_error_$too_many_tables, linus_error_$union_compat, mrds_data_$max_select_items, mrds_data_$max_temp_rels, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, before, fixed, length, rel, null, substr) builtin; dcl linus_assign_data entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl linus_lila_alloc_lit entry (ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_build_expr_tab entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_build_expr_str entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_term$stack_term entry (ptr, ptr); ttn_ptr = lcb.ttn_ptr; linus_rel_array_ptr = lcb.rel_array_ptr; mblk_ptr, rdesc_ptr, rslt_ptr = null; /* initiallize */ lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; si_ptr = ls_set.si_ptr; if token_data.key = NULL then do; /* if no token passed in */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; /* getting first token */ lb_flag, /* initialize state flags */ sel_flag = "1"b; /* can have { or select */ end_flag, un_dup_flag, item_flag = "0"b; done = "0"b; do while (^done); go to token_proc (token_data.key); /* go process the current token */ token_proc (0): /* null */ token_proc (1): /* ) */ token_proc (3): /* linus variable */ token_proc (4): /* constant */ token_proc (5): /* set function */ token_proc (9): /* / */ token_proc (10): /* + */ token_proc (11): /* - */ token_proc (12): /* table name */ token_proc (13): /* row_table_pair */ token_proc (14): /* union */ token_proc (15): /* inter */ token_proc (16): /* differ */ token_proc (19): /* } */ token_proc (21): /* ^ */ token_proc (22): /* & */ token_proc (23): /* | */ token_proc (24): /* = */ token_proc (25): /* ^= */ token_proc (26): /* > */ token_proc (27): /* >= */ token_proc (28): /* < */ token_proc (29): /* <= */ token_proc (30): /* from */ token_proc (31): /* where */ token_proc (34): /* , */ if ^end_flag then /* if end not allowed */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$incomplete_select, token); if token_data.key ^= FROM then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); done = "1"b; /* to get out of loop */ go to next; token_proc (2): /* column specification */ if ^item_flag then /* if select item not allowed */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); temp_cur_pos = ls_header.cur_pos; /* save real pos. */ call linus_lila_get_token (lcb_ptr, lsh_ptr, temp_cur_pos, /* look at next token */ addr (tok_data), icode); if icode = 0 then /* if success. */ if tok_data.key >= STAR & tok_data.key <= MINUS then /* if arith oper. */ call process_expr; /* is expr. process it */ else call process_col_spec; /* is just col. spec. */ else call process_col_spec; un_dup_flag = "0"b; /* wont accept unique/dup anymore */ end_flag = "1"b; /* allow termination */ go to next; /* end column specification */ token_proc (6): /* scalar function */ token_proc (7): /* ( */ if ^item_flag then /* if select item not allowed */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); call process_expr; /* this is an expr, process it */ end_flag = "1"b; /* reset state flags */ un_dup_flag = "0"b; go to next; /* end expr. */ token_proc (8): /* * */ if ^item_flag then /* if select item not allowed */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); if inner then /* total tuple not allowed in inner block */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$bad_inner_select, token); if ls_block.nritems < 1 then /* if no range items */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$no_table, token); if ls_block.nritems > 1 then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$too_many_tables, token); select_info.se_flags.val_mod = "0"b; /* cant mod. entire tuple */ call add_sel_tuple ((ls_block.range_items.tup_var (ls_block.dflt_ritem))) ; /* add tuple to sel. list */ end_flag = "1"b; /* set state flags */ un_dup_flag = "0"b; token_data.key = NULL; /* force new token */ go to next; /* end * */ token_proc (17): /* row descriptor */ if ^item_flag then /* if select item not allowed */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); if inner then /* total tuple not alowed in inner block */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$bad_inner_select, token); select_info.se_flags.val_mod = "0"b; /* cant mod. total tuple */ call add_sel_tuple (token); /* add tuple to sel. list */ token_data.key = NULL; /* force new token */ end_flag = "1"b; /* set state flags */ un_dup_flag = "0"b; go to next; /* end row descr. */ token_proc (18): /* { */ if ^lb_flag then /* if { not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); token_data.key = NULL; /* force new token */ lb_flag = "0"b; /* dont want another one */ go to next; /* end { */ token_proc (20): /* select */ if ^sel_flag then /* if select not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); token_data.key = NULL; /* force new token */ lb_flag, /* reset state flags */ sel_flag = "0"b; un_dup_flag, item_flag = "1"b; go to next; /* end select */ token_proc (32): /* dup */ if ^un_dup_flag then /* if dup not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); ls_set.dup_flag = "1"b; /* remember */ un_dup_flag = "0"b; token_data.key = NULL; go to next; /* end dup */ token_proc (33): /* unique */ if ^un_dup_flag then /* if unique not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_syntax, token); ls_set.unique_flag = "1"b; /* remember */ un_dup_flag = "0"b; token_data.key = NULL; go to next; next: if token_data.key = NULL then do; /* if need new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; end; /* main processing loop */ code = 0; exit: return; process_expr: proc; /* Procedure to handle expressions */ dcl var char (32); dcl i fixed bin; if inner then do; /* if inner block */ var = ""; call linus_lila_build_expr_str (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, var, icode); /* build expr string, */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); if var = "" then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$const_expr_fn, ""); ls_block.leaf_ptr (2) = mblk_ptr; /* put in second leaf */ mblk_ptr = null; call linus_lila_term$stack_term (lcb_ptr, lsh_ptr); /* make into term */ item_flag = "0"b; /* inner blocks have only one item */ end; /* if inner block */ else do; /* is outer LILA block */ if ^ls_set.first_block then /* expr. not allowed for set opers. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$expr_not_alld, token); ls_set.inv_setop = "1"b; select_info.se_flags.val_dtt, /* exprs valid only for retrieve */ select_info.se_flags.val_mod, select_info.se_flags.val_del = "0"b; expr_data.nmrds_items = 0; expr_data.var_name = " "; call linus_lila_build_expr_tab (lcb_ptr, lsh_ptr, td_ptr, addr (expr_data), icode); /* build table for expr */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); do i = 1 to expr_data.nmrds_items; /* process the required mrds items */ if select_info.n_mrds_items >= select_info.nmi_alloc then /* if overflow */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_list_ovfl, ""); select_info.n_mrds_items = select_info.n_mrds_items + 1; select_info.mrds_item.bit_len (select_info.n_mrds_items) = expr_data.mrds_items.bit_length (i); select_info.mrds_item.desc (select_info.n_mrds_items) = expr_data.mrds_items.desc (i); select_info.mrds_item.arg_ptr (select_info.n_mrds_items) = expr_data.mrds_items.assn_ptr (i); select_info.mrds_item.assn_type (select_info.n_mrds_items) = expr_data.mrds_items.assn_type (i); select_info.mrds_item.assn_len (select_info.n_mrds_items) = expr_data.mrds_items.assn_len (i); end; /* mrds items loop */ if select_info.n_user_items >= select_info.nui_alloc then /* if user item ovfl */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_list_ovfl, ""); select_info.n_user_items = select_info.n_user_items + 1; do i = 1 to ls_block.nritems while (expr_data.var_name ^= ls_block.range_items.mrds_var (i)); end; select_info.user_item.name (select_info.n_user_items), select_info.user_item.table_name (select_info.n_user_items) = ls_block.range_items.tup_var (i); /* fill in user item info */ select_info.user_item.item_type (select_info.n_user_items) = SEL_EXPR; select_info.user_item.rslt_desc (select_info.n_user_items) = expr_data.desc; select_info.user_item.rslt_bit_len (select_info.n_user_items) = expr_data.bit_length; select_info.user_item.rslt_assn_ptr (select_info.n_user_items) = expr_data.assn_ptr; select_info.user_item.rslt_assn_type (select_info.n_user_items) = expr_data.assn_type; select_info.user_item.rslt_assn_len (select_info.n_user_items) = expr_data.assn_len; select_info.user_item.item_ptr (select_info.n_user_items) = expr_data.ef_ptr; end; /* if outer block */ end process_expr; process_col_spec: proc; /* Procedure to process a column spec. */ dcl (i, j) fixed bin; dcl rel_name char (32) init (""); if inner then do; /* if inner block, merely place in second term leaf */ nval_args_init = 0; /* set up mrds block */ ms_len_init = token_data.length + length (token_data.mvar) + 1; allocate mrds_block in (work_area); mrds_block.fwd_ptr = null; mrds_block.mrds_string = token_data.mvar || "." || token; ls_block.leaf_ptr (2) = mblk_ptr; /* put in second leaf */ mblk_ptr = null; if token_data.must_free then token_data.t_ptr = null; call linus_lila_term$stack_term (lcb_ptr, lsh_ptr); /* add term to term stack */ item_flag = "0"b; /* no more items for inner select */ end; /* if inner block */ else do; /* is outer block */ if ls_block.nselects >= mrds_data_$max_select_items then /* check overflow */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_list_ovfl, token); do i = 1 to ls_block.nritems while (ls_block.range_items.mrds_var (i) ^= token_data.mvar); end; /* search for range item */ if ls_block.range_items.rel_name (i) = ".V." then do; /* if temp rel. */ select_info.se_flags.val_del, /* cant update temp tables */ select_info.se_flags.val_mod = "0"b; rel_name = temp_tab_names (ls_block.range_items.rel_index (i)); end; else rel_name = ls_block.range_items.rel_name (i); if ls_set.first_block then select_info.user_item.table_name (select_info.n_user_items + 1) = ls_block.range_items.tup_var (i); do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rel_name); end; rslt_ptr = linus_rel_array.rels.rslt_info_ptr (j); do i = 1 to rslt_info.num_attr while (rslt_info.attr.attr_name (i) ^= token); end; /* search for particular attr. */ call add_sel_item (token_data.mvar, i); /* add item to select list */ rslt_ptr = null; end; /* if outer block */ token_data.key = NULL; /* force new token */ end process_col_spec; add_sel_tuple: proc (tup_var); /* Procedure to add each attribute of a relation designated by tup_var to the select list */ dcl (i, j) fixed bin; dcl rel_name char (32) init (""); dcl tup_var char (*); dcl mvar char (32) var; do i = ls_block.nritems by -1 to 1 while (ls_block.range_items.tup_var (i) ^= tup_var); end; /* search for range item */ mvar = ls_block.range_items.mrds_var (i); if ls_block.range_items.rel_name (i) = ".V." then do; /* if temp rel */ select_info.se_flags.val_del, /* cant update temp tables */ select_info.se_flags.val_mod = "0"b; rel_name = temp_tab_names (ls_block.range_items.rel_index (i)); end; else rel_name = ls_block.range_items.rel_name (i); do j = 1 to linus_rel_array.num_of_rels while (linus_rel_array.rels.rel_name (j) ^= rel_name); end; rslt_ptr = linus_rel_array.rels.rslt_info_ptr (j); if rslt_info.num_attr + ls_block.nselects > mrds_data_$max_select_items then /* if overflow */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_list_ovfl, token); do i = 1 to rslt_info.num_attr; /* add each attr. to select list */ call add_sel_item (mvar, i); if ls_set.first_block then if length (mvar) > 2 then if substr (mvar, 1, 3) = "V00" then select_info.user_item.table_name (select_info.n_user_items) = rel_name; else select_info.user_item.table_name (select_info.n_user_items) = mvar; else select_info.user_item.table_name (select_info.n_user_items) = mvar; else; end; end add_sel_tuple; add_sel_item: proc (mvar, attr_ind); /* Procedure to add a select list item given the attr index into rslt_info, and the tuple variable name */ dcl (attr_ind, assn_type) fixed bin; dcl assn_len fixed bin (35); dcl assn_ptr ptr init (null); dcl mvar char (32) var; ls_block.nselects = ls_block.nselects + 1; ls_block.sel_items (ls_block.nselects) = /* add to select list */ mvar || "." || before (rslt_info.attr.attr_name (attr_ind), " "); if ^ls_set.first_block then /* if not first block, check compat. */ if ls_set.domain_info.name (ls_block.nselects) ^= rslt_info.attr.domain_name (attr_ind) then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$union_compat, token); else ; /* if is OK do nothing */ else do; /* is first block, add domain info */ call linus_assign_data (rslt_info.attr.descriptor (attr_ind), assn_type, assn_len); call linus_lila_alloc_lit (lcb_ptr, addr (rslt_info.attr.descriptor (attr_ind)), assn_ptr, bit_len_sink) ; if assn_ptr = null then /* couldnt alloc. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, token); ls_set.nselects = ls_set.nselects + 1; ls_set.domain_info.name (ls_set.nselects) = rslt_info.attr.domain_name (attr_ind); ls_set.domain_info.bit_length (ls_set.nselects) = rslt_info.attr.attr_length (attr_ind); ls_set.domain_info.desc (ls_set.nselects) = rslt_info.attr.descriptor (attr_ind); ls_set.domain_info.assn_ptr (ls_set.nselects) = assn_ptr; ls_set.domain_info.assn_type (ls_set.nselects) = assn_type; ls_set.domain_info.assn_len (ls_set.nselects) = assn_len; if select_info.n_mrds_items >= select_info.nmi_alloc /* if could overflow */ | select_info.n_user_items >= select_info.nui_alloc then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$select_list_ovfl, ""); select_info.n_mrds_items = select_info.n_mrds_items + 1; select_info.n_user_items = select_info.n_user_items + 1; /* fill in select info item data */ select_info.mrds_item.arg_ptr (select_info.n_mrds_items) = assn_ptr; select_info.mrds_item.bit_len (select_info.n_mrds_items) = rslt_info.attr.attr_length (attr_ind); select_info.mrds_item.desc (select_info.n_mrds_items) = rslt_info.attr.descriptor (attr_ind); select_info.mrds_item.assn_type (select_info.n_mrds_items) = assn_type; select_info.mrds_item.assn_len (select_info.n_mrds_items) = assn_len; select_info.user_item.name (select_info.n_user_items) = before (rslt_info.attr.attr_name (attr_ind), " "); select_info.user_item.item_type (select_info.n_user_items) = MRDS; select_info.user_item.item_ptr (select_info.n_user_items) = addr (select_info.mrds_item (select_info.n_mrds_items)); end; /* if first block */ end add_sel_item; end linus_lila_select;  linus_lila_set.pl1 07/29/86 1045.3r w 07/29/86 0939.9 135126 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_set: proc (lcb_ptr, lsh_ptr, td_ptr, si_ptr, code); /* DESCRIPTION: This procedure handles the LILA set, which consists of one or more LILA blocks combined via specified set operators (inter, differ, union), and possibly grouped by brackets ({}). Lower level procedures are called to process each LILA block. This procedure combines the translated LILA blocks according to explicitly specified grouping and set operator precedence. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 78-07-01 J. A. Weeldreyer: Modified to initiallize gen. variable index. 78-08-01 J. A. Weeldreyer: Modified to always pass back next token. 80-04-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 80-12-03 Rickie E. Brinegar: Modified to add one to the sel_offset for each ( added as a result of being in an inner block. This is the result of TR8422 submitted, with this fix suggested, from Moberg at FORD. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-11-06 Rickie E. Brinegar: Removed unreferenced NL variable which was an options constant variable initiated to a new line character. */ %include linus_lcb; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_select_info; %page; %include linus_token_data; %page; %include linus_mrds_block; dcl ( code, /* Output* status code */ icode, /* internal status code */ string_len ) fixed bin (35); /* length for string alloc. */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl done bit (1); /* Internal flag */ dcl token char (token_data.length) based (token_data.t_ptr); dcl string char (string_len) based; dcl sexy (select_info.se_len) char (1) unal based (select_info.se_ptr); dcl setop_prec (14:16) fixed bin (11) int static options (constant) init (1, /* union */ 2, /* inter */ 2); /* differ */ dcl mrds_setop (14:16) char (11) var int static options (constant) init (") -union (", ") -inter (", ") -differ ("); dcl SET fixed bin int static options (constant) init (2); dcl OP fixed bin int static options (constant) init (1); dcl BRACKET fixed bin int static options (constant) init (2); dcl END fixed bin int static options (constant) init (3); dcl ( linus_data_$max_set_stack_size, linus_error_$early_end, linus_error_$misplaced_select, linus_error_$misplaced_setop, linus_error_$setop_ovfl, linus_error_$syntax, linus_error_$unalld_setop, mrds_data_$max_select_items, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, fixed, length, null, rel) builtin; dcl linus_lila_block entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); mblk_ptr, lss_ptr = null; /* initiallize */ allocate ls_set in (work_area); /* alloc. and set up set stack fram */ ls_set.fwd_ptr, ls_set.blk_hd_ptr = null; ls_set.back_ptr = ls_header.cur_ptr; ls_set.type = SET; ls_set.si_ptr = si_ptr; ls_set.br_cnt, ls_set.var_ind, ls_set.nblocks, ls_set.nops, ls_set.nselects = 0; ls_set.dup_flag, ls_set.unique_flag, ls_set.rb_flag, ls_set.setop_flag, ls_set.inv_setop, ls_set.end_flag = "0"b; ls_set.lb_flag, ls_set.first_block, ls_set.select_flag = "1"b; ls_header.cur_ptr -> ls_set.fwd_ptr = lss_ptr; /* thread to end of stack */ ls_header.cur_ptr = lss_ptr; select_info.prior_sf_ptr, /* initialize the select info block */ select_info.se_ptr, select_info.sel_items_ptr = null; select_info.sel_items_len, select_info.se_len, select_info.nsevals, select_info.n_mrds_items, select_info.n_user_items = 0; select_info.dup_flag, select_info.unique_flag, select_info.set_fn = "0"b; select_info.se_flags.val_ret, /* assume valid until proven otherwise */ select_info.se_flags.val_dtt, select_info.se_flags.val_del, select_info.se_flags.val_mod = "1"b; done = "0"b; /* init. */ do while (^done); /* main processing loop */ if token_data.key = NULL then do; /* if token not already there */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; /* if needed to get new token */ go to token_proc (token_data.key); /* go process the token */ token_proc (1): /* ) */ token_proc (2): /* column specif. */ token_proc (3): /* linus variable */ token_proc (4): /* constant */ token_proc (5): /* set function */ token_proc (6): /* scalar function */ token_proc (7): /* ( */ token_proc (8): /* * */ token_proc (9): /* / */ token_proc (10): /* + */ token_proc (11): /* - */ token_proc (12): /* table name */ token_proc (13): /* row table pair */ token_proc (17): /* row designator */ token_proc (21): /* ^ */ token_proc (22): /* & */ token_proc (23): /* | */ token_proc (24): /* = */ token_proc (25): /* ^= */ token_proc (26): /* > */ token_proc (27): /* >= */ token_proc (28): /* < */ token_proc (29): /* <= */ token_proc (30): /* from */ token_proc (31): /* where */ token_proc (32): /* dup */ token_proc (33): /* unique */ token_proc (34): /* , */ if ls_set.end_flag then call finish; /* may be beyond set */ else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$syntax, token) ; go to next; token_proc (0): /* null */ if ^ls_set.end_flag then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$early_end, "") ; call finish; /* if end expected */ go to next; token_proc (14): /* union */ token_proc (15): /* inter */ token_proc (16): /* differ */ if ^ls_set.setop_flag then /* if set oper. not expected */ if ls_set.end_flag then call finish; /* may be out of set */ else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$misplaced_setop, token); else do; /* if set oper. expected */ if ls_set.inv_setop then /* we already have LILA block which cant use set op. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$unalld_setop, token); if ls_set.nops > 0 then /* if oper. stacked */ if ls_set.op_stack.br_cnt (ls_set.nops) = ls_set.br_cnt then /* if in same bracket */ if setop_prec (token_data.key) <= setop_prec (ls_set.op_stack.key (ls_set.nops)) then call reduce (OP); /* if curr.op lower prec, can reduce */ if ls_set.nops + 1 > linus_data_$max_set_stack_size then /* if another op will ovfl. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$setop_ovfl, token); ls_set.nops = ls_set.nops + 1; /* add latest op to stack */ ls_set.op_stack.br_cnt (ls_set.nops) = ls_set.br_cnt; ls_set.op_stack.key (ls_set.nops) = token_data.key; select_info.se_flags.val_del, /* set ops not valid for update */ select_info.se_flags.val_mod = "0"b; ls_set.lb_flag, /* reset state flags */ ls_set.select_flag = "1"b; ls_set.rb_flag, ls_set.setop_flag, ls_set.end_flag = "0"b; token_data.key = NULL; /* so we get new token */ end; /* if oper. expected */ go to next; /* end set operators */ token_proc (18): /* { */ if ^ls_set.lb_flag then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$syntax, token) ; ls_set.br_cnt = ls_set.br_cnt + 1; /* increment bracket level count */ ls_set.end_flag = "0"b; /* cant end now */ token_data.key = NULL; /* must get new token */ go to next; /* end { */ token_proc (19): /* } */ if ^ls_set.rb_flag | ls_set.br_cnt <= 0 then /* if not expected */ if ls_set.end_flag then /* may be done with set */ call finish; else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$syntax, token); else do; /* if expected */ if ls_set.nops > 0 then /* if may need to reduce */ if ls_set.op_stack.br_cnt (ls_set.nops) = ls_set.br_cnt then /* have recuction */ call reduce (BRACKET); /* reduce all items in bracket */ ls_set.br_cnt = ls_set.br_cnt - 1; /* decr. bracket lev. count */ ls_set.end_flag = "0"b; token_data.key = NULL; /* force new token */ end; /* if expected */ go to next; /* end } */ token_proc (20): /* select */ if ^ls_set.select_flag then /* if not expected */ if ls_set.end_flag then call finish; /* may be out of set */ else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$misplaced_select, token); else do; /* if expected */ call linus_lila_block (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, icode); /* translate the block */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, ""); ls_set.nblocks = ls_set.nblocks + 1; /* put results at top of stack */ ls_set.first_block = "0"b; mrds_block.fwd_ptr = ls_set.blk_hd_ptr; ls_set.blk_hd_ptr = mblk_ptr; mblk_ptr = null; if ls_set.br_cnt = 0 then ls_set.end_flag = "1"b; /* end will be OK */ else ls_set.end_flag = "0"b; ls_set.lb_flag, /* reset other state flags */ ls_set.select_flag = "0"b; ls_set.rb_flag, ls_set.setop_flag = "1"b; end; /* if select expected */ go to next; /* end select */ next: end; /* main processing loop */ code = 0; /* made it OK */ exit: return; finish: proc; /* Procedure to finish up the lila set */ dcl i fixed bin; if ls_set.nops > 0 & ls_set.nblocks > 1 then /* if reduction needed */ call reduce (END); /* do final reduction */ if ls_set.nops ^= 0 | ls_set.nblocks ^= 1 then /* have error somewhere */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$syntax, ""); mblk_ptr = ls_set.blk_hd_ptr; /* finalize select info */ ls_set.blk_hd_ptr = null; string_len = length (mrds_block.mrds_string); allocate string in (work_area) set (select_info.se_ptr); /* place for mrds sel. expr. */ select_info.se_ptr -> string = mrds_block.mrds_string; /* copy it */ select_info.se_len = string_len; do i = 1 to mrds_block.nval_args; /* copy value args */ select_info.se_vals.arg_ptr (i) = mrds_block.val_args.arg_ptr (i); select_info.se_vals.desc_ptr (i) = mrds_block.val_args.desc_ptr (i); end; select_info.nsevals = mrds_block.nval_args; select_info.dup_flag = ls_set.dup_flag; select_info.unique_flag = ls_set.unique_flag; select_info.sel_items_ptr = addr (sexy (mrds_block.sel_offset)); select_info.sel_items_len = mrds_block.sel_length; mblk_ptr = null; /* finished with this */ ls_set.back_ptr -> ls_set.fwd_ptr = null; /* remove ls_set from stack */ ls_header.cur_ptr = ls_set.back_ptr; lss_ptr = null; done = "1"b; /* to get out of main loop */ end finish; reduce: proc (type); /* Procedure to reduce items on stack. Three types of reduction are provided, (1) for lower prec. operators, (2) for right bracket, and (3) final reduction. */ dcl type fixed bin; dcl done_flag bit (1); if type = END then do while (ls_set.nops > 0 & ls_set.nblocks > 1); call combine; /* combine top two items and oper. */ end; else if type = BRACKET then do while (ls_set.op_stack.br_cnt (ls_set.nops) = ls_set.br_cnt & ls_set.nops > 0 & ls_set.nblocks > 1); call combine; end; else do; done_flag = "1"b; do while (done_flag); if ls_set.nops ^> 0 | ls_set.nblocks ^> 1 then done_flag = "0"b; else if ls_set.op_stack.br_cnt (ls_set.nops) = ls_set.br_cnt & setop_prec (token_data.key) <= setop_prec (ls_set.op_stack.key (ls_set.nops)) then call combine; else done_flag = "0"b; end; end; combine: proc; /* Procedure to combine top two string blocks and top operator into one string block */ dcl (b1p, b2p) ptr; dcl i fixed bin; b2p = ls_set.blk_hd_ptr; /* top stack item */ b1p = b2p -> mrds_block.fwd_ptr; /* next to top */ ms_len_init = 12 + fixed (ls_set.op_stack.key (ls_set.nops) = DIFFER) + length (b1p -> mrds_block.mrds_string) + length (b2p -> mrds_block.mrds_string); nval_args_init = b1p -> mrds_block.nval_args + b2p -> mrds_block.nval_args; allocate mrds_block in (work_area); /* place for combined string */ mrds_block.fwd_ptr = b1p -> mrds_block.fwd_ptr; /* new item will replace top 2 */ mrds_block.mrds_string = "(" || b1p -> mrds_block.mrds_string || mrds_setop (ls_set.op_stack.key (ls_set.nops)) || b2p -> mrds_block.mrds_string || ")"; /* combined string */ do i = 1 to b1p -> mrds_block.nval_args; /* combine value args */ mrds_block.val_args.arg_ptr (i) = b1p -> mrds_block.val_args.arg_ptr (i); mrds_block.val_args.desc_ptr (i) = b1p -> mrds_block.val_args.desc_ptr (i); end; do i = b1p -> mrds_block.nval_args + 1 to mrds_block.nval_args; mrds_block.val_args.arg_ptr (i) = b2p -> mrds_block.val_args.arg_ptr (i - b1p -> mrds_block.nval_args); mrds_block.val_args.desc_ptr (i) = b2p -> mrds_block.val_args.desc_ptr (i - b1p -> mrds_block.nval_args); end; mrds_block.sel_offset = b1p -> mrds_block.sel_offset + 1; mrds_block.sel_length = b1p -> mrds_block.sel_length; ls_set.nops = ls_set.nops - 1; /* readjust stacks */ ls_set.nblocks = ls_set.nblocks - 1; ls_set.blk_hd_ptr = mblk_ptr; mblk_ptr = null; b1p = null; /* no need for b1p, b2p-> mrds_block anymore */ b2p = null; end combine; end reduce; end linus_lila_set;  linus_lila_set_fn.pl1 07/29/86 1045.3r w 07/29/86 0939.9 160749 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_set_fn: proc (lcb_ptr, lsh_ptr, td_ptr, ed_ptr, code); /* DESCRIPTION: This procedure translates a set function into tabular form suitable for evaluation. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 78-08-01 J. A. Weeldreyer: Modified to move parsing of set fn. brackets to within this program. 80-01-08 Rickie E. Brinegar: Modified to pass linus_lila_alloc_lit a descriptor pointer instead of an assign_ descriptor type and to eliminate the assign_ length parameter. 80-03-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 81-07-07 Rickie E. Brinegar: Changed to check for a null token when no right bracket was found. This is in response to TR10283. 81-09-18 Rickie E. Brinegar: Replaced the checking of varying strings by indexing into a bit string called is_var with a call to mdbm_util_$varying_data_class. At the same time, all calls to set_arg_ptr where changed to pass a pointer to the descriptor in question instead of the assign_ data type. This eliminates problems with subscript range faults. 81-11-06 Rickie E. Brinegar: Added the unspec builtin for initializing the select_info structure. Modified to use the entry variables in the linus_set_fn structure instead of the entry pointers that used to be used. 82-11-15 Dave Schimke: Removed useless cleanup procedure which called linus_free_se$free_sel_info on a cleanup condition. This was part of an earlier change by Rickie Brinegar which moved the select_info to the lila temp_seg. Removed dcl of cleanup condition and linus_free_se$free_sel_info. */ %include linus_lcb; %page; %include linus_select_info; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_ls_block; %page; %include linus_set_fn; %page; %include linus_set_fn_info; %page; %include linus_ef_data; %page; %include linus_token_data; %page; %include mdbm_arg_list; dcl fn_name char (32); /* function name */ dcl (i, type, nargs) fixed bin; dcl ( bit_len, /* bit length variable */ code, /* Output: return code */ icode, /* internal status code */ len ) fixed bin (35); dcl ( arg_desc_ptr init (null), /* a pointer to arg_desc structure */ mi_ptr init (null) ) ptr; /* pointer to a mrds item */ dcl BITD bit (36) int static options (constant) init ("101001100000000000000000000000100100"b); dcl DB fixed bin (4) int static options (constant) init (6); dcl EXPRESS fixed bin (4) int static options (constant) init (5); dcl FB35D bit (36) int static options (constant) init ("100000100000000000000000000000100011"b); dcl MRDS fixed bin int static options (constant) init (1); dcl bit36 bit (36) based; dcl char_desc_bits bit (36) based (addr (char_desc)); dcl sex char (select_info.se_len) based (select_info.se_ptr); dcl token char (token_data.length) based (token_data.t_ptr); dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl 1 arg_desc aligned, /* descs. for info ent. call */ 2 ndescs fixed bin, 2 desc (linus_data_$max_user_items) bit (36); dcl 1 char_desc aligned, /* character desc. */ 2 const bit (12) unal init ("101010110000"b), 2 len fixed bin (23) unal; dcl 1 m_item aligned like select_info.mrds_item based (mi_ptr); dcl 1 rslt_desc_arg_list aligned, 2 arg_count fixed bin (17) unsigned unal init (2), 2 pad1 bit (1) unal init ("0"b), 2 call_type fixed bin (18) unsigned unal init (4), 2 desc_count fixed bin (17) unsigned unal init (0), 2 pad2 bit (19) unal init ("0"b), 2 arg_ptrs (2) ptr; dcl (addr, fixed, rel, after, substr, addrel, null, unspec) builtin; dcl ( linus_error_$setfn_nargs, linus_error_$inv_setfn_set, linus_error_$cant_alloc_lit, linus_error_$inv_setfn_args, linus_error_$setfn_syntax, linus_data_$max_user_items, linus_data_$max_set_stack_size, linus_data_$max_pred_stack_size, linus_data_$max_expr_items, linus_data_$max_range_items, linus_data_$max_lvars, mrds_data_$max_select_items, mrds_data_$max_token_size, sys_info$max_seg_size ) fixed bin (35) ext; dcl cu_$generate_call entry (entry, ptr); dcl linus_lila_set entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_alloc_lit entry (ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_assign_data entry (bit (36), fixed bin, fixed bin (35)); dcl mdbm_util_$varying_data_class entry (ptr) returns (bit (1) aligned); si_ptr, /* initialize */ linus_set_fn_ptr = null; lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; fn_name = token; /* save function name for later */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); if token_data.key ^= LB then /* must have left br. following fn name */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$setfn_syntax, token); token_data.key = NULL; /* dont pass token to linus_lila_set */ nmi_init = mrds_data_$max_select_items; nui_init = linus_data_$max_user_items; nsv_init = linus_data_$max_range_items + linus_data_$max_lvars; allocate select_info in (work_area); /* temp select_info */ unspec (select_info.se_flags) = "0"b; do i = 1 to select_info.nui_alloc; unspec (select_info.user_item (i)) = "0"b; select_info.user_item.name (i) = ""; end; select_info.prior_sf_ptr, select_info.se_ptr, select_info.sel_items_ptr = null; do i = 1 to nsv_init; unspec (select_info.se_vals (i)) = "0"b; select_info.se_vals (i).arg_ptr, select_info.se_vals (i).arg_ptr = null; end; do i = 1 to nmi_init; unspec (select_info.mrds_item (i)) = "0"b; select_info.mrds_item (i).arg_ptr = null; end; do i = 1 to nui_init; select_info.user_item (i).rslt_assn_ptr, select_info.user_item (i).item_ptr = null; end; call linus_lila_set (lcb_ptr, lsh_ptr, td_ptr, si_ptr, icode); /* translate the input LILA set */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); if token_data.key = NULL then do; /* if need to get new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; if token_data.key ^= RB then do; /* must finish with right br. */ if token_data.key = NULL then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$setfn_syntax, ""); else call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$setfn_syntax, token); end; token_data.key = NULL; /* so noone else will use this token */ do linus_set_fn_info_ptr = lcb.setfi_ptr repeat linus_set_fn_info.fwd_ptr /* get info for set fn. */ while (fn_name ^= linus_set_fn_info.name & linus_set_fn_info.fwd_ptr ^= null); end; /* are guaranteed to find it */ if linus_set_fn_info.nargs > 0 then /* if fixed args, check for quant. match */ if linus_set_fn_info.nargs ^= select_info.n_user_items then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$setfn_nargs, fn_name); if ^select_info.se_flags.val_ret then /* input expr. must be valid for retr. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_setfn_set, fn_name); initial_number_of_linus_set_fn_args = select_info.n_user_items; /* alloc. set fn struct. */ allocate linus_set_fn in (work_area); /* need to keep it around */ linus_set_fn.calc_al_ptr, linus_set_fn.assign_al_ptr, linus_set_fn.rtrv_al_ptr = null; /* start filling it in */ linus_set_fn.calc_entry_set = linus_set_fn_info.calc_entry_set; if linus_set_fn_info.calc_entry_set then linus_set_fn.calc_entry = linus_set_fn_info.calc_entry; linus_set_fn.init_entry_set = linus_set_fn_info.init_entry_set; if linus_set_fn_info.init_entry_set then linus_set_fn.init_entry = linus_set_fn_info.init_entry; linus_set_fn.assign_entry_set = linus_set_fn_info.assign_entry_set; if linus_set_fn_info.assign_entry_set then linus_set_fn.assign_entry = linus_set_fn_info.assign_entry; linus_set_fn.prior_ptr = select_info.prior_sf_ptr; linus_set_fn.fwd_ptr = null; linus_set_fn.nargs = select_info.n_user_items; do i = 1 to select_info.n_user_items; /* copy input arg info */ if select_info.user_item.item_type (i) = MRDS then do; /* if data base item */ mi_ptr = select_info.user_item.item_ptr (i); linus_set_fn.arg.desc (i) = m_item.desc; linus_set_fn.arg.assn_ptr (i) = m_item.arg_ptr; linus_set_fn.arg.assn_type (i) = m_item.assn_type; linus_set_fn.arg.assn_len (i) = m_item.assn_len; linus_set_fn.arg.type (i) = DB; linus_set_fn.arg.ef_ptr (i) = null; linus_set_fn.arg.arg_assn_ptr (i) = null; end; /* if data base item */ else do; /* if is expr. */ linus_set_fn.arg.type (i) = EXPRESS; linus_set_fn.arg.desc (i) = select_info.user_item.rslt_desc (i); linus_set_fn.arg.assn_ptr (i) = select_info.user_item.rslt_assn_ptr (i); linus_set_fn.arg.assn_type (i) = select_info.user_item.rslt_assn_type (i); linus_set_fn.arg.assn_len (i) = select_info.user_item.rslt_assn_len (i); linus_set_fn.arg.ef_ptr (i) = select_info.user_item.item_ptr (i); end; /* if is expression */ end; /* first arg copy loop */ num_ptrs = 2 * linus_set_fn.nargs; /* set up and init. the calc. arg list */ allocate arg_list in (work_area); linus_set_fn.calc_al_ptr = al_ptr; arg_list.arg_count, arg_list.desc_count = num_ptrs; arg_list.code = 4; if linus_set_fn_info.nargs > 0 then do; /* if fixed-arg function */ linus_set_fn.rslt_desc = linus_set_fn_info.rslt_desc; /* fill in result desc. */ do i = 1 to linus_set_fn.nargs; /* another pass through input args */ if linus_set_fn_info.arg_desc (i) = linus_set_fn.arg.desc (i) then do; /* no conv. req. */ linus_set_fn.arg.must_convert = "0"b; arg_list.arg_des_ptr (i) = set_arg_ptr (linus_set_fn.arg.assn_ptr (i), addr (linus_set_fn.arg.desc (i))); /* fill in calc. arg list */ arg_list.arg_des_ptr (i + linus_set_fn.nargs) = addr (linus_set_fn.arg.desc (i)); end; /* if no conv. req. */ else do; /* set up for arg conversion */ linus_set_fn.arg.must_convert = "1"b; linus_set_fn.arg.arg_desc (i) = linus_set_fn_info.arg_desc (i); call linus_assign_data ((linus_set_fn.arg.arg_desc (i)), linus_set_fn.arg.arg_assn_type (i), linus_set_fn.arg.arg_assn_len (i)); call linus_lila_alloc_lit (lcb_ptr, addr (linus_set_fn.arg.arg_desc (i)), linus_set_fn.arg.arg_assn_ptr (i), bit_len); if linus_set_fn.arg.arg_assn_ptr (i) = null then /* trouble */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, ""); arg_list.arg_des_ptr (i) = set_arg_ptr (linus_set_fn.arg.arg_assn_ptr (i), addr (linus_set_fn.arg.arg_desc (i))); /* fill in calc arg list */ arg_list.arg_des_ptr (i + linus_set_fn.nargs) = addr (linus_set_fn.arg.arg_desc (i)); end; /* setting up for arg conv. */ end; /* loop through args */ end; /* if fixed arg function call */ else do; /* variable arg function */ arg_desc.ndescs = linus_set_fn.nargs; do i = 1 to linus_set_fn.nargs; /* pass through input args */ linus_set_fn.arg.must_convert (i) = "0"b; /* never need to convert */ arg_desc.desc (i) = linus_set_fn.arg.desc (i); /* save for info call */ arg_list.arg_des_ptr (i) = set_arg_ptr (linus_set_fn.arg.assn_ptr (i), addr (linus_set_fn.arg.desc (i))); /* fill in calc arg list */ arg_list.arg_des_ptr (i + linus_set_fn.nargs) = addr (linus_set_fn.arg.desc (i)); end; /* arg loop */ arg_desc_ptr = addr (arg_desc); rslt_desc_arg_list.arg_ptrs (1) = addr (arg_desc_ptr); rslt_desc_arg_list.arg_ptrs (2) = addr (linus_set_fn.rslt_desc); call cu_$generate_call (linus_set_fn_info.info_entry, addr (rslt_desc_arg_list)); /* call info ent for rslt. */ if linus_set_fn.rslt_desc = "0"b then /* if couldn't handle this input */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$inv_setfn_args, fn_name); end; /* variable arg function call */ num_ptrs = 2; /* set up assign entry arg list */ allocate arg_list in (work_area); linus_set_fn.assign_al_ptr = al_ptr; arg_list.arg_count, arg_list.desc_count = 2; arg_list.code = 4; ef_data.desc = linus_set_fn.rslt_desc; /* set up ef_data while we are at it */ call linus_assign_data ((ef_data.desc), ef_data.assn_type, ef_data.assn_len) ; call linus_lila_alloc_lit (lcb_ptr, addr (ef_data.desc), ef_data.assn_ptr, ef_data.bit_length); if ef_data.assn_ptr = null then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, ""); ef_data.var_name = ""; ef_data.nmrds_items = 0; ef_data.ef_ptr = linus_set_fn_ptr; arg_list.arg_des_ptr (1) = set_arg_ptr (ef_data.assn_ptr, addr (ef_data.desc)); /* back to assign arg list */ arg_list.arg_des_ptr (2) = addr (linus_set_fn.rslt_desc); nargs = 3 + select_info.nsevals + select_info.n_mrds_items; num_ptrs = 2 * nargs; /* set up retrieval arg list */ allocate arg_list in (work_area); linus_set_fn.rtrv_al_ptr = al_ptr; arg_list.arg_count, arg_list.desc_count = num_ptrs; arg_list.code = 4; arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* data base index */ arg_list.arg_des_ptr (nargs + 1) = addr (FB35D); arg_list.arg_des_ptr (2) = select_info.se_ptr; /* selection expr. */ call linus_lila_alloc_lit (lcb_ptr, addr (BITD), arg_list.arg_des_ptr (nargs + 2), bit_len); if arg_list.arg_des_ptr (nargs + 2) = null then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, ""); char_desc.len = select_info.se_len; arg_list.arg_des_ptr (2 + nargs) -> bit36 = char_desc_bits; if ^select_info.unique_flag /* decide if need to tell MRDS to fetch dups */ | (select_info.unique_flag & select_info.dup_flag) then substr (after (sex, "-select "), 1, 4) = "-dup"; do i = 3 to select_info.nsevals + 2; /* add se_val args */ call linus_assign_data (select_info.se_vals.desc_ptr (i - 2) -> bit36, type, len); arg_list.arg_des_ptr (i) = set_arg_ptr (select_info.se_vals.arg_ptr (i - 2), select_info.se_vals.desc_ptr (i - 2)); arg_list.arg_des_ptr (nargs + i) = select_info.se_vals.desc_ptr (i - 2); end; /* adding se_val args */ do i = select_info.nsevals + 3 to nargs - 1; /* add retrieval args */ arg_list.arg_des_ptr (i) = set_arg_ptr (select_info.mrds_item .arg_ptr (i - select_info.nsevals - 2), addr (select_info.mrds_item.desc (i - select_info.nsevals - 2))); call linus_lila_alloc_lit (lcb_ptr, addr (BITD), arg_list.arg_des_ptr (nargs + i), bit_len); if arg_list.arg_des_ptr (nargs + i) = null then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, ""); arg_list.arg_des_ptr (nargs + i) -> bit36 = select_info.mrds_item.desc (i - select_info.nsevals - 2); end; /* adding retrieval args */ call linus_lila_alloc_lit (lcb_ptr, addr (FB35D), arg_list.arg_des_ptr (nargs), bit_len); /* add code */ if arg_list.arg_des_ptr (nargs) = null then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$cant_alloc_lit, ""); arg_list.arg_des_ptr (num_ptrs) = addr (FB35D); si_ptr = null; /* we have taken everything out */ if lss_ptr ^= null then do; /* if not outer set fn */ linus_set_fn.fwd_ptr = ls_set.si_ptr -> select_info.prior_sf_ptr; /* put this block into chain */ ls_set.si_ptr -> select_info.prior_sf_ptr = linus_set_fn_ptr; end; code = 0; return; set_arg_ptr: proc (a_ptr, a_desc_ptr) returns (ptr); /* procedure to return a valid arg pointer given an internal pointer, i.e. resolves the var. str. problem. */ dcl a_ptr ptr; dcl r_ptr ptr; dcl a_desc_ptr ptr; if mdbm_util_$varying_data_class (a_desc_ptr) then r_ptr = addrel (a_ptr, 1); else r_ptr = a_ptr; return (r_ptr); end set_arg_ptr; end linus_lila_set_fn;  linus_lila_term.pl1 07/29/86 1045.3r w 07/29/86 0939.9 140301 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_term: proc (lcb_ptr, lsh_ptr, td_ptr, code); /* DESCRIPTION: This procedure processes a LINUS term and produces a MRDS term string. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 78-04-01 J. A. Weeldreyer: Modified to give better diagnostics for constant expr. of scalar funs. 78-08-01 J. A. Weeldreyer: Modified to conform to new token data. 80-03-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-11-03 DJ Schimke: Modified to allow constant -> op -> column_spec ordering for expressions rather than only column_spec -> op -> constant. */ %include linus_lcb; %page; %include linus_ef_data; %page; %include linus_ls_header; %page; %include linus_ls_set; %page; %include linus_ls_block; %page; %include linus_mrds_block; %page; %include linus_set_fn; %page; %include linus_token_data; %page; %include linus_variables; %page; %include mdbm_descriptor; dcl ( code, /* Output: return code */ icode, /* internal status code */ temp_pos ) fixed bin (35); /* temp cur_pos for look ahead */ dcl ( expr_flag, /* on if expr OK */ atom_flag, /* on if atom OK */ rop_flag, /* on if rel. op. OK */ end_flag, /* on if end OK */ done ) bit (1) unal; /* completion flag */ dcl (i, leaf_no) fixed bin; /* no. of leaf we are working on */ dcl si_ptr ptr; /* pointer to select_info_structure */ dcl token char (token_data.length) based (token_data.t_ptr); dcl mrds_rop (24:29) char (4) var int static options (constant) init (" = ", " ^= ", " > ", " >= ", " < ", " <= "); dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl 1 temp_token aligned like token_data; /* for look-ahead */ dcl 1 expr_data aligned like ef_data; dcl ( linus_error_$where_syntax, linus_error_$incomplete_where, linus_error_$const_expr_fn, linus_data_$max_set_stack_size, linus_data_$max_range_items, linus_data_$max_expr_items, linus_data_$max_pred_stack_size, mrds_data_$max_token_size, mrds_data_$max_select_items, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, fixed, null, length, addrel, rel) builtin; dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_set_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_build_expr_str entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35)); dcl linus_lila_block entry (ptr, ptr, ptr, fixed bin (35)); call init; /* initialize */ if token_data.key = NULL then do; /* if need new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; expr_flag = "1"b; rop_flag, /* init. state flags */ atom_flag, end_flag = "0"b; done = "0"b; /* init for loop */ do while (^done); /* main processing loop */ go to token_proc (token_data.key); token_proc (0): /* null */ token_proc (1): /* ) */ token_proc (8): /* * */ token_proc (9): /* / */ token_proc (10): /* + */ token_proc (11): /* - */ token_proc (12): /* table name */ token_proc (13): /* row table pair */ token_proc (14): /* union */ token_proc (15): /* inter */ token_proc (16): /* differ */ token_proc (17): /* row designator */ token_proc (19): /* } */ token_proc (20): /* select */ token_proc (21): /* ^ */ token_proc (22): /* & */ token_proc (23): /* | */ token_proc (30): /* from */ token_proc (31): /* where */ token_proc (32): /* dup */ token_proc (33): /* unique */ token_proc (34): /* , */ if ^end_flag then /* cant have end of term now */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$incomplete_where, token); call build_term_block; /* build mrds term block and put in stack */ done = "1"b; go to next; token_proc (2): /* column specification */ if ^atom_flag & ^expr_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); temp_pos = ls_header.cur_pos; /* look ahead for operator */ call linus_lila_get_token (lcb_ptr, lsh_ptr, temp_pos, addr (temp_token), icode); if icode ^= 0 then do; /* reset token pos. ind. prior to error call */ token_data = temp_token; ls_header.cur_pos = temp_pos; call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; if temp_token.key >= STAR & temp_token.key <= MINUS then /* if is expr. */ call process_expr; else do; /* is not expression */ call store_leaf (token_data.mvar || "." || token, token_data.must_free); token_data.key = NULL; /* force new token */ end; /* if col. spec. */ if expr_flag then do; /* if was first leaf, expect rel. op. */ expr_flag, atom_flag, end_flag = "0"b; rop_flag = "1"b; end; else do; /* if was second leaf, expect end */ expr_flag, atom_flag, rop_flag = "0"b; end_flag = "1"b; end; go to next; token_proc (3): /* linus variable */ if ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); lv_ptr = lcb.lv_ptr; /* find info for lin. var. */ do i = 1 to variables.nvars while (token ^= variables.var_info.name (i)); end; /* we know we will find it */ call add_val_leaf (variables.var_info.var_ptr (i), addr (variables.var_info.desc (i))); end_flag = "1"b; atom_flag, /* reset state flags */ rop_flag, expr_flag = "0"b; token_data.key = NULL; /* force new token */ go to next; /* 81-11-03 DJ Schimke: Begin Change *************************************** */ token_proc (4): /* constant */ if ^atom_flag & ^expr_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); temp_pos = ls_header.cur_pos; /* look ahead for operator */ call linus_lila_get_token (lcb_ptr, lsh_ptr, temp_pos, addr (temp_token), icode); if icode ^= 0 then do; /* reset token pos. ind. prior to error call */ token_data = temp_token; ls_header.cur_pos = temp_pos; call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; if temp_token.key >= STAR & temp_token.key <= MINUS then /* if is expr. */ call process_expr; else do; /* is not expression */ call store_leaf (token, token_data.must_free); token_data.key = NULL; /* force new token */ end; /* if constant */ if expr_flag then do; /* if was first leaf, expect rel. op. */ expr_flag, atom_flag, end_flag = "0"b; rop_flag = "1"b; end; else do; /* if was second leaf, expect end */ expr_flag, atom_flag, rop_flag = "0"b; end_flag = "1"b; end; go to next; /* 81-11-03 DJ Schimke: End Change ***************************************** */ token_proc (5): /* set function */ if ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); call linus_lila_set_fn (lcb_ptr, lsh_ptr, td_ptr, addr (expr_data), icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); call add_val_leaf (expr_data.assn_ptr, addr (expr_data.ef_ptr -> linus_set_fn.rslt_desc)); end_flag = "1"b; /* reset state flags */ rop_flag, expr_flag, atom_flag = "0"b; go to next; token_proc (6): /* scalar function */ token_proc (7): /* ( */ if ^expr_flag & ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); call process_expr; /* these tokens imply an expression */ if expr_flag then do; /* if expr, then look for rel. op. */ rop_flag = "1"b; expr_flag, atom_flag, end_flag = "0"b; end; else do; /* if atom, look for end */ end_flag = "1"b; expr_flag, rop_flag, atom_flag = "0"b; end; go to next; token_proc (18): /* { */ if ^atom_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); ls_block.pred_pcnt = ls_block.pred_pcnt + 1; /* implied paren at start of blockk */ ls_set.br_cnt = ls_set.br_cnt + 1; /* increment bracket count */ call linus_lila_block (lcb_ptr, lsh_ptr, td_ptr, icode); /* process the inner block */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); if token_data.key ^= RB then /* last token must be } */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); ls_set.br_cnt = ls_set.br_cnt - 1; /* decrement bracket count */ token_data.key = NULL; /* force new token */ end_flag = "1"b; /* reset state flags */ rop_flag, atom_flag, expr_flag = "0"b; go to next; token_proc (24): /* = */ token_proc (25): /* ^= */ token_proc (26): /* > */ token_proc (27): /* >= */ token_proc (28): /* < */ token_proc (29): /* <= */ if ^rop_flag then /* if rel. op. not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); ls_block.term_op = token_data.key; /* save rel. op. */ atom_flag = "1"b; /* reset state flags */ end_flag, rop_flag, expr_flag = "0"b; token_data.key = NULL; go to next; next: if token_data.key = NULL then do; /* get next token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; end; /* main processing loop */ code = 0; /* made it! */ return; stack_term: entry (lcb_ptr, lsh_ptr); /* Entry called by linus_lila_select to cause completed term to be added to term stack. */ call init; /* initialize */ call build_term_block; /* do the work */ return; build_term_block: proc; /* Procedure to build a MRDS term string from the term info stored in the ls_block. */ dcl i fixed bin; if ls_block.term_op > 0 then do; /* only if there is an unbuilt term */ ms_len_init = length (ls_block.leaf_ptr (1) -> mrds_block.mrds_string) + length (ls_block.leaf_ptr (2) -> mrds_block.mrds_string) + length (mrds_rop (ls_block.term_op)); /* alloc. term block */ nval_args_init = ls_block.leaf_ptr (1) -> mrds_block.nval_args + ls_block.leaf_ptr (2) -> mrds_block.nval_args; allocate mrds_block in (work_area); mrds_block.fwd_ptr = ls_block.term_hd_ptr; /* fill in the term block */ mrds_block.mrds_string = ls_block.leaf_ptr (1) -> mrds_block.mrds_string || mrds_rop (ls_block.term_op) || ls_block.leaf_ptr (2) -> mrds_block.mrds_string; ls_block.term_op = 0; /* indicate no term */ do i = 1 to ls_block.leaf_ptr (1) -> mrds_block.nval_args; /* fill in args from first leaf */ mrds_block.val_args.arg_ptr (i) = ls_block.leaf_ptr (1) -> mrds_block.arg_ptr (i); mrds_block.val_args.desc_ptr (i) = ls_block.leaf_ptr (1) -> mrds_block.desc_ptr (i); end; do i = ls_block.leaf_ptr (1) -> mrds_block.nval_args + 1 to mrds_block.nval_args; /* add args from second leaf */ mrds_block.val_args.arg_ptr (i) = ls_block.leaf_ptr (2) -> mrds_block.val_args .arg_ptr (i - ls_block.leaf_ptr (1) -> mrds_block.nval_args); mrds_block.val_args.desc_ptr (i) = ls_block.leaf_ptr (2) -> mrds_block.val_args .desc_ptr (i - ls_block.leaf_ptr (1) -> mrds_block.nval_args); end; ls_block.term_hd_ptr = mblk_ptr; mblk_ptr = null; ls_block.nterms = ls_block.nterms + 1; ls_block.leaf_ptr (1) = null; ls_block.leaf_ptr (2) = null; end; /* if there was unbuilt term */ end build_term_block; process_expr: proc; /* Procedure to handle where clause expressions. */ dcl var char (32); var = ""; call linus_lila_build_expr_str (lcb_ptr, lsh_ptr, td_ptr, mblk_ptr, var, icode); /* build mrds string for this expr. */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); if var = "" then call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$const_expr_fn, ""); if expr_flag then leaf_no = 1; else leaf_no = 2; ls_block.leaf_ptr (leaf_no) = mblk_ptr; mblk_ptr = null; end process_expr; store_leaf: proc (string, must_free); /* procedure to store a leaf into the current term in the ls_block */ dcl string char (*); dcl must_free bit (1); if expr_flag then leaf_no = 1; else leaf_no = 2; ms_len_init = length (string); /* make and fill in mrds block for leaf */ nval_args_init = 0; allocate mrds_block in (work_area); mrds_block.fwd_ptr = null; mrds_block.mrds_string = string; ls_block.leaf_ptr (leaf_no) = mblk_ptr; /* put in leaf */ mblk_ptr = null; token_data.t_ptr = null; end store_leaf; add_val_leaf: proc (arg_ptr, desc_ptr); /* Procedure to add a .V. type of leaf to the current term. */ dcl (arg_ptr, desc_ptr) ptr; dcl is_var (22) bit (1) int static unal options (constant) init ((19) (1)"0"b, "1"b, "0"b, "1"b); ms_len_init = 3; /* make and fill in mrds block for leaf */ nval_args_init = 1; allocate mrds_block in (work_area); mrds_block.fwd_ptr = null; mrds_block.mrds_string = ".V."; if is_var (desc_ptr -> descriptor.type) then mrds_block.val_args.arg_ptr (1) = addrel (arg_ptr, 1); else mrds_block.val_args.arg_ptr (1) = arg_ptr; mrds_block.val_args.desc_ptr (1) = desc_ptr; ls_block.leaf_ptr (2) = mblk_ptr; /* this type of leaf is always second */ mblk_ptr = null; end add_val_leaf; init: proc; /* Procedure to initialize for both entries. */ lsb_ptr = ls_header.cur_ptr; lss_ptr = ls_block.back_ptr; si_ptr = ls_set.si_ptr; mblk_ptr = null; num_dims = 0; end init; end linus_lila_term;  linus_lila_where.pl1 07/29/86 1045.3r w 07/29/86 0939.9 131670 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_lila_where: proc (lcb_ptr, lsh_ptr, inner, td_ptr, code); /* DESCRIPTION: This procedure processes the LILA where clause, producing the qualifier portion of a MRDS -where clause. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 80-03-13 Rickie E. Brinegar: Modified to use a work area defined on lcb.lila_area_ptr instead of getting system free area. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-09-17 Rickie E. Brinegar: Changed the two do loops in the reduce procedure to use the bit variable done in the while clause instead of the large boolean variables that are now done in the if statements just before and inside of the do loops. This avoids subscript range conditions. 81-11-06 Rickie E. Brinegar: Added the declaration of the fixed builtin and deleted the declaration of the unreferenced linus_data_$max_leaf_vals. */ %include linus_lcb; %page; %include linus_ls_block; %page; %include linus_ls_header; %page; %include linus_mrds_block; %page; %include linus_token_data; dcl ( inner, /* Input: on if inner LILA block */ where_flag, /* on if "where" OK */ term_flag, /* on if term OK */ not_flag, /* on if "^" OK */ lp_flag, /* on if "(" OK */ bop_flag, /* on if bool. op. OK */ rp_flag, /* on if ")" OK */ end_flag, /* on if end OK */ done ) bit (1) unal; /* internal completion flag */ dcl ( code, /* Output: status code */ icode ) fixed bin (35); dcl i fixed bin; /* internal index */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl token char (token_data.length) based (token_data.t_ptr); dcl mrds_bop (22:23) char (5) int static options (constant) init (") & (", ") | ("); dcl bop_prec (22:23) fixed bin int static options (constant) init (2, 1); dcl ( END init (1), PAREN init (2), OP init (3) ) fixed bin int static options (constant); dcl ( linus_error_$where_syntax, linus_error_$where_ovfl, linus_error_$incomplete_where, linus_error_$unbal_parens, linus_data_$max_pred_stack_size, linus_data_$max_range_items, mrds_data_$max_token_size, mrds_data_$max_select_items, sys_info$max_seg_size ) fixed bin (35) ext; dcl (addr, fixed, length, null, rel) builtin; dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_lila_term entry (ptr, ptr, ptr, fixed bin (35)); mblk_ptr = null; lsb_ptr = ls_header.cur_ptr; if token_data.key = NULL then do; /* if need to get new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; where_flag = "1"b; /* init. state flags */ term_flag, not_flag, lp_flag, bop_flag, rp_flag, end_flag = "0"b; done = "0"b; do while (^done); /* main token processing loop */ go to token_proc (token_data.key); token_proc (0): /* null */ token_proc (3): /* linus variable */ token_proc (4): /* constant */ token_proc (5): /* set function */ token_proc (8): /* * */ token_proc (9): /* / */ token_proc (10): /* + */ token_proc (11): /* - */ token_proc (12): /* table name */ token_proc (13): /* row table pair */ token_proc (14): /* union */ token_proc (15): /* inter */ token_proc (16): /* differ */ token_proc (17): /* row designator */ token_proc (18): /* { */ token_proc (19): /* } */ token_proc (20): /* select */ token_proc (24): /* = */ token_proc (25): /* ^= */ token_proc (26): /* > */ token_proc (27): /* >= */ token_proc (28): /* < */ token_proc (29): /* <= */ token_proc (30): /* from */ token_proc (32): /* dup */ token_proc (33): /* unique */ token_proc (34): /* , */ if ^end_flag then /* these tokens should not be here, try to treat as end */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$incomplete_where, token); if ^inner then do; /* if legit end for outer block */ call reduce (END); /* perform final predicate retuction */ if ls_block.nprops ^= 0 & ls_block.nterms ^= 1 then /* didnt come out right */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, ""); end; /* if outer block */ else do; /* if is legit end for inner block */ do i = 1, 2 while (ls_block.pred_pcnt > 0); call reduce (PAREN); /* reduce for 2 implied RP's at end of inner block */ ls_block.pred_pcnt = ls_block.pred_pcnt - 1; end; end; /* if inner block */ done = "1"b; /* set completion flag */ go to next; token_proc (1): /* ) */ if ^rp_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); if ls_block.pred_pcnt <= 0 then /* if no matching ( */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$unbal_parens, token); call reduce (PAREN); /* perform any necessary reductions */ ls_block.pred_pcnt = ls_block.pred_pcnt - 1; token_data.key = NULL; /* force new token */ go to next; token_proc (2): /* column spec. */ token_proc (6): /* scalar function */ if ^term_flag then /* both tokens start terms, is one expected? */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); call linus_lila_term (lcb_ptr, lsh_ptr, td_ptr, icode); /* go process the term */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); term_flag, /* set state flags */ lp_flag, not_flag = "0"b; bop_flag, rp_flag, end_flag = "1"b; go to next; token_proc (7): /* ( */ if ^lp_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); ls_block.pred_pcnt = ls_block.pred_pcnt + 1; /* merely incr. par. count */ term_flag, /* set state flags */ not_flag = "1"b; token_data.key = NULL; /* force new token */ go to next; token_proc (21): /* ^ */ if ^not_flag then /* if not allowed here */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); if ls_block.nprops >= linus_data_$max_pred_stack_size then /* if op stack ovfl. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_ovfl, ""); ls_block.nprops = ls_block.nprops + 1; /* add ^ to op stack */ ls_block.pred_op_stack.key (ls_block.nprops) = NOT; ls_block.pred_op_stack.p_cnt (ls_block.nprops) = ls_block.pred_pcnt; token_data.key = NULL; /* force new token */ term_flag, /* set state flags */ not_flag, rp_flag, bop_flag, end_flag = "0"b; lp_flag = "1"b; go to next; token_proc (22): /* & */ token_proc (23): /* | */ if ^bop_flag then /* if bool. oper. not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); if ls_block.nprops > 0 then /* if prev. op. */ if ls_block.pred_op_stack.p_cnt (ls_block.nprops) = ls_block.pred_pcnt then if bop_prec (token_data.key) <= bop_prec (ls_block.pred_op_stack.key (ls_block.nprops)) then call reduce (OP); /* reduce for lower prec. oper. */ if ls_block.nprops >= linus_data_$max_pred_stack_size then /* if over flow */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_ovfl, ""); ls_block.nprops = ls_block.nprops + 1; /* add new op. to stack */ ls_block.pred_op_stack.key (ls_block.nprops) = token_data.key; ls_block.pred_op_stack.p_cnt (ls_block.nprops) = ls_block.pred_pcnt; token_data.key = NULL; /* force new token */ term_flag, /* set state flags */ not_flag, lp_flag = "1"b; bop_flag, rp_flag, end_flag = "0"b; go to next; token_proc (31): /* where */ if ^where_flag then /* if not expected */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_syntax, token); if inner then do; /* if inner block, add implied & and ( */ if ls_block.nprops >= linus_data_$max_pred_stack_size then /* if will overfl. */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$where_ovfl, ""); ls_block.nprops = ls_block.nprops + 1; /* add & */ ls_block.pred_op_stack.key (ls_block.nprops) = AND; ls_block.pred_op_stack.p_cnt (ls_block.nprops) = ls_block.pred_pcnt; ls_block.pred_pcnt = ls_block.pred_pcnt + 1; /* add ( */ end; /* if inner block */ where_flag = "0"b; /* set state flags */ term_flag, not_flag, lp_flag = "1"b; token_data.key = NULL; /* force new token */ go to next; next: if token_data.key = NULL then do; /* if need new token */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, td_ptr, icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); end; end; /* main processing loop */ code = 0; /* made it */ return; reduce: proc (type); /* Procedure to reduce items in pred stack. Three types of reduction are provided: (a) for lower precedence operators, (b) for right parenthesis, and (c) final reduction. */ dcl type fixed bin; dcl bp ptr; dcl done bit (1); if type = END then do while (ls_block.nprops > 0 & ls_block.nterms > 1); call combine; end; /* final reduction */ else if type = PAREN then do; /* paren reduction */ done = "0"b; if ls_block.nprops ^> 0 | ls_block.nterms ^> 1 then done = "1"b; else if ls_block.pred_op_stack.p_cnt (ls_block.nprops) ^= ls_block.pred_pcnt then done = "1"b; do while (^done); call combine; if ls_block.nprops ^> 0 | ls_block.nterms ^> 1 then done = "1"b; else if ls_block.pred_op_stack.p_cnt (ls_block.nprops) ^= ls_block.pred_pcnt then done = "1"b; end; /* combining all terms within paren */ if ls_block.nprops > 0 & ls_block.nterms > 1 then /* check for preceding not */ if ls_block.pred_op_stack.key (ls_block.nprops) = NOT & ls_block.pred_op_stack.p_cnt (ls_block.nprops) = ls_block.pred_pcnt - 1 then do; bp = ls_block.term_hd_ptr; /* point to top term in stack */ ms_len_init = 3 + length (bp -> mrds_block.mrds_string); /* alloc. new block */ nval_args_init = bp -> mrds_block.nval_args; allocate mrds_block in (work_area); mrds_block.fwd_ptr = bp -> mrds_block.fwd_ptr; /* replace current top term */ mrds_block.mrds_string = "^(" || bp -> mrds_block.mrds_string || ")"; mrds_block.val_args = bp -> mrds_block.val_args; ls_block.nprops = ls_block.nprops - 1; ls_block.term_hd_ptr = mblk_ptr; bp = null; mblk_ptr = null; end; /* incorporating not */ end; /* paren reduction */ else do; done = "0"b; if ls_block.nprops ^> 0 | ls_block.nterms ^> 1 then done = "1"b; else if ls_block.pred_op_stack.p_cnt (ls_block.nprops) ^= ls_block.pred_pcnt | bop_prec (token_data.key) > bop_prec (ls_block.pred_op_stack.key (ls_block.nprops)) then done = "1"b; do while (^done); call combine; if ls_block.nprops ^> 0 | ls_block.nterms ^> 1 then done = "1"b; else if ls_block.pred_op_stack.p_cnt (ls_block.nprops) ^= ls_block.pred_pcnt | bop_prec (token_data.key) > bop_prec (ls_block.pred_op_stack.key (ls_block.nprops)) then done = "1"b; end; end; /* operator reduction */ combine: proc; /* Procedure to combine the top two string blocks and top operator into one string block, and replace the items in the stack */ dcl (b1p, b2p) ptr; dcl i fixed bin; b2p = ls_block.term_hd_ptr; /* point to top term */ b1p = b2p -> mrds_block.fwd_ptr; /* and prec. term */ ms_len_init = 7 + length (b1p -> mrds_block.mrds_string) + length (b2p -> mrds_block.mrds_string); nval_args_init = b1p -> mrds_block.nval_args + b2p -> mrds_block.nval_args; allocate mrds_block in (work_area); /* the combination block */ mrds_block.fwd_ptr = b1p -> mrds_block.fwd_ptr; /* replace top two terms */ mrds_block.mrds_string = "(" || b1p -> mrds_block.mrds_string || mrds_bop (ls_block.pred_op_stack.key (ls_block.nprops)) || b2p -> mrds_block.mrds_string || ")"; do i = 1 to b1p -> mrds_block.nval_args; mrds_block.val_args.arg_ptr (i) = b1p -> mrds_block.val_args.arg_ptr (i); mrds_block.val_args.desc_ptr (i) = b1p -> mrds_block.val_args.desc_ptr (i); end; do i = b1p -> mrds_block.nval_args + 1 to mrds_block.nval_args; mrds_block.val_args.arg_ptr (i) = b2p -> mrds_block.val_args.arg_ptr (i - b1p -> mrds_block.nval_args); mrds_block.val_args.desc_ptr (i) = b2p -> mrds_block.val_args.desc_ptr (i - b1p -> mrds_block.nval_args); end; ls_block.nprops = ls_block.nprops - 1; ls_block.nterms = ls_block.nterms - 1; ls_block.term_hd_ptr = mblk_ptr; b1p = null; b2p = null; mblk_ptr = null; end combine; end reduce; end linus_lila_where;  linus_list_db.pl1 07/29/86 1045.3r w 07/29/86 0940.0 135810 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_list_db: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: Procedure to list selected information about the currently open data base. Available information includes the database pathname, the opening mode, table names, and column information. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 77-11-01 J. A. Weeldreyer: Modified to set correct defaults. 78-09-01 J. C. C. Jagernauth: Modified for MR7.0. 80-06-01 Jim Gray : Modified to correct argument handling for the -table option, and to force on the -name option with it, so that it makes semantic sense, and also so that it can detect unknown relation names. The ability to detect, and issue a message about no temp tables currently defined was added. Also, opening modes are now display when -pathname is acked for, as in the old linus. This was done by adding open_mode to mrds_dbcb.incl.pl1 changing mrds_dsl_open, mrds_dsl_init_res, and adding a parameter to dsl_$get_pn. 81-05-12 Rickie E. Brinegar: Modified to only display domain names for administrator if the database is secured. 81-06-18 Rickie E. Brinegar: Modified to not check the database version. 81-11-13 Rickie E. Brinegar: Added timing of dsl_ and mdbm_util_ entries. 82-02-08 Paul W. Benjamin: ssu_ conversion. 82-06-21 Al Dupuis: Removed a meaningless comment as requested by audit team who audited ssu_ conversion. */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_temp_tab_names; %page; %include mrds_model_relations; %page; %include mrds_rslt_info; dcl sci_ptr ptr; /* for ssu_ */ dcl ( code, icode ) fixed bin (35); /* internal status code */ dcl (i, j, k) fixed bin; dcl initial_mrds_vclock float bin (63); dcl ( lg_flag, /* -long */ nm_flag, /* -names */ perm_flag, /* -perm */ pn_flag, /* -pathname */ rels_left, /* on => relation names left for -table */ tb_flag, /* -table */ temp_flag, /* -temp */ tn_flag ) bit (1) unal; /* -table_names */ dcl ( pmr_ptr init (null), /* perm mr_ptr */ tmr_ptr init (null) ) ptr; /* temp mr_ptr */ dcl arg char (char_argl.arg.arg_len (i)) based (char_argl.arg.arg_ptr (i)); dcl db_path char (168) var; dcl desc char (120) varying; dcl open_mode char (20); dcl type char (10) varying; dcl work_area area (sys_info$max_seg_size) based (lcb.linus_area_ptr); dcl ( linus_data_$ldb_id, linus_error_$incons_args, linus_error_$inv_arg, linus_error_$no_db, linus_error_$no_tab, mrds_data_$max_temp_rels, mrds_error_$invalid_db_index, /* caused by closed database */ sys_info$max_seg_size ) ext fixed bin (35); dcl (addr, before, fixed, null, rel, substr, vclock) builtin; dcl dsl_$get_pn entry (fixed bin (35), char (168) var, char (20), fixed bin (35)); dcl dsl_$get_rslt_info entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35)); dcl dsl_$get_rslt_rels entry (fixed bin (35), ptr, ptr, fixed bin (35)); dcl dsl_$get_temp_info entry (fixed bin (35), fixed bin (35), ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl mdbm_util_$display_descriptor entry (ptr) returns (char (120) varying); dcl mdbm_util_$trim_descriptor entry (char (120) varying) returns (char (*)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); code = 0; mr_ptr, rslt_ptr, ca_ptr = null; if lcb.db_index = 0 then call error (linus_error_$no_db, ""); /* must have open db. */ call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then do; /* no args, set defaults */ tn_flag, /* -table_names, -pathname -perm -temp */ pn_flag, perm_flag, temp_flag = "1"b; tb_flag, nm_flag, lg_flag = "0"b; end; /* if no args */ else do; /* process user args */ tn_flag, /* init flags to off */ pn_flag, perm_flag, temp_flag, tb_flag, nm_flag, lg_flag = "0"b; allocate char_argl in (lcb.static_area); do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; i = 1; do while (i <= char_argl.nargs); /* main arg processing loop */ if arg = "-pn" | arg = "-pathname" then do; pn_flag = "1"b; i = i + 1; end; else if arg = "-table_names" then do; tn_flag = "1"b; i = i + 1; end; else if arg = "-names" then do; nm_flag = "1"b; i = i + 1; end; else if arg = "-temp" then do; temp_flag = "1"b; i = i + 1; end; else if arg = "-perm" then do; perm_flag = "1"b; i = i + 1; end; else if arg = "-lg" | arg = "-long" then do; lg_flag = "1"b; i = i + 1; end; else if arg = "-tb" | arg = "-table" then do; tb_flag = "1"b; num_relations_alloc = char_argl.nargs - i; /* init model rels struct. */ alloc model_relations set (mr_ptr) in (work_area); model_relations.nrels = 0; rels_left = "1"b; i = i + 1; do while (rels_left); if i > char_argl.nargs then rels_left = "0"b; else if substr (arg, 1, 1) = "-" then rels_left = "0"b; else do; model_relations.nrels = model_relations.nrels + 1; /* add table name to list */ model_relations.relation_name (model_relations.nrels) = arg; i = i + 1; end; end; if model_relations.nrels <= 0 then call error (linus_error_$no_tab, ""); end; /* if -table */ else call error (linus_error_$inv_arg, arg); end; /* control arg loop */ if ^tb_flag & ^perm_flag & ^temp_flag & (nm_flag | lg_flag | tn_flag) then do; /* if tables not given */ perm_flag = "1"b; temp_flag = "1"b; /* give him everything */ end; if (perm_flag | temp_flag) & ^tn_flag & ^tb_flag & ^nm_flag & ^lg_flag then /* type info not given */ tn_flag = "1"b; /* default to table names */ if tn_flag & nm_flag then /* check for inconsistencies */ call error (linus_error_$incons_args, "-table_names and -names"); if tn_flag & lg_flag then call error (linus_error_$incons_args, "-table_names and -long"); if nm_flag & lg_flag then call error (linus_error_$incons_args, "-names and -long"); end; /* checking user specified args */ if tb_flag & ^lg_flag then nm_flag = "1"b; if tb_flag then tn_flag = "0"b; if mr_ptr = null then /* do we need to supply tab. names */ if perm_flag | temp_flag then do; /* yes */ if perm_flag then do; /* need db. table names */ if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_rslt_rels (lcb.db_index, lcb.linus_area_ptr, pmr_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if icode ^= 0 then call error (icode, ""); end; /* getting db. tab names */ if temp_flag then /* need temp tab names */ if lcb.ttn_ptr ^= null then do; /* if temps defined */ ttn_ptr = lcb.ttn_ptr; num_relations_alloc = mrds_data_$max_temp_rels; allocate model_relations in (work_area) set (tmr_ptr); tmr_ptr -> model_relations.nrels = 0; do i = 1 to mrds_data_$max_temp_rels; /* look for defined tables */ if temp_tab_names (i) ^= "" then do; /* copy those found */ tmr_ptr -> model_relations.nrels = tmr_ptr -> model_relations.nrels + 1; tmr_ptr -> model_relations . relation_name (tmr_ptr -> model_relations.nrels) = temp_tab_names (i); end; end; /* copy loop */ if tmr_ptr -> model_relations.nrels = 0 then tmr_ptr = null;/* since lcb.ttn_ptr not nulled on close */ end; /* if temps defined */ if pmr_ptr ^= null then /* consolidate the lists */ if tmr_ptr ^= null then do; num_relations_alloc = pmr_ptr -> model_relations.nrels + tmr_ptr -> model_relations.nrels; allocate model_relations in (work_area); do i = 1 to pmr_ptr -> model_relations.nrels; model_relations.relation_name (i) = pmr_ptr -> model_relations.relation_name (i); end; do i = 1 to tmr_ptr -> model_relations.nrels; model_relations . relation_name (pmr_ptr -> model_relations.nrels + i) = tmr_ptr -> model_relations.relation_name (i); end; end; else do; mr_ptr = pmr_ptr; pmr_ptr = null; end; else if tmr_ptr ^= null then do; mr_ptr = tmr_ptr; tmr_ptr = null; end; end; /* specifying tables */ if pn_flag then do; /* get pathname and mode */ if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_pn (lcb.db_index, db_path, open_mode, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if icode ^= 0 then call error (icode, ""); call ioa_ ("^/^a^/^a", db_path, open_mode); end; /* pathname and mode */ if mr_ptr = null then do; if temp_flag then call ioa_ ("^/No temp tables defined."); end; else do; /* if need table info */ if tn_flag then /* write table names header */ call ioa_ ("^/TABLE^/"); if nm_flag then /* write names only header */ call ioa_ ("^/^10aCOLUMN^/", "TABLE"); else if lg_flag then /* write long header */ call ioa_ ("^/^10a^10a^23a^[^20a^;^s^20x^]TYPE^/", "TABLE", "COLUMN", "DECLARATION", (^lcb.secured_db | lcb.administrator), "DOMAIN"); do i = 1 to model_relations.nrels; /* major table list loop */ j = mrds_data_$max_temp_rels + 1; if lcb.ttn_ptr ^= null then do; /* if temps defined */ ttn_ptr = lcb.ttn_ptr; do j = 1 to mrds_data_$max_temp_rels while (temp_tab_names (j) ^= model_relations.relation_name (i)); end; /* see if temp. tab. */ end; if j <= mrds_data_$max_temp_rels then do; /* if temp tab */ if tn_flag then /* wants name only */ call ioa_ ("^a", model_relations.relation_name (i)); else do; /* needs column info too */ if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_temp_info (lcb.db_index, (j), lcb.linus_area_ptr, rslt_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if icode ^= 0 then call ioa_ ("^33aUnable to obtain additional information.", model_relations.relation_name (i)); else do; /* got column info */ call ioa_ ("^a (temp)", before (model_relations.relation_name (i), " ")); /* write out rel. name */ if nm_flag then /* wants names only */ do k = 1 to rslt_info.num_attr; call ioa_ ("^10x^a", rslt_info.attr.attr_name (k)); /* write out all attr names */ end; /* names only */ else call write_attr_lines; /* wants long info */ end; /* if obtained attr info */ end; /* if needs column info */ end; /* if temp table */ else do; /* is database relation */ if tn_flag then /* if just name */ call ioa_ ("^a", model_relations.relation_name (i)); else do; /* wants attr info */ if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_rslt_info (lcb.db_index, model_relations.relation_name (i), lcb.linus_area_ptr, rslt_ptr, icode); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if icode ^= 0 then /* couldnt get info */ if icode = mrds_error_$invalid_db_index then call error (icode, ""); else call ioa_ ("^33aUnknown table name given.", model_relations.relation_name (i)); else do; /* got the relation info */ call ioa_ ("^a (perm)", before (model_relations.relation_name (i), " ")); if nm_flag then /* wants names only */ do k = 1 to rslt_info.num_attr; /* write out attr names */ call ioa_ ("^10x^a", rslt_info.attr.attr_name (k)); end; /* attr names */ else call write_attr_lines; end; /* writtind attr info */ end; /* if got relation info */ end; /* if db. relation */ end; /* major table list loop */ end; /* if had relations specified */ call ioa_ (" "); /* finish off with null line */ code = 0; if ca_ptr ^= null then free char_argl; return; write_attr_lines: proc; /* write out long info for all attributes */ do k = 1 to rslt_info.num_attr; if lcb.timing_mode then initial_mrds_vclock = vclock; desc = mdbm_util_$display_descriptor (addr (rslt_info.attr (k).descriptor)) ; desc = mdbm_util_$trim_descriptor (desc); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if rslt_info.attr.key_flag (k) then type = "key"; else type = "data"; if rslt_info.attr.inver_flag (k) then type = type || " index"; call ioa_ ("^10x^33a^[^a^;^s^]^/^20x^43a^a", rslt_info.attr.attr_name (k), (^lcb.secured_db | lcb.administrator), rslt_info.attr.domain_name (k), desc, type); end; end write_attr_lines; error: proc (cd, msg); /* error procedure to write message and clean up */ dcl (cd, ucd) fixed bin (35); dcl msg char (*); if ca_ptr ^= null then free char_argl; call linus_convert_code (cd, ucd, linus_data_$ldb_id); code = 0; call ssu_$abort_line (sci_ptr, ucd, msg); end error; end linus_list_db;  linus_list_scope.pl1 07/29/86 1045.3rew 07/29/86 0937.1 90405 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This is the main level procedure called by ssu_ to implement the linus list_scope request. It lists the current scope settings for permanent tables. Usage: "list_scope {-control_arg}", where -control_arg is -table (-tb) TABLE_NAME_1 ... TABLE_NAME_N. If this isn't supplied, all scope settings are displayed. */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-01-13,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Written by Al Dupuis in December 1984, as part of the rewrite of all linus scope modules. 2) change(86-01-13,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed to also work as an active request. END HISTORY COMMENTS */ /* format: off */ %page; linus_list_scope: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(1); call initialize; on cleanup call terminate; call process_args; if no_scope_is_defined then if active_request_flag then return_value = "false"; else call ssu_$print_message (sci_ptr, linus_error_$no_scope); else call list_scope; call terminate; %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); if active_request_flag then return_value = ""; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); work_area_ptr = lcb.general_work_area_ptr; scope_ptr = null; scope_array_ptr = null; %skip(1); return; %skip(1); end initialize; %page; list_scope: proc; %skip(1); dcl ls_buffer char (64); dcl ls_buffer_as_an_array (64) char (1) based (ls_buffer_as_an_array_ptr); dcl ls_buffer_as_an_array_ptr ptr; dcl ls_index fixed bin; dcl ls_loop fixed bin; dcl ls_permits char (10) defined (ls_buffer_as_an_array) position (36); dcl ls_prevents char (4) defined (ls_buffer_as_an_array) position (46); dcl ls_table_name char (35) defined (ls_buffer); dcl ls_temporary_table_message char (29) defined (ls_buffer_as_an_array) position (36); %skip(1); if ^active_request_flag then do; ls_buffer_as_an_array_ptr = addr (ls_buffer); ls_buffer = ""; call ioa_ ("^/Table^28xPermitted^xPrevented^/"); end; %skip(1); if all_scope_has_been_requested then do ls_loop = 1 to scope_info.nfiles; if scope_info.scope.flags.touched (ls_loop) then call emit_value (ls_loop); end; else do ls_loop = 1 to scope_array.number_of_relations; ls_index = scope_array.relations.indexes (ls_loop); if ^active_request_flag then ls_buffer = ""; if ^scope_array.relations.temporary_table_name (ls_loop) then call emit_value (ls_index); else do; if active_request_flag then return_value = return_value || "temporary_table_with_no_scope" || " r " || "rsdm "; else do; ls_table_name = temporary_table_names (ls_index); ls_temporary_table_message = "Temporary table with no scope"; call ioa_ ("^a", ls_buffer); end; end; end; %skip(1); return; %page; emit_value: proc ( ev_index_parm /* input: index of relation we're working on */ ); dcl ev_index_parm fixed bin parm; %skip(1); if active_request_flag then return_value = return_value || rtrim (scope_info.scope.sm_name (ev_index_parm)) || " " || get_permits (addr (scope_info.scope.flags.permits (ev_index_parm))) || " " || get_permits (addr (scope_info.scope.flags.prevents (ev_index_parm))) || " "; else do; ls_table_name = scope_info.scope.sm_name (ev_index_parm); ls_permits = get_permits (addr (scope_info.scope.flags.permits (ev_index_parm))); ls_prevents = get_permits (addr (scope_info.scope.flags.prevents (ev_index_parm))); call ioa_ ("^a", ls_buffer); end; %skip(1); return; %skip(3); get_permits: proc (gp_permissions_ptr_parm) returns (char (4) varying); %skip(1); dcl gp_permits char (4) varying; dcl gp_permissions bit (4) unaligned based (gp_permissions_ptr_parm); dcl gp_permissions_ptr_parm ptr parm; %skip(1); gp_permits = ""; if substr (gp_permissions, 1, 1) then gp_permits = "r"; if substr (gp_permissions, 3, 1) then gp_permits = gp_permits || "d"; if substr (gp_permissions, 4, 1) then gp_permits = gp_permits || "m"; if substr (gp_permissions, 2, 1) then gp_permits = gp_permits || "s"; if gp_permits = "" then gp_permits = "n"; %skip(1); return (gp_permits); %skip(1); end get_permits; %skip(1); end emit_value; %skip(1); end list_scope; %page; process_args: proc; %skip(1); dcl pa_code fixed bin (35); dcl pa_current_arg_number fixed bin; dcl pa_loop fixed bin; dcl pa_not_found bit (1) aligned; dcl pa_scope_index fixed bin; %skip(1); if number_of_args_supplied = 1 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, USAGE_MESSAGE); all_scope_has_been_requested = (number_of_args_supplied = 0); call dsl_$get_scope_info (lcb.db_index, work_area_ptr, scope_ptr, pa_code); if pa_code ^= 0 then call ssu_$abort_line (sci_ptr, pa_code); no_scope_is_defined = (scope_info.active_scopes = 0); if no_scope_is_defined | all_scope_has_been_requested then return; %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); if arg ^= "-table" & arg ^= "-tb" then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/Expecting the ""-table"" or ""-tb"" control argument, not ^a." || USAGE_MESSAGE, arg); %skip(1); temporary_table_names_ptr = lcb.ttn_ptr; scope_array_init_number_of_relations = number_of_args_supplied - 1; allocate scope_array in (work_area) set (scope_array_ptr); unspec (scope_array.relations) = OFF; pa_scope_index = 1; %skip(1); do pa_current_arg_number = 2 to number_of_args_supplied; call ssu_$arg_ptr (sci_ptr, pa_current_arg_number, arg_ptr, arg_length); if arg = " " then call ssu_$abort_line (sci_ptr, linus_error_$inv_table, "^/A table name of only blanks is invalid."); pa_not_found = ON; do pa_loop = 1 to scope_info.nfiles while (pa_not_found); if scope_info.sm_name (pa_loop) = arg then do; pa_not_found = OFF; scope_array.relations.indexes (pa_scope_index) = pa_loop; end; else; end; if pa_not_found & temporary_table_names_ptr ^= null then do pa_loop = 1 to mrds_data_$max_temp_rels while (pa_not_found); if temporary_table_names (pa_loop) = arg then do; pa_not_found = OFF; scope_array.relations.temporary_table_name (pa_scope_index) = ON; scope_array.relations.indexes (pa_scope_index) = pa_loop; end; else; end; if pa_not_found then call ssu_$abort_line (sci_ptr, linus_error_$undef_tab, "^x^a", arg); pa_scope_index = pa_scope_index + 1; end; %skip(1); return; %skip(1); end process_args; %page; terminate: proc; %skip(1); if scope_ptr ^= null then free scope_info; if scope_array_ptr ^= null then free scope_array; %skip(1); return; %skip(1); end terminate; %page; %skip(1); dcl OFF bit (1) aligned internal static options (constant) init ("0"b); dcl ON bit (1) aligned internal static options (constant) init ("1"b); dcl USAGE_MESSAGE char (49) internal static options (constant) init ( "^/Usage: list_scope {-table TABLE_1 ... TABLE_N}"); %skip(1); dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl all_scope_has_been_requested bit (1) aligned; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl cleanup condition; %skip(1); dcl dsl_$get_scope_info entry (fixed bin (35), ptr, ptr, fixed bin (35)); %skip(1); dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl ioa_ entry() options(variable); %skip(1); dcl linus_error_$inv_table fixed bin(35) ext static; dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_error_$no_scope fixed bin(35) ext static; dcl linus_error_$undef_tab fixed bin(35) ext static; %skip(1); dcl mrds_data_$max_temp_rels fixed bin (35) external; %skip(1); dcl no_scope_is_defined bit (1) aligned; dcl null builtin; dcl number_of_args_supplied fixed bin; %skip(1); dcl rel builtin; dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl 1 scope_array aligned based (scope_array_ptr), 2 number_of_relations fixed bin, 2 relations (scope_array_init_number_of_relations refer ( scope_array.number_of_relations)), 3 temporary_table_name bit (1), 3 indexes fixed bin; dcl scope_array_init_number_of_relations fixed bin; dcl scope_array_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$print_message entry() options(variable); dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl temporary_table_names (mrds_data_$max_temp_rels) char (32) based (temporary_table_names_ptr); dcl temporary_table_names_ptr ptr; %skip(1); dcl unspec builtin; %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include linus_lcb; %page; %include mdbm_scope_info; %skip(3); end linus_list_scope;  linus_list_values.pl1 10/24/88 1647.7r w 10/24/88 1400.4 63927 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-06,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed to also work as an active request. Rewritten to make the program easier to understand. END HISTORY COMMENTS */ /* format: off */ %skip(1); /* DESCRIPTION: This is the main level procedure called by ssu_ to implement the linus list_values request. It prints or returns the values of linus variables that are named as arguments. If no arguments are given (for request usage) all variable values are printed. */ %page; linus_list_values: proc ( sci_ptr_parm, /* input: ptr to the ssu_ info structure */ lcb_ptr_parm /* input: points to the linus control block */ ); %skip(1); dcl lcb_ptr_parm ptr parm; dcl sci_ptr_parm ptr parm; %skip(1); call initialize; %skip(1); if number_of_args_supplied = 0 then do loop = 1 to variables.nvars; call print_value (loop); end; else do loop = 1 to number_of_args_supplied; call print_value (lookup_argument_number (loop)); end; %skip(1); return; %page; initialize: proc; %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; lv_ptr = lcb.lv_ptr; %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); if active_request_flag then return_value = ""; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); if lv_ptr = null then call ssu_$abort_line (sci_ptr, linus_error_$no_linus_var); %skip(1); if active_request_flag then if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, ACTIVE_REQUEST_USAGE_MESSAGE); else if number_of_args_supplied > 1 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, ACTIVE_REQUEST_USAGE_MESSAGE); else; else; %skip(1); return; %skip(1); end initialize; %page; lookup_argument_number: proc ( lan_argument_number_parm) /* input: number of current argument */ returns (fixed bin); /* output: position in variables.var_info array of argument */ %skip(1); dcl lan_argument_number_parm fixed bin parm; dcl lan_loop fixed bin; %skip(1); call ssu_$arg_ptr (sci_ptr, lan_argument_number_parm, arg_ptr, arg_length); if arg_length ^> 1 then call ssu_$abort_line (sci_ptr, linus_error_$linus_var_not_defined); else if substr (arg, 1, 1) ^= "!" then call ssu_$abort_line (sci_ptr, linus_error_$inv_linus_var, "^a", arg); %skip(1); do lan_loop = 1 to variables.nvars; if substr (arg, 2) = variables.var_info.name (lan_loop) then return (lan_loop); end; %skip(1); call ssu_$abort_line (sci_ptr, linus_error_$linus_var_not_defined, "^x^a", arg); %skip(1); end lookup_argument_number; %page; print_value: proc ( pv_variable_index_parm /* input: index of variable in variables.var_info array */ ); %skip(1); dcl pv_based_char_string char (4096) based (pv_based_char_string_ptr); dcl pv_based_char_string_ptr ptr; dcl pv_bit_dtype bit (1) aligned; dcl pv_bit_string bit (pv_bit_string_length) based (pv_bit_string_ptr); dcl pv_bit_string_length fixed bin; dcl pv_bit_string_ptr ptr; dcl pv_char_dtype bit (1) aligned; dcl pv_char_string char (4096) varying; dcl pv_char_string_redefined_smaller char (150) varying based (addr (pv_char_string)); dcl pv_code fixed bin (35); dcl pv_length_doesnt_matter fixed bin (21); dcl pv_numeric_dtype bit (1) aligned; dcl pv_variable_index_parm fixed bin parm; %skip(1); arg_descriptor_ptr = addr (variables.var_info.desc (pv_variable_index_parm)); %skip(1); pv_bit_dtype = (arg_descriptor.type = bit_dtype | arg_descriptor.type = varying_bit_dtype); pv_char_dtype = (arg_descriptor.type = char_dtype | arg_descriptor.type = varying_char_dtype); pv_numeric_dtype = ^(pv_bit_dtype | pv_char_dtype); %skip(1); if pv_char_dtype then do; if arg_descriptor.type = char_dtype then pv_based_char_string_ptr = variables.var_info.var_ptr (pv_variable_index_parm); else pv_based_char_string_ptr = addrel (variables.var_info.var_ptr (pv_variable_index_parm), 1); pv_char_string = rtrim (substr (pv_based_char_string, 1, arg_descriptor.size)); end; else if pv_numeric_dtype then do; call linus_convert_num_to_str (variables.var_info.var_ptr (pv_variable_index_parm), arg_descriptor_ptr, pv_char_string_redefined_smaller, pv_code); if pv_code ^= 0 then call ssu_$abort_line (sci_ptr, pv_code); end; else do; if arg_descriptor.type = varying_bit_dtype then pv_bit_string_ptr = addrel (variables.var_info.var_ptr (pv_variable_index_parm), 1); else pv_bit_string_ptr = variables.var_info.var_ptr (pv_variable_index_parm); pv_bit_string_length = arg_descriptor.size; call ioa_$rsnnl ("^b", pv_char_string, pv_length_doesnt_matter, pv_bit_string); end; %skip(1); if active_request_flag then return_value = pv_char_string; else call ioa_ ("!^a^x=^x^a", variables.var_info.name (pv_variable_index_parm), pv_char_string); %skip(1); return; %skip(1); end print_value; %page; dcl ACTIVE_REQUEST_USAGE_MESSAGE char (34) internal static options (constant) init ("Usage: [list_values VARIABLE_NAME]"); %skip(1); dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl addrel builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl error_table_$noarg fixed bin(35) ext static; dcl error_table_$too_many_args fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl ioa_ entry() options(variable); dcl ioa_$rsnnl entry() options(variable); %skip(1); dcl linus_convert_num_to_str entry (ptr, ptr, char(150) var, fixed bin(35)); dcl linus_error_$inv_linus_var fixed bin(35) ext static; dcl linus_error_$linus_var_not_defined fixed bin(35) ext static; dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_error_$no_linus_var fixed bin(35) ext static; dcl loop fixed bin; %skip(1); dcl null builtin; dcl number_of_args_supplied fixed bin; %skip(1); dcl rel builtin; dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); %page; %include arg_descriptor; %page; %include linus_lcb; %page; %include linus_variables; %page; %include std_descriptor_types; %skip(1); end linus_list_values;  linus_modify.pl1 10/14/90 0931.4rew 10/14/90 0915.0 268398 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-06,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changes calls to assign_round_ from assign_ so that rounding is performed on input values from user. END HISTORY COMMENTS */ linus_modify: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: This request modifies selected data in the data base. Data to be modified must be contained within one table, and key columns cannot be modified. HISTORY: 77-05-01 J. C. C. Jagernauth: Initially written. 78-11-01 J. C. C. Jagernauth: Modified to improve expression parsing. This request now does all quote stripping and all expressions are required to be parenthesized. 80-02-05 Rickie E. Brinegar: Modified to permit null strings as arguments for character and varying bit string modifies. 80-02-06 Rickie E. Brinegar: Modified to initialize sel_info.se_vals so that .V. arguments would be passed to mrds. 80-03-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.linus_area_ptr instead of getting system free area. 80-08-15 Rickie E. Brinegar: Modified to fix some varying character string code to permit modifies of varying character strings. 81-02-02 Rickie E. Brinegar: The declaration for the internal static debug_switch was moved from db_on entry to the main entry. 81-02-20 Rickie E. Brinegar: Changed the calls to mdb_display_value_ to be calls to mdb_display_data_value$ptr. The latter allows more than 256 characters to be displayed. 81-06-25 Rickie E. Brinegar: Changed to not attempt to use linus_variables when the linus variable list pointer is null. This is in response to TR 10194. 81-07-10 Rickie E. Brinegar: Modified to not assign values to sel_info.mrds_items until after all expressions have been evaluated. This permits the use of multiple column specs in a expression, and avoids a Halloween effect. 81-07-13 Rickie E. Brinegar: Removed trapping of the conversion condition. This is done in the linus module. 81-07-14 Rickie E. Brinegar: Removed the useless cleanup handler and unreferenced variables. 81-09-28 Davids: Changed the check for "!" from a substr to an index in the not_expr proc. 81-11-16 Rickie E. Brinegar: changed the call to cu_$gen_call to a call to cu_$generate_call and added the timing of the calls to dsl_$modify and dsl_$retrieve. 82-02-10 Paul W. Benjamin: ssu_ conversion. This program ranks with the invoke request in the magnitude of the headaches that it caused in the conversion. It allows its input to contain parens. This convention caused the creation of the 'iteration mode'. Further, it expected a parenthesized list to be a single argument. With iteration on (not the default at this time) there is no problem, as the user had to quote the argument to get the parens in anyway, but with iteration off, the parenthesized list may well be several arguments. Some rather clumsy code was implemented herein to get around that particular problem. 82-06-23 Dave J. Schimke: cleaned up the code associated with the above mentioned conversion (from a parenthesized list to a single argument). This was done to clarify the code and remove standards violations. 82-07-02 Dave J. Schimke: Added simple_arg to fix a stringrange_error. 82-09-03 Dave Schimke: Added a call to dsl_$get_pn to get the opening mode and report an error if user tries to modify with a retrieval opening. Declared mode, db_path, dsl_$get_path, and linus_error_$update_not_valid. This is in response to phx 13742. 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the first retrieve to keep linus_table from getting lost when loading in the incremental mode. 83-01-11 Dave Schimke: Replaced calls to linus_ok_response with calls to linus_query. Deleted references to error_table_$long_record, out_code, nread, buff_len, and linus_data_$m_id. Declared input, linus_query, prompt, prompt_len, linus_query$yes_no, and length. This is an fix for the ssu conversion which broke input from the terminal during a linus macro and answers TRs 12445 & 13342 (linus 73). Also changed arg_len_bits.length to arg_len_bits.len. 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current select expression is available */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_variables; %page; %include linus_select_info; %page; %include mdbm_arg_list; %page; %include linus_arg_list; %page; %include linus_token_data; %page; %include linus_expression; dcl sci_ptr ptr; /* for ssu_ */ dcl 1 sel_info aligned based (sel_ptr) like select_info; dcl C_R char (1) int static options (constant) init (" "); dcl DATA_BASE fixed bin (3) int static options (constant) init (6); dcl EXPR fixed bin (2) int static options (constant) init (2); dcl debug_switch bit (1) int static init ("0"b); dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 len bit (24) unal; /* Length of argument to be passed in system standard arg list */ dcl combined_arg_idx (linus_data_$max_req_args) bit (1) based (combined_arg_idx_ptr); /* map of allocated combined_args */ dcl combined_arg char (mod_ch_argl.arg.arg_len (mod_ch_argl.nargs)) based; /* parenthesized list */ dcl input_arg char (char_argl.arg.arg_len (input_arg_num)) based (char_argl.arg.arg_ptr (input_arg_num)); /* template for arg in char_argl */ dcl input_buffer (linus_data_$buff_len) char (1) based (in_buf_ptr); /* Max length of input buffer */ dcl input char(linus_data_$buff_len) var; dcl prompt char(40) var; dcl prompt_len fixed bin; dcl mod_buf char (mb_len) based (mb_ptr); dcl mod_curr char (linus_data_$buff_len); dcl sel_expr char (sel_info.se_len) based (sel_info.se_ptr); dcl tmp_buf char (tb_len) based (tb_ptr); dcl tmp_char char (mod_ch_argl.arg.arg_len (i)) based (mod_ch_argl.arg.arg_ptr (i)); dcl (interactive, expr_found, bf_flag, yes_no_flag, found_end_paren, simple_arg) bit (1); dcl offset (10) bit (1) based; dcl (ano_curr_len, caller, desc, i, in_buf_index, input_arg_num, k, l, m, mb_len, source_type, tb_len, temp) fixed bin; dcl initial_mrds_vclock float bin (63); dcl db_path char (168) var; dcl mode char (20); dcl ANOTHER char (8) init ("-another"); dcl CURRENT char (8) init ("-current"); dcl NL char(1) int static options (constant) init (" "); dcl (code, icode, mod_lit_offset, source_len) fixed bin (35); dcl cleanup condition; dcl (addr, addrel, after, before, fixed, index, length, null, rel, rtrim, string, substr, unspec, vclock) builtin; dcl ( interactive_ptr init (null), in_buf_ptr init (null), mb_ptr init (null), tb_ptr init (null), mod_ch_ptr init (null), destination_ptr init (null), start_ptr init (null), mod_lit_ptr init (null), arg_l_ptr init (null), re_ptr init (null), sel_ptr init (null), renv_ptr init (null), e_ptr init (null), env_ptr init (null), combined_arg_idx_ptr init (null) ) ptr; dcl 1 arg_l like arg_list based (arg_l_ptr); dcl ( linus_data_$buff_len, linus_data_$max_req_args, linus_error_$bad_num_args, linus_error_$linus_var_not_defined, linus_error_$mod_not_valid, linus_error_$no_db, linus_error_$null_input, linus_error_$unbal_parens, linus_error_$update_not_allowed, mrds_error_$tuple_not_found, sys_info$max_seg_size ) fixed bin (35) ext; dcl 1 mod_ch_argl aligned based (mod_ch_ptr), /* like char_argl */ 2 nargs fixed bin, 2 arg (nargs_init refer (mod_ch_argl.nargs)), 3 arg_ptr ptr, 3 arg_len fixed bin; dcl work_area area (sys_info$max_seg_size) based (lcb.linus_area_ptr); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl cu_$generate_call entry (entry, ptr); dcl dsl_$get_pn entry (fixed bin (35), char (168) var, char (20), fixed bin (35)); dcl dsl_$modify entry options (variable); dcl dsl_$retrieve entry options (variable); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl ioa_$rsnnl entry() options(variable); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl linus_modify_build_expr_tab entry (ptr, ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_query entry (ptr, char(*) var, char(*) var); /* Linus subroutines */ dcl linus_query$yes_no entry (ptr,bit(1), char(*) var); dcl linus_table$async_retrieval entry (ptr, fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl mdb_display_data_value$ptr entry (ptr, ptr); dcl ( mdbm_util_$character_data_class, mdbm_util_$varying_data_class ) entry (ptr) returns (bit (1)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); mod_lit_ptr, sel_ptr, mod_ch_ptr, arg_l_ptr, ex_ptr, char_ptr, mb_ptr, in_buf_ptr, ca_ptr, al_ptr = null; mb_len, icode, code = 0; ano_curr_len = 8; in_buf_index = 1; yes_no_flag = "1"b; interactive, expr_found, bf_flag = "0"b; source_type = 42; caller = 1; nargs_init = linus_data_$max_req_args; allocate mod_ch_argl in (work_area); allocate token_data in (work_area); token_data.mvar, token_data.lvar = ""; mod_ch_argl.nargs = 0; if lcb.db_index = 0 then call error (linus_error_$no_db); call dsl_$get_pn (lcb.db_index, db_path, mode, code); if substr (mode, 1, 9) = "retrieval" | substr (mode, 11, 9) = "retrieval" then call error (linus_error_$update_not_allowed); if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ si_ptr = lcb.si_ptr; nsv_init = select_info.nsevals; nmi_init = select_info.n_mrds_items; nui_init = select_info.n_user_items; allocate sel_info in (work_area); destination_ptr = sel_ptr; sel_info.se_flags.val_mod = select_info.se_flags.val_mod; /* init sel_info */ sel_info.se_ptr = select_info.se_ptr; sel_info.se_len = select_info.se_len; sel_info.nsevals = select_info.nsevals; sel_info.n_mrds_items = select_info.n_mrds_items; sel_info.n_user_items = select_info.n_user_items; do i = 1 to sel_info.nsevals; sel_info.se_vals.arg_ptr (i) = select_info.se_vals.arg_ptr (i); sel_info.se_vals.desc_ptr (i) = select_info.se_vals.desc_ptr (i); end; do i = 1 to sel_info.n_mrds_items; sel_info.mrds_item.arg_ptr (i) = select_info.mrds_item.arg_ptr (i); sel_info.mrds_item.bit_len (i) = select_info.mrds_item.bit_len (i); sel_info.mrds_item.desc (i) = select_info.mrds_item.desc (i); sel_info.mrds_item.assn_type (i) = select_info.mrds_item.assn_type (i); sel_info.mrds_item.assn_len (i) = select_info.mrds_item.assn_len (i); end; do i = 1 to sel_info.n_user_items; sel_info.user_item.name (i) = select_info.user_item.name (i); sel_info.user_item.item_type (i) = select_info.user_item.item_type (i); sel_info.user_item.rslt_desc (i) = select_info.mrds_item.desc (i); sel_info.user_item.item_ptr (i) = select_info.user_item.item_ptr (i); end; lv_ptr = lcb.lv_ptr; /* Init linus_variables pointer */ if ^sel_info.se_flags.val_mod then call error (linus_error_$mod_not_valid); in_buf_ptr = null; call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then /* No arguments passed */ call interactive_modify; /* Data must be obtained interactively */ else do; allocate char_argl in (lcb.static_area); on cleanup begin; if ca_ptr ^= null then free char_argl; if combined_arg_idx_ptr ^= null then do i = 1 to linus_data_$max_req_args; if combined_arg_idx (i) then free mod_ch_argl.arg.arg_ptr (i) -> combined_arg; end; end; do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; /* The following do-group exists solely for the purpose of putting multiple args that comprise a parenthesized list into a new, single argument. It is only a problem when the user has iteration-mode off. If it is on, the user has to quote a parenthesized list in which case it is a single argument anyway. The programmer was suffering from a singular lack of creativity when this was done. Works, though. */ if ^lcb.iteration then do; mod_ch_argl.nargs = 0; do i = 1 to nargs_init; simple_arg = "0"b; input_arg_num = i; if (char_argl.arg.arg_len (i) = 0) then simple_arg = "1"b; else if (substr (input_arg, 1, 1) = "(") & (substr (input_arg, char_argl.arg.arg_len (i), 1) ^= ")") then do; /* beginning of parenthesized list */ found_end_paren = "0"b; do k = i to nargs_init while (^found_end_paren); input_arg_num = k; if substr (input_arg, char_argl.arg.arg_len (k), 1) = ")" then do; /* when ending paren found */ found_end_paren = "1"b; mod_ch_argl.nargs = mod_ch_argl.nargs + 1; mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = 0; do l = i to k; /* accumulate lengths */ mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) + char_argl.arg.arg_len (l) + 1; end; mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) - 1; if combined_arg_idx_ptr = null then do; allocate combined_arg_idx in (lcb.static_area); unspec (combined_arg_idx) = "0"b; end; allocate combined_arg set (mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs)) in (lcb.static_area); combined_arg_idx (mod_ch_argl.nargs) = "1"b; mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg = ""; do l = i to k; /* create new arg_list */ input_arg_num = l; if l = i then mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg = input_arg; else mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg = rtrim (mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg) || " " || input_arg; end; end; end; if found_end_paren = "0"b then call error (linus_error_$unbal_parens); else i = k; end; /* end parenthesized list */ else simple_arg = "1"b; if (simple_arg) then do; /* vanilla argument */ mod_ch_argl.nargs = mod_ch_argl.nargs + 1; mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = char_argl.arg.arg_len (i); mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) = char_argl.arg.arg_ptr (i); end; end; end; else mod_ch_argl = char_argl; /* iteration on */ i = mod_ch_argl.nargs; /* is last input arg "-bf" ? */ if tmp_char = "-brief" | tmp_char = "-bf" then do; bf_flag = "1"b; /* brief mode */ mod_ch_argl.nargs = mod_ch_argl.nargs - 1; /* Remove "-brief" or "-bf" from char argl */ end; if mod_ch_argl.nargs = 0 then call interactive_modify; else do; /* place input arguments in buffer to be used by this request only */ do i = 1 to mod_ch_argl.nargs; mb_len = mb_len + mod_ch_argl.arg_len (i) + 1; end; mb_len = mb_len + 1; /* for carriage return */ allocate mod_buf in (work_area); mod_buf = ""; tb_ptr = mb_ptr; do i = 1 to mod_ch_argl.nargs; tb_len = mod_ch_argl.arg_len (i); tmp_buf = tmp_char; mod_ch_argl.arg_ptr (i) = tb_ptr; do k = 1 to tb_len + 1; /* bump ptr into the output buffer */ tb_ptr = addr (tb_ptr -> offset (10)); end; end; tb_len = 1; tmp_buf = C_R; /* place carriage return at end of line */ call bf_modify; end; end; if ca_ptr ^= null then free char_argl; if combined_arg_idx_ptr ^= null then do i = 1 to linus_data_$max_req_args; if combined_arg_idx (i) then free mod_ch_argl.arg.arg_ptr (i) -> combined_arg; end; return; db_on: entry; /* Usage: linus_modify$db_on Turns on a switch which causes the value of the current selection expression to be displayed at the terminal. */ debug_switch = "1"b; return; %skip (10); db_off: entry; /* Usage: linus_modify$db_off Turns off the switch which causes the value of the current selection expression to be displayed at the terminal. */ debug_switch = "0"b; return; interactive_modify: proc; call ioa_ (""); interactive = "1"b; allocate input_buffer in (work_area); do l = 1 to sel_info.n_user_items; interactive_ptr = addr (input_buffer (in_buf_index)); call ioa_$rsnnl (" ^a? ", prompt, prompt_len, sel_info.user_item.name (l)); call linus_query (lcb_ptr, input, prompt); substr (string(input_buffer), in_buf_index, length (input)) = input; mod_ch_argl.nargs = mod_ch_argl.nargs + 1; /* Increment number of arguments */ mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = length (input); /* Set attribute length */ mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) = interactive_ptr; /* Set pointer of attribute value or expression */ i = mod_ch_argl.nargs; in_buf_index = in_buf_index + mod_ch_argl.arg.arg_len (i) + 1; /* Set up for next input */ substr (input_buffer (in_buf_index - 1), 1, 1) = " "; end; substr (input_buffer (in_buf_index - 1), 1, 1) = C_R; call bf_modify; end interactive_modify; verbose_modify: proc; do i = 1 to sel_info.n_user_items; call ioa_$nnl ("^/^a = ^a", sel_info.user_item.name (i), tmp_char); end; end verbose_modify; bf_modify: proc; /* modify data base */ dcl var_expr bit (1); if mod_ch_argl.nargs ^= sel_info.n_user_items /* must be one mod arg for every user item */ then call error (linus_error_$bad_num_args); call parse_expr; if ^bf_flag then do; call verbose_modify; call linus_query$yes_no (lcb_ptr, yes_no_flag, NL||" OK? "); end; if yes_no_flag then do; if ^expr_found then call const_mod; else do; /* expression found */ var_expr = "0"b; do l = 1 to sel_info.n_user_items; if sel_info.user_item.item_type (l) = EXPR then do; ex_ptr = sel_info.user_item.item_ptr (l); do i = 1 to expression.nelems; /* find number of database items */ if expression.elem.type (i) = DATA_BASE then var_expr = "1"b; end; if ^var_expr then /* expression has constant result */ call linus_eval_expr (lcb_ptr, sel_info.user_item.item_ptr (l), destination_ptr, caller, l, icode); end; end; if ^var_expr then /* expression has constant result */ call const_mod; else do; /* expression result varies with each tuple */ call set_up; call expr_set_up; do while (icode = 0); do l = 1 to sel_info.n_user_items; if sel_info.user_item.item_type (l) = EXPR then call linus_eval_expr (lcb_ptr, sel_info.user_item.item_ptr (l), destination_ptr, caller, l, icode); end; do l = 1 to sel_info.n_user_items; if sel_info.user_item.item_type (l) = EXPR then call assign_round_ (sel_info.mrds_item.arg_ptr (l), sel_info.mrds_item.assn_type (l), sel_info.mrds_item.assn_len (l), sel_info.user_item.rslt_assn_ptr (l), sel_info.user_item.rslt_assn_type (l), sel_info.user_item.rslt_assn_len (l)); else call not_expr; end; if icode = 0 then do; call bump_var_ptrs; /* increment (by 1) varying argument descriptor pointers */ if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$modify, al_ptr); /* modify current */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if icode = 0 then do; call reset_var_ptrs; /* decrement (by 1) varying argument descriptor pointers */ call linus_table$async_retrieval (lcb_ptr, code); if icode ^= 0 then call error (icode); if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, arg_l_ptr); /* retrieve another */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); end; end; end; if icode ^= mrds_error_$tuple_not_found then call error (icode); end; end; end; const_mod: proc; call set_up; do l = 1 to sel_info.n_user_items; if sel_info.user_item.item_type (l) = EXPR then call assign_round_ (sel_info.mrds_item.arg_ptr (l), sel_info.mrds_item.assn_type (l), sel_info.mrds_item.assn_len (l), sel_info.user_item.rslt_assn_ptr (l), sel_info.user_item.rslt_assn_type (l), sel_info.user_item.rslt_assn_len (l)); else call not_expr; end; call bump_var_ptrs; /* increment (by 1) varying argument descriptor pointers */ if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$modify, al_ptr); /* Call to MRDS modify */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); call reset_var_ptrs; /* decrement (by 1) varying argument descriptor pointers */ if icode ^= 0 then call error (icode); end const_mod; bump_var_ptrs: proc; /* increment (by 1) the varying argument descriptor pointers in arg_list */ dcl (i, k) fixed bin; desc = arg_list.arg_count / 2; /* number of descriptors */ do i = 1 to desc; k = desc + i; /* point to descriptor */ if mdbm_util_$varying_data_class (arg_list.arg_des_ptr (k)) then arg_list.arg_des_ptr (i) = addrel (arg_list.arg_des_ptr (i), +1); end; end bump_var_ptrs; reset_var_ptrs: proc; /* increment (by 1) the varying argument descriptor pointers in arg_list */ dcl (i, k) fixed bin; desc = arg_list.arg_count / 2; /* number of descriptors */ do i = 1 to desc; k = desc + i; /* point to descriptor */ if mdbm_util_$varying_data_class (arg_list.arg_des_ptr (k)) then arg_list.arg_des_ptr (i) = addrel (arg_list.arg_des_ptr (i), -1); end; end reset_var_ptrs; not_expr: proc; /* set items that are not expressions */ dcl tmp_char char (mod_ch_argl.arg.arg_len (l)) based (mod_ch_argl.arg.arg_ptr (l)); if sel_info.user_item.item_type (l) ^= EXPR then do; if tmp_char = "" & ^ mdbm_util_$character_data_class (addr (sel_info.mrds_item.desc (l))) & ^mdbm_util_$varying_data_class (addr (sel_info.mrds_item.desc (l))) then call error (linus_error_$null_input); /* check for null items */ if index (tmp_char, "!") = 1 then do; /* Process LINUS VARIABLES? */ if lv_ptr = null then call error (linus_error_$linus_var_not_defined); do m = 1 to variables.nvars while (variables.var_info.name (m) ^= substr (tmp_char, 2)); end; if m > variables.nvars then call error (linus_error_$linus_var_not_defined); else call assign_round_ (sel_info.mrds_item.arg_ptr (l), sel_info.mrds_item.assn_type (l), sel_info.mrds_item.assn_len (l), variables.var_info.var_ptr (m), variables.var_info.assn_type (m), variables.var_info.assn_len (m)); end; else do; if tmp_char ^= sel_info.user_item.name (l) then do; source_len = mod_ch_argl.arg.arg_len (l); /* Used in call to assign_round_ */ call assign_round_ (sel_info.mrds_item.arg_ptr (l), sel_info.mrds_item.assn_type (l), sel_info.mrds_item.assn_len (l), mod_ch_argl.arg.arg_ptr (l), source_type, source_len); end; end; end; end not_expr; set_up: proc; /* common for all types of modify */ n_chars_init = 2; /* Number for allocate */ allocate char_desc in (work_area); /* Character descriptor */ char_desc.arr.const (2) = char_desc.arr.const (1); desc = sel_info.n_mrds_items + sel_info.nsevals + 3; /* Offset for descriptors */ num_ptrs = desc * 2; /* Number of pointers to be passed in arg_list */ allocate arg_list in (work_area); /* System standard argument list */ allocate arg_l in (work_area); arg_list.arg_des_ptr (desc) = addr (icode); /* Pointer to icode */ arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc); /* Return code descriptor */ arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* Data base index */ arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc); /* Data base index descriptor */ arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */ arg_list.code = 4; arg_list.pad = 0; char_desc.arr.var (1), char_desc.arr.var (2) = addr (sel_info.se_len) -> arg_len_bits.len; arg_list.arg_des_ptr (2) = sel_info.se_ptr; arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (2)); if debug_switch then do; call ioa_ ("Selection expression:"); /* 81-02-20 Rickie E. Brinegar: Start changes ****************************** */ call mdb_display_data_value$ptr (select_info.se_ptr, addr (char_desc.arr (1))); /* 81-02-20 Rickie E. Brinegar: End changes ******************************** */ end; /* if debug_switch */ if sel_info.nsevals ^= 0 then do l = 1 to sel_info.nsevals; arg_list.arg_des_ptr (2 + l) = sel_info.se_vals.arg_ptr (l); arg_list.arg_des_ptr (2 + l + desc) = sel_info.se_vals.desc_ptr (l); end; i = 1; /* mrds items index */ do l = 3 + sel_info.nsevals to 2 + sel_info.n_mrds_items + sel_info.nsevals; /* use sel_info.data */ arg_list.arg_des_ptr (l) = sel_info.mrds_item.arg_ptr (i); arg_list.arg_des_ptr (l + desc) = addr (sel_info.mrds_item.desc (i)); i = i + 1; end; arg_l = arg_list; arg_l.arg_des_ptr (desc + 2) = addr (char_desc.arr (1)); end set_up; expr_set_up: proc; /* called if expression was found */ sel_expr = before (sel_expr, "-select") || "-select -dup" || substr (after (sel_expr, "-select"), 6); /* must modify duplicates */ call linus_table$async_retrieval (lcb_ptr, code); if icode ^= 0 then call error (icode); if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, arg_l_ptr); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); sel_expr = before (sel_expr, "-dup") || " " || after (sel_expr, "-dup"); /* remove "-dup" for modify "-current" */ if icode ^= 0 then call error (icode); char_desc.arr.var (1) = addr (ano_curr_len) -> arg_len_bits.len; arg_l.arg_des_ptr (2) = addr (ANOTHER); /* for another retrieve */ l = index (sel_expr, "-select"); i = index (sel_expr, "-where") - 1; if i <= 0 then i = sel_info.se_len; /* no where clause exists */ temp = i - l + 1; mod_curr = CURRENT || substr (sel_expr, l + 7, temp - 7); temp = temp + 1; char_desc.arr.var (2) = addr (temp) -> arg_len_bits.len; arg_list.arg_des_ptr (2) = addr (mod_curr); /* for current modify */ end expr_set_up; end bf_modify; parse_expr: proc; /* parse expression and build the modify expression table */ expr_found = "0"b; do i = 1 to mod_ch_argl.nargs; if index (tmp_char, "(") = 1 then do; /* process expression */ expr_found = "1"b; call linus_modify_build_expr_tab (lcb_ptr, mod_ch_argl.arg.arg_ptr (i), mod_ch_argl.arg.arg_len (i), i, td_ptr, mod_lit_ptr, mod_lit_offset, sel_ptr, icode); if icode ^= 0 then call error (icode); sel_info.user_item.item_type (i) = EXPR; end; end; end parse_expr; error: proc (err_code); dcl err_code fixed bin (35); if ca_ptr ^= null then free char_argl; if combined_arg_idx_ptr ^= null then do i = 1 to linus_data_$max_req_args; if combined_arg_idx (i) then free mod_ch_argl.arg.arg_ptr (i) -> combined_arg; end; call ssu_$abort_line (sci_ptr, err_code); end error; end linus_modify;  linus_modify_build_expr_tab.pl1 10/14/90 0931.4rew 10/14/90 0915.0 218151 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changes calls to assign_round_ from assign_ so that data is rounded. END HISTORY COMMENTS */ linus_modify_build_expr_tab: proc (lcb_ptr, start_ptr, string_len, si_index, td_ptr, mod_lit_ptr, mod_lit_offset, si_ptr, code); /* DESCRIPTION: This procedure is an Operator Precedence parser that is used by the select clause translator and the modify request processor. HISTORY: 77-08-01 J. C. C. Jagernauth: Initially written. 80-01-11 Rickie E. Brinegar: Modified to use the entry mdbm_util_$complex_data_class. 80-03-12 Rickie E. Brinegar: Modified to use temporary segment pointed to by lcb.linus_area_ptr instead of getting system free area. 81-07-02 Rickie E. Brinegar: Removed the useless cleanup handler, added a go to exit statement in the error procedure and a return statement after the exit label. This is to correct TR9290. 81-07-13 Rickie E. Brinegar: Removed trappping of the conversion condition. This is now relegated to the higher modules. */ %include linus_lcb; %page; %include linus_select_info; %page; %include linus_expression; %page; %include linus_token_data; %page; %include linus_variables; dcl expr_type (9) fixed bin (4) unal int static options (constant) init ( /* Map token key to type or op_code */ 0, 6, /* Data base item */ 2, /* linus variable */ 1, /* constant */ 0, 3, /* multiply */ 4, /* divide */ 1, /* add */ 2); /* subtract */ dcl CMPX_FD bit (36) aligned; dcl CHAR_DESC bit (36) aligned; dcl REAL_FD bit (36) aligned; dcl FD59 bit (36) aligned int static options (constant) init ("100101000000000000000000000000111011"b); /* Float decimal */ dcl CFD59 bit (36) aligned int static options (constant) init ("100110000000000000000000000000111011"b); /* Complex float decimal */ dcl OPERATOR init (15) fixed bin (4) int static options (constant); dcl prec_relations (0:9, 0:9) fixed bin (4) int static options (constant) init ( /* 1 = reduce_op [( .> ) E op_code E ] 2 = reduce_paren [( .= ) (E)] 3 = shift_token [( <. )] 4 = end of expression [variable followed by variable] 5 = shift only if this is the first item 5 = reduce_var [reduce to E] 8 = error [LP followed by invalid token] 9 = make sure the first token shifted is not an operator or RP 10 = make sure you are not reducing E + "" 11 = end of expression the generic term "variable" is used to represent one of the following: column specification linus variable constant set function result scalar function result ROW and COLUMN names correspond in the table below */ 11, 8, (3) 6, 3, (4) 9, /* NULL 11 8 6 6 6 3 9 9 9 9 */ (10) 2, /* RP 2 2 2 2 2 2 2 2 2 2 */ (3) ((2) 5, (4) 4, (4) 5), /* COL_SPEC 5 5 4 4 4 4 5 5 5 5 */ /* LINUS_VAR 5 5 4 4 4 4 5 5 5 5 */ /* CONST 5 5 4 4 4 4 5 5 5 5 */ 8, 9, (4) 3, (4) 9,/* LP 8 9 3 3 3 3 9 9 9 9 */ (2) (10, 1, (4) 3, (4) 1), /* STAR 10 1 3 3 3 3 1 1 1 1 */ /* DIV 10 1 3 3 3 3 1 1 1 1 */ (2) (10, 1, (6) 3, (2) 1)); /* PLUS 10 1 3 3 3 3 3 3 1 1 */ /* MINUS 10 1 3 3 3 3 3 3 1 1 */ dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 length bit (24) unal; /* arg_len for system standard argument list */ dcl 1 stack aligned based (sk_ptr), 2 nargs fixed bin, 2 token_data (linus_data_$stk_depth refer (stack.nargs)), 3 key fixed bin (17) unal, 3 must_free bit (1) unal, 3 reduced bit (1) unal, /* On if item has been reduced */ 3 reserved bit (16) unal, 3 length fixed bin (35), 3 t_ptr ptr, 3 desc bit (36), 3 bit_length fixed bin (35), 3 assn_ptr ptr, 3 assn_type fixed bin, 3 assn_len fixed bin (35), 3 fn_ptr ptr, /* Pointer to function structure */ 3 type fixed bin (4) unal, 3 op_code fixed bin (3) unal; dcl token_item char (token_data.length) based (token_data.t_ptr); /* For shifting */ dcl (i, j, k, temp_token_key, temp_stack_key, target_type, si_index, source_type, string_len, tos_key) fixed bin; /* Points to first terminal on top of the work stack */ dcl (bit_len, code, cs_len, icode, mod_lit_offset, previous_pos, source_length, start_pos, target_length) fixed bin (35); dcl constant_string char (cs_len) based (cs_ptr); dcl (cmpx, test) bit (1); dcl (addr, bit, fixed, mod, null, rel, search, substr) builtin; dcl ( sk_ptr init (null), cs_ptr init (null), start_ptr, mod_lit_ptr, lit_ptr init (null) ) ptr; dcl expr_name (linus_data_$max_expr_items) char (32) init ((linus_data_$max_expr_items) (1)""); dcl var_string bit (linus_data_$lit_string_size) based (mod_lit_ptr); dcl ( linus_data_$stk_depth, linus_data_$lit_string_size, linus_data_$max_expr_items, sys_info$max_seg_size, linus_error_$op_follow_lp, linus_error_$too_many_expr_items, linus_error_$mrds_item_not_def, linus_error_$inv_expr ) fixed bin (35) ext; dcl linus_modify_gt entry (ptr, ptr, fixed bin, fixed bin (35), ptr, ptr, fixed bin (35)); dcl linus_assign_data entry (bit (36), fixed bin, fixed bin (35)); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl work_area area based (linus_area_ptr); dcl mdbm_util_$complex_data_class entry (ptr) returns (bit (1)); sk_ptr, ex_ptr, cs_ptr = null; start_pos = 1; /* starting position is always the first character */ CHAR_DESC = "101010100000000000000000000000000000"b; REAL_FD = "100101000000000000000000000000000000"b; CMPX_FD = "100110000000000000000000000000000000"b; nelems_init = linus_data_$stk_depth; /* For expression structure allocation */ icode, code, tos_key = 0; /* Top of stack item that is not reduced */ cmpx, test = "0"b; lv_ptr = lcb.lv_ptr; /* Init linus_variables */ allocate stack in (work_area); stack.nargs = 0; /* Work stack is empty */ allocate expression in (work_area); expression.nelems = 0; /* Expression stack is empty */ call get_token; do while (^test); /* MAIN LOOP */ if token_data.key > MINUS then temp_token_key = NULL; /* invalid token */ else temp_token_key = token_data.key; /* good token */ if tos_key = 0 then temp_stack_key = 0; else temp_stack_key = stack.token_data.key (tos_key); /* take key off stack */ if ^test then do; go to case (prec_relations (temp_stack_key, temp_token_key)); case (1): call reduce_op; /* E op E is on work stack */ go to end_case; case (2): call reduce_paren; /* (E) is on work stack */ go to end_case; case (3): call shift_token; /* place token on work stack */ call get_token; go to end_case; case (4): call reduce_var; /* end of expression -- variable followed by variable */ if tos_key > 1 then call reduce_op; /* After this call only E should be on work stack */ test = "1"b; /* Exit */ go to end_case; case (5): call reduce_var; /* place variable on expression stack */ go to end_case; case (6): if tos_key ^= stack.nargs then test = "1"b; else do; /* shift */ call shift_token; call get_token; end; go to end_case; case (8): call error (linus_error_$inv_expr);/* LP followed by invalid token */ go to end_case; case (9): if tos_key = stack.nargs then /* make sure the first token shifted is not an operator or RP */ call error (linus_error_$op_follow_lp); else do; call shift_token; /* then place token on work stack */ call get_token; end; go to end_case; case (10): if tos_key = stack.nargs then /* make sure you are not reducing E + "" */ call error (linus_error_$inv_expr); else call reduce_op; /* E op E is on work stack */ go to end_case; case (11): test = "1"b; /* end of expression */ end_case: end; end; /* END MAIN LOOP */ if token_data.key ^= NULL then start_pos = previous_pos; if ^(stack.nargs = 1 & stack.token_data.reduced (1)) | start_pos <= string_len then do; /* Make sure expression was good */ ex_ptr = null; call error (linus_error_$inv_expr); end; else do; if expression.nelems = 1 then expression.rslt_desc = expression.elem.desc (1); /* only one item in expression */ else if cmpx then expression.rslt_desc = CFD59; /* Init to complex float decimal 59 */ else expression.rslt_desc = FD59; /* Init to float decimal 59 */ select_info.user_item.item_ptr (si_index) = ex_ptr; /* pass pointer to expression structure */ select_info.user_item.rslt_desc (si_index) = expression.rslt_desc; /* pass expression info in select_info.user_item.rslt_structure */ call linus_assign_data ((select_info.user_item.rslt_desc (si_index)), select_info.user_item.rslt_assn_type (si_index), select_info.user_item.rslt_assn_len (si_index)); call alloc_lit (select_info.user_item.rslt_assn_type (si_index), select_info.user_item.rslt_assn_len (si_index), select_info.user_item.rslt_assn_ptr (si_index), select_info.user_item.rslt_bit_len (si_index)); end; sk_ptr = null; exit: return; get_token: proc; previous_pos = start_pos; call linus_modify_gt (lcb_ptr, start_ptr, string_len, start_pos, td_ptr, si_ptr, code); if icode ^= 0 then call error (icode); if token_data.key > CONST then token_data.key = token_data.key - 2; /* this allows proper access to the precedence table since set_fn and scal_fn were removed */ end get_token; shift_token: proc; /* Push token data onto work stack */ stack.nargs = stack.nargs + 1; /* push work stack */ tos_key = stack.nargs; /* set top of stack index */ stack.token_data.fn_ptr (stack.nargs) = null; stack.token_data.reduced (stack.nargs) = "0"b; if token_data.key > CONST then do; /* Item is an operator */ stack.token_data.type (stack.nargs) = OPERATOR; stack.token_data.op_code (stack.nargs) = expr_type (token_data.key); end; else do; /* item is not an operator */ stack.token_data.op_code (stack.nargs) = NULL; stack.token_data.type (stack.nargs) = expr_type (token_data.key); end; if token_data.key = LINUS_VAR then call shift_linus_var; else if token_data.key = CONST then call shift_const; else if token_data.key = COL_SPEC then call shift_col_spec; call shift_comm; end shift_token; reduce_op: proc; /* E op_code E is on top of the work stack */ call push_expression; tos_key = tos_key - 2; stack.nargs = stack.nargs - 2; /* point to E */ end reduce_op; reduce_paren: proc; /* (E) is on top of the work stack */ stack.token_data.reduced (tos_key), stack.token_data.reduced (tos_key - 2) = "1"b; /* pushed */ tos_key = tos_key - 3; stack.nargs = stack.nargs - 2; end reduce_paren; reduce_var: proc; /* a variable is on the work stack */ call push_expression; /* place variable on expression stack */ tos_key = tos_key - 1; end reduce_var; push_expression: proc; /* Data is removed from the work stack and pushed onto the expression stack */ stack.token_data.reduced (tos_key) = "1"b; /* Set flag to indicate that item was pushed */ expression.nelems = expression.nelems + 1; /* Point to new top of stack */ expression.elem.type (expression.nelems) = stack.token_data.type (tos_key); /* Push data */ expression.elem.op_code (expression.nelems) = stack.token_data.op_code (tos_key); if expression.elem.type (expression.nelems) ^= OPERATOR then do; expression.elem.desc (expression.nelems) = stack.token_data.desc (tos_key); expression.elem.bit_length (expression.nelems) = stack.token_data.bit_length (tos_key); expression.elem.assn_ptr (expression.nelems) = stack.token_data.assn_ptr (tos_key); expression.elem.assn_type (expression.nelems) = stack.token_data.assn_type (tos_key); expression.elem.assn_len (expression.nelems) = stack.token_data.assn_len (tos_key); expression.elem.fn_ptr (expression.nelems) = stack.token_data.fn_ptr (tos_key); end; if stack.token_data.must_free (tos_key) then stack.token_data.t_ptr (tos_key) = null; if mdbm_util_$complex_data_class (addr (expression.elem.desc (expression.nelems))) then cmpx = "1"b; end push_expression; shift_common: proc (desc, bit_length, assn_ptr, assn_type, assn_len); dcl desc bit (36) aligned; dcl (bit_length, assn_len) fixed bin (35); dcl assn_ptr ptr; dcl assn_type fixed bin; stack.token_data.desc (stack.nargs) = desc; stack.token_data.bit_length (stack.nargs) = bit_length; stack.token_data.assn_ptr (stack.nargs) = assn_ptr; stack.token_data.assn_type (stack.nargs) = assn_type; stack.token_data.assn_len (stack.nargs) = assn_len; call shift_comm; end shift_common; shift_comm: proc; stack.token_data.key (stack.nargs) = token_data.key; stack.token_data.must_free (stack.nargs) = token_data.must_free; stack.token_data.length (stack.nargs) = token_data.length; stack.token_data.t_ptr (stack.nargs) = token_data.t_ptr; end shift_comm; shift_linus_var: proc; i = token_data.length; call shift_common (variables.var_info.desc (i), variables.var_info.bit_len (i), variables.var_info.var_ptr (i), variables.var_info.assn_type (i), variables.var_info.assn_len (i)); end shift_linus_var; shift_const: proc; dcl 1 token_data_temp like token_data; dcl first_char char (1) based (token_data_temp.t_ptr); dcl offset (10) bit (1) based; dcl repl_factor char (repl_len) based (repl_ptr); dcl constant_desc bit (36); dcl one_repl_ch char (1) based (orc_ptr); dcl one_source_ch char (1) based (osc_ptr); dcl ( ci_ptr init (null), repl_ptr init (null), orc_ptr init (null), osc_ptr init (null), source_ptr init (null) ) ptr; dcl k fixed bin; dcl repl_flag bit (1); dcl (repl_fac, repl_len, ci_len) fixed bin (35); dcl RIGHT_PAREN char (1) int static options (constant) init (")"); dcl LEFT_PAREN char (1) int static options (constant) init ("("); dcl QUOTE char (1) int static options (constant) init (""""); dcl BIT_DESC bit (36) init ("101001100000000000000000000000000000"b); token_data_temp = token_data; repl_flag = "0"b; source_length = token_data.length; source_ptr = token_data.t_ptr; if (search (token_item, "i")) > 0 then constant_desc = CMPX_FD; else constant_desc = REAL_FD; addr (constant_desc) -> arg_len_bits.length = substr (bit (token_data.length), 12, 24); /* set length of float dec descriptor */ if first_char = LEFT_PAREN then do; repl_flag = "1"b; /* there is a replication factor */ repl_ptr, token_data.t_ptr = addr (token_data.t_ptr -> offset (10)); do j = 2 to token_data.length while (first_char ^= RIGHT_PAREN); token_data.t_ptr = addr (token_data.t_ptr -> offset (10)); end; repl_len = j - 2; token_data.length = token_data.length - j; token_data.t_ptr = addr (token_data.t_ptr -> offset (10)); token_data_temp = token_data; repl_fac = fixed (repl_factor); end; if first_char = QUOTE then do; ci_ptr, token_data_temp.t_ptr = addr (token_data_temp.t_ptr -> offset (10)); do j = 2 to token_data_temp.length while (first_char ^= QUOTE); token_data_temp.t_ptr = addr (token_data_temp.t_ptr -> offset (10)); end; ci_len = token_data_temp.length - 2; if j = token_data_temp.length then constant_desc = CHAR_DESC; else do; ci_len = token_data_temp.length - 1; constant_desc = BIT_DESC; end; addr (constant_desc) -> arg_len_bits.length = addr (ci_len) -> arg_len_bits.length; source_ptr = ci_ptr; source_length = ci_len; if repl_flag then do; source_length, cs_len = repl_fac * ci_len; addr (constant_desc) -> arg_len_bits.length = addr (cs_len) -> arg_len_bits.length; allocate constant_string in (work_area); source_ptr, orc_ptr = cs_ptr; do j = 1 to repl_fac; /* to number of replication factor */ osc_ptr = ci_ptr; do k = 1 to ci_len; /* one for each character in string */ one_repl_ch = one_source_ch; orc_ptr = addr (orc_ptr -> offset (10)); osc_ptr = addr (osc_ptr -> offset (10)); end; end; end; end; call linus_assign_data (constant_desc, target_type, target_length); /* returns type and length */ call alloc_lit (target_type, target_length, lit_ptr, bit_len); /* returns pointer to literal pool and bit length */ addr (CHAR_DESC) -> arg_len_bits.length = substr (bit (token_data.length), 12, 24); /* set length of char descriptor */ call linus_assign_data ((CHAR_DESC), source_type, source_length); /* returns type and length */ call assign_round_ (lit_ptr, target_type, target_length, source_ptr, source_type, source_length); call shift_common ((constant_desc), bit_len, lit_ptr, target_type, target_length); if cs_ptr ^= null then cs_ptr = null; end shift_const; shift_col_spec: proc; /* index is passed in token_data_length */ i = token_data.length; if i = 0 | i > select_info.n_mrds_items then call error (linus_error_$mrds_item_not_def); do k = 1 to linus_data_$max_expr_items while (expr_name (k) ^= "" & expr_name (k) ^= select_info.user_item.name (i)); end; if k > linus_data_$max_expr_items then call error (linus_error_$too_many_expr_items); else if expr_name (k) = "" then expr_name (k) = select_info.user_item.name (i); call shift_common (select_info.mrds_item.desc (i), select_info.mrds_item.bit_len (i), lcb.si_ptr -> select_info.mrds_item.arg_ptr (i), select_info.mrds_item.assn_type (i), select_info.mrds_item.assn_len (i)); end shift_col_spec; alloc_lit: proc (type, length, lit_ptr, bit_len); /* Procedure to allocate space for a literal in the literal string, given the assign_ type code and length. A pointer and bit length are returned. */ dcl type fixed bin; dcl lit_ptr ptr; dcl (length, bit_len, align_req, needed) fixed bin (35); dcl 1 alen aligned based (addr (length)), 2 q fixed bin (17) unal, 2 p fixed bin (17) unal; dcl align_array (45) fixed bin int static options (constant) init (0, 36, /* real fixed bin short aligned */ 0, /* real fixed bin short unaligned */ 72, /* real fixed bin long aligned */ 0, /* real fixed bin long unaligned */ 36, /* real float bin short aligned */ 0, /* real float bin short unaligned */ 72, /* real float bin long aligned */ 0, /* real float bin long unaligned */ 72, /* complex fixed bin short aligned */ 0, /* complex fixed bin short unaligned */ 72, /* complex fixed bin long aligned */ 0, /* complex fixed bin long unaligned */ 72, /* complex float bin short aligned */ 0, /* complex float bin short unaligned */ 72, /* complex float bin long aligned */ 0, /* complex float bin long unaligned */ 36, /* real fixed dec aligned */ 9, /* real fixed dec unaligned */ 36, /* real float dec aligned */ 9, /* real float dec unaligned */ 36, /* complex fixed dec aligned */ 9, /* complex fixed dec unaligned */ 36, /* complex float dec aligned */ 9, /* complex float dec unaligned */ (12) 0, 36, /* bit aligned */ 0, /* bit uanligned */ 36, /* var bit aligned */ 36, /* var bit unaligned */ 36, /* char aligned */ 9, /* char unaligned */ 36, /* var char aligned */ 36); /* var char unaligned */ dcl bl_factors (45, 3) fixed bin (11) int static options (constant) init ((3) 0, /* pad */ 0, 36, 0, /* real fixed bin short aligned */ 1, 1, 0, /* real fixed bin short unaligned */ 0, 72, 0, /* real fixed bin long aligned */ 1, 1, 0, /* real fixed bin long unal */ 0, 36, 0, /* real float bin short aligned */ 1, 9, 0, /* real float bin short unal */ 0, 72, 0, /* real float bin long aligned */ 1, 9, 0, /* real float bin long unal */ 0, 72, 0, /* complex fixed bin short aligned */ 2, 2, 0, /* complex fixed bin short unal */ 0, 144, 0, /* complex fixed bin long aligned */ 2, 2, 0, /* complex fixed bin long unal */ 0, 72, 0, /* complex float bin short aligned */ 2, 18, 0, /* complex float bin short unal */ 0, 144, 0, /* complex folat bin long aligned */ 2, 18, 0, /* complex float bin long unal */ 9, 9, 36, /* real fixed dec aligned */ 9, 9, 0, /* real fixed dec unal */ 9, 18, 36, /* real float dec aligned */ 9, 18, 0, /* real float dec unal */ 18, 18, 36, /* complex fixed dec aligned */ 18, 18, 0, /* complex fixed dec unal */ 18, 18, 36, /* complex float dec aligned */ 18, 36, 0, /* complex float dec unal */ (36) 0, /* illegal types */ 1, 0, 36, /* bit aligned */ 1, 0, 0, /* bit unal */ 1, 36, 36, /* var bit aligned */ 1, 36, 36, /* var bit unal */ 9, 0, 36, /* char aligned */ 9, 0, 0, /* char unal */ 9, 36, 36, /* char var aligned */ 9, 36, 36); /* char var unal */ dcl COMP_FLT_DEC fixed bin int static options (constant) init (25); dcl var_array (0:linus_data_$lit_string_size - 1) bit (1) unal based (mod_lit_ptr); if mod_lit_ptr = null then do; /* if literal pool not yet allocated */ allocate var_string in (work_area); var_string = "0"b; mod_lit_offset = 0; end; align_req = align_array (type); /* find type of alignment needed */ if align_req > 0 then do; /* if need to align */ needed = align_req - mod (mod_lit_offset, align_req); if needed < align_req then /* if need to adjust */ mod_lit_offset = mod_lit_offset + needed; end; /* aligning */ lit_ptr = addr (var_array (mod_lit_offset)); if type <= COMP_FLT_DEC then /* bit len for arith. type */ bit_len = bl_factors (type, 1) * alen.p + bl_factors (type, 2); else /* bit len for string type */ bit_len = bl_factors (type, 1) * length + bl_factors (type, 2); if bl_factors (type, 3) > 0 then do; /* if padding needed */ needed = bl_factors (type, 3) - mod (bit_len, bl_factors (type, 3)); if needed < bl_factors (type, 3) then /* if need to pad out */ bit_len = bit_len + needed; end; /* if padding */ if mod_lit_offset + bit_len - 1 > linus_data_$lit_string_size then lit_ptr = null; else mod_lit_offset = mod_lit_offset + bit_len; /* keep offset current */ return; end alloc_lit; error: proc (inter_code); dcl inter_code fixed bin (35); code = inter_code; go to exit; end error; end linus_modify_build_expr_tab;  linus_modify_gt.pl1 07/29/86 1045.3r w 07/29/86 0940.0 146232 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_modify_gt: proc (lcb_ptr, start_ptr, string_len, start_pos, td_ptr, si_ptr, code); /* DESCRIPTION: This procedure is the lexical analizer for the MODIFY request expr parser. A key, pointer and length are returned for a CONSTANT. A key and index into the linus variable structure are returned for a linus variable. A key and index into the select info structure are returned for a database item. HISTORY: 77-08-01 J. C. C. Jagernauth: Initially written. 80-03-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.linus_area_ptr instead of getting system free area. */ %include linus_lcb; %page; %include linus_select_info; %page; %include linus_token_data; %page; %include linus_variables; dcl start_ptr ptr; dcl ( code, /* Output: status code */ start_pos, /* Input/Output: position at which to start scan */ i, /* internal indexes */ j, cur_pos ) fixed bin (35); /* current position in string */ dcl string_len fixed bin; dcl found bit (1); dcl ARITH_CHARS char (14) int static options (constant) init (".eib0123456789"); dcl DELIMS char (3) int static options (constant) init (" "); dcl CONS_PREC char (5) int static options (constant) init ("(+-*/"); dcl ARITH_START char (11) int static options (constant) init (".0123456789"); dcl ID_CHARS char (64) int static options (constant) init ( "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-"); dcl tmp_char char (string_len) based (start_ptr); dcl tmp_char_arr (string_len) char (1) based (start_ptr); dcl ( linus_error_$invalid_token, linus_error_$long_id, linus_error_$linus_var_not_defined, linus_error_$long_lv_name, linus_error_$inv_string_const, mrds_data_$max_id_len, sys_info$max_seg_size ) fixed bin (35) ext; dcl (rel, fixed, addr, verify, index, substr, null, collate) builtin; token_data.must_free = "0"b; if start_pos > string_len then token_data.key = NULL; else do; /* if have something left */ i = verify (substr (tmp_char, start_pos), DELIMS); /* skip white spaces */ if i > 0 then do; cur_pos = start_pos + i - 1; go to char_proc (index (collate (), tmp_char_arr (cur_pos))); /* see what we have */ char_proc (1): /* special characters */ char_proc (2): char_proc (3): char_proc (4): char_proc (5): char_proc (6): char_proc (7): char_proc (8): char_proc (9): char_proc (10): char_proc (11): char_proc (12): char_proc (13): char_proc (14): char_proc (15): char_proc (16): char_proc (17): char_proc (18): char_proc (19): char_proc (20): char_proc (21): char_proc (22): char_proc (23): char_proc (24): char_proc (25): char_proc (26): char_proc (27): char_proc (28): char_proc (29): char_proc (30): char_proc (31): char_proc (32): char_proc (33): /* space */ char_proc (36): /* # */ char_proc (37): /* $ */ char_proc (38): /* % */ char_proc (39): /* & */ char_proc (40): /* ' */ char_proc (45): /* , */ char_proc (59): /* : */ char_proc (60): /* ; */ char_proc (61): /* < */ char_proc (62): /* = */ char_proc (63): /* > */ char_proc (64): /* ? */ char_proc (65): /* @ */ char_proc (92): /* [ */ char_proc (93): /* \ */ char_proc (94): /* ] */ char_proc (95): /* ^ */ char_proc (96): /* _ */ char_proc (97): /* ` */ char_proc (124): /* { */ char_proc (125): /* | */ char_proc (126): /* } */ char_proc (127): /* ~ */ char_proc (128): /* PAD */ call error (linus_error_$invalid_token); /* none of these chars. can start a token */ char_proc (34): /* ! */ token_data.key = LINUS_VAR; /* this is a linus variable */ cur_pos = cur_pos + 1; /* first char past ! */ i = verify (substr (tmp_char, cur_pos), ID_CHARS); /* find end of token */ token_data.length = i - 1; if lcb.lv_ptr = null then /* if no variables defined */ call error (linus_error_$linus_var_not_defined); lv_ptr = lcb.lv_ptr; if variables.nvars <= 0 then /* if no variables */ call error (linus_error_$linus_var_not_defined); do j = 1 to variables.nvars while (variables.var_info.name (j) ^= substr (tmp_char, cur_pos, token_data.length)); /* look for var. */ end; if j > variables.nvars then do; /* if didn't find it */ i = index (substr (tmp_char, cur_pos, token_data.length), "-"); /* look for imbedded hyphen */ if i <= 0 then call error (linus_error_$linus_var_not_defined); /* not there */ token_data.length = i - 1; /* found one, check first part */ do j = 1 to variables.nvars while (variables.var_info.name (j) ^= substr (tmp_char, cur_pos, token_data.length)); end; if j > variables.nvars then call error (linus_error_$linus_var_not_defined); end; /* if didn't find it first time */ if token_data.length > mrds_data_$max_id_len then /* if too long */ call error (linus_error_$long_lv_name); start_pos = cur_pos + token_data.length; /* adjust scan start pos. */ token_data.length = j; /* pass index to linus variable structure */ go to exit; /* end ! */ char_proc (35): /* " */ token_data.key = CONST; /* this is a string constant */ token_data.t_ptr = addr (tmp_char_arr (cur_pos)); found = "0"b; /* init for end search */ cur_pos = cur_pos + 1; token_data.length = 1; i = index (substr (tmp_char, cur_pos), """"); /* look for next " */ do while (i > 0 & ^found); /* search for single quote */ token_data.length = token_data.length + i; /* increment length */ cur_pos = cur_pos + i; /* first char beyond */ if cur_pos > string_len then found = "1"b; /* single quote at end of string */ else if tmp_char_arr (cur_pos) = """" then do; cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; if cur_pos <= string_len then i = index (substr (tmp_char, cur_pos), """"); else i = 0; end; /* if double " */ else found = "1"b; /* if single " */ end; /* single " search loop */ if ^found then call error (linus_error_$inv_string_const); if tmp_char_arr (cur_pos) = "b" then do; /* if bit string */ cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; end; start_pos = cur_pos; go to exit; /* end " */ char_proc (41): /* ( */ token_data.key = LP; /* assume LP unless proven other */ i = verify (substr (tmp_char, cur_pos + 1), "0123456789"); /* is possible string const */ if tmp_char_arr (cur_pos + i) = ")" & i > 1 then do; /* good chance of string const */ j = verify (substr (tmp_char, cur_pos + i + 1), DELIMS); /* skip white space */ if tmp_char_arr (cur_pos + i + j) = """" then do; /* have string const */ token_data.key = CONST; token_data.length = i + j + 1; /* init for quote search loop */ token_data.t_ptr = addr (tmp_char_arr (cur_pos)); cur_pos = cur_pos + i + j + 1; found = "0"b; i = index (substr (tmp_char, cur_pos), """"); /* find next quote */ do while (i > 0 & ^found); /* until we find a single quote */ token_data.length = token_data.length + i; /* incr. length */ cur_pos = cur_pos + i; /* first char beyond */ if cur_pos > string_len then call error (linus_error_$inv_string_const); if tmp_char_arr (cur_pos) = """" then do; /* if double quote */ cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; if cur_pos <= string_len then i = index (substr (tmp_char, cur_pos), """"); else i = 0; /* terminate if passed end of string */ end; /* if double quote */ else do; /* if single quote */ found = "1"b; cur_pos = cur_pos + i; token_data.length = token_data.length + i; end; /* if single quote */ end; /* single quote search loop */ if ^found then call error (linus_error_$inv_string_const); if tmp_char_arr (cur_pos) = "b" then do; /* if bit string */ cur_pos = cur_pos + 1; token_data.length = token_data.length + 1; end; start_pos = cur_pos; end; /* if string const */ end; /* if good chance */ if token_data.key = LP then call set_token (LP, 1); /* if wasn't const */ go to exit; /* end ( */ char_proc (42): /* ) */ call set_token (RP, 1); go to exit; char_proc (43): /* * */ call set_token (STAR, 1); go to exit; char_proc (44): /* + */ if is_const () = "1"b then call arith_const; /* is arith const = "1"b */ else call set_token (PLUS, 1);/* is operator */ go to exit; char_proc (46): /* - */ if is_const () = "1"b then call arith_const; else call set_token (MINUS, 1); go to exit; char_proc (47): /* . */ char_proc (49): /* 0 */ char_proc (50): /* 1 */ char_proc (51): /* 2 */ char_proc (52): /* 3 */ char_proc (53): /* 4 */ char_proc (54): /* 5 */ char_proc (55): /* 6 */ char_proc (56): /* 7 */ char_proc (57): /* 8 */ char_proc (58): /* 9 */ /* these characters begin an arith. const. */ call arith_const; go to exit; char_proc (48): /* / */ call set_token (DIV, 1); go to exit; char_proc (66): /* A */ char_proc (67): /* B */ char_proc (68): /* C */ char_proc (69): /* D */ char_proc (70): /* E */ char_proc (71): /* F */ char_proc (72): /* G */ char_proc (73): /* H */ char_proc (74): /* I */ char_proc (75): /* J */ char_proc (76): /* K */ char_proc (77): /* L */ char_proc (78): /* M */ char_proc (79): /* N */ char_proc (80): /* O */ char_proc (81): /* P */ char_proc (82): /* Q */ char_proc (83): /* R */ char_proc (84): /* S */ char_proc (85): /* T */ char_proc (86): /* U */ char_proc (87): /* V */ char_proc (88): /* W */ char_proc (89): /* X */ char_proc (90): /* Y */ char_proc (91): /* Z */ char_proc (98): /* a */ char_proc (99): /* b */ char_proc (100): /* c */ char_proc (101): /* d */ char_proc (102): /* e */ char_proc (103): /* f */ char_proc (104): /* g */ char_proc (105): /* h */ char_proc (106): /* i */ char_proc (107): /* j */ char_proc (108): /* k */ char_proc (109): /* l */ char_proc (110): /* m */ char_proc (111): /* n */ char_proc (112): /* o */ char_proc (113): /* p */ char_proc (114): /* q */ char_proc (115): /* r */ char_proc (116): /* s */ char_proc (117): /* t */ char_proc (118): /* u */ char_proc (119): /* v */ char_proc (120): /* w */ char_proc (121): /* x */ char_proc (122): /* y */ char_proc (123): /* z */ call ident_proc; /* determine identifier type, and set up token data */ go to exit; exit: end; /* token section */ else do; /* ran out of tokens */ token_data.key = NULL; start_pos = string_len + 1; end; end; /* if something to do */ code = 0; real_exit: return; set_token: proc (key, length); /* Procedure to set up token_data given a key value and token length */ dcl (key, length) fixed bin; token_data.key = key; token_data.length = length; token_data.t_ptr = addr (tmp_char_arr (cur_pos)); start_pos = cur_pos + length; end set_token; is_const: proc returns (bit (1)); /* Procedure to determine if token at cur_pos is an arithmetic constant or is n operator. */ dcl i fixed bin; dcl flag bit (1); if index (ARITH_START, tmp_char_arr (cur_pos + 1)) ^= 0 then do; /* possible const. */ do i = cur_pos - 1 to 1 by -1 while (index (DELIMS, tmp_char_arr (i)) ^= 0); end; /* search for end of prev token */ if i < 1 then flag = "1"b; /* first token, must be const */ else if index (CONS_PREC, tmp_char_arr (i)) ^= 0 then flag = "1"b; /* if predecessor forces constant */ else flag = "0"b; /* is operator */ end; /* possible constant */ else flag = "0"b; /* if no chance of constant */ return (flag); end is_const; arith_const: proc; /* Procedure to isolate an arithmetic constant, and set up the resultind token data */ dcl (i, j) fixed bin; token_data.key = CONST; token_data.t_ptr = addr (tmp_char_arr (cur_pos)); j = 0; /* init */ i = verify (substr (tmp_char, cur_pos + 1), ARITH_CHARS); if i <= 0 then i = string_len - cur_pos + 1; else do; /* see if found real end */ if tmp_char_arr (cur_pos + i) = "+" | tmp_char_arr (cur_pos + i) = "-" then /* check for exponent */ if tmp_char_arr (cur_pos + i - 1) ^= "e" then ; /* not exp */ else do; /* is exp, scan further */ j = verify (substr (tmp_char, cur_pos + i + 1), ARITH_CHARS); if j <= 0 then i = string_len - cur_pos + 1; else i = i + j; end; /* if exponent */ end; /* checking for real end */ token_data.length = i; start_pos = cur_pos + i; end arith_const; ident_proc: proc; /* Procedure to determine identifier type. */ dcl (i, j, k, tmp_len) fixed bin; dcl f_choice char (i) based (addr (tmp_char_arr (cur_pos))); dcl s_choice char (j) based (addr (tmp_char_arr (cur_pos))); j = 0; /* init */ i = verify (substr (tmp_char, cur_pos), ID_CHARS);/* find end of id. */ if i <= 0 then i = string_len - cur_pos + 1; else i = i - 1; /* i is length */ if i > mrds_data_$max_id_len then do; /* too long, may have hidden - */ j = index (substr (tmp_char, cur_pos, i), "-"); if j <= 0 then call error (linus_error_$long_id); /* is bad */ if j > mrds_data_$max_id_len then call error (linus_error_$long_id); /* if first part too long */ else do; /* first part ok */ i = j - 1; j = 0; end; end; /* if orig. id. too long */ else j = index (substr (tmp_char, cur_pos, i), "-"); /* see if there is second choice */ if j > 0 then do; /* yes, set true length */ j = j - 1; tmp_len = j + 1; /* remember -- you may have to back up start_pos */ call set_token (COL_SPEC, j); end; else do; call set_token (COL_SPEC, i); tmp_len = i + 1; /* remember -- you may have to back up start_pos */ end; do k = 1 to select_info.n_user_items while (select_info.user_item.name (k) ^= f_choice); end; if k > select_info.n_user_items then do; do k = 1 to select_info.n_user_items while (select_info.user_item.name (k) ^= s_choice); end; end; if k > select_info.n_user_items then do; start_pos = start_pos - tmp_len; if tmp_len = i + 1 /* length of first choice */ then do; token_data.key = NULL; start_pos = string_len + 1; end; end; token_data.length = k; /* return index to mrds item */ end ident_proc; error: proc (cd); /* Error procedure */ dcl cd fixed bin (35); code = cd; go to real_exit; end error; end linus_modify_gt;  linus_open.pl1 07/29/86 1045.3rew 07/29/86 0937.1 117054 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-10,Dupuis), approve(86-01-10,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Corrected the following problems: (1) No usage message when 0 args are supplied. (2) No usage message when 1 arg is supplied. (3) No usage message when more than 2 args are supplied, and an incorrect message is printed. (4) No usage message when an invalid opening mode is supplied. 2) change(86-01-10,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed to work as an active request and cleaned up minor problems. Returns true if database could be opened, false otherwise. END HISTORY COMMENTS */ linus_open: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: The data base is opened in the user specified mode via a call to dsl_$open. Multiple data base opens are not allowed. LINUS request: open data_path mode, o data_path mode data_path is the pathname of a MRDS data base or a data submodel associated with that data data base. mode is one of the following: retrieval, r update, u exclusive_retrieval, er exclusive_update, eu HISTORY: 77-03-01 J. C. C. Jagernauth: Initially written. 78-09-01 J. C. C. Jagernauth: Modified for MR7.0. 79-11-28 Rickie E. Brinegar: Modified to determine old or new data models from the data model headers through the rm_db_info structure. 79-12-18 Rickie E. Brinegar: Modified to set scope for exclusive opening modes, and to require an opening mode. 80-03-12 Rickie E. Brinegar: Modified to use the temporary segment defined on lcb.linus_area_ptr rather than getting system free area. 80-06-01 Jim Gray : Modified to capture a bad opening mode itself, instead of passing a phony mode to dsl_$open, and getting a error message that has little meaning to the linus user. 80-12-22 Jim Gray : changed r-u scope file modes to r-s-m-d usage now that mrds handles these modes for real. Also added use of mrds_opening_modes_.incl 80-12-31 Jim Gray : added init of touched bit in scope_data structure. 81-01-12 Jim Gray : changed handling of touched bit now that part of flags section of scope_data. 81-01-27 Jim Gray : removed reference to mdbm_data_$current_version, and replace with a constant instead. 81-05-12 Rickie E. Brinegar: Modified to not call mdbm_util_$get_rslt_info to get the version number but to use dsl_$get_db_version instead. mdbm_util_$get_rslt_info should not be available outside of MRDS for security reasons. 81-05-13 Rickie E. Brinegar: Added the code to set the secured_db and administrator bits in lcb structure. 81-06-19 Rickie E. Brinegar: Removed call to dsl_$get_rels. 81-11-16 Rickie E. Brinegar: added timing of dsl calls. 82-02-05 Paul W. Benjamin: ssu_ conversion 83-02-04 Al Dupuis: Changed call to com_err_ to ssu_$print_message. */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_ready_data; %page; %include linus_ready_table; %page; %include linus_scal_fn_info; %page; %include linus_set_fn_info; %page; %include mrds_model_relations; %page; %include mrds_opening_modes_; %page; %include mrds_security_info; dcl sci_ptr ptr; /* needed by ssu_ */ dcl ( db_version, i, j, open_mode, retrieval_mode init (2) ) fixed bin; dcl code fixed bin (35); dcl error_codes (2) fixed bin (35); dcl initial_mrds_vclock float bin (63); dcl cleanup condition; dcl cleanup_has_been_signalled bit (1) aligned; dcl ( data_model_ptr init (null), free_setfi_ptr init (null), last_setfi_ptr init (null) ) ptr; dcl mode char (char_argl.arg.arg_len (2)) based (char_argl.arg.arg_ptr (2)); /* Mode for linus open */ dcl open_mode_value (9) fixed bin int static options (constant) init ( /* Codes for valid open modes */ 1, 1, 2, 2, 3, 3, 4, 4, 5); /* 5 is the only invalid open mode */ dcl opened_mode char (20); /* need to call dsl_$get_pn */ dcl path_name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1)); /* Path_Name for linus open */ dcl ( db_path_name, /* the absolute path name of the db */ out_path_name ) char (168); /* a dummy argument to dsl_$get_db_version */ dcl valid_open_mode (8) char (19) int static options (constant) init ( /* Valid open modes */ "r", "retrieval", "u", "update", "er", "exclusive_retrieval", "eu", "exclusive_update"); dcl active_request_flag bit (1) aligned; dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; dcl (addr, fixed, hbound, null, rel, vclock) builtin; dcl ( linus_error_$cant_ref_fun, /* Linus error codes */ linus_error_$inv_mode, linus_error_$no_input_arg, linus_error_$too_few_args, linus_error_$too_many_dbs, mrds_error_$db_busy, mrds_error_$quiesced_db, sys_info$max_seg_size ) ext fixed bin (35); dcl error_table_$too_many_args fixed bin(35) ext static; dcl dsl_$close entry() options(variable); dcl dsl_$declare entry options (variable); dcl dsl_$get_db_version entry (char (168), char (168), fixed bin, fixed bin (35)); dcl dsl_$get_rslt_rels entry (fixed bin (35), ptr, ptr, fixed bin (35)); dcl dsl_$get_pn entry (fixed bin (35), char (168), char (20), fixed bin (35)); dcl dsl_$get_security_info entry (fixed bin (35), ptr, ptr, fixed bin (35)); dcl dsl_$open entry options (variable); /* MRDS Subroutine */ dcl linus_stifle_mrds_sub_error entry ((*) fixed bin(35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$print_message entry() options(variable); dcl sub_error_ condition; dcl USAGE char (36) internal static options (constant) init ( "^/Usage: open pathname opening_mode"); ca_ptr = null; mr_ptr = null; on cleanup begin; cleanup_has_been_signalled = "1"b; call clean_up; end; lcb.trans_id, rd_nfiles_init = 0; call ssu_$return_arg (sci_ptr, nargs_init, active_request_flag, return_value_ptr, return_value_length); if active_request_flag then return_value = "false"; if lcb.db_index ^= 0 then call ssu_$abort_line (sci_ptr, linus_error_$too_many_dbs); /* Only one data base can be open */ if nargs_init = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_input_arg, USAGE); /* Some argument must be passed */ if nargs_init < 2 then call ssu_$abort_line (sci_ptr, linus_error_$too_few_args, USAGE); if nargs_init > 2 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, USAGE); allocate char_argl in (lcb.static_area); do i = 1 to 2; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; do i = 1 to 8 while (mode ^= valid_open_mode (i));/* Find open mode */ end; if i > hbound (valid_open_mode, 1) then call ssu_$abort_line (sci_ptr, linus_error_$inv_mode, "Unrecognizable opening mode ^a.^a", mode, USAGE); open_mode = open_mode_value (i); /* Set open mode for MRDS call */ if active_request_flag then do; error_codes (1) = mrds_error_$db_busy; error_codes (2) = mrds_error_$quiesced_db; on sub_error_ call linus_stifle_mrds_sub_error (error_codes); end; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$open (path_name, lcb.db_index, open_mode, code); /* Try to open data base */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if active_request_flag then revert sub_error_; if code ^= 0 then if active_request_flag & (code = mrds_error_$db_busy | code = mrds_error_$quiesced_db) then do; call clean_up; return; end; else call ssu_$abort_line (sci_ptr, code); else if active_request_flag then return_value = "true"; else; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_pn (lcb.db_index, db_path_name, opened_mode, code); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_db_version (db_path_name, out_path_name, db_version, code); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); if db_version > 3 then lcb.new_version = "1"b; else lcb.new_version = "0"b; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_security_info (lcb.db_index, lcb.linus_area_ptr, mrds_security_info_ptr, code); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); lcb.administrator = mrds_security_info.administrator; lcb.secured_db = mrds_security_info.db_secure; if lcb.sclfi_ptr ^= null then do; /* Declare user defined scalar functions */ sclfi_ptr = lcb.sclfi_ptr; do while (sclfi_ptr ^= null); if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$declare (lcb.db_index, scal_fn_info.name, code); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); sclfi_ptr = scal_fn_info.fwd_ptr; end; end; if lcb.setfi_ptr ^= null then do; free_setfi_ptr = null; last_setfi_ptr = lcb.setfi_ptr; linus_set_fn_info_ptr = lcb.setfi_ptr; do linus_set_fn_info_ptr = lcb.setfi_ptr repeat linus_set_fn_info.fwd_ptr while (linus_set_fn_info.fwd_ptr ^= null); if ^linus_set_fn_info.init_entry_set then do; call ssu_$print_message (linus_error_$cant_ref_fun, "open", "^/The set function ^a does not have an ""_init"" entry ^/point and has been removed from the declared set functions list." , linus_set_fn_info.name); if lcb.setfi_ptr = last_setfi_ptr then do; lcb.setfi_ptr = linus_set_fn_info.fwd_ptr; last_setfi_ptr = linus_set_fn_info.fwd_ptr; end; linus_set_fn_info.fwd_ptr = free_setfi_ptr; free_setfi_ptr = linus_set_fn_info_ptr; end; else last_setfi_ptr = linus_set_fn_info_ptr; end; do linus_set_fn_info_ptr = free_setfi_ptr repeat free_setfi_ptr while (free_setfi_ptr ^= null); free_setfi_ptr = linus_set_fn_info.fwd_ptr; free linus_set_fn_info; end; end; lcb.rt_ptr, lcb.rd_ptr = null; if lcb.timing_mode then initial_mrds_vclock = vclock; call dsl_$get_rslt_rels (lcb.db_index, lcb.linus_area_ptr, mr_ptr, code); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); call init_ready_data; call init_ready_table; return; init_ready_data: proc; /* fill ready_data structure */ rd_nfiles_init = model_relations.nrels; allocate ready_data in (lcb.static_area); lcb.rd_ptr = rd_ptr; ready_data.mode = RETRIEVAL; do j = 1 to model_relations.nrels; ready_data.file.name (j) = model_relations.relation_name (j); ready_data.file.active (j) = "0"b; end; end init_ready_data; init_ready_table: proc; ntabs_init = model_relations.nrels; allocate ready_table in (lcb.static_area); lcb.rt_ptr = rt_ptr; do i = 1 to ntabs_init; ready_table.tab.name (i) = model_relations.relation_name (i); ready_table.tab.active (i) = "0"b; end; mr_ptr = null; end init_ready_table; clean_up: proc; if ca_ptr ^= null then free char_argl; if lcb.db_index ^= 0 & cleanup_has_been_signalled then call dsl_$close (lcb.db_index, code); end clean_up; end linus_open;  linus_output.pl1 10/14/90 0931.4rew 10/14/90 0915.0 75033 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls to assign_round_ from assign_ so that data is rounded. END HISTORY COMMENTS */ linus_output: proc; return; /* This entry point should never be called */ /* DESCRIPTION: The porpose of this module is to permit the common code used by linus_create_list, linus_report, and linus_write to be maintained in a central location. Thus corrections that have to be made need only be made in one location, not in three. HISTORY: 81-04-29 Rickie E. Brinegar: This module was created after hackin on linus_create_list, linus_report, and linus_write. Presumably, it will ease maintenance of the three routines. */ %include linus_lcb; %page; %include linus_select_info; %page; %include mdbm_descriptor; dcl ( caller, l, len, ob_len, /* OUTPUT: output buffer length */ target_type ) fixed bin; dcl n_bytes fixed bin (21); dcl ( called_by, /* INPUT: The linus_data_ id of my caller */ code, /* INPUT: standard code */ icode init (0) ) fixed bin (35); dcl EXPR fixed bin (2) int static options (constant) init (2); dcl NEWLINE char (1) options (constant) int static init (" "); /* New line character */ dcl wcb_dm char (1); /* INPUT: delimiter character for write request */ dcl ( dec_3_ptr init (null), destination_ptr init (null), file_info_ptr, /* INPUT: pointer to the file information for the create_list request */ iocb_ptr, /* INPUT: iocb_ptr for the report and write requests */ out_buf_ptr, /* INPUT/OUTPUT: if null then allocate and return the value */ rec_info_ptr, /* INPUT: pointer to the record information for the create_list request */ ti_ptr, /* INPUT: target item pointer */ user_item_ptr init (null) ) ptr; dcl (addr, fixed, length, ltrim, null, rel, rtrim, substr) builtin; dcl 1 user_item aligned based (user_item_ptr), /* Valid when mrds_item = user_item */ 2 arg_ptr ptr, 2 bit_len fixed bin (35), 2 desc bit (36), 2 assn_type fixed bin, 2 assn_len fixed bin (35); dcl 1 ti (select_info.n_user_items) aligned based (ti_ptr), 2 ptr ptr, 2 len fixed bin (35); dcl 1 record_info aligned based (rec_info_ptr), 2 version fixed bin, /* (INPUT) =1 */ 2 n_fields fixed bin, /* (INPUT) number of fields in this record */ 2 field (n refer (record_info.n_fields)) aligned, 3 field_ptr ptr, /* (INPUT) ptr to first char of Nth record */ 3 field_len fixed bin (21); /* (INPUT) len in chars of Nth record */ /* NOTE: This entry adds a new record to a lister file. The order of the fields is the same as the order in the fieldname_info structure (see lister_$open_file, or lister_$get_fieldnames). The number of fields in each record must match the number of fields in every other record in the file. If the file is full a non-zero code will be returned. If the number of fields is incorrect a non-zero code will be returned. Zero-length fields are OK. */ dcl ( linus_data_$buff_len, linus_data_$create_list_id, linus_data_$report_id, linus_data_$w_id, sys_info$max_seg_size ) ext fixed bin (35); dcl dec_3 pic "+999" based (dec_3_ptr); dcl output_buffer (ob_len) char (1) unal based (out_buf_ptr); dcl out_buffer char (ob_len) unal based (out_buf_ptr); dcl target_item char (ti.len (l)) var aligned based; dcl work_area area (sys_info$max_seg_size) based (lcb.i_o_area_ptr); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl lister_$add_record entry (ptr, ptr, fixed bin (35)); dcl mdbm_util_$string_data_class entry (ptr) returns (bit (1)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); create_list: entry (lcb_ptr, called_by, file_info_ptr, rec_info_ptr, si_ptr, ti_ptr, target_type, out_buf_ptr, ob_len, code); call main_routine; return; report: entry (lcb_ptr, called_by, iocb_ptr, si_ptr, ti_ptr, target_type, out_buf_ptr, ob_len, code); allocate dec_3 in (work_area); call main_routine; return; write: entry (lcb_ptr, called_by, iocb_ptr, si_ptr, wcb_dm, ti_ptr, target_type, out_buf_ptr, ob_len, code); call main_routine; return; main_routine: proc; n_bytes = 0; code = 0; caller = 1; destination_ptr = lcb.si_ptr; do l = 1 to select_info.n_user_items; if ti.ptr (l) = null then do; if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then desc_ptr = addr (select_info.user_item.rslt_desc (l)); else do; user_item_ptr = select_info.user_item.item_ptr (l); desc_ptr = addr (user_item.desc); end; if ^mdbm_util_$string_data_class (desc_ptr) then ti.len (l) = linus_data_$buff_len; else ti.len (l) = fixed (descriptor.size.scale || descriptor.size.precision); allocate target_item in (work_area) set (ti.ptr (l)); ti.ptr (l) -> target_item = ""; end; if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then do; /* Evaluate expression */ if ^select_info.set_fn then call linus_eval_expr (lcb_ptr, select_info.user_item.item_ptr (l), destination_ptr, caller, l, icode); if icode ^= 0 then do; code = icode; return; end; call assign_round_ (ti.ptr (l), target_type, ti.len (l), select_info.user_item.rslt_assn_ptr (l), select_info.user_item.rslt_assn_type (l), select_info.user_item.rslt_assn_len (l)); end; else do; user_item_ptr = select_info.user_item.item_ptr (l); /* Init user_item structure */ call assign_round_ (ti.ptr (l), target_type, ti.len (l), user_item.arg_ptr, user_item.assn_type, user_item.assn_len); end; end; /* get length of output buffer. allocate and fill it with target items */ if out_buf_ptr = null then do; ob_len = 0; do l = 1 to select_info.n_user_items; ob_len = ob_len + ti.len (l) + 2; end; allocate output_buffer in (work_area); end; do l = 1 to select_info.n_user_items; if called_by = linus_data_$create_list_id then ti.ptr (l) -> target_item = ltrim (rtrim (ti.ptr (l) -> target_item)); len = length (ti.ptr (l) -> target_item); if called_by = linus_data_$create_list_id then do; record_info.field.field_len (l) = len; record_info.field.field_ptr (l) = addr (output_buffer (n_bytes + 1)); end; else if called_by = linus_data_$report_id then do; dec_3_ptr = addr (output_buffer (n_bytes + 1)); dec_3 = len; n_bytes = n_bytes + 4; end; n_bytes = n_bytes + 1; substr (out_buffer, n_bytes, len) = ti.ptr (l) -> target_item; n_bytes = n_bytes + len - 1; if called_by = linus_data_$w_id then do; n_bytes = n_bytes + 1; output_buffer (n_bytes) = wcb_dm; end; end; if called_by = linus_data_$create_list_id then call lister_$add_record (file_info_ptr, rec_info_ptr, code); else do; if called_by = linus_data_$w_id then do; n_bytes = n_bytes + 1; output_buffer (n_bytes) = NEWLINE; end; call iox_$put_chars (iocb_ptr, out_buf_ptr, n_bytes, code); end; end main_routine; end linus_output;  linus_print.pl1 10/14/90 0931.4rew 10/14/90 0915.0 319329 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls to assign_round_ from assign_ so that data is rounded. END HISTORY COMMENTS */ linus_print: proc (sci_ptr, lcb_ptr); /* HISTORY: 77-05-01 J. C. C. Jagernauth: Initially written. 79-12-19 Rickie E. Brinegar: Modified to output no data found message over user_output instead of over error_output. 80-01-03 Rickie E. Brinegar: Modified to truncate blanks off of the right hand end of the output line. 80-01-10 Rickie E. Brinegar: Modified to use mdbm_util_$(binary complex fixed number string)_data_class entry points. 80-02-04 Rickie E. Brinegar: Modified to add the -no_end, -ne control arguments. 80-04-10 Rickie E. Brinegar: Modified to remove certain loops which were being called 5,000 times for each line printed. This increased the speed of linus_print by 30 percent. 80-04-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.i_o_area_ptr instead of getting system free area. 80-06-01 Jim Gray: Modified to detect integer control argument args that are too large, to correct -all, make -all and -max incompatible to fix effect of arg ordering bug, and fix error given when -col_widths had no additional argument given. 80-06-02 Jim Gray: Modified to make -cw and -cwt incompatible, fix the detection of too many/few args for -cw/-max, detect p.q column width given for strings, detect when max buffer length exceeded, and improve error messages. 80-06-24 Jim Gray: Modified to add capabilty of printing fixed scaled numbers, where column has not been specified. 80-10-21 Rickie E. Brinegar: The initialization of the buffers in the declaration was changed to be done at the begining of the executable code, and to use assignments of one buffer to another using the string psuedo variable and builtin function. These changes were made as a performance improvement and were suggested by Matt Pierret. 81-01-16 Rickie E. Brinegar: Added a check of the error code after the call to linus_eval_set_func to catch error returns rather than letting linus_print blow up ungracefully. 81-07-15 Rickie E. Brinegar: Removed the conversion and cleanup condition handlers. 81-09-17 Rickie E. Brinegar: Changed the assignment of num_ptrs to num_ptrs to be an assignment of arg_list.arg_count to num_ptrs later on in the code to eliminate a size condition from occuring. 81-11-12 Rickie E. Brinegar: Added timing of this request and its dsl_$retrieve call. 82-02-10 Paul W. Benjamin: ssu_ conversion 82-06-15 Dave J. Schimke: added short names to the MORE? responses a = all, y = yes, n = no. 82-06-18 Dave J. Schimke: Modified internal procedure overflow_check to avoid a stringsize condition when assign_ truncates. This occurred whenever the -cw control arg was used to reduce the column widths. 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the first retrieve to keep linus_table from getting lost when loading in the incremental mode. This call can be eliminated when all modules call linus_table for their retrievals. 83-01-11 Dave Schimke: Replace call to iox_$get_line and associated code in the more_response internal proc with a call to linus_query. This fixes a ssu conversion bug for invoke and answers TRs 12445 & 13342 (linus 73). Also changed arg_len_bits.length to arg_len_bits.len. 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current select expression is available */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_select_info; %page; %include linus_arg_list; %page; %include mdbm_arg_list; %page; %include mdbm_descriptor; dcl sci_ptr ptr; /* for ssu_ */ dcl 1 one_line based (line_ptr), /* Format for one print line */ 2 num_items fixed bin, 2 item (select_info.n_user_items refer (one_line.num_items)), 3 len fixed bin (35), 3 ptr ptr; dcl 1 out_line based (out_line_ptr), /* like one_line */ 2 num_items fixed bin, 2 item (select_info.n_user_items refer (out_line.num_items)), 3 len fixed bin (35), 3 ptr ptr; dcl 1 user_item aligned based (user_item_ptr), /* valid when mrds item = user item */ 2 arg_ptr ptr, 2 bit_len fixed bin (35), 2 desc bit (36), 2 assn_type fixed bin, 2 assn_len fixed bin (35); dcl 1 arg_len_bits based, /* Pick up length for descriptor */ 2 pad bit (12) unal, 2 len bit (24) unal; dcl tmp_char char (char_argl.arg.arg_len (i)) based (char_argl.arg.arg_ptr (i)); dcl (he_flag, print_end, first_retrieve, search_for_mrds_item, cwt_flag, cw_flag) bit (1); dcl ( e_ptr init (null), out_line_ptr init (null), source_ptr init (null), prt_data_ptr init (null), target_ptr init (null), user_item_ptr init (null), expr_results_ptr init (null), stars_ptr init (null), destination_ptr init (null), /* Points to the scalar function init (null), set function or select_info structure */ line_ptr init (null) ) ptr; dcl iox_$user_output ptr ext; dcl (item_length, float_dec_len, icode, code, out_code, constant_max_lines, max_lines) fixed bin (35); dcl expr_results float dec (59); dcl char_61 char (61); dcl char_122 char (122); dcl out_item char (out_line.item.len (l)) aligned based (out_line.item.ptr (l)); dcl picture_output char (one_line.item.len (l)) aligned based (one_line.item.ptr (l)); dcl long_message char (100); dcl short_message char (8); dcl (abs, addr, after, before, ceil, char, copy, fixed, index, length, log10, ltrim, null, rel, rtrim, search, string, substr, vclock, verify) builtin; dcl cleanup condition; dcl offset (10) bit (1) based; dcl ( i, j, output_line_buf_index, line_buf_index, line_count, out_line_index, out_data_len, prt_data_len, target_type, source_type, another_len, caller, /* 1 = from request processor, 2 = from scalar function, 3 = from set function */ mrds_item_index, temp, cmpx_float_dec_type, float_dec_type, l ) fixed bin; dcl n_bytes fixed bin (21); /* for iox_ call */ dcl num_bytes fixed bin (35); dcl initial_mrds_vclock float bin (63); dcl (function_err, fatal_func_err) condition; dcl float_dec_59_desc bit (36) int static options (constant) init ("100101000000000000000000000000111011"b); dcl fix_of_scale (linus_data_$max_user_items) fixed bin init ((linus_data_$max_user_items) 3); dcl ioars_string (linus_data_$max_user_items) char (8) var init ((linus_data_$max_user_items) (1)"^.3f"); dcl ioars_len fixed bin (17); dcl STARS char (100) int static options (constant) init ((100)"*"); dcl DEFAULT_EXPR_SIZE fixed bin (5) int static options (constant) init (17); dcl expr_head char (36) var; dcl ANOTHER char (8) int static options (constant) init ("-another"); dcl EXPR fixed bin (2) int static options (constant) init (2); dcl stars_var char (one_line.item.len (l)) based (stars_ptr); dcl ( linus_data_$p_id, linus_data_$max_user_items, linus_data_$print_col_spaces, linus_data_$pr_buff_len, linus_error_$dup_ctl_args, linus_error_$func_err, linus_error_$incons_args, linus_error_$integer_too_small, linus_error_$inv_arg, linus_error_$integer_too_large, 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, sys_info$max_seg_size ) fixed bin (35) ext; dcl all_seen bit (1); /* on => -all control arg already given */ dcl max_seen bit (1); /* on => -max control alreay given */ dcl temp_int fixed bin (35); /* temp_int for -max 0 check */ dcl MRDS_ITEM fixed bin int static options (constant) init (1); dcl temp_desc_ptr ptr; dcl buffer_character_string char (out_line.item.len (l)) based; dcl line_buf (linus_data_$pr_buff_len) char (1); dcl temp_buf (linus_data_$pr_buff_len) char (1); dcl out_buf (linus_data_$pr_buff_len) char (1); dcl output_line_buf (linus_data_$pr_buff_len) char (1); dcl linus_retrieve entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_table$async_retrieval entry (ptr, fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (8), char (100)); dcl cu_$generate_call entry (entry, ptr); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ( 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 ) entry (ptr) returns (bit (1)); dcl dsl_$retrieve entry options (variable); dcl work_area area (sys_info$max_seg_size) based (lcb.i_o_area_ptr); dcl linus_define_area entry (ptr, char (6), fixed bin (35)); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$abort_subsystem entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$print_message entry options (variable); ca_ptr, char_ptr, al_ptr, out_line_ptr, line_ptr = null; on function_err go to continue; on fatal_func_err call func_err; expr_results_ptr = addr (expr_results); stars_ptr = addr (STARS); string (line_buf) = copy (" ", linus_data_$pr_buff_len); string (out_buf), string (temp_buf), string (output_line_buf) = string (line_buf); num_dims = 1; out_data_len, prt_data_len, code, line_count, icode = 0; cwt_flag, cw_flag = "0"b; first_retrieve, print_end, he_flag = "1"b; constant_max_lines, max_lines = 10; /* Set default print lines */ target_type = 43; /* Char * 2 */ source_type = 44; /* Char_var * 2 */ cmpx_float_dec_type = 24; desc_ptr = addr (float_dec_59_desc); float_dec_type = 2 * descriptor.type; float_dec_len = fixed (descriptor.size.scale || "000000"b || descriptor.size.precision) ; another_len = 8; /* There are 8 characters in "-another" */ caller = 1; /* For linus_eval_expr */ line_ptr = null; prt_data_ptr = addr (output_line_buf (1)); /* Init */ if lcb.db_index = 0 then call error (linus_error_$no_db, ""); if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ destination_ptr = lcb.si_ptr; /* For linus_eval_expr */ si_ptr = lcb.si_ptr; if ^select_info.se_flags.val_ret then call error (linus_error_$ret_not_valid, ""); call linus_define_area (lcb.i_o_area_ptr, "I_O_", code); if code ^= 0 then call error (code, ""); allocate one_line in (work_area); allocate out_line in (work_area); max_seen, all_seen = "0"b; i = 1; call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init ^= 0 then do; allocate char_argl in (lcb.static_area); on cleanup begin; if ca_ptr ^= null then free char_argl; end; do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; i = 1; do while (i <= char_argl.nargs); if tmp_char = "-no_header" | tmp_char = "-nhe" then he_flag = "0"b; /* Set header flag */ else if tmp_char = "-max" then do; if max_seen then call error (linus_error_$dup_ctl_args, "-max"); if i = char_argl.nargs then call error (linus_error_$no_max_lines, ""); else if all_seen then call error (linus_error_$incons_args, "-max and -all"); else do; i = i + 1; if substr (tmp_char, 1, 1) = "-" then call error (linus_error_$no_max_lines, "before " || tmp_char); call integer_check ((char_argl.arg.arg_len (i))); temp_int = fixed (tmp_char); if temp_int = 0 then call error (linus_error_$integer_too_small, "for -max LINES"); constant_max_lines, max_lines = temp_int; /* Set if maximum print lines */ i = i + 1; if i ^> char_argl.nargs then if substr (tmp_char, 1, 1) ^= "-" then call error (linus_error_$too_many_args, "for -max LINES"); i = i - 1; max_seen = "1"b; end; end; else if tmp_char = "-all" | tmp_char = "-a" then do; if max_seen then call error (linus_error_$incons_args, "-all and -max"); max_lines = 999999999; all_seen = "1"b; end; else if tmp_char = "-col_widths_trunc" | tmp_char = "-cwt" then do; if cwt_flag then call error (linus_error_$dup_ctl_args, "-col_width_trunc"); if cw_flag then call error (linus_error_$incons_args, "-col_width_trunc and -col_width"); cwt_flag = "1"b; call cw_specified; end; else if tmp_char = "-col_widths" | tmp_char = "-cw" then do; if cwt_flag then call error (linus_error_$incons_args, "-cold_width and -col_width_trunc"); if cw_flag then call error (linus_error_$dup_ctl_args, "-col_width"); cw_flag = "1"b; call cw_specified; end; else if tmp_char = "-no_end" | tmp_char = "-ne" then print_end = "0"b; else call error (linus_error_$inv_arg, tmp_char); /* Print error */ i = i + 1; end; end; if ^cw_flag then /* make sure ioa control string is blank */ do l = 1 to select_info.n_user_items; /* so that no scale adjustment is made */ if ^(select_info.user_item.item_type (l) = EXPR | select_info.set_fn) then ioars_string (l) = ""; end; call print_layout; /* Fix format for print data */ if select_info.prior_sf_ptr ^= null then call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode); /* evaluate prior set functions */ if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then call error (icode, ""); if select_info.set_fn then do; /* set function to be applied */ call linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1), icode); if icode = 0 then call print_line; end; else do; call linus_table$async_retrieval (lcb_ptr, icode); if icode ^= 0 then call error (icode, ""); call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); char_desc.arr.var (1) = addr (another_len) -> arg_len_bits.len; /* Set up for additional retrievals */ num_ptrs = arg_list.arg_count; arg_list.arg_des_ptr (2) = addr (ANOTHER); do while (icode = 0 & max_lines > line_count); call print_line; continue: if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, al_ptr); /* Retrieve "-another" */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; if constant_max_lines ^= 0 & max_lines = line_count & icode = 0 then call more_response; end; end; if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then call error (icode, ""); if first_retrieve then call no_data; if print_end then call ioa_ ("(END)^/"); exit: if ca_ptr ^= null then free char_argl; return; no_data: proc; call convert_status_code_ (linus_error_$no_data, short_message, long_message); call ioa_$ioa_switch (iox_$user_output, "^/^a^/", long_message); code = 0; goto exit; end no_data; cw_specified: proc; dcl dot_flag bit (1); out_line_index, line_buf_index = 1; cw_flag = "1"b; /* Turn col_widths flag ON */ do l = 1 to select_info.n_user_items; /* Initialize one_line structure */ dot_flag = "0"b; /* init */ i = i + 1; /* Go to next item in char_argl structure */ if i > char_argl.nargs then call error (linus_error_$too_few_args, "column widths"); /* Input argument error */ if substr (tmp_char, 1, 1) = "-" then call error (linus_error_$too_few_args, "column widths before " || tmp_char); temp = search (tmp_char, "."); /* search for user specified scale */ if temp = 0 then do; temp = char_argl.arg.arg_len (i); if select_info.user_item.item_type (l) ^= EXPR & ^select_info.set_fn then ioars_string (l) = ""; end; else do; ioars_string (l) = "^." || substr (tmp_char, temp + 1, char_argl.arg.arg_len (i) - temp) || "f"; if verify (after (tmp_char, "."), "-0123456789") ^= 0 | length (after (tmp_char, ".")) > 4 | (index (after (tmp_char, "."), "-") ^= 0 & (index (substr (after (tmp_char, "."), 2), "-") ^= 0 | substr (after (tmp_char, "."), 1, 1) ^= "-")) then call error (linus_error_$non_integer, "scale factor in column " || ltrim (char (l)) || " width"); fix_of_scale (l) = fixed (after (tmp_char, ".")); if fix_of_scale (l) < -128 | fix_of_scale (l) > 127 then call error (linus_error_$inv_arg, "scale > 127, or < -128 in column " || ltrim (char (l)) || " width"); temp = temp - 1; /* number of column spaces or precision */ dot_flag = "1"b; /* period found in this column specification */ end; call integer_check (temp); out_line.item.len (l) = fixed (substr (tmp_char, 1, temp)); if out_line.item.len (l) = 0 then call error (linus_error_$integer_too_small, "column width argument " || ltrim (char (l))); if dot_flag then do; if select_info.user_item.item_type (l) = MRDS_ITEM then temp_desc_ptr = addr (select_info.user_item.item_ptr (l) -> user_item.desc); else temp_desc_ptr = addr (select_info.user_item.rslt_desc (l)); if ^mdbm_util_$number_data_class (temp_desc_ptr) then call error (linus_error_$inv_arg, "scale in column " || ltrim (char (l)) || " width for string data"); out_line.item.len (l) = out_line.item.len (l) + 1; /* for period */ end; out_line.item.ptr (l) = addr (out_buf (out_line_index)); out_line_index = out_line_index + out_line.item.len (l); out_data_len = out_data_len + out_line.item.len (l) + linus_data_$print_col_spaces; /* Set up for output */ if out_data_len > linus_data_$pr_buff_len - 1 then call error (linus_error_$print_buf_ovfl, "column widths total > max of " || ltrim (char (linus_data_$pr_buff_len - 1))); end; /* check for too many col_widths */ i = i + 1; if i ^> char_argl.nargs then if substr (tmp_char, 1, 1) ^= "-" then call error (linus_error_$too_many_args, tmp_char); i = i - 1; end cw_specified; print_layout: proc; mrds_item_index = 0; search_for_mrds_item = "0"b; line_buf_index = 1; /* Init index to line buffer */ do l = 1 to select_info.n_user_items; /* Find length of each item to be printed */ mrds_item_index = mrds_item_index + 1; one_line.item.len (l) = 0; if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then do; one_line.item.len (l) = 3; /* for F() */ search_for_mrds_item = "1"b; if mdbm_util_$number_data_class ( addr (select_info.user_item.rslt_desc (l))) then do; if cw_flag then item_length = out_line.item.len (l); else item_length = DEFAULT_EXPR_SIZE; end; else item_length = select_info.user_item.rslt_assn_len (l); end; else do; if search_for_mrds_item then do mrds_item_index = mrds_item_index to select_info.n_mrds_items while (select_info.user_item.item_ptr (l) ^= addr (select_info.mrds_item (mrds_item_index))); end; call calc_len ((select_info.mrds_item.desc (mrds_item_index)), item_length); search_for_mrds_item = "0"b; end; one_line.item.len (l) = one_line.item.len (l) + length (select_info.user_item.name (l)); /* Get number of characters in attribute or function name */ if one_line.item.len (l) < item_length then one_line.item.len (l) = item_length; /* Set width of column to larger of header or data */ one_line.item.ptr (l) = addr (line_buf (line_buf_index)); line_buf_index = line_buf_index + one_line.item.len (l); prt_data_len = prt_data_len + one_line.item.len (l) + linus_data_$print_col_spaces; /* Init for tmp_print_data */ if prt_data_len > linus_data_$pr_buff_len - 1/* subtract one for newline character */ then call error (linus_error_$print_buf_ovfl, "print line exceeds maximum length of " || ltrim (char (linus_data_$pr_buff_len - 1))); end; end print_layout; calc_len: proc (descrip, length); /* Calculate the length of a print field given a descriptor */ dcl descrip bit (36); dcl length fixed bin (35); dcl prec_len fixed bin; dcl scale_len fixed bin (11); dcl fixed_bin_11_ovrly fixed bin (11) unal based; desc_ptr = addr (descrip); /* Point to descriptor */ prec_len = fixed (descriptor.size.precision); if mdbm_util_$binary_data_class (desc_ptr) then length = prec_len / 3 + 5; /* binary */ else if mdbm_util_$number_data_class (desc_ptr) then length = prec_len + 3; /* decimal */ else if mdbm_util_$string_data_class (desc_ptr) then length = fixed (descriptor.size.scale || descriptor.size.precision); else length = 20; if mdbm_util_$number_data_class (desc_ptr) then do; if mdbm_util_$fixed_data_class (desc_ptr) then do; /* fixed */ scale_len = addr (descriptor.size.scale) -> fixed_bin_11_ovrly; /* get signed scale */ if scale_len = 0 | (scale_len > 0 & prec_len >= scale_len) then ; /* no scale_len factor */ else if cw_flag & ioars_string (l) ^= "" then ; /* use specified length instead */ else length = length + ceil (log10 (abs (scale_len))); /* largest scale will be f-128 to f+127 */ end; else length = length + 5; /* float */ end; if mdbm_util_$complex_data_class (desc_ptr) then length = length * 2; if cw_flag & ioars_string (l) ^= "" then /* length has been specified */ if ^mdbm_util_$string_data_class (desc_ptr) then /* exclude string types */ length = out_line.item.len (l); /* use specified length */ end calc_len; print_header: proc; dcl (type, j) fixed bin; search_for_mrds_item, he_flag = "0"b; mrds_item_index = 0; do l = 1 to select_info.n_user_items; mrds_item_index = mrds_item_index + 1; out_item = ""; item_length = length (select_info.user_item.name (l)); target_ptr = out_line.item.ptr (l); if select_info.user_item.item_type (l) = EXPR then do; search_for_mrds_item = "1"b; /* the next data base user item will need to find desc */ expr_head = "F(" || select_info.user_item.name (l) || ")"; /* add F to tuple attribute */ source_ptr = addr (expr_head); item_length = item_length + 3; end; else if select_info.set_fn then source_ptr = addr (select_info.user_item.name (l)); else do; /* user item is selected from data base */ source_ptr = addr (select_info.user_item.name (l)); if search_for_mrds_item then /* the previous item was an expression */ do mrds_item_index = mrds_item_index to select_info.n_mrds_items while (select_info.user_item.item_ptr (l) ^= addr (select_info.mrds_item (mrds_item_index))); end; desc_ptr = addr (select_info.mrds_item.desc (mrds_item_index)); search_for_mrds_item = "0"b; type = descriptor.type; if mdbm_util_$number_data_class (desc_ptr) & ioars_string (l) = "" then do j = 1 to out_line.item.len (l) - item_length; target_ptr = addr (target_ptr -> offset (10)); end; end; call assign_round_ (target_ptr, target_type, item_length, source_ptr, source_type, item_length); end; if ^cw_flag then out_buf = line_buf; call set_up_output; call ioa_ (""); call print_a_line; /* Print header */ call ioa_ (""); end print_header; print_line: proc; do l = 1 to select_info.n_user_items; if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then do; /* Evaluate expression */ if ^select_info.set_fn then call linus_eval_expr (lcb_ptr, select_info.user_item.item_ptr (l), destination_ptr, caller, l, icode); if icode ^= 0 then call error (icode, ""); picture_output = stars_var; /* init */ if mdbm_util_$number_data_class ( addr (select_info.user_item.rslt_desc (l))) then do; /* this is really an expr -- not char or string scalar function */ if mdbm_util_$complex_data_class ( addr (select_info.user_item.rslt_desc (l))) then do; call assign_round_ (expr_results_ptr, cmpx_float_dec_type, float_dec_len, select_info.user_item.rslt_assn_ptr (l), select_info.user_item.rslt_assn_type (l), select_info.user_item.rslt_assn_len (l)); call ioa_$rsnnl (ioars_string (l), char_122, ioars_len, expr_results); end; else do; call assign_round_ (expr_results_ptr, float_dec_type, float_dec_len, select_info.user_item.rslt_assn_ptr (l), select_info.user_item.rslt_assn_type (l), select_info.user_item.rslt_assn_len (l)); call ioa_$rsnnl (ioars_string (l), char_61, ioars_len, expr_results); ioars_len = length (before (char_61, ".")) + fix_of_scale (l) + 1; end; if ioars_len <= one_line.item.len (l) | cwt_flag then call ioa_$rsnnl (ioars_string (l), picture_output, ioars_len, expr_results); else /* adjust output format */ if first_retrieve & ^cw_flag then do; /* adjust output format */ temp = ioars_len - one_line.item.len (l); prt_data_len = prt_data_len + temp; /* output buffer length */ do i = l to select_info.n_user_items; one_line.item.len (l) = one_line.item.len (l) + temp; do j = 1 to temp while (l ^= select_info.n_user_items); one_line.item.ptr (l + 1) = addr (one_line.item.ptr (l + 1) -> offset (10)); end; end; call ioa_$rsnnl (ioars_string (l), picture_output, ioars_len, expr_results); end; if cw_flag then call overflow_check;/* check column width with data retrieved */ end; else do; /* output result of non-arithmetic scalar function */ call assign_round_ (one_line.item.ptr (l), target_type, one_line.item.len (l), select_info.user_item.rslt_assn_ptr (l), select_info.user_item.rslt_assn_type (l), select_info.user_item.rslt_assn_len (l)); if cw_flag then call overflow_check;/* check column width with data retrieved */ end; end; else do; user_item_ptr = select_info.user_item.item_ptr (l); /* init user item structure */ /* temp = floor (user_item.assn_type / 2); */ if mdbm_util_$number_data_class (addr (user_item.desc)) & ioars_string (l) ^= "" then do; /* make adjustment for specified scale */ call assign_round_ (expr_results_ptr, float_dec_type, float_dec_len, user_item.arg_ptr, user_item.assn_type, user_item.assn_len); call ioa_$rsnnl (ioars_string (l), char_61, ioars_len, expr_results); ioars_len = length (before (char_61, ".")) + fix_of_scale (l) + 1; if ioars_len > one_line.item.len (l) & ^cwt_flag /* output data does not fit in the space areserved */ then picture_output = stars_var; /* print asterisks */ else /* prepare data for output */ call ioa_$rsnnl (ioars_string (l), picture_output, ioars_len, expr_results); end; else call assign_round_ (one_line.item.ptr (l), target_type, one_line.item.len (l), user_item.arg_ptr, user_item.assn_type, user_item.assn_len); if cw_flag then call overflow_check; end; end; first_retrieve = "0"b; if ^cw_flag then do; out_buf = line_buf; out_line = one_line; end; else prt_data_len = out_data_len; if he_flag then do; /* print header */ string (temp_buf) = string (out_buf); call print_header; string (out_buf) = string (temp_buf); end; call set_up_output; call print_a_line; /* print one line of data */ line_count = line_count + 1; end print_line; overflow_check: proc; dcl t1_char char (t1_len) based (t1_ptr); dcl t1_len fixed bin (35); dcl type fixed bin; dcl t1_ptr ptr; dcl stringsize condition; t1_ptr = null; if out_line.item.len (l) < one_line.item.len (l) then do; t1_len = out_line.item.len (l) + 1; allocate t1_char in (work_area); t1_char = " "; if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then call assign_round_ (t1_ptr, target_type, t1_len, select_info.user_item.rslt_assn_ptr (l), select_info.user_item.rslt_assn_type (l), select_info.user_item.rslt_assn_len (l)); else do; on condition (stringsize) ; call assign_round_ (t1_ptr, target_type, t1_len, user_item.arg_ptr, user_item.assn_type, user_item.assn_len); revert stringsize; end; temp = one_line.item.len (l) - out_line.item.len (l); user_item_ptr = select_info.user_item.item_ptr (l); desc_ptr = addr (user_item.desc); type = descriptor.type; if mdbm_util_$string_data_class (addr (user_item.desc)) then do; if substr (t1_char, t1_len) ^= " " then if ^cwt_flag then picture_output = stars_var; out_item = substr (picture_output, 1, out_line.item.len (l)); end; else do; if substr (picture_output, temp, 1) ^= " " then if ^cwt_flag then picture_output = stars_var; out_item = substr (picture_output, temp + 1); end; end; else do; temp = out_line.item.len (l) - one_line.item.len (l); substr (out_item, temp + 1) = picture_output; end; t1_ptr = null; end overflow_check; set_up_output: proc; /* Merge line_buf and output_line_buf leaving spaces between each column */ out_line_index, output_line_buf_index = 1; /* Init */ do l = 1 to out_line.num_items; /* Move data into output buffer for printing */ addr (output_line_buf (output_line_buf_index)) -> buffer_character_string = addr (out_buf (out_line_index)) -> buffer_character_string; out_line_index = out_line_index + out_line.item.len (l); output_line_buf_index = output_line_buf_index + out_line.item.len (l) + linus_data_$print_col_spaces; if output_line_buf_index > linus_data_$pr_buff_len - 1 /* subtract 1 for new line character */ then call error (linus_error_$print_buf_ovfl, "print line exceeds maximum length of " || ltrim (char (linus_data_$pr_buff_len - 1))); end; end set_up_output; integer_check: proc (no_of_intg); dcl no_of_intg fixed bin; /* Check for integer in char_argl */ if verify (substr (tmp_char, 1, no_of_intg), "0123456789") ^= 0 then call error (linus_error_$non_integer, ""); else if no_of_intg > 9 then call error (linus_error_$integer_too_large, ""); end integer_check; print_a_line: proc; dcl print_line_character_string char (prt_data_len) based (addr (output_line_buf (1))); dcl NEWLINE char (1) int static options (constant) init (" "); n_bytes = length (rtrim (print_line_character_string)) + 1; output_line_buf (n_bytes) = NEWLINE; /* add newline character */ call iox_$put_chars (iox_$user_output, prt_data_ptr, n_bytes, icode); if icode ^= 0 then call error (icode, ""); num_bytes = n_bytes; output_line_buf (n_bytes) = " "; end print_a_line; error: proc (err_code, msg); dcl err_code fixed bin (35); dcl msg char (*); if ca_ptr ^= null then free char_argl; call linus_convert_code (err_code, out_code, linus_data_$p_id); if code = 0 then call ssu_$abort_line (sci_ptr, out_code, msg); else call ssu_$abort_subsystem (sci_ptr, out_code, msg); end error; func_err: proc; call linus_convert_code (linus_error_$func_err, out_code, linus_data_$p_id); call ssu_$print_message (sci_ptr, out_code); go to continue; end func_err; more_response: proc; dcl linus_query entry (ptr, char(*) var, char(*) var); dcl verify_more char (5) var; dcl more_test bit (1) aligned; dcl NL char(1) int static options (constant) init (" "); more_test = "0"b; call linus_query (lcb_ptr, verify_more, NL||"More? "); do while (^more_test); more_test = "1"b; if verify_more = "all" | verify_more = "a" then max_lines = 999999999; else if verify_more = "yes" | verify_more = "y" then max_lines = max_lines + constant_max_lines; else if verify_more = "no" | verify_more = "n" then print_end = "0"b; /* do not print (END) */ else do; call linus_query (lcb_ptr, verify_more, "Please answer ""yes"", ""no"" or ""all""."||NL); more_test = "0"b; end; end; call ioa_ (""); end more_response; end linus_print;  linus_print_error.pl1 09/16/83 1805.4rew 09/16/83 1739.7 18765 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_print_error: proc (code, message); /* DESCRIPTION: This procedure prints an error message to the LINUS user on the error_output switch. The message consists of two parts: (1) the message associated with code, (2) the optional additional message contained in the message argument. HISTORY: 77-03-01 J. A. Weeldreyer: Initially written. */ dcl code fixed bin (35); /* error code */ dcl message char (*); /* optional supplementary message */ dcl short_msg char (8) aligned; dcl long_msg char (100) aligned; dcl iox_$error_output ext ptr; dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl ioa_$ioa_switch entry options (variable); if code ^= 0 then do; call convert_status_code_ (code, short_msg, long_msg); if message ^= "" then call ioa_$ioa_switch (iox_$error_output, "^/^a^/^a^/", long_msg, message); else call ioa_$ioa_switch (iox_$error_output, "^/^a^/", long_msg); end; else if message ^= "" then call ioa_$ioa_switch (iox_$error_output, "^/^a^/", message); return; end linus_print_error;  linus_query.pl1 07/29/86 1045.3r w 07/29/86 0940.0 31671 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ linus_query: proc (lcb_ptr_parm, answer_parm, question_parm); /* This module provides an interface to the command_query subroutine It handles most of the setup work for its callers. The following external entry points are available: linus_query - general question and answer entry linus_query$yes_no - allows only a yes or no response */ %page; /* Known Bugs: Other Problems: History: Written - 82/01/10 - Dave Schimke */ %page; dcl answer_parm char(*) var parm; /* output: user's response */ dcl lcb_ptr_parm ptr parm; /* input: ptr to linus control block */ dcl question_parm char(*) var parm; /* input: prompt */ dcl yes_no_parm bit (1) aligned parm; /* output: yes or no flag */ /* This entry is the basic question/answer mode. */ answer_parm = ""; lcb_ptr = lcb_ptr_parm; question = question_parm; query_information.switches.yes_or_no_sw = "0"b; call query; answer_parm = answer; return; yes_no: entry (lcb_ptr_parm, yes_no_parm, question_parm); /* This entrypoint accepts only a yes or no response and returns a flag (yes_no_parm) where "1"b equals yes and "0"b equals no. */ yes_no_parm = "0"b; lcb_ptr = lcb_ptr_parm; question = question_parm; query_information.switches.yes_or_no_sw = "1"b; call query; if substr (answer, 1, 1) = "y" then yes_no_parm = "1"b; return; query: proc; query_information.version = query_info_version_5; query_information.switches.suppress_name_sw = "1"b; query_information.switches.cp_escape_control = "00"b; query_information.switches.suppress_spacing = "1"b; query_information.switches.padding = "0"b; query_information.status_code = 0; query_information.query_code = 0; query_information.question_iocbp = iox_$user_output; query_information.answer_iocbp = iox_$user_input; query_information.repeat_time = 0; query_information.explanation_ptr = null(); query_information.explanation_len = 0; /************************************************************************/ /* Code added to insure upward compatibility with pre_ssu_linus invoke. */ /* This can be removed if and when invoke is completely removed. */ /* If attached though invoke then get input from terminal regardless. */ if lcb.is_ptr ^= iox_$user_input then query_information.answer_iocbp = iox_$user_io; /* */ /************************************************************************/ call command_query_ (addr(query_information), answer, "linus_query", (question)); return; end; %page; %include iocb; %page; %include linus_lcb; %page; %include query_info; /* Automatic */ dcl answer char(linus_data_$buff_len) varying; dcl 1 query_information like query_info; dcl question char(linus_data_$buff_len) varying; /* Builtin */ dcl (addr, fixed, null, rel, substr) builtin; /* Static */ dcl iox_$user_input ptr ext static; dcl iox_$user_io ptr ext static; dcl iox_$user_output ptr ext static; dcl linus_data_$buff_len fixed bin(35) ext static; dcl sys_info$max_seg_size fixed bin(35) ext static; /* Entries */ dcl command_query_ entry() options(variable); end linus_query;  linus_report.pl1 07/29/86 1045.3r w 07/29/86 0940.0 108063 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_report: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: A REPORT is generated using data retrieved from the data base via the MRPG (Multics Report Program Generator). HISTORY: 77-08-01 J. C. C. Jagernauth: Initially written. 78-08-01 J. C. C. Jagernauth: Modified to handle output buffers of unlimited length. 80-01-15 Rickie E. Brinegar: to use mdbm_util_$string_data_class. 80-03-14 Rickie E. Brinegar: to use a work area defined on lcb.i_o_area_ptr instead of getting system free area. 80-07-01 Rickie E. Brinegar: to initiate segments and pass report_ only the entry point names of the MRPG object segments. This permits the user to give absolute path names. 80-10-21 Rickie E. Brinegar: The changes suggested in TR7999 were made to this source except the change to use the string builtin, which was accomplished by using a based character string to overlay the output buffer and using the substr builtin as a pseudo variable. 81-09-21 Rickie E. Brinegar: Changed the assignment of num_ptrs to num_ptrs to an assignment of arg_list.arg_count to num_ptrs to overcome the subscript range condition that it was getting. 81-11-16 Rickie E. Brinegar: added timing of dsl_$retrieve and changed the call to cu_$gen_call to a call to cu_$generate_call. 81-12-17 Paul W. Benjamin: fixed bug where an arg_string was passed to MRPG whether or not one existed. 81-12-21 Paul W. Benjamin: fixed bug where only paths (not entrynames were working for report programs. 82-02-05 Paul W. Benjamin: ssu_ conversion. 82-06-21 Al Dupuis: trap linkage error when the site has no MRPG. 82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the first retrieve to keep linus_table from getting lost when loading in the incremental mode. This call can be eliminated when all modules call linus_table for their retrievals. 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current select expression is available */ %include linus_lcb; %page; %include linus_arg_list; %page; %include linus_char_argl; %page; %include linus_select_info; %page; %include mdbm_arg_list; dcl sci_ptr ptr; /* ssu_ uses this */ dcl 1 ti (select_info.n_user_items) aligned based (ti_ptr), 2 ptr ptr, 2 len fixed bin (35); dcl 1 arg_len_bits based, /* Pick up length for descriptor */ 2 pad bit (12) unal, 2 length bit (24) unal; dcl ANOTHER char (8) options (constant) int static init ("-another"); dcl STREAM_OUTPUT fixed bin options (constant) int static init (2); /* Mode for iox open */ dcl sw_name char (28); /* Unique switch name */ dcl n fixed bin (21); dcl rgl_module char (rgl_len) based (rgl_ptr); /* RGL object module name + control args */ dcl ( dec_3_ptr init (null), destination_ptr init (null), /* Points to the scalar function, set function or select_info structure */ e_ptr init (null), env_ptr init (null), iocb_ptr init (null), out_buf_ptr init (null), ref_ptr init (null), rgl_ptr init (null), seg_ptr init (null), ti_ptr init (null), user_item_ptr init (null) ) ptr; dcl ( another_len, caller, /* 1 = from the request processor, 2 = from a scalar function, 3 = from a set function */ i, l, ob_len, /* length of output buffer */ rgl_len, target_type ) fixed bin; dcl initial_mrds_vclock float bin (63); dcl (addr, fixed, index, length, null, rel, search, substr, vclock) builtin; dcl first_retrieve bit (1); dcl (icode, code, out_code) fixed bin (35); dcl (directory, entry) char (168); dcl ( error_table_$noentry, error_table_$segknown, linus_data_$report_id, linus_error_$conv, linus_error_$inv_arg, linus_error_$no_data, linus_error_$no_db, linus_error_$ret_not_valid, mrds_error_$tuple_not_found, sys_info$max_seg_size ) fixed bin (35) ext; dcl (cleanup, conversion, linkage_error) condition; dcl cu_$decode_entry_value entry (entry, ptr, ptr); dcl cu_$generate_call entry (entry, ptr); dcl dsl_$retrieve entry options (variable); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl linus_define_area entry (ptr, char (6), fixed bin (35)); dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); dcl linus_output$report entry (ptr, fixed bin (35), ptr, ptr, ptr, fixed bin, ptr, fixed bin, fixed bin (35)); dcl linus_retrieve entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_table$async_retrieval entry (ptr, fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl report_$report_attach entry (ptr, (*) char (*) var, bit (1), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$abort_subsystem entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl test_entry entry variable; dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl work_area area (sys_info$max_seg_size) based (lcb.i_o_area_ptr); icode, code = 0; ca_ptr = null; al_ptr, char_ptr = null; on cleanup call clean_up; on conversion call error (linus_error_$conv); on linkage_error call ssu_$abort_line (sci_ptr, error_table_$noentry, "Your site hasn't purchased the Multics Report Program Generator (MRPG)."); test_entry = report_$report_attach; revert linkage_error; n = 0; first_retrieve = "1"b; another_len = 8; target_type = 44; /* char var * 2 */ caller = 1; /* Init for linus_eval_expr */ if lcb.db_index = 0 then call error (linus_error_$no_db); if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then return; /* No good? Oh, well */ else do; destination_ptr = lcb.si_ptr; /* Init for linus_eval_expr */ si_ptr = lcb.si_ptr; /* Activate select_info data */ call ssu_$arg_count (sci_ptr, nargs_init); if ^select_info.se_flags.val_ret then call error (linus_error_$ret_not_valid); else if nargs_init = 0 then call error (linus_error_$inv_arg); /* There must be args */ else do; allocate char_argl in (lcb.static_area); do i = 1 to char_argl.nargs; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; rgl_ptr = char_argl.arg.arg_ptr (1); /* get RGL arg list */ rgl_len = 0; do i = 1 to char_argl.nargs; rgl_len = rgl_len + char_argl.arg.arg_len (i) + 1; end; rgl_len = rgl_len - 1; call linus_define_area (lcb.i_o_area_ptr, "I_O_", code); if code ^= 0 then call error (code); allocate ti in (work_area); do l = 1 to select_info.n_user_items; ti.ptr (l) = null; end; sw_name = unique_chars_ ("0"b) || ".linus_report"; /* Unique switch_name */ call cu_$decode_entry_value (linus_report, ref_ptr, env_ptr); l = index (rgl_module, " "); if l = 0 then l = length (rgl_module); /* Begin Change 12-21-81 PWB */ if search (substr (rgl_module, 1, l), "><") ^= 0 then do; call expand_pathname_ (substr (rgl_module, 1, l), directory, entry, icode); if icode ^= 0 then call error (icode); call hcs_$initiate (directory, entry, entry, 0, 1, seg_ptr, icode); if icode ^= 0 & icode ^= error_table_$segknown then call error (icode); end; else entry = substr (rgl_module, 1, l); /* End Change 12-21-81 PWB */ /* Begin Change 12-17-81 PWB */ call iox_$attach_name (sw_name, iocb_ptr, "report_ " || entry || " " || substr (rgl_module, l + 1), ref_ptr, icode); /* End Change 12-17-81 PWB */ /* Init for RGL option */ if icode ^= 0 then call error (icode); call iox_$open (iocb_ptr, STREAM_OUTPUT, "0"b, icode); if icode ^= 0 then call error (icode); if select_info.prior_sf_ptr ^= null then call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode); if select_info.set_fn then do; call linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1), icode); if icode = 0 then do; call linus_output$report (lcb_ptr, linus_data_$report_id, iocb_ptr, si_ptr, ti_ptr, target_type, out_buf_ptr, ob_len, icode); if icode ^= 0 then call error (icode); end; end; else do; call linus_table$async_retrieval (lcb_ptr, icode); if icode ^= 0 then call error (icode); call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); if al_ptr ^= null then num_ptrs = arg_list.arg_count; char_desc.arr.var (1) = addr (another_len) -> arg_len_bits.length; /* Get ready for "another" retrieve */ arg_list.arg_des_ptr (2) = addr (ANOTHER); if icode = 0 then first_retrieve = "0"b; do while (icode = 0); /* Retrieve all */ call linus_output$report (lcb_ptr, linus_data_$report_id, iocb_ptr, si_ptr, ti_ptr, target_type, out_buf_ptr, ob_len, icode); if icode ^= 0 then call error (icode); if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, al_ptr); /* Retrieve another */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock); end; if icode ^= mrds_error_$tuple_not_found then call error (icode); if first_retrieve then call error (linus_error_$no_data); end; end; end; call clean_up; return; error: proc (err_code); dcl err_code fixed bin (35); call linus_convert_code (err_code, out_code, linus_data_$report_id); call clean_up; if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code); else call ssu_$abort_line (sci_ptr, out_code, ""); end error; clean_up: proc; if ca_ptr ^= null then free char_argl; if iocb_ptr ^= null then do; call iox_$close (iocb_ptr, icode); call iox_$detach_iocb (iocb_ptr, icode); iocb_ptr = null; end; end clean_up; end linus_report;  linus_retrieve.pl1 07/29/86 1045.3r w 07/29/86 0940.0 64251 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_retrieve: proc (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode); /* DESCRIPTION: Data is retrieved from the currently open data base and used by various linus request procedures. This procedure does the first retrieval and sets up the system standard arg list for subsequent retrievals using the "-another" selection expression. Therefore the "char_desc" and the "arg_list" structures must be released by the calling procedure. HISTORY: 77-05-01 J. C. C. Jagernauth: Initially written. 80-03-14 Rickie E. Brinegar: Modified to use a work area defined on lcb.linus_area_ptr instead of getting system free area. 81-02-02 Rickie E. Brinegar: The internal static debug switch declaration was moved from the db_on entry to the main entry. 81-02-11 Rickie E. Brinegar: Modified to set the argument list only when the al_ptr is null and to do the work of preparing the argument list for another processing as was advertised in the notes above (something it did not do). 81-02-20 Rickie E. Brinegar: changed the call to mdb_display_value_ to a call to mdb_display_data_value$ptr to allow for selection expressions longer that 256 characters. 81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler. 81-09-17 Rickie E. Brinegar: Removed the is_var bit array for determining if a descriptor is a varying data type. This use of the bit array was replaced with a call to mdbm_util_$varying_data_class with a pointer to the appropriate descriptor. 81-11-12 Rickie E. Brinegar: Added timing of dsl_$retrieve call. */ %include linus_lcb; %page; %include linus_char_argl; %page; %include linus_arg_list; %page; %include linus_select_info; %page; %include mdbm_arg_list; dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 length bit (24); /* Length of argument to be passed in arg_list */ dcl debug_switch bit (1) int static init ("0"b); dcl icode fixed bin (35); dcl (desc, l, loop) fixed bin; dcl initial_vclock float bin (63); dcl (addr, addrel, fixed, null, rel, vclock) builtin; dcl ( e_ptr, env_ptr init (null), temp_ptr init (null) ) ptr; dcl ANOTHER char (8) init ("-another") int static options (constant); dcl ANOTHER_LEN bit (24) init ("000000000000000000001000"b) int static options (constant); dcl ANOTHER_PTR ptr init (null) int static; dcl cu_$generate_call entry (entry, ptr); dcl dsl_$retrieve entry options (variable); /* MRDS subroutine */ dcl ioa_ entry options (variable); dcl mdb_display_data_value$ptr entry (ptr, ptr); dcl mdbm_util_$varying_data_class entry (ptr) returns (bit (1) aligned); dcl sys_info$max_seg_size fixed bin (35) ext;/* Used in linus control block */ dcl work_area area (sys_info$max_seg_size) based (lcb.linus_area_ptr); /* assure ANOTHER_PTR is not null and that the arg_list is only when the al_ptr is null */ if ANOTHER_PTR = null then ANOTHER_PTR = addr (ANOTHER); si_ptr = lcb.si_ptr; /* Init */ desc = select_info.n_mrds_items + 3 + select_info.nsevals; /* Offset for descriptors */ if al_ptr = null then do; num_ptrs = desc * 2; /* Number of pointers in arg_list */ allocate arg_list in (work_area); /* System standard argument list */ arg_list.arg_des_ptr (desc) = addr (icode); /* Pointer to return code */ if char_ptr = null then do; n_chars_init = 1; /* Number to allocate */ allocate char_desc in (work_area); /* Character descriptors */ end; arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc); /* Return code descriptor */ arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* Data base index */ arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc); /* Data base index descriptor */ arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */ arg_list.code = 4; arg_list.pad = 0; /* Fill in rest of standard arg_list */ char_desc.arr.var (1) = addr (select_info.se_len) -> arg_len_bits.length; arg_list.arg_des_ptr (2) = select_info.se_ptr; arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (1)); if select_info.nsevals ^= 0 then do l = 1 to select_info.nsevals; arg_list.arg_des_ptr (2 + l) = select_info.se_vals.arg_ptr (l); arg_list.arg_des_ptr (2 + desc + l) = select_info.se_vals.desc_ptr (l); end; l = 1; do loop = 3 + select_info.nsevals to 2 + select_info.n_mrds_items + select_info.nsevals; /* Use pointers and descriptors from select_info structure */ arg_list.arg_des_ptr (loop) = select_info.mrds_item.arg_ptr (l); arg_list.arg_des_ptr (desc + loop) = addr (select_info.mrds_item.desc (l)); if mdbm_util_$varying_data_class ( addr (select_info.mrds_item.desc (l))) then do; temp_ptr = select_info.mrds_item.arg_ptr (l); arg_list.arg_des_ptr (loop) = addrel (temp_ptr, 1); end; l = l + 1; end; end; if debug_switch then do; call ioa_ ("Selection expression:"); call mdb_display_data_value$ptr (select_info.se_ptr, addr (char_desc.arr (1))); end; /* if debug_switch */ if lcb.timing_mode then initial_vclock = vclock; call cu_$generate_call (dsl_$retrieve, al_ptr); /* Call retrieve */ if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_vclock; /* Insure that we are now set up for -another processing */ if arg_list.arg_des_ptr (2) ^= ANOTHER_PTR then do; arg_list.arg_des_ptr (2) = ANOTHER_PTR; char_desc.arr (1).var = ANOTHER_LEN; end; return; db_on: entry; /* Usage: linus_retrieve$db_on Turns on a switch which causes the value of the current selection expression to be displayed at the terminal. */ debug_switch = "1"b; return; db_off: entry; /* Usage: linus_retrieve$db_off Turns off the switch which causes the value of the current selection expression to be displayed at the terminal. */ debug_switch = "0"b; return; end linus_retrieve;  linus_rq_table_.alm 11/05/86 1610.0r w 11/04/86 1038.5 67986 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(84-12-10,Dupuis), approve(86-01-10,MCR7188), " audit(86-07-29,GWMay), install(86-07-29,MR12.0-1106): " Changed linus_del_scope to linus_scope_manager$delete_scope. " 2) change(86-01-09,Dupuis), approve(86-05-23,MCR7404), " audit(86-07-29,GWMay), install(86-07-29,MR12.0-1106): " Allowed assign_values, del_scope, list_scope, list_values, open, " and set_scope to be called as active requests. Added the new active " request opened_database. " END HISTORY COMMENTS " " Changed: November 1984 - Al Dupuis - Deleted the ssu_ requests. name linus_rq_table_ include ssu_request_macros begin_table linus_rq_table_ set_default_multics_doc (Type '..help &1' for more information.) request ., linus_self_identify$linus_self_identify, (), (Print status information.), flags.allow_command request apply, linus_apply$linus_apply, (ap), (Apply a Multics command line to the current query.), flags.allow_command request assign_values, linus_assign_values$linus_assign_values, (av), (Retrieve data and assign values to variables.), flags.allow_both " Undocumented short name for assign_values: request set, linus_assign_values$linus_assign_values, (), , flags.dont_summarize+flags.dont_list+flags.allow_command request close, linus_close$linus_close, (c), (Close the currently open database.), flags.allow_command request column_value, linus_column_value$linus_column_value, (clv), (Return the value of a specified column.), flags.allow_af request create_list, linus_create_list$linus_create_list, (cls), (Retrieve data and write it to a Lister file.), flags.allow_command " Undocumented short name for create_list: request cl, linus_create_list$linus_create_list, (), , flags.dont_summarize+flags.dont_list+flags.allow_command request declare, linus_declare$linus_declare, (dcl), (Declare a user written function.), flags.allow_command request define_temp_table, linus_dtt$linus_dtt, (dtt), (Retrieve data and place in a temporary table.), flags.allow_command request del_scope, linus_scope_manager$delete_scope, (ds), (Delete all or a portion of the current scope of access.), flags.allow_both request delete, linus_delete$linus_delete, (dl), (Delete selected data.), flags.allow_command " Undocumented short name for delete: request d, linus_delete$linus_delete, (), , flags.dont_summarize+flags.dont_list+flags.allow_command request delete_temp_table, linus_dltt$linus_dltt, (dltt), (Delete the specified temporary table.), flags.allow_command request display, linus_display$linus_display, (di), (Retrieve data and produce a formatted report.), flags.allow_command request display_builtins, linus_display_builtins$linus_display_builtins, (dib), (Return the value of a display builtin.), flags.allow_af multics_request format_line, (fl), ,,, flags.allow_both+flags.dont_list+flags.dont_summarize request input_query, linus_input_query$linus_input_query, (iq), (Input a query from the terminal or a file.), flags.allow_command request invoke, linus_invoke$linus_invoke, (i), (Execute requests in a designated LINUS macro segment.), flags.allow_command request lila, linus_lila$linus_lila, (), (Invoke the lila editor.), flags.allow_command request list_db, linus_list_db$linus_list_db, (ldb), (List information about the currently open database.), flags.allow_command request list_format_options, linus_list_format_options$linus_list_format_options, (lsfo), (List formatting option values.), flags.allow_both request list_scope, linus_list_scope$linus_list_scope, (ls), (List/return the scope of access currently in force.), flags.allow_both request list_values, linus_list_values$linus_list_values, (lv), (List/return current value of designated LINUS variable.), flags.allow_both multics_request ltrim, (), ,,, flags.allow_both+flags.dont_list+flags.dont_summarize request modify, linus_modify$linus_modify, (m), (Modify a selected portion of the database.), flags.allow_command request open, linus_open$linus_open, (o), (Open a database.), flags.allow_both request opened_database, linus_opened_database$linus_opened_database, (odb), (Return true or false for an open database.), flags.allow_af multics_request picture, (pic), ,,, flags.allow_both+flags.dont_list+flags.dont_summarize request print, linus_print$linus_print, (pr), (Retrieve data and print in default format.), flags.allow_command " Undocumented short name for print: request p, linus_print$linus_print, (), , flags.dont_summarize+flags.dont_list+flags.allow_command request print_query, linus_print_query$linus_print_query, (pq), (Print or return the current query.), flags.allow_both request qedx, linus_qedx$linus_qedx, (qx), (Edit the current query with the qedx editor.), flags.allow_command request report, linus_report$linus_report, (rpt), (Retrieve data and invoke an MRPG report program.), flags.allow_command request restore_format_options, linus_restore_format_option$linus_restore_format_option, (rsfo), (Restore formatting option values.), flags.allow_command multics_request rtrim, (), ,,, flags.allow_both+flags.dont_list+flags.dont_summarize request save_format_options, linus_save_format_options$linus_save_format_options, (svfo), (Save formatting option values.), flags.allow_command request save_query, linus_save_query$linus_save_query, (sq), (Save the current query to a file.), flags.allow_command request set_format_options, linus_set_format_options$linus_set_format_options, (sfo), (Set formatting option values.), flags.allow_command request set_mode, linus_set_mode$linus_set_mode, (sm), (Set or reset modes for the current session.), flags.allow_command request set_scope, linus_scope_manager$set_scope, (ss), (Define the current scope of access to the database.), flags.allow_both request store, linus_store$linus_store, (s), (Add new rows to a specified table in the database.), flags.allow_command request store_from_data_file, linus_store_from_data_file$linus_store_from_data_file, (sdf), (Read data from a file and store to a specified table.), flags.allow_command multics_request string, (), ,,, flags.allow_both+flags.dont_list+flags.dont_summarize request translate_query, linus_translate_query$linus_translate_query, (tq), (Translate the current query for use by LINUS.), flags.allow_command request write, linus_write$linus_write, (w), (Retrieve data and write to a segment.), flags.allow_command request write_data_file, linus_write_data_file$linus_write_data_file, (wdf), (Retrieve data and write it to a data file.), flags.allow_command end_table linus_rq_table_ end  linus_self_identify.pl1 07/29/86 1045.3r w 07/29/86 0940.0 21663 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ linus_self_identify: proc (sci_ptr, lcb_ptr); /* This procedure is called in place of the standard ssu_$self_identify procedure. It prints the subsystem name and version number along with the pathname and opening mode of the currently open database if there is one. */ /* History: 82-11-02 Dave Schimke Written from ssu_misc_requests_$self_identify */ %include linus_lcb; dcl abbrev_switch bit (1) aligned; dcl addr builtin; dcl code fixed bin (35); dcl dsl_$get_pn entry (fixed bin (35), char (168) var, char (20), fixed bin (35)); dcl fixed builtin; dcl ioa_ entry () options (variable); dcl level fixed bin; dcl n_arguments fixed bin; dcl null builtin; dcl opening_mode char (20); dcl pathname char (168) var; dcl rel builtin; dcl sci_ptr ptr; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$get_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned); dcl ssu_$get_invocation_count entry (ptr, fixed bin, fixed bin); dcl ssu_$get_subsystem_name entry (ptr) returns (char (32)); dcl ssu_$get_subsystem_version entry (ptr) returns (char (32)); dcl sys_info$max_seg_size fixed bin (35) ext static; call ssu_$arg_count (sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (sci_ptr, 0, "No arguments may be given."); call ssu_$get_abbrev_info (sci_ptr, (null ()), (null ()), abbrev_switch); call ssu_$get_invocation_count (sci_ptr, level, (0)); if lcb.db_index ^= 0 then do; call dsl_$get_pn (lcb.db_index, pathname, opening_mode, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); end; call ioa_ ("^a ^a^[ (abbrev)^]^[ (level ^d)^]", ssu_$get_subsystem_name (sci_ptr), ssu_$get_subsystem_version (sci_ptr), abbrev_switch, (level > 1), level); call ioa_ ("^[Database: ^a^;No database open.^]^[^/open for ^a.^;]", (lcb.db_index ^= 0), pathname, (lcb.db_index ^= 0), opening_mode); return; end linus_self_identify;  linus_set_mode.pl1 07/29/86 1045.3r w 07/29/86 0940.0 72090 /* /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_set_mode: proc (sci_ptr, lcb_ptr); /* DESCRIPTION: This procedure sets or resets the specified modes. HISTORY: 77-08-01 J. A. Weeldreyer: Initially written. 80-06-01 Jim Gray : Modified to correct prompt_string declaration to agree with it's usage in the command loop. 81-11-12 Rickie E. Brinegar: Added the timing mode. 81-12-12 Bert G. Moberg: Added print_search_order and no_optimize 82-02-10 Paul W. Benjamin: ssu_ conversion. Added iteration mode. 82-10-27 David J. Schimke: Modified the way iteration is controled to use the new ssu_$set_request_processor_options. Deleted references to the replacement procedures: execute_line, evaluate_active_string, invoke_request and unknown_request which were used to implement the original iteration control under ssu_. */ %include linus_lcb; %page; %include cp_character_types; %page; %include linus_char_argl; %page; %include ssu_prompt_modes; %page; %include ssu_rp_options; dcl sci_ptr ptr; /* for ssu_ */ dcl code fixed bin (35); dcl scode fixed bin (35); /* used in calls to ssu_ */ dcl i fixed bin; dcl arg char (char_argl.arg_len (i)) based (char_argl.arg_ptr (i)); dcl 1 local_rpo aligned like rp_options; dcl mode_name char (32); dcl mode_sw bit (1); dcl prompt_string char (32) varying based; dcl ( linus_error_$bad_mode, linus_error_$long_id, linus_error_$no_input_arg, linus_data_$set_mode_id, sys_info$max_seg_size, linus_error_$too_few_args ) fixed bin (35) ext; dcl cleanup condition; dcl (fixed, rel, addr, null, rank, substr) builtin; dcl linus$post_request_line entry (ptr); dcl linus$pre_request_line entry (ptr); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$get_request_processor_options entry (ptr, char(8), ptr, fixed bin(35)); dcl ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35)); dcl ssu_$set_prompt entry (ptr, char (64) varying); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl ssu_$set_request_processor_options entry (ptr, ptr, fixed bin(35)); ca_ptr = null; call ssu_$arg_count (sci_ptr, nargs_init); if nargs_init = 0 then call error (linus_error_$no_input_arg, ""); allocate char_argl in (lcb.static_area); on cleanup begin; if ca_ptr ^= null then free char_argl; end; do i = 1 to nargs_init; call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i)); end; do i = 1 to char_argl.nargs; /* for each mode specified */ if substr (arg, 1, 1) = "^" then do; /* turning off */ mode_sw = "0"b; mode_name = substr (arg, 2); end; else do; /* turning on */ mode_sw = "1"b; mode_name = arg; end; if mode_name = "prompt" then do; lcb.prompt_flag = mode_sw; if mode_sw then call ssu_$set_prompt_mode (sci_ptr, PROMPT | DONT_PROMPT_AFTER_NULL_LINES | PROMPT_IF_TYPEAHEAD); else call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); end; else if mode_name = "test" then lcb.test_flag = mode_sw; else if mode_name = "pso" | mode_name = "print_search_order" then lcb.pso_flag = mode_sw; else if mode_name = "no_ot" | mode_name = "no_optimize" then lcb.no_ot_flag = mode_sw; else /* if invalid mode */ if mode_name = "set_linus_prompt_string" | mode_name = "slups" then do; if i >= char_argl.nargs then call error (linus_error_$too_few_args, "set_linus_prompt_string needs a string"); i = i + 1; if char_argl.arg_len (i) > 32 then call error (linus_error_$long_id, arg); call ssu_$set_prompt (sci_ptr, (arg)); end; else if mode_name = "set_lila_prompt_string" | mode_name = "slaps" then do; if i >= char_argl.nargs then call error (linus_error_$too_few_args, "set_lila_prompt_string needs a string."); i = i + 1; if char_argl.arg_len (i) > 32 then call error (linus_error_$long_id, arg); lcb.lila_promp_chars_ptr -> prompt_string = arg; end; else if mode_name = "timing" then do; if mode_sw & lcb.timing_mode then ; /* no change */ else if ^mode_sw & ^lcb.timing_mode then ; /* no change */ else if ^mode_sw & lcb.timing_mode then do; /* turn timing off */ call ssu_$set_procedure (sci_ptr, "pre_request_line", lcb.ssu_pre_request_line, scode); if scode ^= 0 then call error (scode, ""); call ssu_$set_procedure (sci_ptr, "post_request_line", lcb.ssu_post_request_line, scode); if scode ^= 0 then call error (scode, ""); lcb.timing_mode = mode_sw; end; else do; /* turn timing on */ call ssu_$set_procedure (sci_ptr, "pre_request_line", linus$pre_request_line, scode); if scode ^= 0 then call error (scode, ""); call ssu_$set_procedure (sci_ptr, "post_request_line", linus$post_request_line, scode); if scode ^= 0 then call error (scode, ""); lcb.timing_mode = mode_sw; lcb.request_time = -1; /* Don't report timings this time */ end; end; else if mode_name = "iteration" then do; if mode_sw & lcb.iteration then ; /* no change */ else if ^mode_sw & ^lcb.iteration then ; /* no change */ else do; /* change iteration*/ call ssu_$get_request_processor_options (sci_ptr, RP_OPTIONS_VERSION_1, addr(local_rpo), scode); if scode ^= 0 then call error (scode, ""); if mode_sw & ^lcb.iteration then local_rpo.language_info.non_standard_language = "0"b; /* turn iteration on (go back to standard language) */ else do; /* turn iteration off */ local_rpo.language_info.non_standard_language = "1"b; local_rpo.language_info.character_types (rank ("(")) = NORMAL_CHARACTER; local_rpo.language_info.character_types (rank (")")) = NORMAL_CHARACTER; end; call ssu_$set_request_processor_options (sci_ptr, addr(local_rpo), scode); if scode ^= 0 then call error (scode, ""); lcb.iteration = mode_sw; end; /* change iteration */ end; else call error (linus_error_$bad_mode, arg); end; /* mode loop */ code = 0; if ca_ptr ^= null then free char_argl; return; error: proc (icode, msg); /* Error procedure, calls convert_code and print_error and then returns. */ dcl (icode, ucode) fixed bin (35); dcl msg char (*); if ca_ptr ^= null then free char_argl; call linus_convert_code (icode, ucode, linus_data_$set_mode_id); call ssu_$abort_line (sci_ptr, ucode, msg); end error; end linus_set_mode;  linus_store.pl1 03/16/88 0829.2rew 03/15/88 1551.4 216117 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-13,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed code to place the column delimiters between the column values when the tuple is written out in an error situation. 2) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-14,Blair), install(88-03-15,MR12.2-1036): Implemented the -progress/-no_progress and -warning/-no_warning control arguments. END HISTORY COMMENTS */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus store request. Description and usage follows. Description: This request prompts the user for values, takes the values from the request line, or reads the values from a file. It then takes these values and stores them into the specified relation. Usage: "store table_name {column_values} {-control_args}" where table_name is the name of the relation where the data will be stored. {column_values} are one or more values provided on the request line. {-control_args} can be: -brief -- verification of input values isn't performed. -column_delimiter X -- the delimiter used to separate column values. X can be any single ascii character (default is one blank). The old control arg -delimiter is still accepted but not documented. -input_file pathname -- the file where the values should be taken from. -long -- verification of input values is performed. -progress {N} -- prints a progress report every N tuples, where N defaults to linus_data_$trace_every_n_tuples if not specified. -row_delimiter X -- the delimiter used to separate rows. X can be any single ascii character (default is newline character). -warning, -warn, -no_warning, -no_warn -- prints or doesn't print warning messages caused by the storing of duplicate tuples or conversion errors. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - September 1983 - complete rewrite of old module. Changed - Al Dupuis - November 4, 1983 - changed code from error_table_$fatal_error to ssu_et_$program_interrupt in call to ssu_$abort_line after user types "no" to verification of values. */ %page; linus_store: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); /* Mainline Processing Overview: (1) Process control arguments setting flags and collecting values. (2) Get the values from the request line, from the user, or from an input file. (3) Store the row. Repeat 2 and 3 if -input_file was used. (4) Clean up. */ %skip(3); call initialize; %skip(1); cleanup_signalled = OFF; on cleanup begin; cleanup_signalled = ON; call terminate; end; %skip(1); call process_args; call get_values_procedure (get_values_mode); %skip(1); call terminate; %skip(1); return; %page; get_values_from_file: proc; %skip(1); dcl gvff_code fixed bin (35); dcl gvff_error_occured bit (1) aligned; dcl gvff_still_storing bit (1) aligned; %skip(1); call linus_parse_file$start (lcb_ptr, addr (data_file_info), table_ip, gvff_code); if gvff_code ^= 0 then call ssu_$abort_line (sci_ptr, gvff_code); packed_buffer_ptr = buffer_ptr; file_parsing_has_been_started = ON; %skip(1); gvff_still_storing = ON; do while (gvff_still_storing); call linus_parse_file$get_row (lcb_ptr, addr (data_file_info), table_ip, buffer_ptr, gvff_code); if gvff_code ^= 0 then if gvff_code = error_table_$end_of_info then gvff_still_storing = OFF; else call ssu_$abort_line (sci_ptr, gvff_code); else; if gvff_still_storing then do; call linus_table$store_row (lcb_ptr, table_ip, packed_buffer_ptr, gvff_code); if gvff_code ^= 0 then do; if print_warning_messages & (gvff_code = mrds_error_$duplicate_key | gvff_code = mrds_error_$conversion_condition) then call ssu_$print_message (sci_ptr, gvff_code, "^/The error occured on line number ^d while trying to store row number ^d." || PARTIAL_FILE_STORE_MESSAGE, data_file_info.current_line_number - 1, data_file_info.current_row_number - 1, FILE_NAME_FOR_FAILED_STORE, (data_file_info.column_delimiter = BLANK), data_file_info.column_delimiter); call write_partial_file_to_pdir (number_of_columns, EXTEND, gvff_error_occured); if gvff_error_occured then call ssu_$abort_line (sci_ptr, gvff_code); if gvff_code ^= mrds_error_$duplicate_key & gvff_code ^= mrds_error_$conversion_condition then call ssu_$abort_line (sci_ptr, gvff_code, PARTIAL_FILE_STORE_MESSAGE, FILE_NAME_FOR_FAILED_STORE, (data_file_info.column_delimiter = BLANK), data_file_info.column_delimiter); end; else do; number_of_tuples_stored = number_of_tuples_stored + 1; if data_file_info.flags.tracing then if mod (data_file_info.current_row_number - 1, data_file_info.trace_every_n_tuples) = 0 then call ioa_ ("^d lines (^d tuples) read from input file. ^d tuples stored.", data_file_info.current_line_number - 1, data_file_info.current_row_number - 1, number_of_tuples_stored); end; end; end; %skip(1); if data_file_info.flags.tracing then call ioa_ ("Storing completed. ^d lines (^d tuples) read, ^d tuples stored.", data_file_info.current_line_number - 1, data_file_info.current_row_number - 1, number_of_tuples_stored); %skip(1); return; %skip(1); end get_values_from_file; %page; get_values_from_request_line: proc; %skip(3); dcl gvfrl_error_occured bit (1) aligned; dcl gvfrl_index fixed bin (21); dcl gvfrl_length fixed bin (21); dcl gvfrl_loop fixed bin; %skip(1); current_arg_number = 2; do gvfrl_loop = 1 to number_of_columns; gvfrl_index = table_info.columns.column_index (gvfrl_loop); gvfrl_length = table_info.columns.column_length (gvfrl_loop); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg_length > gvfrl_length then do; call ssu_$print_message (sci_ptr, 0, "Warning: the value ""^a"" ^/for the ""^a"" column will be truncated to ^d characters.", arg, table_info.columns.column_name (gvfrl_loop), gvfrl_length); substr (buffer, gvfrl_index, gvfrl_length) = substr (arg, 1, gvfrl_length); end; else substr (buffer, gvfrl_index, gvfrl_length) = arg; current_arg_number = current_arg_number + 1; %skip(1); if current_arg_number > number_of_args_supplied then if gvfrl_loop ^= number_of_columns then call too_few_values_supplied; else; else; %skip(1); if first_control_arg_has_been_found then if current_arg_number = first_control_arg_number & gvfrl_loop ^= number_of_columns then call too_few_values_supplied; else; else; end; %skip(1); call store_the_row; %skip(1); return; %page; too_few_values_supplied: proc; %skip(3); call write_partial_file_to_pdir (gvfrl_loop, TRUNCATE, gvfrl_error_occured); %skip(1); if ^gvfrl_error_occured then call ssu_$abort_line (sci_ptr, error_table_$fatal_error, "^/There were ^d column values expected, but only ^d were supplied." || PARTIAL_FILE_STORE_MESSAGE, table_info.column_count, gvfrl_loop, FILE_NAME_FOR_FAILED_STORE, (data_file_info.column_delimiter = BLANK), data_file_info.column_delimiter); else call ssu_$abort_line (sci_ptr, error_table_$fatal_error, "^/There were ^d column values expected, but only ^d were supplied.", table_info.column_count, gvfrl_loop); %skip(1); return; %skip(1); end too_few_values_supplied; %skip(1); end get_values_from_request_line; %page; get_values_from_user: proc; %skip(3); dcl gvfu_index fixed bin (21); dcl gvfu_length fixed bin (21); dcl gvfu_loop fixed bin; %skip(1); do gvfu_loop = 1 to number_of_columns; question_buffer = table_info.columns.column_name (gvfu_loop) || BLANK || QUESTION_MARK || BLANK; gvfu_index = table_info.columns.column_index (gvfu_loop); gvfu_length = table_info.columns.column_length (gvfu_loop); call linus_query (lcb_ptr, answer_buffer, question_buffer); if length (answer_buffer) > gvfu_length then do; call ssu_$print_message (sci_ptr, 0, "Warning: the ^d characters just received will be truncated to ^d.", length (answer_buffer), gvfu_length); substr (buffer, gvfu_index, gvfu_length) = substr (answer_buffer, 1, gvfu_length); end; else substr (buffer, gvfu_index, gvfu_length) = substr (answer_buffer, 1); end; %skip(1); call store_the_row; %skip(1); return; %skip(1); end get_values_from_user; %page; initialize: proc; %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; work_area_ptr = addr (lcb.static_area); %skip(1); unspec (data_file_info) = OFF; data_file_info.flags.process_quotes = ON; data_file_info.flags.process_whitespace = ON; data_file_info.flags.last_column_delimiter_is_optional = ON; data_file_info.column_delimiter = BLANK; data_file_info.row_delimiter = NEWLINE; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; brief_mode = OFF; buffer_has_been_allocated = OFF; first_control_arg_has_been_found = OFF; table_info_has_been_allocated = OFF; file_parsing_has_been_started = OFF; print_warning_messages = ON; number_of_tuples_stored = 0; %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: store table_name {column_values} {-control_args}"); return; %skip(1); end initialize; %page; process_args: proc; %skip(3); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); table_name = arg; call linus_table$info_for_store (lcb_ptr, table_name, work_area_ptr, table_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); number_of_columns = table_info.column_count; table_info_has_been_allocated = ON; buffer_length = table_info.row_value_length; allocate buffer in (work_area) set (buffer_ptr); buffer_has_been_allocated = ON; get_values_mode = GET_VALUES_FROM_USER; %skip(1); if number_of_args_supplied = 1 then return; %skip(1); moved_into_the_values = OFF; moved_into_the_control_args = OFF; call ssu_$arg_ptr (sci_ptr, 2, arg_ptr, arg_length); if arg_length > 0 then if substr (arg, 1, 1) = "-" then moved_into_the_control_args = ON; else moved_into_the_values = ON; else moved_into_the_values = ON; %skip(1); if moved_into_the_values then do; get_values_mode = GET_VALUES_FROM_REQUEST_LINE; current_arg_number = 2 + number_of_columns; if current_arg_number > number_of_args_supplied then return; else moved_into_the_control_args = ON; end; else current_arg_number = 2; %skip(1); first_control_arg_has_been_found = ON; first_control_arg_number = current_arg_number; still_processing_args = ON; %skip(1); do while (still_processing_args); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); %skip(1); if arg = "-column_delimiter" | arg = "-cdm" | arg = "-delimiter" | arg = "-dm" | arg = "-row_delimiter" | arg = "-rdm" then do; if current_arg_number + 1 > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/^a must be followed by a delimiter.", arg); else; current_arg_number = current_arg_number + 1; if arg = "-row_delimiter" | arg = "-rdm" then row_delimiter_flag = ON; else row_delimiter_flag = OFF; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg_length ^= 1 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "The specified delimiter ""^a"" is not a single ascii character.", arg); else; if row_delimiter_flag then data_file_info.row_delimiter = arg; else data_file_info.column_delimiter = arg; data_file_info.flags.process_quotes = OFF; data_file_info.flags.process_whitespace = OFF; end; else if arg = "-input_file" | arg = "-if" | arg = "-file" | arg = "-f" then do; if get_values_mode = GET_VALUES_FROM_REQUEST_LINE then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/^a and column values can't both be supplied.", arg); if current_arg_number + 1 > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/^a must be followed by a pathname.", arg); else; current_arg_number = current_arg_number + 1; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); data_file_info.output_file_pathname = arg; get_values_mode = GET_VALUES_FROM_FILE; brief_mode = OFF; end; else if arg = "-progress" | arg = "-pg" then do; data_file_info.flags.tracing = ON; if current_arg_number + 1 <= number_of_args_supplied then do; call ssu_$arg_ptr (sci_ptr, current_arg_number + 1, arg_ptr, arg_length); if verify (arg, "01234546789") = 0 then do; data_file_info.trace_every_n_tuples = convert (data_file_info.trace_every_n_tuples, arg); current_arg_number = current_arg_number + 1; end; end; end; else if arg = "-no_progress" | arg = "-npg" then do; data_file_info.flags.tracing = OFF; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; end; else if arg = "-brief" | arg = "-bf" then brief_mode = ON; else if arg = "-long" | arg = "-lg" then brief_mode = OFF; else if arg = "-warning" | arg = "-warn" then print_warning_messages = ON; else if arg = "-no_warning" | arg = "-no_warn" then print_warning_messages = OFF; else do; if arg_length > 0 then if substr (arg, 1, 1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; else code = error_table_$bad_arg; call ssu_$abort_line (sci_ptr, code, "^a", arg); end; %skip(1); current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then still_processing_args = OFF; end; %skip(1); return; %skip(1); end process_args; %page; store_the_row: proc; %skip(1); dcl str_code fixed bin (35); dcl str_error_occured bit (1) aligned; %skip(1); if ^brief_mode then call verify_user_values; %skip(1); packed_buffer_ptr = buffer_ptr; call linus_table$store_row (lcb_ptr, table_ip, packed_buffer_ptr, str_code); if str_code ^= 0 then do; call write_partial_file_to_pdir (number_of_columns, TRUNCATE, str_error_occured); if ^str_error_occured then call ssu_$abort_line (sci_ptr, str_code, PARTIAL_FILE_STORE_MESSAGE, FILE_NAME_FOR_FAILED_STORE, (data_file_info.column_delimiter = BLANK), data_file_info.column_delimiter); else call ssu_$abort_line (sci_ptr, str_code); end; %skip(1); return; %skip(1); end store_the_row; %page; terminate: proc; %skip(3); if buffer_has_been_allocated then do; free buffer; buffer_has_been_allocated = OFF; end; %skip(1); if table_info_has_been_allocated then do; store_ap = table_info.store_args_ptr; free store_args; free table_info; table_info_has_been_allocated = OFF; end; %skip(1); if file_parsing_has_been_started then do; call linus_parse_file$stop (lcb_ptr, addr (data_file_info), table_ip, cleanup_signalled, code); file_parsing_has_been_started = OFF; end; %skip(1); return; %skip(1); end terminate; %page; verify_user_values: proc; %skip(1); dcl vuv_error_occured bit (1) aligned; dcl vuv_loop fixed bin; dcl vuv_user_wants_to_continue_parm bit (1) aligned; %skip(1); call ioa_ (""); do vuv_loop = 1 to number_of_columns; call ioa_$nnl ("^a =^x", table_info.columns.column_name (vuv_loop)); call ioa_ ("^a", substr (buffer, table_info.columns.column_index (vuv_loop), table_info.columns.column_length (vuv_loop))); end; %skip(1); call linus_query$yes_no (lcb_ptr, vuv_user_wants_to_continue_parm, NEWLINE || "OK? "); %skip(1); if ^vuv_user_wants_to_continue_parm then do; call write_partial_file_to_pdir (number_of_columns, TRUNCATE, vuv_error_occured); if ^vuv_error_occured then call ssu_$abort_line (sci_ptr, ssu_et_$program_interrupt, PARTIAL_FILE_STORE_MESSAGE, FILE_NAME_FOR_FAILED_STORE, (data_file_info.column_delimiter = BLANK), data_file_info.column_delimiter); else call ssu_$abort_line (sci_ptr, 0); return; end; %skip(1); return; %skip(1); end verify_user_values; %page; write_partial_file_to_pdir: proc ( wpftp_number_of_columns_written_parm, /* input: how many we sucessfully got */ wpftp_truncate_parm, /* input: on means to truncate file */ wpftp_error_occured_parm /* output: on if error occured */ ); %skip(3); dcl wpftp_code fixed bin (35); dcl wpftp_error_occured_parm bit (1) aligned parm; dcl wpftp_loop fixed bin; dcl wpftp_number_of_columns_written_parm fixed bin parm; dcl wpftp_truncate_parm bit (1) aligned parm; %skip(1); wpftp_error_occured_parm = ON; switch_name = unique_chars_ ("0"b) || ".linus_store"; if wpftp_truncate_parm then attach_description = "vfile_ " || rtrim (get_pdir_ ()) || ">linus.store.error"; else attach_description = "vfile_ " || rtrim (get_pdir_ ()) || ">linus.store.error -extend"; %skip(1); call iox_$attach_name (switch_name, iocb_ptr, attach_description, null (), wpftp_code); if wpftp_code ^= 0 then return; %skip(1); call iox_$open (iocb_ptr, Stream_output, "0"b, wpftp_code); if wpftp_code ^= 0 then return; %skip(1); do wpftp_loop = 1 to wpftp_number_of_columns_written_parm; call iox_$put_chars (iocb_ptr, addr (buffer_as_an_array (table_info.columns.column_index (wpftp_loop))), table_info.columns.column_length (wpftp_loop), wpftp_code); call iox_$put_chars (iocb_ptr, addr (data_file_info.column_delimiter), length (data_file_info.column_delimiter), wpftp_code); end; %skip(1); call iox_$put_chars (iocb_ptr, addr (NEWLINE), length (NEWLINE), wpftp_code); call iox_$close (iocb_ptr, wpftp_code); call iox_$detach_iocb (iocb_ptr, wpftp_code); call iox_$destroy_iocb (iocb_ptr, wpftp_code); wpftp_error_occured_parm = OFF; %skip(1); return; %skip(1); end write_partial_file_to_pdir; %page; dcl BLANK char (1) static internal options (constant) init (" "); %skip(1); dcl EXTEND bit (1) aligned static internal options (constant) init ("0"b); %skip(1); dcl FILE_NAME_FOR_FAILED_STORE char (22) static internal options (constant) init ("[pd]>linus.store.error"); %skip(1); dcl GET_VALUES_FROM_FILE fixed bin static internal options (constant) init (1); dcl GET_VALUES_FROM_REQUEST_LINE fixed bin static internal options (constant) init (2); dcl GET_VALUES_FROM_USER fixed bin static internal options (constant) init (3); %skip(1); dcl QUESTION_MARK char (1) static internal options (constant) init ("?"); %skip(1); dcl MAXIMUM_MRDS_ATTRIBUTE_LENGTH fixed bin static internal options (constant) init (4096); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); dcl PARTIAL_FILE_STORE_MESSAGE char (92) static internal options (constant) init ( "^/The supplied values are in ^a with a ^[blank^;""^a""^]^/separating each column value."); %skip(1); dcl TRUNCATE bit (1) aligned static internal options (constant) init ("1"b); %page; dcl addr builtin; dcl answer_buffer char (MAXIMUM_MRDS_ATTRIBUTE_LENGTH) varying; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl attach_description char (256); %skip(1); dcl brief_mode bit (1) aligned; dcl buffer char (buffer_length) based (buffer_ptr); dcl buffer_as_an_array (buffer_length) char (1) based (buffer_ptr); dcl buffer_has_been_allocated bit (1) aligned; dcl buffer_length fixed bin (21); dcl buffer_ptr ptr; %skip(1); dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; dcl code fixed bin (35); dcl current_arg_number fixed bin; %skip(1); dcl error_table_$bad_arg fixed bin(35) ext static; dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$fatal_error fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; %skip(1); dcl file_parsing_has_been_started bit (1) aligned; dcl first_control_arg_has_been_found bit (1) aligned; dcl first_control_arg_number fixed bin; dcl fixed builtin; %skip(1); dcl get_pdir_ entry() returns(char(168)); dcl get_values_mode fixed bin; dcl get_values_procedure (3) entry init ( get_values_from_file, get_values_from_request_line, get_values_from_user ); %skip(1); dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl iocb_ptr ptr; %skip(1); dcl mrds_error_$conversion_condition fixed bin(35) ext static; dcl mrds_error_$duplicate_key fixed bin(35) ext static; %skip(1); dcl length builtin; dcl linus_data_$trace_every_n_tuples fixed bin (35) external static; dcl linus_query entry (ptr, char(*) var, char(*) var); dcl linus_query$yes_no entry (ptr, bit(1) aligned, char(*) var); dcl linus_parse_file$get_row entry (ptr, ptr, ptr, ptr, fixed bin(35)); dcl linus_parse_file$start entry (ptr, ptr, ptr, fixed bin(35)); dcl linus_parse_file$stop entry (ptr, ptr, ptr, bit (1) aligned, fixed bin(35)); dcl linus_table$info_for_store entry (ptr, char(30), ptr, ptr, fixed bin(35)); dcl linus_table$store_row entry (ptr, ptr, ptr unal, fixed bin(35)); %skip(1); dcl packed_buffer_ptr ptr unaligned; dcl print_warning_messages bit (1) aligned; %skip(1); dcl moved_into_the_control_args bit (1) aligned; dcl moved_into_the_values bit (1) aligned; %skip(1); dcl null builtin; dcl number_of_args_supplied fixed bin; dcl number_of_columns fixed bin; dcl number_of_tuples_stored fixed bin (35); %skip(1); dcl question_buffer char (80) varying; %skip(1); dcl rel builtin; dcl row_delimiter_flag bit (1) aligned; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$print_message entry() options(variable); dcl ssu_et_$program_interrupt fixed bin(35) ext static; dcl still_processing_args bit (1) aligned; dcl substr builtin; dcl switch_name char (32); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl table_info_has_been_allocated bit (1) aligned; dcl table_name char (30); %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl unspec builtin; %skip(1); dcl verify builtin; %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_descriptor; %page; %include arg_list; %page; %include iox_dcls; %page; %include iox_modes; %page; %include linus_data_file_info; %page; %include linus_lcb; %page; %include linus_table_info; %skip(3); end linus_store;  linus_table.pl1 10/14/90 0931.4rew 10/14/90 0915.0 583407 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ linus_table: proc; /* This module retrieves the data from the database and loads it into the "table" for processing by the display request. The module also keeps information about the current table in the table_info structure. Known Bugs: Other Problems: History: Written - March 1983 - Dave Schimke 83-08-30 Bert Moberg: Added call to linus_translate_query$auto if no current select expression is available 83-09-09 Al Dupuis: Added translate_query entrypoint. Took the call to linus_translate_query$auto from the info entrypoint and added it to the new entrypoint. 83-09-19 Al Dupuis: Added get_row entrypoint. This is a simple entrypoint for requests like write, who need to just have one row retrieved and then dispose of it when they call back for another row. 83-09-27 Al Dupuis: Added info_for_store entrypoint. This entrypoint allocates and fills in the table_info structure for the table named by the caller. 83-09-27 Al Dupuis: Added store_row entrypoint. This entrypoint stores a single row into the table named by the caller. 84-08-07 John Hergert: Fixed bug in load_table_info that was causing the value table_info.columns.column_length to be loaded with seemingly random values when evaluating mrds items. */ /****^ HISTORY COMMENTS: 1) change(88-05-09,Dupuis), approve(88-07-13,MCR7905), audit(88-07-14,Blair), install(88-07-26,MR12.2-1068): Added an extra check to the code that determined if column names should be qualified. It was forgetting to check for the case when there were different row designators used on one table. 2) change(90-04-30,Leskiw), approve(90-10-05,MCR8202), audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039): Changed calls to assign_round_ from assign_ so that data is rounded. END HISTORY COMMENTS */ %page; /* format: style3,ind3 */ /* parameters */ dcl caller_area_ptr_parm ptr parm; dcl code_parm fixed bin (35) parm; /* These parameters are */ dcl keep_from_row_parm fixed bin (35) parm; /* described at each */ dcl lcb_ptr_parm ptr parm; /* entry where they are used */ dcl permanent_table_parm bit (1) aligned parm; dcl row_count_specified_parm fixed bin (35) parm; dcl row_count_actual_parm fixed bin (35) parm; dcl row_value_ptr_parm ptr unaligned parm; dcl sort_info_ptr_parm ptr parm; dcl table_info_ptr_parm ptr parm; dcl table_name_parm char (30) parm; dcl temp_directory_parm char (168) var parm; %skip(3); lcb_ptr = lcb_ptr_parm; call ssu_$abort_line (lcb.subsystem_control_info_ptr, 0, "This is not a valid entrypoint."); %page; async_retrieval: entry (lcb_ptr_parm, /* input: linus control block */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point is called by the linus requests that do */ /* retrievals from the database: linus_assign_values.pl1, */ /* linus_create_list.pl1, linus_eval_set_func.pl1, linus_modify.pl1, */ /* linus_print.pl1, linus_report.pl1, and linus_write.pl1. */ /* The entry point sets the retrieval indentifier so incremental */ /* retrievals can determine that their "-another" selection is */ /* no longer valid. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ code_parm = 0; lcb_ptr = lcb_ptr_parm; if lcb.table_control_info_ptr = null () then return; call initialize; if table_ip = null () then return; table_info.retrieval_identifier, table_control_info.retrieval_id = table_control_info.retrieval_id + 1; return; /* end async_retrieval */ %page; db_on: entry; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint turns on a switch which causes the value of */ /* the current selection expression to be displayed at the terminal. */ /* */ /* Usage: */ /* linus_table$db_on */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ debug_switch = "1"b; return; %page; db_off: entry; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint turns off the switch which causes the value of */ /* the current selection expression to be displayed at the terminal. */ /* */ /* Usage: */ /* linus_table$db_off */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ debug_switch = "0"b; return; %page; delete_table: entry (lcb_ptr_parm, /* input: linus control block */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point deletes the current table. It is called from */ /* linus_display to conserve space when the table is known to be */ /* invalid and we will need to rebuild it. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; code_parm = 0; call initialize; call cleanup_table; code_parm = icode; return; /* end linus_table_$delete_table */ %page; get_row: entry ( lcb_ptr_parm, /* input: ptr to linus control block */ row_value_ptr_parm, /* output: packed ptr to the row */ code_parm /* output: success or failure */ ); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry point gets a single row from the data base and loads it into the table. */ /* The parm row_value_ptr_parm describes where the row has been placed, and can be used */ /* with the row_value character string to do substr's to access the individual columns. */ /* The table_info, table_control_info, and row_ptrs variables below are set to 1 so that */ /* the newly retrieved row is always placed in the second slot in the table. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; row_value_ptr_parm = null; code_parm = 0; %skip(1); call initialize; if select_info.set_fn then do; code_parm = mrds_error_$tuple_not_found; return; end; call prepare_to_load_rows; call retrieve_another; if icode ^= 0 then do; code_parm = icode; return; end; table_control_info.current_seg_row_count = 1; table_info.row_count = 1; call load_one_row; row_value_ptr_parm = row_value_p; row_ptrs.number_of_ptrs_this_seg = 1; %skip(1); return; %page; info: entry (lcb_ptr_parm, /* input: pointer to linus control_block */ table_info_ptr_parm, /* output: pointer to the table_info structure */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint is called by the linus_options subroutine to */ /* return information on the current state of the display table. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ table_info_ptr_parm = null (); code_parm, icode = 0; lcb_ptr = lcb_ptr_parm; call initialize; if lcb.si_ptr = null then icode = linus_error_$no_lila_expr_processed; else do; si_ptr = lcb.si_ptr; call load_table_info; table_info_ptr_parm = table_control_info.table_info_ptr; end; code_parm = icode; return; /* end linus_table$info */ %page; info_for_store: entry ( lcb_ptr_parm, /* input: ptr to linus control block */ table_name_parm, /* input: name of relation */ caller_area_ptr_parm, /* input: ptr to caller specified area */ table_info_ptr_parm, /* output: points to table_info structure */ code_parm /* output: success or failure */ ); %skip(1); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint is called to provide a table_info structure for a named table. The */ /* structure store_args is also allocated and filled in for future calls to dsl_$store. */ /* The caller is responsible for freeing both of these structures when finished with */ /* them. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ %skip(1); lcb_ptr = lcb_ptr_parm; work_area_p = caller_area_ptr_parm; %skip(1); call load_table_info_for_store (table_name_parm, table_info_ptr_parm, code_parm); %skip(1); return; %page; new_table: entry (lcb_ptr_parm, /* input: pointer to linus control block */ temp_directory_parm, /* input: workspace for the table */ permanent_table_parm, /* input: "1"b = permanent */ code_parm /* output: status code */); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint is called by the display request to initialize */ /* the display table. It takes care of: */ /* 1) initializing the table info */ /* 2) creating the table */ /* 3) retrieving the first row from the database */ /* 4) loading the first row into the table */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; code_parm, icode = 0; call initialize; table_control_info.temp_directory = temp_directory_parm; table_control_info.flags.permanent = permanent_table_parm; if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then do; icode = linus_error_$no_lila_expr_processed; goto NEW_TABLE_EXIT; end; si_ptr = lcb.si_ptr; /* select_info */ sci_ptr = lcb.subsystem_control_info_ptr; /* ssu_ */ if ^select_info.se_flags.val_ret then do; icode = linus_error_$ret_not_valid; goto NEW_TABLE_EXIT; end; if table_control_info.msf_seg_count ^= 0 then do; call cleanup_table; if icode ^= 0 then goto NEW_TABLE_EXIT; call initialize; end; call load_table_info; if icode ^= 0 then goto NEW_TABLE_EXIT; table_control_info.incremental_retrieval_arg_ptr = null (); table_info.row_count = 0; table_control_info.flags.sorted = "0"b; if select_info.prior_sf_ptr ^= null then call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode); /* evaluate prior set functions */ if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then do; icode = icode; goto NEW_TABLE_EXIT; end; if select_info.set_fn /* set function to be applied */ then call linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1), icode); else call retrieve_new; /* or retrieve */ if icode = 0 then do; call create_table; allocate char_output_string in (work_area) set (char_string_ptr); table_control_info.char_output_string_ptr = char_string_ptr; call prepare_to_load_rows; call load_one_row; end; NEW_TABLE_EXIT: code_parm = icode; return; /* end linus_table$new_table */ %page; load_rows: entry (lcb_ptr_parm, /* input: pointer to linus control_block */ row_count_specified_parm, /* input: number of rows to load into the display table. */ row_count_actual_parm, /* output: actual number of rows loaded into the display table. */ keep_from_row_parm, /* input: (disposable table) discard only rows prior to this row number */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint loads N rows into the display table making N */ /* retrieves from the database. It is called by the linus_display */ /* subroutine. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; code_parm, icode, row_count_actual_parm = 0; row_count_specified = row_count_specified_parm; keep_from_row = keep_from_row_parm; call initialize; if select_info.set_fn then do; /* can only apply set function once */ icode = mrds_error_$tuple_not_found; goto LOAD_ROWS_EXIT; end; call prepare_to_load_rows; do row_index = 1 to row_count_specified while (icode = 0); call retrieve_another; if icode = 0 then do; call load_one_row; row_count_actual_parm = row_count_actual_parm + 1; end; end; LOAD_ROWS_EXIT: code_parm = icode; return; /* end linus_table$load_rows */ %page; load_table: entry (lcb_ptr_parm, /* input: pointer to linus control_block */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint loads rows into the display table until no more */ /* rows are available from the database. It is called by the linus_display */ /* subroutine. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; code_parm, icode = 0; call initialize; if select_info.set_fn then goto LOAD_TABLE_EXIT; /* can only apply set function once */ call prepare_to_load_rows; do while (icode = 0); call retrieve_another; if icode = 0 then call load_one_row; end; LOAD_TABLE_EXIT: if icode ^= mrds_error_$tuple_not_found then code_parm = icode; return; /* end linus_table$load_table */ %page; sort: entry (lcb_ptr_parm, /* input: pointer to linus control_block */ sort_info_ptr_parm, /* input: how to sort the table */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint is called by the display request to sort the current */ /* table. It sorts the table by: */ /* 1) loading the ss_info structure to describe the sort. */ /* 2) allocating and loading the sort_input structure to describe the current table. */ /* 3) allocating the sort output structure for sort_seg_$linus_table. */ /* 4) calling sort_seg_$linus_table. */ /* 5) transforming the sort_output into the row_segs_info structure. */ /* 6) freeing the sort_input and sort_output structures. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; sort_info_ptr = sort_info_ptr_parm; ss_info_ptr, sort_desc_array_ptr, sort_input_ptr, sort_output_ptr = null; code_parm = 0; call initialize; if table_control_info.component_ptrs_ptr = null () then do; icode = error_table_$no_table; goto SORT_EXIT; end; ss_field_count = sort_info.number_of_columns_to_sort; allocate ss_info in (info_area) set (ss_info_ptr); allocate sort_desc_array in (info_area); ss_info.header.version = SS_info_version_1; ss_info.header.block_size = 1; ss_info.header.duplicate_mode = SS_duplicates; ss_info.header.mbz1 = 0; ss_info.header.delim.type = SS_length; ss_info.header.delim.number = table_info.row_value_length; do item_index = 1 to ss_field_count; ss_info.field.from.type (item_index) = SS_index; ss_info.field.from.number (item_index) = table_info.columns .column_index (sort_info.columns.number (item_index)); ss_info.field.to.type (item_index) = SS_length; ss_info.field.to.number (item_index) = table_info.columns .column_length (sort_info.columns.number (item_index)); ss_info.field.modes.descending (item_index) = sort_info.columns.modes.descending (item_index); ss_info.field.modes.non_case_sensitive (item_index) = sort_info.columns.modes.non_case_sensitive (item_index); desc_ptr = addr (table_info.columns.column_data_type (sort_info.columns.number (item_index))); sort_desc_array (item_index) = desc_ptr; ss_info.field.modes.numeric (item_index) = mdbm_util_$number_data_class (desc_ptr); end; allocate sort_input in (info_area) set (sort_input_ptr); sort_input.sorted = table_control_info.flags.sorted; do item_index = 1 to row_segs_info.number_of_seg_ptrs; sort_input.segment_ptr (item_index) = row_segs_info.seg_ptr (item_index); end; do item_index = 1 to table_control_info.msf_seg_count; sort_input.component_ptr (item_index) = component_ptr (item_index); end; allocate sort_output in (info_area) set (sort_output_ptr); do item_index = 1 to sort_output.number_of_segs; call linus_temp_seg_mgr$get_segment (lcb_ptr, my_name, table_control_info.temp_directory, temp_ptr, icode); if icode ^= 0 then call ssu_$abort_line (icode, "While getting a new row_ptr_seg."); sort_output.seg_ptr (item_index) = temp_ptr; end; call sort_seg_$linus_table (lcb_ptr, my_name, ss_info_ptr, linus_temp_seg_mgr$get_segment, linus_temp_seg_mgr$release_segment, table_control_info.temp_directory, sort_input_ptr, sort_desc_array, sort_output_ptr, icode); if icode = 0 then do; table_control_info.flags.sorted = "1"b; /* mark this table sorted */ do item_index = 1 to row_segs_info.number_of_seg_ptrs; call linus_temp_seg_mgr$release_segment (lcb_ptr, my_name, (row_segs_info.seg_ptr (item_index)), icode); end; row_segs_info.number_of_seg_ptrs = sort_output.number_of_segs; /* transform output into row_segs_info */ do item_index = 1 to sort_output.number_of_segs; row_segs_info.seg_ptr (item_index) = sort_output.seg_ptr (item_index); end; end; else do item_index = 1 to sort_output.number_of_segs; /* must clean up */ call linus_temp_seg_mgr$release_segment (lcb_ptr, my_name, (sort_output.seg_ptr (item_index)), icode); end; SORT_EXIT: if ss_info_ptr ^= null then free ss_info; if sort_desc_array_ptr ^= null then free sort_desc_array; if sort_input_ptr ^= null then free sort_input; if sort_output_ptr ^= null then free sort_output; code_parm = icode; return; /* end linus_table$sort */ %page; store_row: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ table_info_ptr_parm, /* input: ptr to the table_info structure */ row_value_ptr_parm, /* input: ptr to the row value */ code_parm /* output: success or failure */ ); %skip(1); lcb_ptr = lcb_ptr_parm; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint is called to store a row. The table_info structure used by this */ /* entrypoint should have been generated earlier by the info_for_store entrypoint. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call store_the_row (table_info_ptr_parm, row_value_ptr_parm, code_parm); %skip(1); return; %page; terminate: entry (lcb_ptr_parm, /* input: pointer to linus control_block */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is called by the linus terminate procedure */ /* when a "quit" request or the linus cleanup handler */ /* is executed. It cleans up all table work areas. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lcb_ptr = lcb_ptr_parm; code_parm = 0; if lcb.table_control_info_ptr = null then return; table_control_ip = lcb.table_control_info_ptr; table_ip = table_control_info.table_info_ptr; component_ptrs_p = table_control_info.component_ptrs_ptr; if table_ip ^= null then row_segs_ip = table_info.row_segs_info_ptr; else row_segs_ip = null; call cleanup_table; if table_control_info.info_area_ptr ^= null () then do; info_area_p = table_control_info.info_area_ptr; call release_area_ (info_area_p); call linus_temp_seg_mgr$release_segment (lcb_ptr, "linus_table$info", table_control_info.info_area_ptr, icode); end; lcb.table_control_info_ptr = null (); code_parm = icode; return; /* end linus_table$terminate */ %page; translate_query: entry (lcb_ptr_parm, /* input: pointer to linus control_block */ table_info_ptr_parm, /* output: pointer to the table_info structure */ code_parm); /* output: status code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entrypoint is called by the linus display request to */ /* return information on the current state of the display */ /* table and to translate the current query. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ table_info_ptr_parm = null (); code_parm, icode = 0; lcb_ptr = lcb_ptr_parm; call initialize; if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */ if lcb.si_ptr = null then icode = linus_error_$no_lila_expr_processed; else do; si_ptr = lcb.si_ptr; call load_table_info; table_info_ptr_parm = table_control_info.table_info_ptr; end; code_parm = icode; return; /* end linus_table$translate_query */ %page; /* internal procedures */ append_row: proc; /* Do we need another msf component for another row of data? */ /* If this component is full or this is the first call... */ if (table_control_info.current_seg_row_count >= table_control_info.max_number_of_rows_per_seg) | (table_control_info.msf_seg_count = 0) then call get_next_component; /* Now do we have room for another pointer in the current ptr seg? */ if table_info.row_segs_info_ptr = null then call load_row_info; /* create row info */ else row_segs_ip = table_info.row_segs_info_ptr; if row_segs_info.number_of_seg_ptrs = 0 then call get_ptr_seg (row_ptrs_p); else row_ptrs_p = row_segs_info.seg_ptr (row_segs_info.number_of_seg_ptrs); if row_ptrs.number_of_ptrs_this_seg = row_segs_info.max_number_of_ptrs_per_seg then call get_ptr_seg (row_ptrs_p); /* need another seg for ptrs!! */ row_value_p = addr (component_value (table_control_info.current_seg_row_count + 1)); row_ptrs.number_of_ptrs_this_seg = row_ptrs.number_of_ptrs_this_seg + 1; row_ptrs.row_value_ptr (row_ptrs.number_of_ptrs_this_seg) = row_value_p; end append_row; %page; calc_len: proc (descriptor_parm, length_parm); /* Calculate the length of a print field given a descriptor */ dcl descriptor_parm bit (36) parm; dcl fixed_bin_11_ovrly fixed bin (11) unal based; dcl length_parm fixed bin (21) parm; desc_ptr = addr (descriptor_parm); /* Point to descriptor */ prec_len = fixed (descriptor.size.precision); if mdbm_util_$binary_data_class (desc_ptr) then length_parm = divide(prec_len, 3, 21) + 5; /* binary */ else if mdbm_util_$number_data_class (desc_ptr) then length_parm = prec_len + 3; /* decimal */ else if mdbm_util_$string_data_class (desc_ptr) then length_parm = fixed (descriptor.size.scale || descriptor.size.precision); else length_parm = 20; if mdbm_util_$number_data_class (desc_ptr) then do; if mdbm_util_$fixed_data_class (desc_ptr) then do; /* fixed */ scale_len = addr (descriptor.size.scale) -> fixed_bin_11_ovrly; /* get signed scale */ if (scale_len < 0) | (scale_len > 0 & prec_len < scale_len) then length_parm = length_parm + ceil (log10 (abs (scale_len))); /* largest scale will be f-128 to f+127 */ end; else length_parm = length_parm + 5; /* float */ end; if mdbm_util_$complex_data_class (desc_ptr) then length_parm = length_parm * 2; end calc_len; %page; create_table: proc; table_control_info.table_msf = unique_chars_ ("0"b) || ".LINUS.table"; if table_control_info.temp_directory = "" then table_control_info.temp_directory = get_pdir_ (); call msf_manager_$open (table_control_info.temp_directory, table_control_info.table_msf, table_control_info.fcb_ptr, icode); if icode = error_table_$noentry then icode = 0; if icode ^= 0 then call ssu_$abort_line (sci_ptr, icode, "^/While opening ^a>^a", table_control_info.temp_directory, table_control_info.table_msf); table_control_info.current_seg_row_count = 0; if table_control_info.component_ptrs_ptr = null then do; /* need to create the structure */ table_control_info.max_number_of_components = ROW_SEG_INCREASE; allocate component_ptr in (work_area) set (component_ptrs_p); table_control_info.component_ptrs_ptr = component_ptrs_p; end; end create_table; %page; cleanup_table: proc; icode = 0; table_control_info.current_component_ptr = null; table_control_info.current_seg_row_count = 0; if table_control_info.fcb_ptr ^= null then do; call msf_manager_$close (table_control_info.fcb_ptr); component_ptr (*) = null; table_control_info.component_ptrs_ptr = null; call delete_$path (table_control_info.temp_directory, table_control_info.table_msf, DELETE_SEG_SW, my_name, icode); if icode ^= 0 then call ssu_$print_message (icode, "While deleting table msf"); table_control_info.msf_seg_count = 0; end; if row_segs_ip ^= null then do; /* clean_up row segs info */ if row_segs_info.number_of_seg_ptrs ^= 0 then do item_index = 1 to row_segs_info.number_of_seg_ptrs; if row_segs_info.seg_ptr (item_index) ^= null then call linus_temp_seg_mgr$release_segment (lcb_ptr, my_name, (row_segs_info.seg_ptr (item_index)), icode); if icode ^= 0 then call ssu_$print_message (icode, "While deleting table row seg ptr ^d.", item_index); end; table_control_info.row_info_ptr, table_info.row_segs_info_ptr, row_segs_ip = null; end; if table_control_info.work_area_ptr ^= null () then do; work_area_p = table_control_info.work_area_ptr; call release_area_ (work_area_p); call linus_temp_seg_mgr$release_segment (lcb_ptr, my_name, table_control_info.work_area_ptr, icode); if icode ^= 0 then call ssu_$print_message (icode, "While releasing table work area."); end; end cleanup_table; %page; get_next_component: proc; if table_control_info.msf_seg_count + 1 > table_control_info.max_number_of_components then do; /* need to expand the structure */ table_control_info.max_number_of_components = ROW_SEG_INCREASE + table_control_info.msf_seg_count; allocate new_component_ptr in (work_area) set (new_component_ptrs_p); new_component_ptrs_p -> component_ptr = component_ptr; table_control_info.component_ptrs_ptr, component_ptrs_p = new_component_ptrs_p; end; call msf_manager_$get_ptr (table_control_info.fcb_ptr, table_control_info.msf_seg_count, CREATE, table_control_info.current_component_ptr, bit_count, icode); /* actually getting the (seg_count - 1)th component (1st seg is 0) */ if icode ^= 0 then call ssu_$abort_line (sci_ptr, icode, "^/While creating ^[a component of ^]^a>^a", (table_control_info.msf_seg_count > 0), table_control_info.temp_directory, table_control_info.table_msf); table_control_info.msf_seg_count = table_control_info.msf_seg_count + 1; component_ptr (table_control_info.msf_seg_count) = table_control_info.current_component_ptr; table_control_info.current_seg_row_count = 0; end get_next_component; %page; get_ptr_seg: proc (seg_ptr_parm); dcl seg_ptr_parm ptr parm; call linus_temp_seg_mgr$get_segment (lcb_ptr, my_name, table_control_info.temp_directory, seg_ptr_parm, icode); if icode ^= 0 then call ssu_$abort_line (icode, "While getting a new row_ptr_seg."); if row_segs_info.number_of_seg_ptrs = row_segs_info.max_number_of_seg_ptrs then call load_row_info; /* need to grow structure */ row_segs_info.number_of_seg_ptrs = row_segs_info.number_of_seg_ptrs + 1; row_segs_info.seg_ptr (row_segs_info.number_of_seg_ptrs) = seg_ptr_parm; seg_ptr_parm -> row_ptrs.number_of_ptrs_this_seg = 0; end get_ptr_seg; %page; initialize: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Make sure everything is ready. Set automatic pointers and */ /* initialize common structures. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ sci_ptr = lcb.subsystem_control_info_ptr; if lcb.table_control_info_ptr = null () then do; /* init control structure */ allocate table_control_info in (lcb.static_area) set (table_control_ip); lcb.table_control_info_ptr = table_control_ip; end; else table_control_ip = lcb.table_control_info_ptr; work_area_p = table_control_info.work_area_ptr; if work_area_p = null () then do; call linus_temp_seg_mgr$get_segment (lcb_ptr, my_name, table_control_info.temp_directory, work_area_p, icode); if icode ^= 0 then call ssu_$abort_line (sci_ptr, icode, "While getting table work area temp seg."); call mdbm_util_$mu_define_area (work_area_p, (sys_info$max_seg_size), "work_area", EXTENSIBLE, NO_FREEING, NO_ZERO_ON_ALLOC, NO_ZERO_ON_FREE, icode); if icode ^= 0 then call ssu_$abort_line (sci_ptr, icode, "While getting table work area."); table_control_info.work_area_ptr = work_area_p; end; info_area_p = table_control_info.info_area_ptr; if info_area_p = null () then do; call linus_temp_seg_mgr$get_segment (lcb_ptr, "linus_table$info", table_control_info.temp_directory, info_area_p, icode); if icode ^= 0 then call ssu_$abort_line (sci_ptr, icode, "While getting table info area temp seg."); call mdbm_util_$mu_define_area (info_area_p, (sys_info$max_seg_size), "table.info", EXTENSIBLE, FREEING, NO_ZERO_ON_ALLOC, NO_ZERO_ON_FREE, icode); if icode ^= 0 then call ssu_$abort_line (sci_ptr, icode, "While getting table info area."); table_control_info.info_area_ptr = info_area_p; end; table_ip = table_control_info.table_info_ptr; if table_ip ^= null then row_segs_ip = table_info.row_segs_info_ptr; else row_segs_ip = null; component_ptrs_p = table_control_info.component_ptrs_ptr; si_ptr = lcb.si_ptr; /* select_info ptr */ end initialize; %page; load_one_row: proc; call append_row; /* adjust row_ptr */ do item_index = 1 to table_info.column_count; char_output_string = ""; if ^select_info.set_fn & select_info.user_item.item_type (item_index) = MRDS then do; user_item_ptr = select_info.user_item.item_ptr (item_index); /* init user item structure */ call assign_round_ (char_string_ptr, target_type, (table_info.columns.column_length (item_index)), user_item.arg_ptr, user_item.assn_type, user_item.assn_len); end; else do; /* Evaluate expression */ if select_info.user_item.item_type (item_index) = EXPR then do; call linus_eval_expr (lcb_ptr, select_info.user_item.item_ptr (item_index), si_ptr, caller, item_index, icode); if icode ^= 0 then return; end; if mdbm_util_$number_data_class ( addr (select_info.user_item.rslt_desc (item_index))) then do; /* this is really an expr -- not char or string scalar function */ if mdbm_util_$complex_data_class ( addr (select_info.user_item.rslt_desc (item_index))) then call assign_round_ (expr_results_ptr, cmpx_float_dec_type, float_dec_len, select_info.user_item.rslt_assn_ptr (item_index), select_info.user_item.rslt_assn_type (item_index), select_info.user_item.rslt_assn_len (item_index)); else call assign_round_ (expr_results_ptr, float_dec_type, float_dec_len, select_info.user_item.rslt_assn_ptr (item_index), select_info.user_item.rslt_assn_type (item_index), select_info.user_item.rslt_assn_len (item_index)); call ioa_$rsnnl (IOARS_STRING, char_output_string, (0), expr_results); /* convert to a character string */ end; else /* output result of non-arithmetic scalar function */ call assign_round_ (char_string_ptr, target_type, (table_info.columns.column_length (item_index)), select_info.user_item.rslt_assn_ptr (item_index), select_info.user_item.rslt_assn_type (item_index), select_info.user_item.rslt_assn_len (item_index)); end; substr (row_value, table_info.columns (item_index).column_index, table_info.columns (item_index).column_length) = char_output_string; end; table_info.row_count = table_info.row_count + 1; table_control_info.current_seg_row_count = table_control_info.current_seg_row_count + 1; end load_one_row; %page; load_row_info: proc; if table_info.row_segs_info_ptr = null then do; /* need to create the row info structure */ rsi_init_max_number_of_seg_ptrs = ROW_SEG_INCREASE; allocate row_segs_info in (work_area) set (row_segs_ip); table_info.row_segs_info_ptr = row_segs_ip; row_segs_info.max_number_of_ptrs_per_seg = sys_info$max_seg_size - 1; row_segs_info.number_of_seg_ptrs = 0; end; else do; /* need to expand the row info structure */ rsi_init_max_number_of_seg_ptrs, row_segs_info.max_number_of_seg_ptrs = ROW_SEG_INCREASE + row_segs_info.number_of_seg_ptrs; allocate new_row_segs_info in (work_area) set (new_row_segs_ip); new_row_segs_ip -> row_segs_info = row_segs_info; row_segs_ip, table_info.row_segs_info_ptr = new_row_segs_ip; end; table_control_info.row_info_ptr = row_segs_ip; /* save for synchronization over table_info reinitialization */ end load_row_info; %page; load_table_info: proc; /* Is the old table information still valid? */ if table_control_info.table_info_ptr ^= null () then if table_control_info.selection_expression_identifier = lcb.selection_expression_identifier then return; /* No, we need to calculate and load table_info. */ /* Get a new table_info structure. */ if table_control_info.table_info_ptr ^= null then free table_info; ti_init_column_count = select_info.n_user_items; allocate table_info in (info_area) set (table_ip); table_control_info.table_info_ptr = table_ip; /* save the ptr */ /* initialization */ expression_count = 0; linus_rel_array_ptr = lcb.rel_array_ptr; /* init table_info */ table_info.retrieval_identifier, table_control_info.retrieval_id = table_control_info.retrieval_id + 1; table_info.row_segs_info_ptr = table_control_info.row_info_ptr; table_info.maximum_column_value_length = 1; table_info.maximum_column_name_length = 0; table_info.columns.column_name = ""; table_info.store_args_ptr = null; /* Try to set unique names for each MRDS item */ /* If more than 1 table (relation) is selected, include the table name. */ if linus_rel_array.num_of_rels > 1 | select_uses_different_row_designators () then do row_index = 1 to table_info.column_count; if (select_info.user_item.item_type (row_index) = MRDS) then table_info.columns.column_name (row_index) = rtrim (select_info.user_item.table_name (row_index)) || "." || select_info.user_item.name (row_index); end; /* Fill in the rest of the column specific data. */ do item_index = 1 to table_info.column_count; /* column data */ if ^select_info.set_fn & select_info.user_item.item_type (item_index) = MRDS then do; /* MRDS item */ if (table_info.columns.column_name (item_index) = "") then table_info.columns.column_name (item_index) = select_info.user_item.name (item_index); user_item_ptr = select_info.user_item.item_ptr (item_index); call calc_len ((user_item.desc), table_info.columns.column_length (item_index)); table_info.columns.column_data_type (item_index) = user_item.desc; end; else do; /* Expression or Function */ expression_count = expression_count + 1; table_info.columns.column_name (item_index) = "e" || ltrim (char (expression_count)); if mdbm_util_$number_data_class ( addr (select_info.user_item.rslt_desc (item_index))) then do; table_info.columns.column_length (item_index) = DEFAULT_EXPR_SIZE; table_info.columns.column_data_type (item_index) = FIXED_DEC_14_3_DESC; end; else do; table_info.columns.column_length (item_index) = select_info.user_item.rslt_assn_len (item_index); table_info.columns.column_data_type (item_index) = select_info.user_item.rslt_desc (item_index); end; end; table_info.maximum_column_value_length = max (table_info.maximum_column_value_length, table_info.columns.column_length (item_index)); table_info.maximum_column_name_length = max (table_info.maximum_column_name_length, length (table_info.columns.column_name (item_index))); if item_index ^= 1 then table_info.columns (item_index).column_index = table_info.columns (item_index - 1).column_length + table_info.columns (item_index - 1).column_index; else table_info.columns (1).column_index = 1; end; /* column data */ /* If duplicates from the same table exist, add numeric suffixes. */ do row_index = 1 to table_info.column_count; do item_index = row_index + 1 to table_info.column_count; duplicate_count = 1; if (table_info.columns.column_name (row_index) = table_info.columns.column_name (item_index)) then do loop_index = 1 to table_info.column_count; if (select_info.user_item.name (row_index) = select_info.user_item.name (loop_index)) & (select_info.user_item.table_name (row_index) = select_info.user_item.table_name (loop_index)) then do; table_info.columns.column_name (loop_index) = rtrim (table_info.columns.column_name (loop_index)) || "." || ltrim (char (duplicate_count)); duplicate_count = duplicate_count + 1; end; end; end; end; table_info.row_value_length = sum (table_info.columns.column_length (*)); table_control_info.max_number_of_rows_per_seg = divide ((sys_info$max_seg_size * 4), table_info.row_value_length, 10); table_control_info.selection_expression_identifier = lcb.selection_expression_identifier; end load_table_info; %page; load_table_info_for_store: proc ( ltifs_table_name_parm, /* input: name of table for info */ ltifs_table_info_ptr_parm, /* output: points to table_info structure */ ltifs_code_parm /* output: success or failure */ ); %skip(1); dcl ltifs_code_parm fixed bin (35) parm; dcl ltifs_current_index fixed bin (21); dcl ltifs_found_the_relation bit (1) aligned; dcl ltifs_loop fixed bin; dcl ltifs_relation_index fixed bin (35); dcl ltifs_table_name char (30); dcl ltifs_table_name_parm char (30) parm; dcl ltifs_table_info_ptr_parm ptr parm; %skip(1); ltifs_table_name = ltifs_table_name_parm; ltifs_table_info_ptr_parm = null; ltifs_code_parm = 0; %skip(1); if lcb.db_index = 0 then do; ltifs_code_parm = linus_error_$no_db; return; end; %skip(1); if lcb.timing_mode then initial_vclock = vclock; %skip(1); call dsl_$get_rslt_info (lcb.db_index, ltifs_table_name, work_area_p, rslt_ptr, ltifs_code_parm); if ltifs_code_parm ^= 0 then do; ltifs_found_the_relation = "0"b; if lcb.ttn_ptr ^= null then do; ttn_ptr = lcb.ttn_ptr; do ltifs_loop = 1 to mrds_data_$max_temp_rels while (^ltifs_found_the_relation); if ltifs_table_name = temp_tab_names (ltifs_loop) then do; ltifs_found_the_relation = "1"b; ltifs_relation_index = ltifs_loop; end; end; end; if ltifs_found_the_relation then call dsl_$get_temp_info (lcb.db_index, ltifs_relation_index, work_area_p, rslt_ptr, ltifs_code_parm); else; end; %skip(1); if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_vclock; if ltifs_code_parm ^= 0 then return; %skip(1); ti_init_column_count = rslt_info.num_attr; allocate table_info in (work_area) set (table_ip); table_info.retrieval_identifier = 0; table_info.row_count = 0; table_info.row_segs_info_ptr = null; table_info.store_args_ptr = null; %skip(1); table_info.maximum_column_name_length = 0; table_info.maximum_column_value_length = 0; table_info.row_value_length = 0; ltifs_current_index = 1; %skip(1); do ltifs_loop = 1 to ti_init_column_count; table_info.columns.column_name (ltifs_loop) = rtrim (rslt_info.attr (ltifs_loop).attr_name); table_info.maximum_column_name_length = max (length (table_info.columns.column_name (ltifs_loop)), table_info.maximum_column_name_length); table_info.columns.column_data_type (ltifs_loop) = rslt_info.attr (ltifs_loop).descriptor; call calc_len ((table_info.columns.column_data_type (ltifs_loop)), table_info.columns.column_length (ltifs_loop)); table_info.maximum_column_value_length = max (table_info.columns.column_length (ltifs_loop), table_info.maximum_column_value_length); table_info.row_value_length = table_info.row_value_length + table_info.columns.column_length (ltifs_loop); table_info.columns.column_index (ltifs_loop) = ltifs_current_index; ltifs_current_index = ltifs_current_index + table_info.columns.column_length (ltifs_loop); end; free rslt_info; %skip(1); /* Add extra args and descriptors for db index, relation name, and error code. */ %skip(1); arg_list_arg_count = table_info.column_count + 3; init_number_of_descriptors = arg_list_arg_count; %skip(1); allocate store_args in (work_area) set (store_ap); store_args.table_name = ltifs_table_name; store_args.header.pad1 = "0"b; store_args.header.call_type = Interseg_call_type; store_args.header.desc_count = store_args.header.arg_count; store_args.header.pad2 = "0"b; %skip(1); /* Init descriptors and set db index, table name, and code. */ %skip(1); unspec (store_args.argument_list_descriptors) = "0"b; store_args.argument_list_descriptors (*).flag = "1"b; store_args.argument_list_descriptors (1).type = real_fix_bin_1_dtype; store_args.argument_list_descriptors (1).size = 35; store_args.argument_list_descriptors (2).type = char_dtype; store_args.argument_list_descriptors (2).size = length (store_args.table_name); store_args.argument_list_descriptors (arg_list_arg_count).type = real_fix_bin_1_dtype; store_args.argument_list_descriptors (arg_list_arg_count).size = 35; %skip(1); /* Fill in arg and desc ptrs for db index, table name, and code. */ %skip(1); store_args.arg_ptrs (1) = addr (lcb.db_index); store_args.desc_ptrs (1) = addr (store_args.argument_list_descriptors (1)); store_args.arg_ptrs (2) = addr (store_args.table_name); store_args.desc_ptrs (2) = addr (store_args.argument_list_descriptors (2)); store_args.arg_ptrs (arg_list_arg_count) = addr (store_args.error_code); store_args.desc_ptrs (arg_list_arg_count) = addr (store_args.argument_list_descriptors (arg_list_arg_count)); %skip(1); /* Fill in desc ptrs for column values after setting them. arg ptrs are filled in when store takes place. */ %skip(1); do ltifs_loop = 3 to table_info.column_count + 2; store_args.arg_ptrs (ltifs_loop) = null; store_args.argument_list_descriptors (ltifs_loop).type = char_dtype; store_args.argument_list_descriptors (ltifs_loop).size = table_info.columns.column_length (ltifs_loop - 2); store_args.desc_ptrs (ltifs_loop) = addr (store_args.argument_list_descriptors (ltifs_loop)); end; %skip(1); table_info.store_args_ptr = store_ap; ltifs_table_info_ptr_parm = table_ip; %skip(1); return; %skip(1); end load_table_info_for_store; %page; prepare_to_load_rows: proc; caller = 1; /* for linus_eval_expr */ cmpx_float_dec_type = 24; arg_descriptor_ptr = addr (FLOAT_DEC_59_DESC); float_dec_len = arg_descriptor.size; float_dec_type = 2 * arg_descriptor.type; expr_results_ptr = addr (expr_results); if ^select_info.set_fn then do; /* extra setup for "-another" */ retrieval_arg_list_ptr = table_control_info.incremental_retrieval_arg_ptr; retrieve_code_ptr = retrieval_arg_list.arg_ptrs (retrieval_arg_list.arg_count); end; char_string_ptr = table_control_info.char_output_string_ptr; end prepare_to_load_rows; %page; retrieve_another: proc; if lcb.timing_mode then initial_mrds_vclock = vclock; call cu_$generate_call (dsl_$retrieve, retrieval_arg_list_ptr); /* Retrieve "-another" */ icode = retrieve_code; if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock; end retrieve_another; %page; retrieve_new: proc; /* This procedure does the first retrieval from the currently open database and sets up for subsequent retrievals using the "-another" selection expression. */ /* assure that the arg_list is new */ n_chars_init = 1; allocate char_desc in (work_area); arg_list_arg_count = select_info.n_mrds_items + 3 + select_info.nsevals; /* Offset for descriptors */ allocate retrieval_arg_list in (work_area) set (retrieval_arg_list_ptr); /* System standard argument list */ retrieval_arg_list.header.pad1 = "0"b; retrieval_arg_list.header.call_type = Interseg_call_type; retrieval_arg_list.header.desc_count = retrieval_arg_list.arg_count; retrieval_arg_list.header.pad2 = "0"b; allocate retrieve_code in (work_area) set (retrieve_code_ptr); /* Code returned by generated call to dsl_$retrieve */ retrieval_arg_list.arg_ptrs (arg_list_arg_count) = retrieve_code_ptr; retrieval_arg_list.desc_ptrs (arg_list_arg_count) = addr (char_desc.fb_desc); /* DB index */ retrieval_arg_list.arg_ptrs (1) = addr (lcb.db_index); retrieval_arg_list.desc_ptrs (1) = addr (char_desc.fb_desc); /* selection expression */ char_desc.arr.var (1) = addr (select_info.se_len) -> arg_len_bits.len; retrieval_arg_list.arg_ptrs (2) = select_info.se_ptr; retrieval_arg_list.desc_ptrs (2) = addr (char_desc.arr (1)); /* Fill in rest of standard arg_list */ /* First the selection expression values for substitution. */ if select_info.nsevals ^= 0 then do item_index = 1 to select_info.nsevals; retrieval_arg_list.arg_ptrs (item_index + 2) = select_info.se_vals.arg_ptr (item_index); retrieval_arg_list.desc_ptrs (item_index + 2) = select_info.se_vals.desc_ptr (item_index); end; /* Then the retrieved attribute values. */ item_index = 1; do loop_index = 3 + select_info.nsevals to 2 + select_info.n_mrds_items + select_info.nsevals; /* Use pointers and descriptors from select_info structure */ retrieval_arg_list.arg_ptrs (loop_index) = select_info.mrds_item.arg_ptr (item_index); retrieval_arg_list.desc_ptrs (loop_index) = addr (select_info.mrds_item.desc (item_index)); if mdbm_util_$varying_data_class ( addr (select_info.mrds_item.desc (item_index))) then do; temp_ptr = select_info.mrds_item.arg_ptr (item_index); retrieval_arg_list.arg_ptrs (loop_index) = addrel (temp_ptr, 1); end; item_index = item_index + 1; end; if debug_switch then do; call ioa_ ("Selection expression:"); call mdb_display_data_value$ptr (select_info.se_ptr, addr (char_desc.arr (1))); end; /* if debug_switch */ if lcb.timing_mode then initial_vclock = vclock; call cu_$generate_call (dsl_$retrieve, retrieval_arg_list_ptr); /* Call retrieve */ icode = retrieve_code; if lcb.timing_mode then lcb.mrds_time = lcb.mrds_time + vclock - initial_vclock; /* Insure that we are now set up for -another processing */ retrieval_arg_list.arg_ptrs (2) = addr (ANOTHER); char_desc.arr (1).var = ANOTHER_LEN; table_control_info.incremental_retrieval_arg_ptr = retrieval_arg_list_ptr; table_control_info.incremental_retrieval_char_ptr = char_ptr; return; end retrieve_new; %page; select_uses_different_row_designators: proc () returns (bit (1) aligned); dcl sudrd_loop fixed bin; do sudrd_loop = 2 to select_info.n_user_items; if select_info.user_item.table_name (1) ^= select_info.user_item.table_name (sudrd_loop) then return ("1"b); end; return ("0"b); end select_uses_different_row_designators; %page; store_the_row: proc ( str_table_info_ptr_parm, /* input: ptr to the table_info structure */ str_row_value_ptr_parm, /* input: ptr to the row value */ str_code_parm /* output: success or failure */ ); %skip(1); dcl str_code_parm fixed bin (35) parm; dcl str_descriptor_ptr ptr; dcl str_current_column_number fixed bin; dcl str_loop fixed bin; dcl str_row_value char (table_info.row_value_length) based (str_row_value_ptr); dcl str_row_value_as_an_array (table_info.row_value_length) char (1) based (str_row_value_ptr); dcl str_row_value_ptr ptr; dcl str_row_value_ptr_parm ptr unaligned parm; dcl str_table_info_ptr_parm ptr parm; %skip(1); table_ip = str_table_info_ptr_parm; str_row_value_ptr = str_row_value_ptr_parm; str_code_parm = 0; store_ap = table_info.store_args_ptr; %skip(1); do str_loop = 3 to table_info.column_count + 2; str_current_column_number = str_loop - 2; store_args.arg_ptrs (str_loop) = addr (str_row_value_as_an_array (table_info.columns (str_current_column_number).column_index)); str_descriptor_ptr = addr (table_info.columns.column_data_type (str_current_column_number)); if str_descriptor_ptr -> arg_descriptor.type = bit_dtype then substr (str_row_value, table_info.columns.column_index (str_current_column_number), table_info.columns.column_length (str_current_column_number)) = translate (substr (str_row_value, table_info.columns.column_index (str_current_column_number), table_info.columns.column_length (str_current_column_number)), CHARACTER_ZERO, BLANK); else if str_descriptor_ptr -> arg_descriptor.type = varying_bit_dtype | str_descriptor_ptr -> arg_descriptor.type = varying_char_dtype then store_args.argument_list_descriptors (str_loop).size = length (rtrim (substr (str_row_value, table_info.columns.column_index (str_current_column_number), table_info.columns.column_length (str_current_column_number)))); else; end; %skip(1); call cu_$generate_call (dsl_$store, addr (store_args.header)); str_code_parm = store_args.error_code; %skip(1); return; %skip(1); end store_the_row; %skip(1); %include access_mode_values; %page; %include arg_descriptor; %page; %include arg_list; %page; %include linus_arg_list; %page; %include linus_char_argl; %page; %include linus_lcb; %page; %include linus_rel_array; %page; %include linus_select_info; %page; %include linus_sort_info; %page; %include linus_table_control; %page; %include linus_table_info; %page; %include linus_temp_tab_names; %page; %include mdbm_descriptor; %page; %include mrds_rslt_info; %page; %include sort_seg_info; %page; %include std_descriptor_types; /* Based */ dcl 1 arg_len_bits based, 2 pad bit (12) unal, 2 len bit (24); /* Length of argument to be passed in arg_list */ dcl char_output_string char (table_info.maximum_column_value_length) based (char_string_ptr) varying; dcl component_ptr (table_control_info.max_number_of_components) ptr based (component_ptrs_p); dcl new_component_ptr (table_control_info.max_number_of_components) ptr based (new_component_ptrs_p); dcl component_value (table_control_info.max_number_of_rows_per_seg) char (table_info.row_value_length) based (table_control_info.current_component_ptr); dcl sort_desc_array (sort_info.number_of_columns_to_sort) ptr based (sort_desc_array_ptr); dcl info_area area (sys_info$max_seg_size) based (info_area_p); dcl 1 new_row_segs_info like row_segs_info based (new_row_segs_ip); dcl retrieve_code fixed bin (35) based (retrieve_code_ptr); dcl 1 retrieval_arg_list aligned based (retrieval_arg_list_ptr), 2 header like arg_list.header, 2 arg_ptrs (arg_list_arg_count refer (retrieval_arg_list.header.arg_count)) ptr, 2 desc_ptrs (arg_list_arg_count refer (retrieval_arg_list.header.arg_count)) ptr; dcl retrieval_arg_list_ptr ptr; dcl 1 sort_input aligned based (sort_input_ptr), 2 number_of_ptr_segments fixed bin, 2 number_of_components fixed bin, 2 sorted bit (1), 2 segment_ptr (row_segs_info .number_of_seg_ptrs refer (sort_input.number_of_ptr_segments)) ptr unal init (null), 2 component_ptr (table_control_info .msf_seg_count refer (sort_input.number_of_components)) ptr unal init (null); dcl 1 sort_output based (sort_output_ptr), 2 number_of_segs fixed bin, 2 seg_ptr (row_segs_info .number_of_seg_ptrs refer (sort_output.number_of_segs)) ptr unal init (null); dcl 1 user_item aligned based (user_item_ptr), /* valid when mrds item = user item */ 2 arg_ptr ptr, 2 bit_len fixed bin (35), 2 desc bit (36), 2 assn_type fixed bin, 2 assn_len fixed bin (35); dcl work_area area (sys_info$max_seg_size) based (work_area_p); /* Automatic */ dcl arg_list_arg_count fixed bin (17) unsigned unaligned; dcl bit_count fixed bin (24); dcl caller fixed bin; dcl char_string_ptr ptr; dcl component_ptrs_p ptr init (null); dcl cmpx_float_dec_type fixed bin; dcl duplicate_count fixed bin; dcl expr_results float dec (59); dcl expr_results_ptr ptr; dcl expression_count fixed bin; dcl float_dec_len fixed bin (35); dcl float_dec_type fixed bin; dcl icode fixed bin (35); dcl info_area_p ptr init (null); dcl initial_mrds_vclock float bin (63); dcl initial_vclock float bin (63); dcl item_index fixed bin; dcl keep_from_row fixed bin (35); dcl loop_index fixed bin; dcl my_name char (11) init ("linus_table"); dcl new_component_ptrs_p ptr init (null); dcl new_row_segs_ip ptr init (null); dcl prec_len fixed bin; dcl retrieve_code_ptr ptr; dcl row_count_specified fixed bin; dcl row_index fixed bin; dcl scale_len fixed bin (11); dcl sci_ptr ptr; /* for ssu_ */ dcl sort_desc_array_ptr ptr; dcl sort_input_ptr ptr; dcl sort_output_ptr ptr; dcl target_type fixed bin init (44); /* char * 2 */ dcl temp_ptr ptr init (null); dcl user_item_ptr ptr init (null); dcl work_area_p ptr init (null); /* Builtins */ dcl abs builtin; dcl addr builtin; dcl addrel builtin; dcl ceil builtin; dcl char builtin; dcl divide builtin; dcl fixed builtin; dcl length builtin; dcl log10 builtin; dcl ltrim builtin; dcl max builtin; dcl null builtin; dcl rel builtin; dcl rtrim builtin; dcl substr builtin; dcl sum builtin; dcl translate builtin; dcl unspec builtin; dcl vclock builtin; /* Conditions */ /* Static */ dcl debug_switch bit (1) int static init ("0"b); /* Constants */ dcl ANOTHER char (8) int static options (constant) init ("-another"); dcl ANOTHER_LEN bit (24) init ("000000000000000000001000"b) int static options (constant); dcl BLANK char (1) internal static options (constant) init (" "); dcl CHARACTER_ZERO char (1) internal static options (constant) init ("0"); dcl CREATE bit (1) int static options (constant) init ("1"b); dcl DEFAULT_EXPR_SIZE fixed bin (5) int static options (constant) init (17); dcl DELETE_SEG_SW bit (6) int static options (constant) init ("100100"b); dcl EXPR fixed bin (2) int static options (constant) init (2); dcl EXTENSIBLE bit (1) aligned int static options (constant) init ("1"b); dcl FIXED_DEC_14_3_DESC bit (36) int static options (constant) init ("110101110000000000000011000000001110"b); dcl FLOAT_DEC_59_DESC bit (36) int static options (constant) init ("100101000000000000000000000000111011"b); dcl FREEING bit (1) aligned int static options (constant) init ("0"b); dcl IOARS_STRING char (8) int static options (constant) init ("^.3f"); dcl MRDS fixed bin (2) int static options (constant) init (1); dcl NO_FREEING bit (1) aligned int static options (constant) init ("1"b); dcl NO_ZERO_ON_ALLOC bit (1) aligned int static options (constant) init ("0"b); dcl NO_ZERO_ON_FREE bit (1) aligned int static options (constant) init ("0"b); dcl ROW_SEG_INCREASE fixed bin int static options (constant) init (10); /* External */ dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$no_table fixed bin (35) ext; dcl linus_error_$no_lila_expr_processed fixed bin (35) ext; dcl linus_error_$ret_not_valid fixed bin (35) ext; dcl linus_error_$no_db fixed bin(35) ext static; dcl mrds_data_$max_temp_rels fixed bin (35) ext static; dcl mrds_error_$tuple_not_found fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (35) ext; /* Entries */ dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl cu_$generate_call entry (entry, ptr); dcl dsl_$get_rslt_info entry (fixed bin(35), char(*), ptr, ptr, fixed bin(35)); dcl dsl_$get_temp_info entry (fixed bin(35), fixed bin(35), ptr, ptr, fixed bin(35)); dcl dsl_$retrieve entry options (variable); dcl dsl_$store entry() options(variable); dcl get_pdir_ entry () returns (char (168)); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl linus_eval_expr entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl linus_eval_set_func entry (ptr, ptr, fixed bin (35)); dcl linus_temp_seg_mgr$get_segment entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl linus_temp_seg_mgr$release_segment entry (ptr, char (*), ptr, fixed bin (35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl mdbm_util_$binary_data_class entry (ptr) returns (bit (1) aligned); dcl mdbm_util_$complex_data_class entry (ptr) returns (bit (1) aligned); dcl mdbm_util_$fixed_data_class entry (ptr) returns (bit (1) aligned); dcl mdbm_util_$number_data_class entry (ptr) returns (bit (1) aligned); dcl mdbm_util_$string_data_class entry (ptr) returns (bit (1) aligned); dcl mdbm_util_$varying_data_class entry (ptr) returns (bit (1) aligned); dcl mdb_display_data_value$ptr entry (ptr, ptr); dcl mdbm_util_$mu_define_area entry (ptr, fixed bin (18), char (11), bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl release_area_ entry (ptr); dcl sort_seg_$linus_table entry (ptr, char (*), ptr, entry, entry, char (*), ptr, (*) ptr, ptr, fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$print_message entry () options (variable); dcl unique_chars_ entry (bit (*)) returns (char (15)); end linus_table;  linus_thread_fn_list.pl1 11/20/86 1413.4r w 11/20/86 1145.0 62919 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_thread_fn_list: proc (lcb_ptr, calc_entry, input_file_name, function_name, code); /* DESCRIPTION: Procedure to fill in a linus_set_fn_info block for a builtin or declared set function, given a pointer to the calc. entry in the text portion of the object segment. HISTORY: 76-06-01 J. A. Weeldreyer: Initially written. 80-11-03 Rickie E. Brinegar: changed cent_ptr, a entry pointer, to calc_entry, a link snapped entry. The purpose was to allow path names to be handled and not use cv_ptr_, which does not set up appropriate linkage information. */ %include linus_lcb; %page; %include definition; %page; %include entry_sequence_info; %page; %include object_info; %page; %include linus_set_fn_info; dcl ( b_ptr, /* pointer to base of object */ d_ptr, /* ptr to definition block */ e_ptr, /* pointer to entry sequence */ pd_ptr, /* pointer to parameter descriptor offsets */ s_ptr ) ptr; /* pointer to seg. definition block */ dcl calc_entry entry variable; /* Input: snapped calc entry in object */ dcl i fixed bin; /* internal index */ dcl ( code, /* Output: status code */ icode ) fixed bin (35); /* internal status code */ dcl function_name char (32) var; dcl (file_name, input_file_name) char (168) varying; /* where to look for the function */ dcl 1 obj_info aligned like object_info; /* place for object information */ dcl bc fixed bin (24); /* bit count of object seg */ dcl stype fixed bin (2); /* type code of object seg */ dcl 1 acc aligned based, /* template for acc string */ 2 len fixed bin (8) unal, 2 string char (0 refer (acc.len)) unal; dcl bit36 bit (36) based; /* template for descriptor */ dcl ( linus_error_$cant_ref_fun, linus_error_$incons_fun, sys_info$max_seg_size ) ext fixed bin (35); dcl cleanup condition; dcl (addr, addrel, codeptr, fixed, null, ptr, rel, string) builtin; dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); linus_set_fn_info_ptr = null; /* initiallize */ on cleanup call tidy_up; file_name = input_file_name || "$"; b_ptr = ptr (codeptr (calc_entry), 0); /* point to base of object */ call hcs_$status_mins (b_ptr, stype, bc, icode); /* get bit count of object */ if icode ^= 0 then call error (linus_error_$cant_ref_fun); call object_info_$brief (b_ptr, bc, addr (obj_info), icode); /* get info on obj seg */ if icode ^= 0 then call error (linus_error_$cant_ref_fun); e_ptr = addrel (codeptr (calc_entry), -2); /* point to entry sequence */ if e_ptr -> entry_sequence.flags.has_descriptors then do; /* if have args */ pd_ptr = addrel (obj_info.textp, e_ptr -> entry_sequence.descr_relp_offset); /* point to parameter descriptors */ initial_number_of_set_fn_info_args = fixed (pd_ptr -> parm_desc_ptrs.n_args); /* no. input args */ end; else initial_number_of_set_fn_info_args = 0; alloc linus_set_fn_info in (lcb.static_area); /* alloc. an info block */ string (linus_set_fn_info.flags) = "0"b; /* fill in the block */ linus_set_fn_info.fwd_ptr = lcb.setfi_ptr; linus_set_fn_info.calc_entry = calc_entry; linus_set_fn_info.calc_entry_set = "1"b; d_ptr = addrel (obj_info.defp, e_ptr -> entry_sequence.def_relp); /* point to def. block */ linus_set_fn_info.name = function_name; s_ptr = addrel (obj_info.defp, d_ptr -> definition.segname); /* point to def. block for seg. */ linus_set_fn_info.assign_entry = cv_entry_ (file_name || function_name || "_assign", null, icode); /* set up assignment entry */ if icode ^= 0 then call error (icode); linus_set_fn_info.assign_entry_set = "1"b; if lcb.db_index ^= 0 & ^lcb.new_version then linus_set_fn_info.init_entry_set = "0"b; else do; linus_set_fn_info.init_entry = cv_entry_ (file_name || function_name || "_init", null, icode); /* set up initial entry */ if icode ^= 0 then call error (icode); linus_set_fn_info.init_entry_set = "1"b; end; if e_ptr -> entry_sequence.flags.has_descriptors then do; /* if fixed input */ linus_set_fn_info.info_entry_set = "0"b;/* no info entry in this case */ do i = 1 to linus_set_fn_info.nargs; /* fill in input descriptors */ linus_set_fn_info.arg_desc (i) = addrel (obj_info.textp, pd_ptr -> parm_desc_ptrs.descriptor_relp (i)) -> bit36; end; e_ptr = addrel (codeptr (linus_set_fn_info.assign_entry), -2); /* entry seq. for assign ent. */ if e_ptr -> entry_sequence.flags.has_descriptors then /* get ptr to rslt descr. */ pd_ptr = addrel (obj_info.textp, e_ptr -> entry_sequence.descr_relp_offset); else call error (linus_error_$incons_fun); linus_set_fn_info.rslt_desc = addrel (obj_info.textp, pd_ptr -> parm_desc_ptrs.descriptor_relp (1)) -> bit36; end; /* if fixed args */ else do; /* no descriptors, variable args */ linus_set_fn_info.rslt_desc = "0"b; linus_set_fn_info.nargs = 0; linus_set_fn_info.info_entry = cv_entry_ (file_name || function_name || "_info", null, icode); if icode ^= 0 then call error (linus_error_$cant_ref_fun); linus_set_fn_info.info_entry_set = "1"b; end; /* if variable args */ lcb.setfi_ptr = linus_set_fn_info_ptr; /* put block at head of list */ code = 0; exit: return; error: proc (cd); /* error procedure */ dcl cd fixed bin (35); code = cd; call tidy_up; go to exit; end error; tidy_up: proc; /* Procedure to clean up our mess */ if setfi_ptr ^= null & setfi_ptr ^= lcb.setfi_ptr then free linus_set_fn_info; end tidy_up; end linus_thread_fn_list;  linus_write.pl1 03/16/88 0829.2rew 03/15/88 1551.4 58581 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-14,Blair), install(88-03-15,MR12.2-1036): Implemented the -progress/-no_progress control arguments. END HISTORY COMMENTS */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus write request. Description and usage follows. Description: This request retrieves the selected data from the data base and writes it to a file. Usage: "write pathname {-control_args}" where pathname is the name of the file which will contain the data. -control_args can be: -column_delimiter X -- the delimiter used to separate column values. X can be any single ascii character (default is one blank). The old control arg -delimiter is still accepted but not documented. -extend -- the file is extended rather than truncated. -progress {N} -- prints a progress report every N tuples, where N defaults to linus_data_$trace_every_n_tuples if not specified. -row_delimiter X -- the delimiter used to separate rows. X can be any single ascii character (default is newline character). -truncate -- the file is truncated rather than extended (default). Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - September 1983 - complete rewrite of old module. */ %page; linus_write: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); /* Mainline Processing Overview: (1) Process control arguments setting flags and collecting values. (2) Have the subroutine do all the work (it reports errors and calls ssu_$abort_line if things don't go well). */ %skip(3); call initialize; call process_args; call linus_create_data_file (lcb_ptr, addr (data_file_info)); %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); unspec (data_file_info) = OFF; data_file_info.column_delimiter = BLANK; data_file_info.row_delimiter = NEWLINE; data_file_info.flags.truncate_file = ON; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "An output file pathname must be supplied."); %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); data_file_info.output_file_pathname = arg; %skip(1); return; %skip(1); end initialize; %page; process_args: proc; do current_arg_number = 2 to number_of_args_supplied; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg = "-extend" then data_file_info.flags.truncate_file = OFF; else if arg = "-truncate" | arg = "-tc" then data_file_info.flags.truncate_file = ON; else if arg = "-no_progress" | arg = "-npg" then do; data_file_info.flags.tracing = OFF; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; end; else if arg = "-progress" | arg = "-pg" then call setup_tracing; else if arg = "-column_delimiter" | arg = "-cdm" | arg = "-delimiter" | arg = "-dm" | arg = "-row_delimiter" | arg = "-rdm" then call setup_delimiter; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a is not a valid control argument.", arg); end; return; %page; setup_delimiter: proc; if current_arg_number + 1 > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/^[-row_delimiter^;-column_delimiter^] must be followed by a delimiter.", (arg = "-row_delimiter" | arg = "-rdm")); current_arg_number = current_arg_number + 1; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg_length ^= 1 then call ssu_$abort_line (sci_ptr, 0, "The specified delimiter ""^a"" is not a single ascii character.", arg); if (arg = "-row_delimiter" | arg = "-rdm") then data_file_info.row_delimiter = arg; else data_file_info.column_delimiter = arg; return; end setup_delimiter; %page; setup_tracing: proc; data_file_info.tracing = ON; if current_arg_number + 1 > number_of_args_supplied then return; call ssu_$arg_ptr (sci_ptr, current_arg_number + 1, arg_ptr, arg_length); if verify (arg, "01234546789") = 0 then do; data_file_info.trace_every_n_tuples = convert (data_file_info.trace_every_n_tuples, arg); current_arg_number = current_arg_number + 1; end; return; end setup_tracing; end process_args; %page; dcl BLANK char (1) static internal options (constant) init (" "); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl current_arg_number fixed bin; %skip(1); dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; %skip(1); dcl lcb_ptr ptr; dcl linus_create_data_file entry (ptr, ptr); dcl linus_data_$trace_every_n_tuples fixed bin (35) external static; %skip(1); dcl number_of_args_supplied fixed bin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); %skip(1); dcl unspec builtin; %page; %include linus_data_file_info; %skip(3); end linus_write; */ ----------------------------------------------------------- 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 */