1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
  4         *                                                         *
  5         * Copyright (c) 1972 by Massachusetts Institute of        *
  6         * Technology and Honeywell Information Systems, Inc.      *
  7         *                                                         *
  8         *********************************************************** */
  9 
 10 
 11 
 12 /****^  HISTORY COMMENTS:
 13   1) change(86-01-13,Dupuis), approve(86-01-13,MCR7188), audit(86-07-23,GWMay),
 14      install(86-07-29,MR12.0-1106):
 15      84-12-01 Al Dupuis: Renamed sfr_ptr to force_retrieve_scope_info_ptr and
 16      force_ret structure to forced_retrieve_scope_info.
 17                                                    END HISTORY COMMENTS */
 18 
 19 
 20 linus_close:
 21      proc (sci_ptr, lcb_ptr);
 22 
 23 /*  DESCRIPTION:
 24 
 25    The data base is closed in the user specified mode via a call to dsl_$close.
 26 
 27    Linus Command:     close (c)
 28 
 29 
 30    HISTORY:
 31 
 32    77-03-01 J. C. C. Jagernauth: Initially written.
 33 
 34    78-09-01 J. C. C. Jagernauth: Modified for MR7.0.
 35 
 36    80-06-01  Jim  Gray  :  Modified  to allow close to work even when database
 37    already  closed outside of linus, without blowing up, and to clean up close
 38    processing.
 39 
 40    81-11-06  Rickie  E.   Brinegar:  Removed  calls  to  linus_free_se  as the
 41    selection expression is now allocated in the lila temporary segment.
 42 
 43    82-02-09  Paul W. Benjamin: ssu_ conversion.
 44 
 45    82-06-03  DJ Schimke: Added code to set si_ptr to null denying any
 46    succeeding opening access to the processed selection expression from
 47    this opening (TR phx13269).
 48 
 49 */
 50 ^L
 51 %include linus_lcb;
 52 %page;
 53 %include linus_forced_scope_info;
 54 %page;
 55 %include linus_ready_data;
 56 %page;
 57 %include linus_ready_table;
 58 %page;
 59 %include linus_temp_tab_names;
 60 %page;
 61 ^L
 62           dcl     sci_ptr                ptr;               /* for ssu_ */
 63 
 64           dcl     dsl_$close             entry options (variable); /*  MRDS Subroutine  */
 65           dcl     (
 66                   linus_data_$c_id,                         /* Linus data */
 67                   linus_error_$no_db,                       /* Linus error code */
 68                   linus_error_$no_input_arg_reqd,
 69                   mrds_data_$max_temp_rels,
 70                   sys_info$max_seg_size
 71                   )                      ext fixed bin (35);
 72 
 73           dcl     initial_mrds_vclock    float bin (63);
 74 
 75           dcl     cleanup                condition;
 76 
 77           dcl     i                      fixed bin;
 78 
 79           dcl     (addr, fixed, null, rel, vclock) builtin;
 80 
 81           dcl     nargs                  fixed;
 82 
 83           dcl     (icode, code, out_code) fixed bin (35);
 84 
 85           dcl     linus_print_error      entry (fixed bin (35), char (*));
 86           dcl     linus_convert_code     entry (fixed bin (35), fixed bin (35), fixed bin (35));
 87           dcl     ssu_$arg_count         entry (ptr, fixed bin);
 88 ^L
 89           on cleanup call clean_up;
 90 
 91           icode, code = 0;
 92           call ssu_$arg_count (sci_ptr, nargs);
 93           if nargs ^= 0 then
 94                call linus_print_error (linus_error_$no_input_arg_reqd, "");
 95                                                             /* No argument should be
 96                                                                passed */
 97           else if lcb.db_index = 0 then
 98                call linus_print_error (linus_error_$no_db, "");
 99           else call main_close;
100 ^L
101 main_close:
102      proc;
103 
104           declare temp_index             fixed bin (35);
105 
106           if lcb.db_index ^= 0 then do;
107                     temp_index = lcb.db_index;              /* use force close philosophy */
108                     lcb.db_index = 0;
109                     if lcb.timing_mode then
110                          initial_mrds_vclock = vclock;
111                     call dsl_$close (temp_index, icode);    /* Try to close data base */
112                     if lcb.timing_mode then
113                          lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
114                end;
115 
116 
117           if icode ^= 0 then do;
118                     call linus_convert_code (icode, out_code, linus_data_$c_id);
119                                                             /* Convert system error code */
120                     call linus_print_error (out_code, "");  /* Print linus error */
121                end;
122 
123           if lcb.force_retrieve_scope_info_ptr ^= null then do;
124                     free lcb.force_retrieve_scope_info_ptr -> forced_retrieve_scope_info;
125                     lcb.force_retrieve_scope_info_ptr = null;
126                end;
127 
128           lcb.si_ptr = null;                                /* delete processed selection expression */
129 
130           if lcb.ttn_ptr ^= null then do;
131                     ttn_ptr = lcb.ttn_ptr;
132                     do i = 1 to mrds_data_$max_temp_rels;
133                          temp_tab_names (i) = "";
134                     end;
135                end;
136 
137           if lcb.rd_ptr ^= null then do;
138                     free lcb.rd_ptr -> ready_data;
139                     lcb.rd_ptr = null;
140                end;
141           if lcb.rt_ptr ^= null then do;
142                     free lcb.rt_ptr -> ready_table;
143                     lcb.rt_ptr = null;
144                end;
145 
146      end main_close;
147 ^L
148 
149 
150 clean_up:
151      proc;
152 
153           call main_close;
154 
155      end clean_up;
156 
157 
158      end linus_close;