src/sml/scanner.sml~

   1 (* Scanner *)
   2
   3 datatype SchemeToken = LparenToken
   4              | RparenToken
   5              | QuoteToken
   6              | DotToken
   7              | VectorToken
   8              | IntToken of int
   9              | CharToken of char
  10              | StringToken of string
  11              | SymbolToken of string
  12              | BoolToken of bool;
  13
  14
  15 signature SCANNER =
  16 sig
  17     val stringToTokens : string -> SchemeToken list;
  18 end;
  19
  20 (* *********************************************************** Scanner *)
  21
  22 exception ErrorNothingAfterHash;
  23 exception ErrorBadChar of char * string;
  24 exception ErrorStringDoesntEnd of string;
  25 exception ErrorNoMetaChar of string;
  26 exception ErrorNoSuchMetaChar of string;
  27 exception ErrorNoChar;
  28 exception ErrorUnknownNamedChar of string;
  29 exception ErrorHash of string;
  30
  31 structure Scanner : SCANNER =
  32 struct
  33
  34 val whiteChar = makeIsChar(" \t\r\n");
  35 val delimiterChar = makeIsChar("'()\";, \t\r\n");
  36 val octalChar = makeCharInRange(#"0", #"7");
  37 val upperChar = makeCharInRange(#"A", #"Z");
  38 val lowerChar = makeCharInRange(#"a", #"z");
  39 val digitChar = makeCharInRange(#"0", #"9");
  40 val specialSymbolChar = makeIsChar("!@$%^*-_=+<>/?.#");
  41
  42 fun symbolChar (ch) =
  43     lowerChar(ch) orelse
  44     upperChar(ch) orelse
  45     digitChar(ch) orelse
  46     specialSymbolChar(ch);
  47
  48 local
  49     fun stInit([]) = []
  50       | stInit(#";" :: s) = stComment(s)
  51       | stInit(#"(" :: s) = LparenToken :: stInit(s)
  52       | stInit(#")" :: s) = RparenToken :: stInit(s)
  53       | stInit(#"'" :: s) = QuoteToken :: stInit(s)
  54       | stInit(#"#" :: s) = stHash(s)
  55       | stInit(#"." :: s) = DotToken :: stInit(s)
  56       | stInit(#"-" :: s) = stMinus(s)
  57       | stInit(#"\"" ::s) = stString([], s)
  58       | stInit(ch :: s) =
  59             if whiteChar(ch) then stInit(s)
  60             else if digitChar(ch) then stDecDigit([ch],s)
  61             else if symbolChar(ch) then stSymbol([ch],s)
  62             else raise ErrorBadChar(ch, implode(s))
  63
  64     and stMinus([]) = SymbolToken("-") :: stInit([])
  65       | stMinus(ch :: s) =
  66             (* [minus,digit,...] => number *)
  67             if digitChar(ch) then
  68                 stDecDigit([#"-",ch],s)
  69
  70             (* [minus,non-digit] => symbol *)
  71             else
  72                 stSymbol([#"-"],[ch] @ s)
  73
  74     and stDecDigit(num,[]) = IntToken(stringToInt num) :: stInit([])
  75       | stDecDigit(num,ch :: s) =
  76             if (delimiterChar(ch)) then (* end of int *)
  77                 IntToken(stringToInt num) :: stInit(ch :: s)
  78             else
  79                 stDecDigit(num @ [ch], s)
  80
  81     and stSymbol(symname,[]) = SymbolToken(implode symname) :: stInit([])
  82       | stSymbol(symname,ch :: s) =
  83               if symbolChar(ch) then
  84                   stSymbol(symname @ [ch],s)
  85               else
  86                   SymbolToken(implode symname) :: stInit(ch :: s)
  87
  88     and stString(str, []) = raise ErrorStringDoesntEnd(implode str)
  89       | stString(str, #"\"" :: s) = StringToken(implode str) :: stInit(s)
  90       | stString(str, #"\\" :: s) = stStringMetaChar(str,s)
  91       | stString(str, ch :: s) = stString(str @ [ch], s)
  92
  93     and stStringMetaChar(str,[]) = raise ErrorNoMetaChar(implode str)
  94       | stStringMetaChar(str, #"t" :: s) = stString(str @ [#"\t"],s)
  95       | stStringMetaChar(str, #"r" :: s) = stString(str @ [#"\r"],s)
  96       | stStringMetaChar(str, #"n" :: s) = stString(str @ [#"\n"],s)
  97       | stStringMetaChar(str, #"\\" :: s) = stString(str @ [#"\\"],s)
  98       | stStringMetaChar(str, #"\"" :: s) = stString(str @ [#"\""],s)
  99       | stStringMetaChar(str, ch1 :: ch2 :: ch3 :: s) =
 100               if andmap octalChar [ch1,ch2,ch3] then
 101                   stString(str @ [chr( digitToInt(ch1)*8*8
 102                                       +digitToInt(ch2)*8
 103                                       +digitToInt(ch3))
 104                                       ],s)
 105               else
 106                 raise (ErrorNoSuchMetaChar(implode([ch1,ch2,ch3]@s)))
 107       | stStringMetaChar(str, s) = raise (ErrorNoSuchMetaChar(implode s))
 108
 109     and stHash([]) = raise ErrorNothingAfterHash
 110       | stHash(#"t" :: s) = BoolToken(true) :: stInit(s)
 111       | stHash(#"T" :: s) = BoolToken(true) :: stInit(s)
 112       | stHash(#"f" :: s) = BoolToken(false) :: stInit(s)
 113       | stHash(#"F" :: s) = BoolToken(false) :: stInit(s)
 114       | stHash(#"\\" :: s) = stChar(s)
 115       | stHash(#"(" :: s) = VectorToken :: stInit(s)
 116       | stHash(s) = raise ErrorHash("#\\" ^ implode(s))
 117
 118     and stChar([]) = raise ErrorNoChar
 119       | stChar(ch :: s) = stChar'(s, [ch])
 120
 121     and stChar'([], chars) = makeCharToken(chars) :: stInit([])
 122       | stChar'(s as ch :: s', chars) =
 123         if delimiterChar(ch) then makeCharToken(chars) :: stInit(s)
 124         else stChar'(s', ch :: chars)
 125
 126     and stComment([]) = stInit([])
 127       | stComment(#"\n" :: s) = stInit(s)
 128       | stComment(ch :: s) = stComment(s)
 129
 130     and charsToString(s) = implode(rev(s))
 131
 132     and makeCharToken([ch]) = CharToken(ch)
 133       | makeCharToken(chars as [ch1, ch2, ch3]) =
 134             if (andmap octalChar chars) then
 135                 CharToken(chr(digitToInt(ch1) +
 136                     8 * (digitToInt(ch2) +
 137                         8 * digitToInt(ch3))))
 138             else charNameToCharToken(charsToString(chars))
 139       | makeCharToken(chars) = charNameToCharToken(charsToString(chars))
 140
 141     and charNameToCharToken(charName) =
 142     if stringEqual(charName, "space") then CharToken(#" ")
 143     else if stringEqual(charName, "return") then CharToken(#"\r")
 144     else if stringEqual(charName, "newline") then CharToken(#"\n")
 145     else if stringEqual(charName, "tab") then CharToken(#"\t")
 146     else raise ErrorUnknownNamedChar(charName)
 147
 148     and digitToInt(ch) = ord(ch) - ord(#"0")
 149
 150     and stringToInt(str) = valOf( Int.fromString(implode str) )
 151 in
 152 fun stringToTokens(string) = stInit(explode(string))
 153 end
 154
 155 end;