C$Procedure RKWVAL ( Read the next variable from a kernel file ) SUBROUTINE RKWVAL ( KWTBLE, KWPTR, KWVALS, NAME, EOF ) C$ Abstract C C Read the next variable from a SPICE keyword=value file into a C the input symbol table.. C C$ Copyright C C Copyright (1995), California Institute of Technology. C U.S. Government sponsorship acknowledged. C C$ Required_Reading C C PRIVATE KERNEL C C$ Keywords C C FILES C C$ Declarations IMPLICIT NONE INTEGER LBCELL PARAMETER ( LBCELL = -5 ) CHARACTER*(*) KWTBLE ( LBCELL : * ) INTEGER KWPTR ( LBCELL : * ) CHARACTER*(*) KWVALS ( LBCELL : * ) CHARACTER*(*) NAME LOGICAL EOF INTEGER LINLEN PARAMETER ( LINLEN = 132 ) C$ Brief_I/O C C VARIABLE I/O DESCRIPTION C -------- --- -------------------------------------------------- C KWTBLE I/O The name portion of an initialized symbol table C KWPTR I/O The pointer portion of an initialized symbol table C KWVALS I/O The values portion of an initialized symbol table C NAME O name of variable parsed C EOF O if TRUE end of input file has been reached. C C$ Detailed_Input C C KWTBLE form an initialized symbol table that will have C KWPTR inserted into the next set of values for the C KWVALS variable name located and parsed by this routine. C C$ Detailed_Output C C KWTBLE the input symbol table updated with the value(s) C KWPTR found for the named variable (NAME). C KWVALS C C NAME is the name of the variable. NAME is blank if C no variable is read. C C EOF is true when the end of the file has been C reached, and is false otherwise. The kernel file C is closed automatically when the end of the file C is reached. C C$ Parameters C C LINLEN is the maximum length of a line in the kernel file. C C C$ Files C C RKWVAL reads from the file most recently opened by RDSNEW. C C$ Exceptions C C C 1) The error 'SPICE(BADTIMESPEC)' is signalled if a value C beginning with '@' cannot be parsed as a time. C C 2) The error 'SPICE(BADVARASSIGN)' is signalled if variable C assignment does not have the form NAME = [(] value [ value ) ]. C C 3) The error 'SPICE(KERNELPOOLFULL)' is signalled if there is C no room left in the kernel pool to store another variable C or value. C C 4) The error 'SPICE(NONPRINTINGCHAR)' is signalled if the name C in a variable assignment contains a non-printing character. C C 5) The error 'SPICE(NUMBEREXPECTED)' is signalled if a value C that is unquoted cannot be parsed as time or number. C C 6) The error 'SPICE(TYPEMISMATCH)' is signalled if a variable C has a first value of one type (numeric or character) and C a subsequent component has the other type. C C$ Particulars C C None. C C$ Examples C C See the program MAKLABEL and its routine RDMISN. C C$ Restrictions C C The input file must be opened and initialized by RDSNEW prior C to the first call to RKWVAL. C C$ Literature_References C C None. C C$ Author_and_Institution C C W.L. Taber (JPL) C C$ Version C C- SPICELIB Version 1.0.0, 10-JAN-1997 (WLT) C C-& C C C SPICELIB functions C INTEGER LASTPC INTEGER RTRIM INTEGER CARDC INTEGER SIZEC LOGICAL ELEMC LOGICAL RETURN LOGICAL FAILED C C Local parameters. C C Below are a collection of enumerated lists that are used C to discern what part of the processing we are in and what C kind of entity we are dealing with. First the overall C processing flow of a variable assignment. C INTEGER BEGIN PARAMETER ( BEGIN = 1 ) INTEGER DONE PARAMETER ( DONE = BEGIN + 1 ) INTEGER INVAR PARAMETER ( INVAR = DONE + 1 ) C C Next we have the various types of tokens that can be found C in the parsing of an input line C C Q --- quoted (or protected tokens) C NQ --- unquoted tokens C BV --- beginning of a vector C EV --- ending of a vector C EQ --- equal sign C EQP --- equal sign plus C INTEGER Q PARAMETER ( Q = 1 ) INTEGER NQ PARAMETER ( NQ = Q + 1 ) INTEGER BV PARAMETER ( BV = NQ + 1 ) INTEGER EV PARAMETER ( EV = BV + 1 ) INTEGER EQ PARAMETER ( EQ = EV + 1 ) INTEGER EQP PARAMETER ( EQP = EQ + 1 ) C C A variable can have one of three types as we process C it. It can have an unknown type UNKNWN, STRTYP or NUMTYP. C C INTEGER STRTYP PARAMETER ( STRTYP = 1 ) INTEGER NUMTYP PARAMETER ( NUMTYP = STRTYP + 1 ) INTEGER UNKNWN PARAMETER ( UNKNWN = NUMTYP + 1 ) C C The next two parameters indicate which component of a linked C list node point to the previous node and the next node. C INTEGER PREV PARAMETER ( PREV = 2 ) INTEGER NEXT PARAMETER ( NEXT = 1 ) INTEGER FILSIZ PARAMETER ( FILSIZ = 255 ) C C The next collection of variables are set up in first pass C through this routine. They would be parameters if FORTRAN C allowed us to do this in a standard way. C INTEGER IBLANK INTEGER ICOMMA INTEGER IEQUAL INTEGER ILPARN INTEGER IPLUS INTEGER IQUOTE INTEGER IRPARN INTEGER ITAB INTEGER ITMARK CHARACTER*(LINLEN) LINE CHARACTER*(LINLEN) CHVAL CHARACTER*(LINLEN) VARNAM CHARACTER*(FILSIZ) FILE CHARACTER*30 ERROR DOUBLE PRECISION DVALUE INTEGER AT INTEGER B INTEGER BADAT INTEGER BEGS(LINLEN) INTEGER CODE INTEGER COUNT INTEGER DIRCTV INTEGER E INTEGER ENDS(LINLEN) INTEGER I INTEGER J INTEGER NUMBER INTEGER NXTTOK INTEGER R1 INTEGER R2 INTEGER STATUS INTEGER TYPE(LINLEN) INTEGER VARTYP C C The logicals below are used to take apart the tokens in an C input line. C LOGICAL EVEN LOGICAL INTOKN LOGICAL INQUOT LOGICAL INSEPF LOGICAL FULL LOGICAL FOUND LOGICAL FIRST C C The following logicals are in-line functions that are used C when processing the input strings. C LOGICAL ISSEP LOGICAL ISQUOT LOGICAL ISEQU LOGICAL ISRPAR LOGICAL ISLPAR LOGICAL ISPLUS LOGICAL ISBAD LOGICAL ISTIME C C Save everything. C SAVE DATA FIRST / .TRUE. / C C Below are a collection of In-line function definitions that are C intended to make the code a bit easier to write and read. C ISSEP ( CODE ) = CODE .EQ. IBLANK . .OR. CODE .EQ. ICOMMA . .OR. CODE .EQ. ILPARN . .OR. CODE .EQ. IRPARN . .OR. CODE .EQ. IEQUAL . .OR. CODE .EQ. ITAB ISQUOT( CODE ) = CODE .EQ. IQUOTE ISEQU ( CODE ) = CODE .EQ. IEQUAL ISRPAR( CODE ) = CODE .EQ. IRPARN ISLPAR( CODE ) = CODE .EQ. ILPARN ISPLUS( CODE ) = CODE .EQ. IPLUS ISTIME( CODE ) = CODE .EQ. ITMARK ISBAD ( DIRCTV ) = DIRCTV .NE. EQ . .AND. DIRCTV .NE. EQP C C Standard SPICE error handling. C IF ( RETURN() ) THEN RETURN ELSE CALL CHKIN ( 'RKWVAL' ) END IF C C Initializations. C IF ( FIRST ) THEN FIRST = .FALSE. ICOMMA = ICHAR( ',' ) IBLANK = ICHAR( ' ' ) IQUOTE = ICHAR( '"' ) ILPARN = ICHAR( '{' ) IRPARN = ICHAR( '}' ) IEQUAL = ICHAR( '=' ) IPLUS = ICHAR( '+' ) ITMARK = ICHAR( '@' ) ITAB = 9 END IF C C No variable yet and no parsing errors so far. C NAME = ' ' ERROR = ' ' C C Get the next data line. Unless something is terribly wrong, C this will begin a new variable definition. We have to read C the whole variable, unless we get an error, in which case C we can quit. C STATUS = BEGIN DO WHILE ( ( STATUS .NE. DONE ) .AND. ( .NOT. FAILED() ) ) CALL RDSDAT ( LINE, EOF ) IF ( EOF ) THEN CALL CHKOUT ( 'RKWVAL' ) RETURN END IF C C Find the "tokens" in the input line. As you scan from left C to right along the line, exactly one of the following C conditions is true. C C 1) You are in a separator field C 4) You are in a quoted substring C 5) You are in a non-quoted substring that isn't a separator C field. C C Stuff between separator fields are regarded as tokens. Note C this includes quoted strings. C C In addition we keep track of 3 separators: '=', '(', ')' C Finally, whenever we encounters the separator '=', we back C up and see if it is preceded by a '+', if so we attach C it to the '=' and treat the pair of characters as a single C separator. C EVEN = .TRUE. INTOKN = .FALSE. INQUOT = .FALSE. INSEPF = .TRUE. COUNT = 0 I = 0 DO WHILE ( I .LT. LEN(LINE) ) C C The current character is either a separator, quote or C some other character. C I = I + 1 CODE = ICHAR(LINE(I:I)) IF ( ISSEP(CODE) ) THEN C C There are 3 possible states we could be in C Separation Field C A quoted substring with the last quote an odd one. C A quoted substring with the last quote an even one. C A non-quoted token. C In the first two cases nothing changes, but in the C next two cases we transition to a separation field. C IF ( INTOKN .OR. ( INQUOT .AND. EVEN ) ) THEN INQUOT = .FALSE. INTOKN = .FALSE. INSEPF = .TRUE. END IF IF ( INSEPF ) THEN C C We need to see if this is one of the special C separators C IF ( ISEQU(CODE) ) THEN COUNT = COUNT + 1 BEGS(COUNT) = I TYPE(COUNT) = EQ ENDS(COUNT) = I IF ( I .GT. 1 ) THEN C C Look back at the previous character. C See if it is a plus character. C CODE = ICHAR( LINE(I-1:I-1) ) IF ( ISPLUS(CODE) ) THEN C C This is the directive '+=' we need C to set the beginning of this token C to the one before this and adjust C the end of the last token. C TYPE(COUNT) = EQP BEGS(COUNT) = I-1 IF ( BEGS(COUNT-1) . .EQ. ENDS(COUNT-1) ) THEN COUNT = COUNT - 1 BEGS(COUNT) = I - 1 ENDS(COUNT) = I TYPE(COUNT) = EQP ELSE ENDS(COUNT-1) = ENDS(COUNT-1) - 1 END IF END IF END IF ELSE IF ( ISRPAR(CODE) ) THEN COUNT = COUNT + 1 BEGS(COUNT) = I ENDS(COUNT) = I TYPE(COUNT) = EV ELSE IF ( ISLPAR(CODE) ) THEN COUNT = COUNT + 1 BEGS(COUNT) = I ENDS(COUNT) = I TYPE(COUNT) = BV END IF END IF ELSE IF ( ISQUOT(CODE) ) THEN C C There are 3 cases of interest. C We are in a quoted substring already C We are in a separator field C We are in a non-quoted token. C In the first case nothing changes. In the second C two cases we change to being in a quoted substring. C EVEN = .NOT. EVEN IF ( .NOT. INQUOT ) THEN INSEPF = .FALSE. INTOKN = .FALSE. INQUOT = .TRUE. COUNT = COUNT + 1 BEGS(COUNT) = I TYPE(COUNT) = Q END IF ENDS(COUNT) = I ELSE C C This is some character other than a quote, or C separator character. C C We are in one of four situations. C C 1) We are in a quoted substring with an odd number of C quotes. C 2) We are in a quoted substring with an even number of C quotes. C 2) We are in a separator field C 3) We are in a non-quoted token. C C In cases 1 and 3 nothing changes. So we won't check C those cases. C IF ( INSEPF .OR. ( INQUOT .AND. EVEN ) ) THEN INQUOT = .FALSE. INSEPF = .FALSE. INTOKN = .TRUE. COUNT = COUNT + 1 BEGS(COUNT) = I TYPE(COUNT) = NQ END IF ENDS(COUNT) = I END IF END DO C C At this point we have "tokenized" the line that was just C read. Now we perform syntactic checks on it. C C C The first word on the first line should be the name of a C variable. The second word should be a directive: = or +=. C IF ( STATUS .EQ. BEGIN ) THEN C C There must be at least 3 contributing tokens on this line. C IF ( COUNT .LT. 3 ) THEN CALL RDSLIN ( FILE, NUMBER ) CALL SETMSG ( 'A kernel variable was not properly ' . // 'formed on line # of the file #. ' . // 'Such an assignment should have the ' . // 'form: '' [+]= ' . // '''. This line was ''#''. ' ) R1 = RTRIM(FILE) R2 = RTRIM(LINE) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE(1:R1) ) CALL ERRCH ( '#', LINE(1:R2) ) CALL SIGERR ( 'SPICE(BADVARASSIGN)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN END IF C C See if the variable name is legitimate: C BADAT = LASTPC(LINE(BEGS(1):ENDS(1))) IF ( BADAT .LE. ENDS(1) - BEGS(1) ) THEN C C There is a non-printing character in the variable C name. This isn't allowed. C AT = BEGS(1) + BADAT CALL RDSLIN ( FILE, NUMBER ) CALL SETMSG ( 'There is a non-printing character ' . // 'embedded in line # of the text ' . // 'kernel file #. Non-printing ' . // 'characters are not allowed in ' . // 'kernel variable assignments. The ' . // 'non-printing character has ascii ' . // 'code #. ' ) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE(1 :R1) ) CALL ERRINT ( '#', ICHAR(LINE(AT:AT)) ) CALL SIGERR ( 'SPICE(NONPRINTINGCHAR)') CALL CHKOUT ( 'RKWVAL' ) RETURN END IF C C The variable name is ok. How about the directive. C VARNAM = LINE(BEGS(1):ENDS(1)) CALL UCASE (VARNAM, VARNAM ) DIRCTV = TYPE(2) C C If this is replacement (=) and not an addition (=+), C delete the values currently associated with the variable. C They will be replaced later. C IF ( ISBAD(DIRCTV) ) THEN CALL RDSLIN ( FILE, NUMBER ) CALL SETMSG ( 'A kernel variable was not properly ' . // 'formed on line # of the file #. ' . // 'Such an assignment should have the ' . // 'form: '' [+]= ' . // '''. More specifically, ' . // 'the assignment operator did not have ' . // 'one of the expected forms: ''='' or ' . // '''+=''. The line was ''#''. ' ) R1 = RTRIM(FILE) R2 = RTRIM(LINE) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE(1:R1) ) CALL ERRCH ( '#', LINE(1:R2) ) CALL SIGERR ( 'SPICE(BADVARASSIGN)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN END IF C C Locate this variable name in the name pool or insert it C if it isn't there. The location will be NAMEAT and C we will use the variable FOUND to indicate whether or C not it was already present. C FOUND = ELEMC ( VARNAM, KWTBLE ) FULL = CARDC ( KWTBLE ) .EQ. SIZEC ( KWTBLE ) C C If the name pool was full and we didn't find this name C we've got an error. Diagnose it and return. C IF ( FULL .AND. .NOT. FOUND ) THEN CALL RDSLIN ( FILE, NUMBER ) CALL SETMSG ( 'The keyword buffer does not have room ' . // 'for any more variables. It filled ' . // 'up at line # of the file #. ' ) R1 = RTRIM(FILE) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE(1:R1) ) CALL SIGERR ( 'SPICE(KERNELPOOLFULL)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN END IF C C Now depending upon the kind of directive, we will need C to remove data and allocate a new list or simply append C data to the existing list. C VARTYP = UNKNWN IF ( DIRCTV .EQ. EQ ) THEN C C We are going to dump whatever is associated with C this name and then we will need to allocate a new C linked list for the data. C IF ( FOUND ) THEN C C We need to free the data associated with this C variable. C CALL SYDELC ( VARNAM, KWTBLE, KWPTR, KWVALS ) END IF END IF C C If this is a vector, the next thing on the line will be a C left parenthesis. Otherwise, assume that this is a scalar. C If it's a vector, get the first value. If it's a scalar, C plant a bogus right parenthesis, to make the following loop C terminate after one iteration. C IF ( TYPE(3) .EQ. BV ) THEN NXTTOK = 4 ELSE NXTTOK = 3 COUNT = COUNT + 1 TYPE(COUNT) = EV END IF C C For subsequent lines, treat everything as a new value. C ELSE NXTTOK = 1 END IF C C We have a value anyway. Store it in the table. C C Keep going until the other shoe (the right parenthesis) C drops, or until the end of the line is reached. C C Dates begin with @; anything else is presumed to be a number. C DO WHILE ( TYPE(NXTTOK) .NE. EV .AND. NXTTOK .LE. COUNT ) C C Get the begin and end of this token. C B = BEGS(NXTTOK) E = ENDS(NXTTOK) C C Determine what kind of item we have here. C IF ( TYPE(NXTTOK) .EQ. Q ) THEN VARTYP = STRTYP ELSE IF ( TYPE(NXTTOK) .EQ. NQ ) THEN VARTYP = NUMTYP ELSE C C This is an error. We should have had one of the C two previous types. C C First perform the clean up function. C CALL SYDELC ( VARNAM, KWTBLE, KWPTR, KWVALS ) CALL RDSLIN ( FILE, NUMBER ) R1 = RTRIM ( FILE ) CALL SETMSG ( 'The first item following the ' . // 'assignment operator should be ' . // 'the value of a variable or a ' . // 'left parenthesis ''('' followed ' . // 'by a value for a variable. This ' . // 'is not true on line # of the ' . // 'text file ''#''. ' ) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE(1:R1) ) CALL SIGERR ( 'SPICE(BADVARASSIGN)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN END IF IF ( VARTYP .EQ. STRTYP ) THEN C C Still going? Make sure there is something between C the quotes. C IF ( B+1 .GE. E ) THEN C C First perform the clean up function. C CALL SYDELC ( VARNAM, KWTBLE, KWPTR, KWVALS ) CALL RDSLIN ( FILE, NUMBER ) R1 = RTRIM ( FILE ) CALL SETMSG ( 'There is a quoted string with ' . // 'no characters on line # of the ' . // 'text kernel file ''#''. ' ) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE (1:R1) ) CALL SIGERR ( 'SPICE(TYPEMISMATCH)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN END IF C C Finally insert this data item in the data buffer. C Note: any quotes will be doubled so we C have to undo this affect when we store the data. C CHVAL = ' ' I = 1 J = B+1 DO WHILE ( J .LT. E ) CODE = ICHAR(LINE(J:J)) IF ( ISQUOT(CODE) ) THEN J = J+1 END IF CHVAL(I:I) = LINE(J:J) I = I + 1 J = J + 1 END DO C C Store the value C CALL SYENQC ( VARNAM, CHVAL, KWTBLE, KWPTR, KWVALS ) C C That's all for this value. It's now time to loop C back through and get the next value. C ELSE C C Look at the first character to see if we have a time C or a number. C CODE = ICHAR( LINE(B:B) ) IF ( ISTIME(CODE) ) THEN C C We need to have more than a single character. C IF ( E .EQ. B ) THEN C C First perform the clean up function. C CALL RDSLIN(FILE, NUMBER ) CALL SYDELC ( VARNAM, KWTBLE, KWPTR, KWVALS ) R1 = RTRIM (VARNAM ) R2 = RTRIM (FILE ) CALL SETMSG ( 'At character # of line # in ' . // 'the text kernel file ''#'' the ' . // 'character ''@'' appears. This ' . // 'character is reserved for ' . // 'identifying time values in ' . // 'assignments to ' . // 'variables. However it is not ' . // 'being used in this fashion for ' . // 'the variable ''#''. ' ) CALL ERRINT ( '#', B ) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE (1:R2) ) CALL ERRCH ( '#', VARNAM(1:R1) ) CALL SIGERR ( 'SPICE(BADTIMESPEC)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN END IF CALL TPARSE ( LINE(B+1:E), DVALUE, ERROR ) IF ( ERROR .NE. ' ' ) THEN C C First perform the clean up function. C CALL SYDELC ( VARNAM, KWTBLE, KWPTR, KWVALS ) CALL RDSLIN ( FILE, NUMBER ) CALL SETMSG ( 'Encountered ''#'' while ' . // 'attempting to parse a time ' . // 'on line # of the text kernel ' . // 'file ''#''. ' ) CALL ERRCH ( '#', LINE(B+1:E) ) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE ) CALL SIGERR ( 'SPICE(BADTIMESPEC)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN ELSE CHVAL = LINE(B+1:E) END IF ELSE CALL NPARSD ( LINE(B:E), DVALUE, ERROR, I ) IF ( ERROR .NE. ' ' ) THEN CALL SYDELC ( VARNAM, KWTBLE, KWPTR, KWVALS ) CALL RDSLIN ( FILE, NUMBER ) CALL SETMSG ( 'Encountered ''#'' while ' . // 'attempting to parse a number on ' . // 'line # of the text kernel file ' . // '''#''. ' ) CALL ERRCH ( '#', LINE(B:E) ) CALL ERRINT ( '#', NUMBER ) CALL ERRCH ( '#', FILE ) CALL SIGERR ( 'SPICE(NUMBEREXPECTED)' ) CALL CHKOUT ( 'RKWVAL' ) RETURN ELSE CHVAL = LINE(B:E) END IF END IF C C OK. This value is parsable, store the value. C CALL SYENQC ( VARNAM, CHVAL, KWTBLE, KWPTR, KWVALS ) END IF C C Now process the next token in the list of tokens. C NXTTOK = NXTTOK + 1 END DO C C We could have ended the above loop in one of two ways. C C 1) NXTTOK now exceeds count. This means we did not reach C an end of vector marker. C 2) We hit an end of vector marker. C IF ( NXTTOK .GT. COUNT ) THEN STATUS = INVAR ELSE STATUS = DONE END IF END DO C C Return the name of the variable. C NAME = VARNAM CALL CHKOUT ( 'RKWVAL' ) RETURN END