1(* 2 Copyright (c) 2000 3 Cambridge University Technical Services Limited 4 5 This library is free software; you can redistribute it and/or 6 modify it under the terms of the GNU Lesser General Public 7 License as published by the Free Software Foundation; either 8 version 2.1 of the License, or (at your option) any later version. 9 10 This library is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 Lesser General Public License for more details. 14 15 You should have received a copy of the GNU Lesser General Public 16 License along with this library; if not, write to the Free Software 17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18*) 19 20(* 21 Title: Parse Types. 22 Author: Dave Matthews, Cambridge University Computer Laboratory 23 Copyright Cambridge University 1985 24*) 25 26functor PARSE_TYPE ( 27 28structure SYMBOLS : SymbolsSig 29structure SYMSET : SymsetSig 30structure LEX : LEXSIG 31 32structure SKIPS : 33sig 34 type sys; 35 type lexan; 36 type symset; 37 type location = 38 { file: string, startLine: FixedInt.int, startPosition: FixedInt.int, 39 endLine: FixedInt.int, endPosition: FixedInt.int } 40 41 val badsyms: sys * lexan -> unit; 42 val getsym: sys * lexan -> unit; 43 val skipon: symset * symset * string * lexan -> unit; 44 val getid: symset * symset * lexan -> string * location; 45 val getLabel: symset * lexan -> string * location; 46 val getList: sys * symset * lexan * (unit -> 'a * location) -> 'a list * location; 47end; 48 49structure UTILITIES : 50sig 51 val noDuplicates: (string * 'a * 'a -> unit) -> 52 { apply: (string * 'a -> unit) -> unit, 53 enter: string * 'a -> unit, 54 lookup: string -> 'a option }; 55end 56 57structure TYPETREE : TYPETREESIG 58 59(*****************************************************************************) 60(* PARSETYPE sharing constraints *) 61(*****************************************************************************) 62 63sharing type 64 SYMBOLS.sys 65= SYMSET.sys 66= SKIPS.sys 67= LEX.sys 68 69sharing type 70 SYMSET.symset 71= SKIPS.symset 72 73sharing type 74 LEX.lexan 75= SKIPS.lexan 76 77) : 78 79(*****************************************************************************) 80(* PARSETYPE export signature *) 81(*****************************************************************************) 82sig 83 type symset; 84 type lexan; 85 type types; 86 type typeParsetree; 87 type typeVarForm 88 type location = 89 { file: string, startLine: FixedInt.int, startPosition: FixedInt.int, 90 endLine: FixedInt.int, endPosition: FixedInt.int } 91 92 val parseType: symset * lexan * {lookupTvar:string -> typeVarForm} -> typeParsetree * location; 93end = 94 95 96(*****************************************************************************) 97(* PARSETYPE functor body *) 98(*****************************************************************************) 99struct 100 open TYPETREE 101 open LEX 102 open SYMSET 103 open SKIPS 104 open SYMBOLS 105 open UTILITIES 106 107 infix 8 ++; 108 infix 8 inside; 109 110 val tyseqSyntax = SYMSET.comma ++ SYMSET.rightParen 111 val lrSyntax = SYMSET.comma ++ SYMSET.rightCurly 112 113 fun parseType (fsys, lex, env) = 114 let 115 fun tupleType fsys = 116 let 117 fun basicType fsys = 118 let (* First part may be a type sequence. *) 119 val sym = sy lex and startLocn = location lex 120 val (tySeq, seqLocn) = 121 case sym of 122 LeftParen => (* sequence of types *) 123 let 124 fun processList () = 125 let 126 val thisType = 127 if sy lex inside startTypeSys 128 then #1 (parseType (fsys ++ tyseqSyntax, lex, env)) 129 else 130 ( 131 badsyms (TypeIdent, lex); 132 ParseTypeBad (* not there *) 133 ); 134 fun testfor (sym, startsys, lex) = 135 (* repeat if the separator or a starting sym is found *) 136 if sy lex = sym 137 then (insymbol lex; true) 138 else if sy lex inside startsys 139 then (badsyms (sym, lex); true) 140 else false; 141 142 in (* Check for any more *) 143 if testfor (SYMBOLS.Comma, startTypeSys, lex) 144 then thisType :: processList() (* get some more *) 145 else [thisType] (* that's it *) 146 end (* processList *); 147 148 val () = insymbol lex; (* Remove opening bracket *) 149 val sequence = processList(); (* read list of items *) 150 val endLocn = location lex (* Should be the loc. of the close paren. *) 151 in 152 getsym (SYMBOLS.RightParen, lex); 153 (sequence, locSpan(startLocn, endLocn)) 154 end 155 156 | LeftCurly => 157 let 158 val () = insymbol lex; (* Remove opening bracket *) 159 val posEnd = location lex 160 in 161 case sy lex of 162 RightCurly => 163 let 164 val () = insymbol lex 165 val locs = locSpan(startLocn, posEnd) 166 in 167 ([unitTree locs], locs) 168 end 169 170 | _ => 171 let 172 (* The same label name should not be used more than once. *) 173 fun reportDup (name, newLoc, _) = 174 errorMessage (lex, newLoc, "Label (" ^ name ^ ") appears more than once.") 175 val dupCheck = noDuplicates reportDup 176 (* All the labels should be the same sort. *) 177 val (l, _) = 178 getList (SYMBOLS.Comma, empty, lex, 179 fn () => 180 let 181 val nameAndLoc as (_, nameLoc) = 182 getLabel (fsys ++ SYMSET.colon, lex); 183 val () = #enter dupCheck nameAndLoc; 184 val () = getsym (SYMBOLS.Colon, lex); 185 val (types, typeLoc) = parseType (fsys ++ lrSyntax, lex, env) 186 val fullLoc = locSpan(nameLoc, typeLoc) 187 in 188 ((nameAndLoc, types, fullLoc), fullLoc) 189 end); 190 val locs = locSpan(startLocn, location lex) (* Include '}' *) 191 in 192 getsym (SYMBOLS.RightCurly, lex); 193 ([makeParseTypeLabelled(l, true, locs) (* frozen *)], locs) 194 end 195 end 196 197 | TypeIdent => 198 let (* type variable *) 199 val ty = #lookupTvar env (id lex); 200 in 201 getsym (TypeIdent, lex); 202 ([makeParseTypeId(ty, startLocn)], startLocn) 203 end 204 205 | Ident => 206 (* Constructor such as `int' *) 207 let 208 val idLocn as (_, locn) = getid (SYMSET.ident, fsys, lex) 209 in 210 ([makeParseTypeConstruction (idLocn, ([], locn), locn)], locn) 211 end 212 213 | _ => 214 ( 215 badsyms (SYMBOLS.Ident, lex); 216 ([], startLocn) 217 ) 218 in 219 (* Type sequence read. Can now have some type constructors. *) 220 case (sy lex, tySeq) of 221 (Ident, _) => 222 let (* Returns the type made from the constructors. *) 223 fun constructors(args, argLoc) = 224 let 225 val idAndLoc as (_, idLoc) = (id lex, location lex) 226 val loc = locSpan(argLoc, idLoc) 227 val constructed = makeParseTypeConstruction(idAndLoc, (args, argLoc), loc); 228 in 229 insymbol lex; 230 if sy lex = SYMBOLS.Ident 231 then constructors([constructed], loc) 232 else (constructed, loc) 233 end; 234 in 235 constructors(tySeq, seqLocn) 236 end 237 238 (* no constructor - get the first part of the sequence 239 and check that that's all. *) 240 | (_, []) => (ParseTypeBad, seqLocn) 241 | (_, [t]) => (t, seqLocn) 242 | (_, t::_) => (badsyms (SYMBOLS.Ident, lex); (t, seqLocn)) 243 end (* basicType *); 244 245 (* ty * .. * ty *) 246 fun getProduct () = 247 let 248 val fsys' = fsys ++ SYMSET.asterisk; 249 val (firstPart, firstLocn) = basicType fsys' 250 in 251 case sy lex of 252 Asterisk => 253 let 254 val () = insymbol lex 255 val (rest, restLocn) = getProduct () 256 in 257 (firstPart :: rest, locSpan(firstLocn, restLocn)) 258 end 259 | _ => ([firstPart], firstLocn) 260 end 261 in 262 case getProduct () of 263 ([notProduct], locn) => (notProduct, locn) 264 | (product, locn) => (makeParseTypeProduct(product, locn), locn) 265 end (* tupleType *)(* ty -> ty *) 266 267 val (firstType, firstLoc) = tupleType (fsys ++ SYMSET.arrow); 268 in 269 case sy lex of 270 Arrow => 271 let 272 val () = insymbol lex 273 val (resType, resLocn) = parseType (fsys, lex, env) 274 val locs = locSpan(firstLoc, resLocn) 275 in 276 (makeParseTypeFunction (firstType, resType, locs), locs) 277 end 278 | _ => 279 ( 280 skipon (fsys, empty, "End of type", lex); 281 (firstType, firstLoc) 282 ) 283 end 284end; 285