



		    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

*/
