1 /* zzrvar.f -- translated by f2c (version 19980913).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include "f2c.h"
7
8 /* Table of constant values */
9
10 static integer c__32 = 32;
11 static integer c__132 = 132;
12
13 /* $Procedure ZZRVAR ( Private --- Pool, read the next kernel variable ) */
zzrvar_(integer * namlst,integer * nmpool,char * names,integer * datlst,integer * dppool,doublereal * dpvals,integer * chpool,char * chvals,char * varnam,logical * eof,ftnlen names_len,ftnlen chvals_len,ftnlen varnam_len)14 /* Subroutine */ int zzrvar_(integer *namlst, integer *nmpool, char *names,
15 integer *datlst, integer *dppool, doublereal *dpvals, integer *chpool,
16 char *chvals, char *varnam, logical *eof, ftnlen names_len, ftnlen
17 chvals_len, ftnlen varnam_len)
18 {
19 /* Initialized data */
20
21 static logical first = TRUE_;
22
23 /* System generated locals */
24 integer i__1, i__2;
25
26 /* Builtin functions */
27 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
28 integer i_len(char *, ftnlen), s_rnge(char *, integer, char *, integer),
29 s_cmp(char *, char *, ftnlen, ftnlen);
30
31 /* Local variables */
32 static integer head, code, itab;
33 static char name__[132], file[255];
34 static integer free, begs[132], node;
35 static char line[132];
36 static integer tail, ends[132];
37 static logical even, full;
38 static integer type__[132], b, e, i__, j, badat;
39 extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
40 ftnlen, ftnlen), lnkan_(integer *, integer *);
41 static logical found;
42 static integer ncomp, lstnb, count;
43 static char error[255];
44 static integer iplus;
45 extern integer rtrim_(char *, ftnlen);
46 extern /* Subroutine */ int zzcln_(integer *, integer *, integer *,
47 integer *, integer *, integer *, integer *);
48 static integer r1, r2;
49 extern logical failed_(void);
50 static integer at, datahd, iblank, chnode, icomma, nameat, dpnode;
51 extern /* Subroutine */ int rdkdat_(char *, logical *, ftnlen), lnkila_(
52 integer *, integer *, integer *);
53 static integer iequal;
54 extern integer lastnb_(char *, ftnlen), lastpc_(char *, ftnlen), lnknfn_(
55 integer *);
56 static integer ilparn, irparn, itmark;
57 static doublereal dvalue;
58 static integer dirctv, lookat, iquote;
59 extern integer zzhash_(char *, ftnlen);
60 static integer number, varlen;
61 static logical intokn, insepf;
62 extern logical return_(void);
63 static logical inquot;
64 static integer status, vartyp;
65 extern /* Subroutine */ int chkout_(char *, ftnlen);
66 static integer nxttok;
67 extern /* Subroutine */ int rdklin_(char *, integer *, ftnlen), setmsg_(
68 char *, ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char
69 *, ftnlen), lnkfsl_(integer *, integer *, integer *), tparse_(
70 char *, doublereal *, char *, ftnlen, ftnlen), nparsd_(char *,
71 doublereal *, char *, integer *, ftnlen, ftnlen);
72
73 /* $ Abstract */
74
75 /* SPICE Private routine intended solely for the support of SPICE */
76 /* routines. Users should not call this routine directly due */
77 /* to the volatile nature of this routine. */
78
79 /* Read the next variable from a SPICE ASCII kernel file into */
80 /* the kernel pool. */
81
82 /* $ Disclaimer */
83
84 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
85 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
86 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
87 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
88 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
89 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
90 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
91 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
92 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
93 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
94
95 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
96 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
97 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
98 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
99 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
100 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
101
102 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
103 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
104 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
105 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
106
107 /* $ Required_Reading */
108
109 /* PRIVATE KERNEL */
110
111 /* $ Keywords */
112
113 /* FILES */
114
115 /* $ Declarations */
116 /* $ Brief_I/O */
117
118 /* VARIABLE I/O DESCRIPTION */
119 /* -------- --- -------------------------------------------------- */
120 /* NAMLST I/O array of collision resolution list heads. */
121 /* NMPOOL I/O linked list pool of collision resolution lists. */
122 /* NAMES I/O array of names of kernel pool variables. */
123 /* DATLST I/O array of heads of lists of variable values. */
124 /* DPPOOL I/O linked list pool of pointer lists to d.p. values. */
125 /* DPVALS I/O array of d.p. kernel pool values. */
126 /* CHPOOL I/O linked list pool of pointer lists to string values. */
127 /* CHVALS I/O array of string kernel pool values. */
128 /* VARNAM O name of variable parsed. */
129 /* EOF O if TRUE end of input file has been reached. */
130
131 /* $ Detailed_Input */
132
133
134 /* NAMLST this collection of arrays together with the hash */
135 /* NMPOOL function ZZHASH provide the mechanism for storing */
136 /* NAMES and retrieving kernel pool variables. */
137 /* DATLST */
138 /* DPPOOL Given a potential variable name NAME the function */
139 /* DPVALS ZZHASH(NAME) gives the location in the array in */
140 /* CHPOOL NAMLST where one should begin looking for the */
141 /* CHVALS kernel pool variable NAME. */
142
143 /* If NAMLST( ZZHASH(NAME) ) is zero, there is no kernel */
144 /* pool variable corresponding to NAME. If it is non-zero */
145 /* then NAMLST is the head node of a linked list of names */
146 /* that evaluate to the same integer under the function */
147 /* ZZHASH. Letting NODE = NAMLST( ZZHASH(NAME) ) check */
148 /* NAMES(NODE) for equality with NAME. If there is */
149 /* no match find the next node ( NMPOOL(NEXT,NODE) ) until */
150 /* a match occurs or all nodes of the list have been */
151 /* examined. To insert a new NAME allocate a node NEW from */
152 /* the free list of NMPOOL and append it to the tail of the */
153 /* list pointed to by NAMLST ( ZZHASH(NAME) ). */
154
155 /* Once a node for NAME is located (call it NAMEAT) */
156 /* the values for NAME can be found by examining */
157 /* DATLST(NAMEAT). If zero, no values have yet been */
158 /* given to NAME. If less than zero, -DATLST(NAMEAT) */
159 /* is the head node of a list in CHPOOL that gives the */
160 /* indexes of the values of NAME in CHVALS. If greater */
161 /* than zero, DATLST(NAMEAT) is the head node of a list */
162 /* in DPPOOL that gives the indexes of the values of NAME */
163 /* in DPVALS. */
164
165 /* $ Detailed_Output */
166
167
168 /* NAMLST is the same structure as input but updated to */
169 /* NMPOOL include the next variable read from the current */
170 /* NAMES active text kernel in RDKER. */
171 /* DATLST */
172 /* DPPOOL */
173 /* DPVALS */
174 /* CHPOOL */
175 /* CHVALS */
176
177 /* VARNAM is the name of the variable. VARNAM is blank if */
178 /* no variable is read. */
179
180 /* EOF is true when the end of the kernel file has been */
181 /* reached, and is false otherwise. The kernel file */
182 /* is closed automatically when the end of the file */
183 /* is reached. */
184
185 /* $ Parameters */
186
187 /* LINLEN is the maximum length of a line in the kernel file. */
188
189 /* MAXLEN is the maximum length of the variable names that */
190 /* can be stored in the kernel pool (also set in */
191 /* pool.f). */
192
193 /* $ Exceptions */
194
195
196 /* 1) The error 'SPICE(BADTIMESPEC)' is signaled if a value */
197 /* beginning with '@' cannot be parsed as a time. */
198
199 /* 2) The error 'SPICE(BADVARASSIGN)' is signaled if variable */
200 /* assignment does not have the form NAME = [(] value [ value ) ]. */
201
202 /* 3) The error 'SPICE(KERNELPOOLFULL)' is signaled if there is */
203 /* no room left in the kernel pool to store another variable */
204 /* or value. */
205
206 /* 4) The error 'SPICE(NONPRINTINGCHAR)' is signaled if the name */
207 /* in a variable assignment contains a non-printing character. */
208
209 /* 5) The error 'SPICE(NUMBEREXPECTED)' is signaled if a value */
210 /* that is unquoted cannot be parsed as time or number. */
211
212 /* 6) The error 'SPICE(TYPEMISMATCH)' is signalled if a variable */
213 /* has a first value of one type (numeric or character) and */
214 /* a subsequent component has the other type. */
215
216 /* 7) The error 'SPICE(BADVARNAME)' signals if a kernel pool */
217 /* variable name length exceeds MAXLEN. */
218
219 /* $ Files */
220
221 /* ZZRVAR reads from the file most recently opened by RDKNEW. */
222
223 /* $ Particulars */
224
225 /* None. */
226
227 /* $ Examples */
228
229 /* See POOL (entry point LDPOOL). */
230
231 /* $ Restrictions */
232
233 /* The input file must be opened and initialized by RDKNEW prior */
234 /* to the first call to ZZRVAR. */
235
236 /* $ Literature_References */
237
238 /* None. */
239
240 /* $ Author_and_Institution */
241
242 /* W.L. Taber (JPL) */
243 /* B.V. Semenov (JPL) */
244
245 /* $ Version */
246
247 /* - SPICELIB Version 1.7.0, 08-FEB-2010 (EDW) */
248
249 /* Added an error check on the length of the kernel pool variable */
250 /* name read from the kernel file. */
251
252 /* - SPICELIB Version 1.6.0, 06-AUG-2002 (BVS) */
253
254 /* Modified to make sure that DO WHILE loop that looks for the */
255 /* end of string variable value always exits. */
256
257 /* - SPICELIB Version 1.5.0, 07-APR-2000 (WLT) */
258
259 /* Happy Birthday Alex. Added check to the assignment to CHVALS */
260 /* so that we cannot store data past the end of the string. */
261
262 /* - SPICELIB Version 1.4.0, 22-MAR-1999 (WLT) */
263
264 /* Added code to detect and signal an error for empty */
265 /* vector assignment. */
266
267 /* - SPICELIB Version 1.3.0, 16-JAN-1997 (WLT) */
268
269 /* The error message regarding the directives allowed */
270 /* in a keyword = value directive was updated. */
271
272 /* - SPICELIB Version 1.1.0, 25-JUN-1996 (WLT) */
273
274 /* The error message for unparsed numeric components */
275 /* was corrected so that it now shows the line and */
276 /* line number on which the error occurred. */
277
278 /* - SPICELIB Version 1.0.0, 20-SEP-1995 (WLT) */
279
280 /* -& */
281
282
283 /* SPICELIB functions */
284
285
286 /* Local parameters. */
287
288 /* Below are a collection of enumerated lists that are used */
289 /* to discern what part of the processing we are in and what */
290 /* kind of entity we are dealing with. First the overall */
291 /* processing flow of a variable assignment. */
292
293
294 /* Next we have the various types of tokens that can be found */
295 /* in the parsing of an input line */
296
297 /* Q --- quoted (or protected tokens) */
298 /* NQ --- unquoted tokens */
299 /* BV --- beginning of a vector */
300 /* EV --- ending of a vector */
301 /* EQ --- equal sign */
302 /* EQP --- equal sign plus */
303
304
305 /* A variable can have one of three types as we process */
306 /* it. It can have an unknown type UNKNWN, STRTYP or NUMTYP. */
307
308
309
310 /* The next two parameters indicate which component of a linked */
311 /* list node point to the previous node and the next node. */
312
313
314 /* The next collection of variables are set up in first pass */
315 /* through this routine. They would be parameters if FORTRAN */
316 /* allowed us to do this in a standard way. */
317
318
319 /* The logicals below are used to take apart the tokens in an */
320 /* input line. */
321
322
323 /* The following logicals are in-line functions that are used */
324 /* when processing the input strings. */
325
326
327 /* Save everything. */
328
329
330 /* Below are a collection of In-line function definitions that are */
331 /* intended to make the code a bit easier to write and read. */
332
333
334 /* Standard SPICE error handling. */
335
336 if (return_()) {
337 return 0;
338 } else {
339 chkin_("ZZRVAR", (ftnlen)6);
340 }
341
342 /* Initializations. */
343
344 if (first) {
345 first = FALSE_;
346 icomma = ',';
347 iblank = ' ';
348 iquote = '\'';
349 ilparn = '(';
350 irparn = ')';
351 iequal = '=';
352 iplus = '+';
353 itmark = '@';
354 itab = 9;
355 }
356
357 /* No variable yet and no parsing errors so far. */
358
359 s_copy(name__, " ", (ftnlen)132, (ftnlen)1);
360 s_copy(error, " ", (ftnlen)255, (ftnlen)1);
361 ncomp = 0;
362
363 /* Get the next data line. Unless something is terribly wrong, */
364 /* this will begin a new variable definition. We have to read */
365 /* the whole variable, unless we get an error, in which case */
366 /* we can quit. */
367
368 status = 1;
369 while(status != 2 && ! failed_()) {
370 rdkdat_(line, eof, (ftnlen)132);
371 if (*eof) {
372 chkout_("ZZRVAR", (ftnlen)6);
373 return 0;
374 }
375
376 /* Find the "tokens" in the input line. As you scan from left */
377 /* to right along the line, exactly one of the following */
378 /* conditions is true. */
379
380 /* 1) You are in a separator field */
381 /* 4) You are in a quoted substring */
382 /* 5) You are in a non-quoted substring that isn't a separator */
383 /* field. */
384
385 /* Stuff between separator fields are regarded as tokens. Note */
386 /* this includes quoted strings. */
387
388 /* In addition we keep track of 3 separators: '=', '(', ')' */
389 /* Finally, whenever we encounters the separator '=', we back */
390 /* up and see if it is preceded by a '+', if so we attach */
391 /* it to the '=' and treat the pair of characters as a single */
392 /* separator. */
393
394 even = TRUE_;
395 intokn = FALSE_;
396 inquot = FALSE_;
397 insepf = TRUE_;
398 count = 0;
399 i__ = 0;
400 while(i__ < i_len(line, (ftnlen)132)) {
401
402 /* The current character is either a separator, quote or */
403 /* some other character. */
404
405 ++i__;
406 code = *(unsigned char *)&line[i__ - 1];
407 if (code == iblank || code == icomma || code == ilparn || code ==
408 irparn || code == iequal || code == itab) {
409
410 /* There are 3 possible states we could be in */
411 /* Separation Field */
412 /* A quoted substring with the last quote an odd one. */
413 /* A quoted substring with the last quote an even one. */
414 /* A non-quoted token. */
415 /* In the first two cases nothing changes, but in the */
416 /* next two cases we transition to a separation field. */
417
418 if (intokn || inquot && even) {
419 inquot = FALSE_;
420 intokn = FALSE_;
421 insepf = TRUE_;
422 }
423 if (insepf) {
424
425 /* We need to see if this is one of the special */
426 /* separators */
427
428 if (code == iequal) {
429 ++count;
430 begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
431 s_rnge("begs", i__1, "zzrvar_", (ftnlen)555)]
432 = i__;
433 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
434 s_rnge("type", i__1, "zzrvar_", (ftnlen)556)]
435 = 5;
436 ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
437 s_rnge("ends", i__1, "zzrvar_", (ftnlen)557)]
438 = i__;
439 if (i__ > 1) {
440
441 /* Look back at the previous character. */
442 /* See if it is a plus character. */
443
444 i__1 = i__ - 2;
445 code = *(unsigned char *)&line[i__1];
446 if (code == iplus) {
447
448 /* This is the directive '+=' we need */
449 /* to set the beginning of this token */
450 /* to the one before this and adjust */
451 /* the end of the last token. */
452
453 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ?
454 i__1 : s_rnge("type", i__1, "zzrvar_"
455 , (ftnlen)573)] = 6;
456 begs[(i__1 = count - 1) < 132 && 0 <= i__1 ?
457 i__1 : s_rnge("begs", i__1, "zzrvar_",
458 (ftnlen)574)] = i__ - 1;
459 if (begs[(i__1 = count - 2) < 132 && 0 <=
460 i__1 ? i__1 : s_rnge("begs", i__1,
461 "zzrvar_", (ftnlen)576)] == ends[(
462 i__2 = count - 2) < 132 && 0 <= i__2 ?
463 i__2 : s_rnge("ends", i__2, "zzrvar_"
464 , (ftnlen)576)]) {
465 --count;
466 begs[(i__1 = count - 1) < 132 && 0 <=
467 i__1 ? i__1 : s_rnge("begs", i__1,
468 "zzrvar_", (ftnlen)580)] = i__ -
469 1;
470 ends[(i__1 = count - 1) < 132 && 0 <=
471 i__1 ? i__1 : s_rnge("ends", i__1,
472 "zzrvar_", (ftnlen)581)] = i__;
473 type__[(i__1 = count - 1) < 132 && 0 <=
474 i__1 ? i__1 : s_rnge("type", i__1,
475 "zzrvar_", (ftnlen)582)] = 6;
476 } else {
477 ends[(i__1 = count - 2) < 132 && 0 <=
478 i__1 ? i__1 : s_rnge("ends", i__1,
479 "zzrvar_", (ftnlen)586)] = ends[(
480 i__2 = count - 2) < 132 && 0 <=
481 i__2 ? i__2 : s_rnge("ends", i__2,
482 "zzrvar_", (ftnlen)586)] - 1;
483 }
484 }
485 }
486 } else if (code == irparn) {
487 ++count;
488 begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
489 s_rnge("begs", i__1, "zzrvar_", (ftnlen)597)]
490 = i__;
491 ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
492 s_rnge("ends", i__1, "zzrvar_", (ftnlen)598)]
493 = i__;
494 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
495 s_rnge("type", i__1, "zzrvar_", (ftnlen)599)]
496 = 4;
497 } else if (code == ilparn) {
498 ++count;
499 begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
500 s_rnge("begs", i__1, "zzrvar_", (ftnlen)604)]
501 = i__;
502 ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
503 s_rnge("ends", i__1, "zzrvar_", (ftnlen)605)]
504 = i__;
505 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
506 s_rnge("type", i__1, "zzrvar_", (ftnlen)606)]
507 = 3;
508 }
509 }
510 } else if (code == iquote) {
511
512 /* There are 3 cases of interest. */
513 /* We are in a quoted substring already */
514 /* We are in a separator field */
515 /* We are in a non-quoted token. */
516 /* In the first case nothing changes. In the second */
517 /* two cases we change to being in a quoted substring. */
518
519 even = ! even;
520 if (! inquot) {
521 insepf = FALSE_;
522 intokn = FALSE_;
523 inquot = TRUE_;
524 ++count;
525 begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
526 s_rnge("begs", i__1, "zzrvar_", (ftnlen)629)] =
527 i__;
528 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
529 s_rnge("type", i__1, "zzrvar_", (ftnlen)630)] = 1;
530 }
531 ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
532 "ends", i__1, "zzrvar_", (ftnlen)634)] = i__;
533 } else {
534
535 /* This is some character other than a quote, or */
536 /* separator character. */
537
538 /* We are in one of four situations. */
539
540 /* 1) We are in a quoted substring with an odd number of */
541 /* quotes. */
542 /* 2) We are in a quoted substring with an even number of */
543 /* quotes. */
544 /* 2) We are in a separator field */
545 /* 3) We are in a non-quoted token. */
546
547 /* In cases 1 and 3 nothing changes. So we won't check */
548 /* those cases. */
549
550 if (insepf || inquot && even) {
551 inquot = FALSE_;
552 insepf = FALSE_;
553 intokn = TRUE_;
554 ++count;
555 begs[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
556 s_rnge("begs", i__1, "zzrvar_", (ftnlen)659)] =
557 i__;
558 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 :
559 s_rnge("type", i__1, "zzrvar_", (ftnlen)660)] = 2;
560 }
561 ends[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
562 "ends", i__1, "zzrvar_", (ftnlen)663)] = i__;
563 }
564 }
565
566 /* The first word on the first line should be the name of a */
567 /* variable. The second word should be a directive: = or +=. */
568
569 if (status == 1) {
570
571 /* There must be at least 3 contributing tokens on this line. */
572
573 if (count < 3) {
574 rdklin_(file, &number, (ftnlen)255);
575 setmsg_("A kernel variable was not properly formed on line #"
576 " of the file #. Such an assignment should have the f"
577 "orm: '<variable name> [+]= <values>'. This line was "
578 "'#'. ", (ftnlen)160);
579 r1 = rtrim_(file, (ftnlen)255);
580 r2 = rtrim_(line, (ftnlen)132);
581 errint_("#", &number, (ftnlen)1);
582 errch_("#", file, (ftnlen)1, r1);
583 errch_("#", line, (ftnlen)1, r2);
584 sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
585 chkout_("ZZRVAR", (ftnlen)6);
586 return 0;
587 }
588
589 /* See if the variable name is legitimate: */
590
591 i__1 = begs[0] - 1;
592 badat = lastpc_(line + i__1, ends[0] - i__1);
593 if (badat <= ends[0] - begs[0]) {
594
595 /* There is a non-printing character in the variable */
596 /* name. This isn't allowed. */
597
598 at = begs[0] + badat;
599 rdklin_(file, &number, (ftnlen)255);
600 r1 = rtrim_(file, (ftnlen)255);
601 setmsg_("There is a non-printing character embedded in line "
602 "# of the text kernel file #. Non-printing character"
603 "s are not allowed in kernel variable assignments. T"
604 "he non-printing character has ASCII code #. ", (
605 ftnlen)199);
606 errint_("#", &number, (ftnlen)1);
607 errch_("#", file, (ftnlen)1, r1);
608 i__1 = *(unsigned char *)&line[at - 1];
609 errint_("#", &i__1, (ftnlen)1);
610 sigerr_("SPICE(NONPRINTINGCHAR)", (ftnlen)22);
611 chkout_("ZZRVAR", (ftnlen)6);
612 return 0;
613 }
614
615 /* Check the variable name length; signal an error */
616 /* if longer than MAXLEN. */
617
618 i__1 = begs[0] - 1;
619 varlen = i_len(line + i__1, ends[0] - i__1);
620 if (varlen > 32) {
621 setmsg_("A kernel pool variable name read from a kernel file"
622 " exceeds the maximum allowed length #1. The actual l"
623 "ength of the variable name is #2, the offending vari"
624 "able name to #3 characters: '#4'.", (ftnlen)188);
625 errint_("#1", &c__32, (ftnlen)2);
626 errint_("#2", &varlen, (ftnlen)2);
627 errint_("#3", &c__132, (ftnlen)2);
628 i__1 = begs[0] - 1;
629 errch_("#4", line + i__1, (ftnlen)2, ends[0] - i__1);
630 sigerr_("SPICE(BADVARNAME)", (ftnlen)17);
631 }
632
633 /* The variable name is ok. How about the directive. */
634
635 i__1 = begs[0] - 1;
636 s_copy(varnam, line + i__1, varnam_len, ends[0] - i__1);
637 dirctv = type__[1];
638
639 /* If this is replacement (=) and not an addition (+=), */
640 /* delete the values currently associated with the variable. */
641 /* They will be replaced later. */
642
643 if (dirctv != 5 && dirctv != 6) {
644 rdklin_(file, &number, (ftnlen)255);
645 setmsg_("A kernel variable was not properly formed on line #"
646 " of the file #. Such an assignment should have the f"
647 "orm: '<variable name> [+]= <values>'. More specific"
648 "ally, the assignment operator did not have one of th"
649 "e expected forms: '=' or '+='. The line was '#'. ", (
650 ftnlen)256);
651 r1 = rtrim_(file, (ftnlen)255);
652 r2 = rtrim_(line, (ftnlen)132);
653 errint_("#", &number, (ftnlen)1);
654 errch_("#", file, (ftnlen)1, r1);
655 errch_("#", line, (ftnlen)1, r2);
656 sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
657 chkout_("ZZRVAR", (ftnlen)6);
658 return 0;
659 }
660
661 /* Locate this variable name in the name pool or insert it */
662 /* if it isn't there. The location will be NAMEAT and */
663 /* we will use the variable FOUND to indicate whether or */
664 /* not it was already present. */
665
666 lookat = zzhash_(varnam, varnam_len);
667 node = namlst[lookat - 1];
668 full = lnknfn_(nmpool) <= 0;
669 found = FALSE_;
670
671 /* See if this name (or one colliding with it in the */
672 /* hash scheme) has already been stored in the name list. */
673
674 if (node > 0) {
675 head = node;
676 tail = -nmpool[(head << 1) + 11];
677 while(node > 0 && ! found) {
678 found = s_cmp(names + (node - 1) * names_len, varnam,
679 names_len, varnam_len) == 0;
680 nameat = node;
681 node = nmpool[(node << 1) + 10];
682 }
683 if (! found && ! full) {
684
685 /* We didn't find this name on the conflict resolution */
686 /* list. Allocate a new slot for it. */
687
688 lnkan_(nmpool, &node);
689 lnkila_(&tail, &node, nmpool);
690 s_copy(names + (node - 1) * names_len, varnam, names_len,
691 varnam_len);
692 nameat = node;
693 }
694 } else if (! full) {
695
696 /* Nothing like this variable name (in the hashing sense) */
697 /* has been loaded so far. We need to allocate */
698 /* a name slot for this variable. */
699
700 lnkan_(nmpool, &node);
701 namlst[lookat - 1] = node;
702 s_copy(names + (node - 1) * names_len, varnam, names_len,
703 varnam_len);
704 nameat = node;
705 }
706
707 /* If the name pool was full and we didn't find this name */
708 /* we've got an error. Diagnose it and return. */
709
710 if (full && ! found) {
711 rdklin_(file, &number, (ftnlen)255);
712 r1 = rtrim_(file, (ftnlen)255);
713 setmsg_("The kernel pool does not have room for any more var"
714 "iables. It filled up at line # of the kernel file #"
715 ". ", (ftnlen)105);
716 errint_("#", &number, (ftnlen)1);
717 errch_("#", file, (ftnlen)1, r1);
718 sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
719 chkout_("ZZRVAR", (ftnlen)6);
720 return 0;
721 }
722
723 /* Now depending upon the kind of directive, we will need */
724 /* to remove data and allocate a new list or simply append */
725 /* data to the existing list. */
726
727 if (dirctv == 5) {
728
729 /* We are going to dump whatever is associated with */
730 /* this name and then we will need to allocate a new */
731 /* linked list for the data. */
732
733 vartyp = 3;
734 if (found) {
735
736 /* We need to free the data associated with this */
737 /* variable. */
738
739 datahd = datlst[nameat - 1];
740 datlst[nameat - 1] = 0;
741 if (datahd < 0) {
742
743 /* This variable was character type we need to */
744 /* free a linked list from the character data */
745 /* pool. */
746
747 head = -datahd;
748 tail = -chpool[(head << 1) + 11];
749 lnkfsl_(&head, &tail, chpool);
750 } else {
751
752 /* This variable was numeric type. We need to */
753 /* free a linked list from the numeric pool. */
754
755 head = datahd;
756 tail = -dppool[(head << 1) + 11];
757 lnkfsl_(&head, &tail, dppool);
758 }
759 }
760 } else if (dirctv == 6) {
761
762 /* We need to append to the current variable. */
763
764 if (found) {
765 if (datlst[nameat - 1] > 0) {
766 vartyp = 2;
767 } else if (datlst[nameat - 1] < 0) {
768 vartyp = 1;
769 } else {
770 vartyp = 3;
771 }
772 } else {
773 vartyp = 3;
774 }
775 }
776
777 /* If this is a vector, the next thing on the line will be a */
778 /* left parenthesis. Otherwise, assume that this is a scalar. */
779 /* If it's a vector, get the first value. If it's a scalar, */
780 /* plant a bogus right parenthesis, to make the following loop */
781 /* terminate after one iteration. */
782
783 if (type__[2] == 3) {
784 nxttok = 4;
785 } else {
786 nxttok = 3;
787 ++count;
788 type__[(i__1 = count - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
789 "type", i__1, "zzrvar_", (ftnlen)950)] = 4;
790 }
791
792 /* For subsequent lines, treat everything as a new value. */
793
794 } else {
795 nxttok = 1;
796 }
797
798 /* We have a value anyway. Store it in the table. */
799
800 /* Keep going until the other shoe (the right parenthesis) */
801 /* drops, or until the end of the line is reached. */
802
803 /* Dates begin with @; anything else is presumed to be a number. */
804
805 while(type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
806 "type", i__1, "zzrvar_", (ftnlen)971)] != 4 && nxttok <=
807 count) {
808
809 /* Get the begin and end of this token. */
810
811 b = begs[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
812 "begs", i__1, "zzrvar_", (ftnlen)975)];
813 e = ends[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 : s_rnge(
814 "ends", i__1, "zzrvar_", (ftnlen)976)];
815 if (vartyp == 3) {
816
817 /* We need to determine which category of variable we */
818 /* have by looking at this token and deducing the */
819 /* type. */
820
821 if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
822 s_rnge("type", i__1, "zzrvar_", (ftnlen)984)] == 1) {
823 vartyp = 1;
824 } else if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ?
825 i__1 : s_rnge("type", i__1, "zzrvar_", (ftnlen)988)]
826 == 2) {
827 vartyp = 2;
828 } else {
829
830 /* This is an error. We should have had one of the */
831 /* two previous types. */
832
833 /* First perform the clean up function. */
834
835 zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
836 dppool);
837 rdklin_(file, &number, (ftnlen)255);
838 r1 = rtrim_(file, (ftnlen)255);
839 setmsg_("The first item following the assignment operato"
840 "r should be the value of a variable or a left pa"
841 "renthesis '(' followed by a value for a variable"
842 ". This is not true on line # of the text kernel "
843 "file '#'. ", (ftnlen)201);
844 errint_("#", &number, (ftnlen)1);
845 errch_("#", file, (ftnlen)1, r1);
846 sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
847 chkout_("ZZRVAR", (ftnlen)6);
848 return 0;
849 }
850 }
851 if (vartyp == 1) {
852
853 /* First make sure that this token represents a string. */
854
855 if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
856 s_rnge("type", i__1, "zzrvar_", (ftnlen)1029)] != 1) {
857
858 /* First perform the clean up function. */
859
860 zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
861 dppool);
862 rdklin_(file, &number, (ftnlen)255);
863 r1 = rtrim_(varnam, varnam_len);
864 r2 = rtrim_(file, (ftnlen)255);
865 setmsg_("The kernel variable # has been set up as a stri"
866 "ng variable. However, the value that you are at"
867 "tempting to assign to this variable on line # of"
868 " the kernel file '#' is not a string value. ", (
869 ftnlen)187);
870 errch_("#", varnam, (ftnlen)1, r1);
871 errint_("#", &number, (ftnlen)1);
872 errch_("#", file, (ftnlen)1, r2);
873 sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
874 chkout_("ZZRVAR", (ftnlen)6);
875 return 0;
876 }
877
878 /* Still going? Make sure there is something between */
879 /* the quotes. */
880
881 if (b + 1 >= e) {
882
883 /* First perform the clean up function. */
884
885 zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
886 dppool);
887 rdklin_(file, &number, (ftnlen)255);
888 r1 = rtrim_(file, (ftnlen)255);
889 setmsg_("There is a quoted string with no characters on "
890 "line # of the text kernel file '#'. ", (ftnlen)83)
891 ;
892 errint_("#", &number, (ftnlen)1);
893 errch_("#", file, (ftnlen)1, r1);
894 sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
895 chkout_("ZZRVAR", (ftnlen)6);
896 return 0;
897 }
898
899 /* We are ready to go. Allocate a node for this data */
900 /* item. First make sure there is room to do so. */
901
902 free = lnknfn_(chpool);
903 if (free <= 0) {
904 rdklin_(file, &number, (ftnlen)255);
905 r1 = rtrim_(file, (ftnlen)255);
906 setmsg_("There is no room available for adding another c"
907 "haracter value to the kernel pool. The characte"
908 "r values buffer became full at line # of the tex"
909 "t kernel file '#'. ", (ftnlen)162);
910 errint_("#", &number, (ftnlen)1);
911 errch_("#", file, (ftnlen)1, r1);
912 sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
913 chkout_("ZZRVAR", (ftnlen)6);
914 return 0;
915 }
916
917 /* Allocate a node for storing this string value: */
918
919 lnkan_(chpool, &chnode);
920 if (datlst[nameat - 1] == 0) {
921
922 /* There was no data for this name yet. We make */
923 /* CHNODE be the head of the data list for this name. */
924
925 datlst[nameat - 1] = -chnode;
926 } else {
927
928 /* Put this node after the tail of the current list. */
929
930 head = -datlst[nameat - 1];
931 tail = -chpool[(head << 1) + 11];
932 lnkila_(&tail, &chnode, chpool);
933 }
934
935 /* Finally insert this data item in the data buffer */
936 /* at CHNODE. Note any quotes will be doubled so we */
937 /* have to undo this affect when we store the data. */
938
939 s_copy(chvals + (chnode - 1) * chvals_len, " ", chvals_len, (
940 ftnlen)1);
941 ++ncomp;
942
943 /* Adjust end-of-token position (E) if it happens to the */
944 /* last, non-quote character of the truncated input line. */
945 /* This has to be done to make sure that all meaningful */
946 /* characters get moved to the value. */
947
948 code = *(unsigned char *)&line[e - 1];
949 if (! (code == iquote)) {
950 ++e;
951 }
952 i__ = 1;
953 j = b + 1;
954 while(j < e) {
955 code = *(unsigned char *)&line[j - 1];
956 if (code == iquote) {
957 ++j;
958 }
959 if (i__ <= i_len(chvals + (chnode - 1) * chvals_len,
960 chvals_len)) {
961 *(unsigned char *)&chvals[(chnode - 1) * chvals_len +
962 (i__ - 1)] = *(unsigned char *)&line[j - 1];
963 ++i__;
964 ++j;
965 } else {
966 ++j;
967 }
968 }
969
970 /* That's all for this value. It's now time to loop */
971 /* back through and get the next value. */
972
973 } else {
974 if (type__[(i__1 = nxttok - 1) < 132 && 0 <= i__1 ? i__1 :
975 s_rnge("type", i__1, "zzrvar_", (ftnlen)1175)] != 2) {
976
977 /* First perform the clean up function. */
978
979 zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool,
980 dppool);
981 rdklin_(file, &number, (ftnlen)255);
982 r1 = rtrim_(varnam, varnam_len);
983 r2 = rtrim_(file, (ftnlen)255);
984 setmsg_("The kernel variable # has been set up as a nume"
985 "ric or time variable. However, the value that y"
986 "ou are attempting to assign to this variable on "
987 "line # of the kernel file '#' is not a numeric o"
988 "r time value. ", (ftnlen)205);
989 errch_("#", varnam, (ftnlen)1, r1);
990 errint_("#", &number, (ftnlen)1);
991 errch_("#", file, (ftnlen)1, r2);
992 sigerr_("SPICE(TYPEMISMATCH)", (ftnlen)19);
993 chkout_("ZZRVAR", (ftnlen)6);
994 return 0;
995 }
996
997 /* Look at the first character to see if we have a time */
998 /* or a number. */
999
1000 code = *(unsigned char *)&line[b - 1];
1001 if (code == itmark) {
1002
1003 /* We need to have more than a single character. */
1004
1005 if (e == b) {
1006
1007 /* First perform the clean up function. */
1008
1009 zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
1010 chpool, dppool);
1011 rdklin_(file, &number, (ftnlen)255);
1012 r1 = rtrim_(varnam, varnam_len);
1013 r2 = rtrim_(file, (ftnlen)255);
1014 setmsg_("At character # of line # in the text kerne"
1015 "l file '#' the character '@' appears. This "
1016 "character is reserved for identifying time v"
1017 "alues in assignments to kernel pool variable"
1018 "s. However it is not being used in this fas"
1019 "hion for the variable '#'. ", (ftnlen)246);
1020 errint_("#", &b, (ftnlen)1);
1021 errint_("#", &number, (ftnlen)1);
1022 errch_("#", file, (ftnlen)1, r2);
1023 errch_("#", varnam, (ftnlen)1, r1);
1024 sigerr_("SPICE(BADTIMESPEC)", (ftnlen)18);
1025 chkout_("ZZRVAR", (ftnlen)6);
1026 return 0;
1027 }
1028 i__1 = b;
1029 tparse_(line + i__1, &dvalue, error, e - i__1, (ftnlen)
1030 255);
1031 if (s_cmp(error, " ", (ftnlen)255, (ftnlen)1) != 0) {
1032
1033 /* First perform the clean up function. */
1034
1035 zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
1036 chpool, dppool);
1037 rdklin_(file, &number, (ftnlen)255);
1038 r1 = rtrim_(file, (ftnlen)255);
1039 lstnb = lastnb_(error, (ftnlen)255);
1040 setmsg_("Encountered '#' while attempting to parse a"
1041 " time on line # of the text kernel file '#'."
1042 " Error message: '#'", (ftnlen)107);
1043 i__1 = b;
1044 errch_("#", line + i__1, (ftnlen)1, e - i__1);
1045 errint_("#", &number, (ftnlen)1);
1046 errch_("#", file, (ftnlen)1, (ftnlen)255);
1047 errch_("#", error, (ftnlen)1, lstnb);
1048 sigerr_("SPICE(BADTIMESPEC)", (ftnlen)18);
1049 chkout_("ZZRVAR", (ftnlen)6);
1050 return 0;
1051 }
1052 } else {
1053 nparsd_(line + (b - 1), &dvalue, error, &i__, e - (b - 1),
1054 (ftnlen)255);
1055 if (s_cmp(error, " ", (ftnlen)255, (ftnlen)1) != 0) {
1056 zzcln_(&lookat, &nameat, namlst, datlst, nmpool,
1057 chpool, dppool);
1058 rdklin_(file, &number, (ftnlen)255);
1059 lstnb = lastnb_(error, (ftnlen)255);
1060 setmsg_("Encountered '#' while attempting to parse a"
1061 " number on line # of the text kernel file '#"
1062 "'. Error message: '#'", (ftnlen)109);
1063 errch_("#", line + (b - 1), (ftnlen)1, e - (b - 1));
1064 errint_("#", &number, (ftnlen)1);
1065 errch_("#", file, (ftnlen)1, (ftnlen)255);
1066 errch_("#", error, (ftnlen)1, lstnb);
1067 sigerr_("SPICE(NUMBEREXPECTED)", (ftnlen)21);
1068 chkout_("ZZRVAR", (ftnlen)6);
1069 return 0;
1070 }
1071 }
1072
1073 /* OK. We have a parsed value. See if there is room in */
1074 /* the numeric portion of the pool to store this value. */
1075
1076 free = lnknfn_(dppool);
1077 if (free <= 0) {
1078 rdklin_(file, &number, (ftnlen)255);
1079 r1 = rtrim_(file, (ftnlen)255);
1080 setmsg_("There is no room available for adding another n"
1081 "umeric value to the kernel pool. The numeric va"
1082 "lues buffer became full at line # of the text ke"
1083 "rnel file '#'. ", (ftnlen)158);
1084 errint_("#", &number, (ftnlen)1);
1085 errch_("#", file, (ftnlen)1, r1);
1086 sigerr_("SPICE(KERNELPOOLFULL)", (ftnlen)21);
1087 chkout_("ZZRVAR", (ftnlen)6);
1088 return 0;
1089 }
1090
1091 /* Allocate a node for storing this numeric value: */
1092
1093 lnkan_(dppool, &dpnode);
1094 if (datlst[nameat - 1] == 0) {
1095
1096 /* There was no data for this name yet. We make */
1097 /* DPNODE be the head of the data list for this name. */
1098
1099 datlst[nameat - 1] = dpnode;
1100 } else {
1101
1102 /* Put this node after the tail of the current list. */
1103
1104 head = datlst[nameat - 1];
1105 tail = -dppool[(head << 1) + 11];
1106 lnkila_(&tail, &dpnode, dppool);
1107 }
1108
1109 /* Finally insert this data item into the numeric buffer. */
1110
1111 dpvals[dpnode - 1] = dvalue;
1112 ++ncomp;
1113 }
1114
1115 /* Now process the next token in the list of tokens. */
1116
1117 ++nxttok;
1118 }
1119
1120 /* We could have ended the above loop in one of two ways. */
1121
1122 /* 1) NXTTOK now exceeds count. This means we did not reach */
1123 /* an end of vector marker. */
1124 /* 2) We hit an end of vector marker. */
1125
1126 if (nxttok > count) {
1127 status = 3;
1128 } else {
1129 status = 2;
1130 }
1131 }
1132
1133 /* It is possible that we reached this point without actually */
1134 /* assigning a value to the kernel pool variable. This can */
1135 /* happen if there is a vector input of the form NAME = ( ) */
1136
1137 if (ncomp < 1) {
1138 zzcln_(&lookat, &nameat, namlst, datlst, nmpool, chpool, dppool);
1139 rdklin_(file, &number, (ftnlen)255);
1140 r1 = rtrim_(file, (ftnlen)255);
1141 setmsg_("The first item following the assignment operator should be "
1142 "the value of a variable or a left parenthesis '(' followed b"
1143 "y a value for a variable. This is not true on line # of the "
1144 "text kernel file '#'. ", (ftnlen)201);
1145 errint_("#", &number, (ftnlen)1);
1146 errch_("#", file, (ftnlen)1, r1);
1147 sigerr_("SPICE(BADVARASSIGN)", (ftnlen)19);
1148 chkout_("ZZRVAR", (ftnlen)6);
1149 return 0;
1150 }
1151
1152 /* Return the name of the variable. */
1153
1154 s_copy(name__, varnam, (ftnlen)132, varnam_len);
1155 chkout_("ZZRVAR", (ftnlen)6);
1156 return 0;
1157 } /* zzrvar_ */
1158
1159