subroutine DCUnitsGetToken(tokentype, ivalue, dvalue, cvalue)
implicit none
integer, intent(out):: tokentype
integer, intent(out):: ivalue(5)
double precision, intent(out):: dvalue
character(*), intent(out):: cvalue
integer:: iend, istr, ilen, ios
ivalue = 0
dvalue = 0.0d0
cvalue = ""
iend = len_trim(thisline)
do
if (i > iend) exit
! '#' 文字が現われれば EOF シンボルを返す
call match("^##", thisline(i:), istr, ilen)
if (istr > 0) then
i = iend + 1
tokentype = S_EOF
return
endif
! 空白を無視
call match("^#s+", thisline(i:), istr, ilen)
if (istr > 0) then
i = i + ilen
if (i > iend) exit
endif
! シフト演算子チェック
call match("^@", thisline(i:), istr, ilen)
if (istr <= 0) call match("^from", thisline(i:), istr, ilen)
if (istr <= 0) call match("^at", thisline(i:), istr, ilen)
if (istr > 0) then
i = i + ilen
tokentype = S_SHIFT
cvalue = thisline(i: i+ilen-1)
return
endif
! 名前チェック
call match("^#a#w*#a", thisline(i:), istr, ilen)
if (istr <= 0) call match("^[#a'""]", thisline(i:), istr, ilen)
if (istr > 0) then
tokentype = S_TEXT
cvalue = thisline(i: i+ilen-1)
i = i + ilen
return
endif
! '*' の前に '**' を認知せねば。
call match("^#^", thisline(i:), istr, ilen)
if (istr <= 0) call match("^#*#*", thisline(i:), istr, ilen)
if (istr > 0) then
tokentype = S_EXPONENT
cvalue = thisline(i: i+ilen-1)
i = i + ilen
return
endif
! 実数にならない小数点は S_MULTIPLY
call match("^#.[^#d]", thisline(i:), istr, ilen)
if (istr <= 0) call match("^#*", thisline(i:), istr, ilen)
if (istr > 0) then
tokentype = S_MULTIPLY
cvalue = thisline(i: i+ilen-1)
i = i + 1
return
endif
! 実数チェック. 小数点は語頭にあれば必ず数字が伴うので安心せよ
call match("^[-+]?#d*#.#d*[EeDd][-+]?#d+", thisline(i:), istr, ilen)
if (istr <= 0) call match("^[-+]?#d*#.#d*", thisline(i:), istr, ilen)
if (istr > 0) then
read(thisline(i: i+ilen-1), fmt=*, iostat=ios) dvalue
if (ios /= 0) dvalue = HUGE(dvalue)
cvalue = thisline(i: i+ilen-1)
tokentype = S_REAL
i = i + ilen
return
endif
! 整数チェック
call match("^[-+]?#d+", thisline(i:), istr, ilen)
if (istr > 0) then
read(thisline(i: i+ilen-1), fmt=*, iostat=ios) ivalue(1)
if (ios /= 0) ivalue(1) = HUGE(1)
cvalue = thisline(i: i+ilen-1)
tokentype = S_INTEGER
i = i + ilen
return
endif
! ほかの１字トークンチェック
if (thisline(i:i) == '/') then
tokentype = S_DIVIDE
cvalue = thisline(i:i)
i = i + 1
return
endif
if (thisline(i:i) == '(') then
tokentype = S_OPENPAR
cvalue = thisline(i:i)
i = i + 1
return
endif
if (thisline(i:i) == ')') then
tokentype = S_CLOSEPAR
cvalue = thisline(i:i)
i = i + 1
return
endif
! だめだこりゃ。はい次いってみよう
tokentype = ichar(thisline(i:i))
cvalue = thisline(i:i)
i = i + 1
return
enddo
i = iend + 1
tokentype = S_EOF
cvalue = ""
end subroutine