1 /* ***********************************************************
  2    *                                                         *
  3    *                                                         *
  4    * Copyright, (C) Honeywell Information Systems Inc., 1981 *
  5    *                                                         *
  6    *                                                         *
  7    *********************************************************** */
  8 
  9 /* ******************************************************
 10    *                                                    *
 11    *                                                    *
 12    * Copyright (c) 1972 by Massachusetts Institute of   *
 13    * Technology and Honeywell Information Systems, Inc. *
 14    *                                                    *
 15    *                                                    *
 16    ****************************************************** */
 17 
 18 linus_declare:
 19      proc (sci_ptr, lcb_ptr);
 20 
 21 /* DESCRIPTION:
 22 
 23    This procedure implements the LINUS declare request.  There must be exactly
 24    two  arguments  supplied,  namely  function  name  and  function type.  Set
 25    functions are threaded into the set function list, and scalar functions are
 26    declared  to MRDS and their names are threaded into a scalar function list.
 27 
 28 
 29 
 30    HISTORY:
 31 
 32    77-06-01 J. A. Weeldreyer: Initially written.
 33 
 34    80-10-17  Rickie  E.   Brinegar: changed hcs_$make_ptr for a combination of
 35    expand_pathname_ and cv_ptr_ inorder to allow for absolute pathnames in set
 36    functions.   A similar change was made to mrds_dsl_declare to handle scalar
 37    functions.
 38 
 39    80-11-03 Rickie E. Brinegar: cv_ptr_ changed to cv_entry_.
 40 
 41    81-11-13 Rickie E. Brinegar: Added timing of dsl_$declare.
 42 
 43    82-02-10 Paul W. Benjamin: ssu_ conversion
 44 
 45    82-06-21 Al Dupuis: Following changes resulting from audit of ssu_
 46                        conversion. Remove kill/nokill comment from code
 47                        as it was no longer meaningfull. Remove NO_KILL
 48                        usage as it no longer had meaning either.
 49 */
 50 ^L
 51 %include linus_lcb;
 52 %page;
 53 %include linus_char_argl;
 54 %page;
 55 %include linus_scal_fn_info;
 56 ^L
 57           dcl     sci_ptr                ptr;               /* for ssu_ */
 58 
 59           dcl     (
 60                   code,
 61                   icode
 62                   )                      fixed bin (35);    /* internal status code */
 63 
 64           dcl     initial_mrds_vclock    float bin (63);
 65 
 66           dcl     name                   char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1));
 67                                                             /* function name */
 68           dcl     type                   char (char_argl.arg.arg_len (2)) based (char_argl.arg.arg_ptr (2));
 69                                                             /* function type */
 70           dcl     file_name              char (168) varying;
 71 
 72           dcl     (directory, entry_name) char (168);
 73 
 74           dcl     (
 75                   linus_data_$dcl_id,
 76                   linus_error_$bad_num_args,
 77                   linus_error_$inv_fn_type,
 78                   linus_error_$no_db,
 79                   sys_info$max_seg_size
 80                   )                      fixed bin (35) ext;
 81 
 82           dcl     cleanup                condition;
 83 
 84           dcl     (addr, fixed, null, rel, rtrim, vclock) builtin;
 85 
 86           dcl     calc_entry             entry variable;    /* virtual entry to set function calc. entry */
 87 
 88           dcl     cv_entry_              entry (char (*), ptr, fixed bin (35)) returns (entry);
 89           dcl     expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
 90           dcl     dsl_$declare           entry (fixed bin (35), char (*), fixed bin (35));
 91           dcl     linus_convert_code     entry (fixed bin (35), fixed bin (35), fixed bin (35));
 92           dcl     linus_thread_fn_list
 93                                          entry (ptr, entry, char (168) varying, char (32) varying,
 94                                          fixed bin (35));
 95           dcl     ssu_$abort_line        entry options (variable);
 96           dcl     ssu_$arg_count         entry (ptr, fixed bin);
 97           dcl     ssu_$arg_ptr           entry (ptr, fixed bin, ptr, fixed bin (21));
 98 ^L
 99           sclfi_ptr, ca_ptr = null;                         /* initiallize */
100           on cleanup call tidy_up;
101 
102           if lcb.db_index = 0 then
103                call error (linus_error_$no_db, "");
104           call ssu_$arg_count (sci_ptr, nargs_init);
105           if nargs_init = 0 then
106                call error (linus_error_$bad_num_args, "");
107           if nargs_init ^= 2 then /* must have correct no. args */
108                call error (linus_error_$bad_num_args, "");
109           allocate char_argl in (lcb.static_area);
110           call ssu_$arg_ptr (sci_ptr, 1, char_argl.arg.arg_ptr (1), char_argl.arg.arg_len (1));
111           call ssu_$arg_ptr (sci_ptr, 2, char_argl.arg.arg_ptr (2), char_argl.arg.arg_len (2));
112           file_name = rtrim (name);
113 
114           if type = "set" then do;                          /* set function */
115                     call expand_pathname_ (name, directory, entry_name, icode);
116                     if icode ^= 0 then
117                          call error (icode, name);
118                     calc_entry =
119                          cv_entry_ (rtrim (directory) || ">" || rtrim (entry_name) || "$"
120                          || rtrim (entry_name) || "_calc", null, icode);
121                     if icode ^= 0 then
122                          call error (icode, file_name || " calc. entry.");
123                     call
124                          linus_thread_fn_list (lcb_ptr, calc_entry, file_name,
125                          rtrim (entry_name), icode);        /* put into fn. list */
126                     if icode ^= 0 then
127                          call error (icode, name);
128                end;                                         /* if set function */
129 
130           else if type = "scalar" then do;                  /* if scalar function */
131                     if lcb.timing_mode then
132                          initial_mrds_vclock = vclock;
133                     call dsl_$declare (lcb.db_index, name, icode); /* let MRDS know about it */
134                     if lcb.timing_mode then
135                          lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
136                     if icode ^= 0 then
137                          call error (icode, name);
138                     allocate scal_fn_info in (lcb.static_area);
139                     scal_fn_info.name = rtrim (entry_name); /* fill in scal_fn_info block */
140                     scal_fn_info.fwd_ptr = lcb.sclfi_ptr;   /* put at head of list */
141                     lcb.sclfi_ptr = sclfi_ptr;
142                end;                                         /* if scalar function */
143           else call error (linus_error_$inv_fn_type, type);
144 
145           if ca_ptr ^= null
146           then free char_argl;
147           return;
148 ^L
149 error:
150      proc (cd, msg);
151 
152 /* error procedure */
153 
154           dcl     (cd, ucd)              fixed bin (35);
155 
156           dcl     msg                    char (*);
157 
158           call tidy_up;
159           call linus_convert_code (cd, ucd, linus_data_$dcl_id); /* so LINUS user can understand */
160           call ssu_$abort_line (sci_ptr, ucd, msg);
161 
162      end error;
163 ^L
164 tidy_up:
165      proc;
166 
167 /* procedure to clean up allocated structures */
168 
169           if sclfi_ptr ^= null then
170                if sclfi_ptr ^= lcb.sclfi_ptr then
171                     free scal_fn_info;
172           if ca_ptr ^= null
173           then free char_argl;
174 
175      end tidy_up;
176 
177      end linus_declare;