/************************************************************************ * scan -a new, more compact scanner for ratfor * * * * Scan is based on a finite state automata to classify all tokens * * except identifiers. This is the 3rd generation of scan. The * * major difference between this routine and the one that preceede it* * is the use of switch/case statements. * * * * usage: foo = scan(string) * * where: scan =the type of the token. * * string =the string, EOS terminated. * * * * All identifiers are translated into upper case. * * Strings are returned as read. Strings must terminate before * * the end of the line. * * Many syntactic types are translated into equivalent FORTRAN * * symbols, '>' into '.gt.' * ************************************************************************/ integer function scan(token) include ratfor.def include getlin.cmm #current line and pointer character token(MAXTOKEN) #the returned string integer dsw #error return from getlin integer tptr #pointer into token integer old #the type of the last token logical nlflag #true if newline encountered logical conchr #true if continuation character logical octdec #true if legal octal number /*----->* oft used macros */ define incptr ptr=ptr+1 define inctptr tptr=tptr+1 define copyc token(tptr)=buf(ptr) define addeos token(tptr)=EOS define convert buf(ptr)=buf(ptr)-32 /*----->* The following table is used to classify a character * according to type. */ define BAD 1 #The character is an illegal character define LOWER 2 #The character is a lower case character define UPPER 3 #The character is an upper case character define DIGIT 4 #'0'-'9' define WHITE 5 #Space and tab characters define TYPCR 6 #Newline, end of line (different from EOS) define OTHER 7 #Punctuation and other byte disp(127) #general dispatch table for character type data disp/BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD, #octal 1-10 WHITE,TYPCR,BAD,TYPCR,TYPCR,BAD,BAD,BAD, #octal 11-20 BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD, #octal 21-30 BAD,BAD,BAD,BAD,BAD,BAD,BAD,WHITE, #31-40 OTHER,OTHER,OTHER,UPPER,OTHER,OTHER,OTHER,OTHER, #41-50 OTHER,OTHER,OTHER,OTHER,OTHER,OTHER,OTHER,DIGIT, #51-60 DIGIT,DIGIT,DIGIT,DIGIT,DIGIT,DIGIT,DIGIT,DIGIT, #61-70 DIGIT,OTHER,OTHER,OTHER,OTHER,OTHER,OTHER,OTHER, #71,100 UPPER,UPPER,UPPER,UPPER,UPPER,UPPER,UPPER,UPPER, #101-110 UPPER,UPPER,UPPER,UPPER,UPPER,UPPER,UPPER,UPPER, #111-120 UPPER,UPPER,UPPER,UPPER,UPPER,UPPER,UPPER,UPPER, #121-130 UPPER,UPPER,OTHER,OTHER,OTHER,OTHER,UPPER,OTHER, #131-140 LOWER,LOWER,LOWER,LOWER,LOWER,LOWER,LOWER,LOWER, #141-150 LOWER,LOWER,LOWER,LOWER,LOWER,LOWER,LOWER,LOWER, #151-160 LOWER,LOWER,LOWER,LOWER,LOWER,LOWER,LOWER,LOWER, #161-170 LOWER,LOWER,OTHER,OTHER,OTHER,OTHER,BAD/ #171-177 data old/0/ #initialize to not used lex type tptr = 1 #begin at beginning repeat { if(ptr > INBUFSIZE) { #get another line call getlin(dsw) if(dsw ^= OK) { #at end of file, return it scan = dsw token(1) = dsw token(2) = EOS break } } switch(disp(buf(ptr))) { #dispatch on character type case default: #illegal values (negative numbers) if(buf(ptr) == eof) { scan = EOF token(1) = EOF token(2) = EOS break } case bad: #an illegal character incptr #just skip the character call synerr(S_ILL_CHAR) next case typcr: #carriage return found if(conchr(old)) { #last token continuation incptr next } copyc #copy character incptr token(2) = EOS #append EOS scan = NEWLINE #the value is newline break case white: #a space or a tab incptr #advance pointer next case digit: #a digit repeat { copyc #copy the digit incptr #increment buf pointer inctptr #incr token pointer } until (disp(buf(ptr)) ^= digit) #loop until non-digit scan = LEXNUMBER #a number addeos #append zero byte break case lower: #a lower case letter encountered case upper: #an upper case letter repeat { if(disp(buf(ptr)) == lower) #lower, convert convert copyc #copy the character incptr inctptr } until(disp(buf(ptr)) ^= lower & disp(buf(ptr)) ^= upper & disp(buf(ptr)) ^= digit) addeos #append eos to token scan = LEXIDENT #this was an identifier break case other: #all of the punctuation switch(buf(ptr)) { case default: #non special punctuation copyc;incptr;inctptr;addeos scan = LEXOTHER break case semicol: #semicolon copyc;incptr;inctptr;addeos scan = LEXSEMICOL break case colon: #colon copyc;incptr;inctptr;addeos scan = LEXCOLON break case lparen: #'(' copyc;incptr;inctptr;addeos scan = LEXLPAREN break case rparen: #')' copyc;incptr;inctptr;addeos scan = LEXRPAREN break case sharp: #beginning of comment ptr = INBUFSIZE + 1 #force getlin if(conchr(old))next #continue to next line token(1) = NEWLINE #otherwise, newline token(2) = EOS scan = NEWLINE break case slash: #comment, or just slash if(buf(ptr+1) ^= star) { #just a slash token(1) = slash;token(2) = EOS scan = LEXOTHER incptr break } nlflag = .false. #no newlines seen ptr = ptr + 2 #look at new character repeat { if(buf(ptr) == star) if(buf(ptr+1) == slash) { ptr = ptr + 2 break } if(buf(ptr) == NEWLINE)nlflag = .true. incptr if(ptr > INBUFSIZE) { call getlin(dsw) if(dsw ^= OK) { scan = EOF token(1) = EOF token(2) = EOS call synerr(S_EOF) break } } } if(nlflag) { #check if newline incptr if(conchr(old)) #continuation? next token(1) = newline token(2) = EOS scan = NEWLINE break } next #go again case squote: #a string scan = LEXSTRING #type string repeat { copyc;incptr;inctptr if(buf(ptr) != '\' | buf(ptr+1) != NEWLINE) next ptr = ptr + 2 if(ptr > INBUFSIZE) { #get another line call getlin(dsw) if(dsw ^= OK) break } }until(buf(ptr)==SQUOTE | buf(ptr)==NEWLINE) if(buf(ptr) == NEWLINE) { call synerr(S_ILL_STR) token(tptr) = squote #put quote in token(tptr+1) = EOS #terminate break } copyc #copy in quote token(tptr+1) = eos incptr break case equals: #either '==' or not incptr if(buf(ptr) == equals) { call scopy('.EQ.',1,token,1) scan = LEXOTHER incptr break } call scopy('=',1,token,1) scan = LEXOTHER break case greater: #'>' or '>=' incptr if(buf(ptr) == equals) { #'>=' call scopy('.GE.',1,token,1) scan = LEXOTHER incptr #point past '=' break #go home } call scopy('.GT.',1,token,1) #'>' scan = LEXOTHER break case less: #'<=' or '<' or '<>' incptr if(buf(ptr) == equals) { #'<=' call scopy('.LE.',1,token,1) scan = LEXOTHER;incptr break } if(buf(ptr) == greater) { #'<>' call scopy('.NE.',1,token,1) scan = LEXOTHER;incptr break } call scopy('.LT.',1,token,1) #less than scan = LEXOTHER break case bang: #'!=' or '!' case uparrow: #'^=' or '^' #### incptr if(buf(ptr) == equals) { call scopy('.NE.',1,token,1) incptr scan = LEXOTHER break } call scopy('.NOT.',1,token,1) scan = LEXOTHER break case amper: #and incptr call scopy('.AND.',1,token,1) scan = LEXOTHER break case backslash: #.or. or continuation if(buf(ptr+1) == NEWLINE) { ptr = ptr + 2 next } #else fall through to bar case bar: #or incptr call scopy('.OR.',1,token,1) scan = LEXOTHER break case percent: #quote next character incptr;copyc;inctptr;addeos scan = LEXOTHER incptr #go past character break case atsign: #next number is octal incptr #skip the atsign while(disp(buf(ptr)) == digit) { copyc incptr inctptr } addeos if(octdec(token)) { scan = LEXNUMBER #a number break } call synerr(S_ILL_OCTAL) #else an error next case lbrace: #'begin' case lbrack: incptr call scopy('[',1,token,1) scan = LEXBEGIN break case rbrace: #'end' case rbrack: incptr call scopy(']',1,token,1) scan = LEXEND break case dquote: #a string scan = LEXSTRING #type string buf(ptr) = squote #fake a single quote repeat { copyc;incptr;inctptr if(buf(ptr) == NEWLINE) { #illegal call synerr(S_ILL_STR) token(tptr) = squote token(tptr+1) = EOS break } if(buf(ptr) == squote) { #double copyc inctptr next } if(buf(ptr) != '\' | buf(ptr+1) != NEWLINE) next ptr = ptr + 2 if(ptr > INBUFSIZE) { call getlin(dsw) if(dsw ^= OK) break } } until(buf(ptr) == dquote) #all done if(buf(ptr) ^= dquote) break token(tptr) = squote #append single quote token(tptr+1) = eos incptr }#inner switch }#of outer switch break }#of repeat old = token(1) #copy token type return end /************************************************************************ * conchr -is character a continuation character? * * * * useage: foo = concur(c) * * where: foo =logical, true if character is continuation * * c =the character type to check * * notes: * * the function returns true if the character is one * * of the ratfor continuation characters. * ************************************************************************/ logical function conchr(c) character c string buf "+-*\|&(,<>=" if(iindex(buf,c) == 0) conchr =.false. else conchr = .true. return end /************************************************************************ * octdec -convert an octal number to decimal * * * * usage: if(octdec(string))... * * where: string =input, the octal digit string * * output, the converted string * * octdec =.true. if goodness * ************************************************************************/ logical function octdec(str) character str(1) integer temp temp = 0 for(i = 1;str(i) >= '0' & str(i) <= '7';i = i + 1) temp = temp*8 + (str(i) -'0') if(str(i) != 0) { octdec = .false. return } call ita(temp,str) #convert to decimal octdec = .true. return end