1(* 2 Copyright (c) 2000 3 Cambridge University Technical Services Limited 4 5 Further development: 6 Copyright (c) 2000-15 David C.J. Matthews 7 8 This library is free software; you can redistribute it and/or 9 modify it under the terms of the GNU Lesser General Public 10 License version 2.1 as published by the Free Software Foundation. 11 12 This library is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 Lesser General Public License for more details. 16 17 You should have received a copy of the GNU Lesser General Public 18 License along with this library; if not, write to the Free Software 19 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 20*) 21 22(* 23 Title: Parse Tree Structure and Operations. 24 Author: Dave Matthews, Cambridge University Computer Laboratory 25 Copyright Cambridge University 1985 26*) 27 28functor PARSE_TREE ( 29 30structure BASEPARSETREE : BaseParseTreeSig 31structure PRINTTREE: PrintParsetreeSig 32structure EXPORTTREE: ExportParsetreeSig 33structure TYPECHECKTREE: TypeCheckParsetreeSig 34structure CODEGENPARSETREE: CodegenParsetreeSig 35 36structure LEX : LEXSIG 37structure STRUCTVALS : STRUCTVALSIG; 38structure TYPETREE : TYPETREESIG 39 40sharing LEX.Sharing = TYPETREE.Sharing = STRUCTVALS.Sharing 41 = BASEPARSETREE.Sharing = PRINTTREE.Sharing = EXPORTTREE.Sharing = CODEGENPARSETREE.Sharing 42 = TYPECHECKTREE.Sharing 43 44) : PARSETREESIG = 45 46struct 47 48 open LEX 49 open STRUCTVALS 50 open TYPETREE 51 open BASEPARSETREE 52 open PRINTTREE 53 open EXPORTTREE 54 open CODEGENPARSETREE 55 open TYPECHECKTREE 56 57 val badType = BadType 58 59 fun isIdent (Ident _) = true | isIdent _ = false; 60 61 val unit = Unit; 62 val wildCard = WildCard; 63 val emptyTree = EmptyTree; 64 65 (* A general type variable for an expression. This is used to record the type. *) 66 fun makeGeneralTypeVar() = mkTypeVar(generalisable, false, false, false) 67 68 fun mkIdent (name, loc) : parsetree = 69 Ident 70 { 71 name = name, 72 expType = ref EmptyType, 73 value = ref undefinedValue, 74 location = loc, 75 possible = ref(fn () => []) 76 }; 77 78 local 79 (* Make overloaded functions for the conversions. *) 80 (* For the moment we make the type string->t and raise an exception 81 if the constant cannot be converted. *) 82 val ty = mkOverloadSet[] 83 val funType = mkFunctionType (stringType, ty); 84 fun mkOverloaded name : values = makeOverloaded (name, funType, TypeDep) 85 in 86 val convString = mkOverloaded "convString" 87 and convInt = mkOverloaded "convInt" 88 and convWord = mkOverloaded "convWord" 89 and convChar = mkOverloaded "convChar" 90 and convReal = mkOverloaded "convReal" 91 end; 92 93 fun mkString(s: string, loc): parsetree = 94 Literal{converter=convString, literal=s, expType=ref EmptyType, location=loc}; 95 96 fun mkInt (i : string, loc) : parsetree = 97 Literal{converter=convInt, literal=i, expType=ref EmptyType, location=loc}; 98 99 fun mkReal (r : string, loc) : parsetree = 100 Literal{converter=convReal, literal=r, expType=ref EmptyType, location=loc}; 101 102 fun mkChar (c : string, loc) : parsetree = 103 Literal{converter=convChar, literal=c, expType=ref EmptyType, location=loc}; 104 105 fun mkWord (w : string, loc) : parsetree = 106 Literal{converter=convWord, literal=w, expType=ref EmptyType, location=loc}; 107 108 fun mkApplic (f, arg, loc, isInfix) : parsetree = 109 Applic 110 { 111 f = f, 112 arg = arg, 113 location = loc, 114 isInfix = isInfix, 115 expType = ref EmptyType 116 }; 117 118 fun mkCond (test, thenpt, elsept, location) : parsetree = 119 Cond 120 { 121 test = test, 122 thenpt = thenpt, 123 elsept = elsept, 124 location = location, 125 thenBreak = ref NONE, 126 elseBreak = ref NONE 127 } 128 129 fun mkTupleTree(fields, location) = TupleTree { fields=fields, location=location, expType = ref EmptyType } 130 131 fun mkValDeclaration (dec, explicit, implicit, location) : parsetree = 132 ValDeclaration 133 { 134 dec = dec, 135 explicit = explicit, 136 implicit = implicit, 137 location = location 138 }; 139 140 fun mkFunDeclaration (dec, explicit, implicit, location) : parsetree = 141 FunDeclaration 142 { 143 dec=dec, 144 explicit = explicit, 145 implicit = implicit, 146 location = location 147 }; 148 149 fun mkOpenTree(ptl : structureIdentForm list, location): parsetree = 150 OpenDec{decs=ptl, variables=ref [], structures = ref [], typeconstrs = ref [], location = location}; 151 152 fun mkStructureIdent (name, location) : structureIdentForm = 153 { 154 name = name, 155 value = ref NONE, 156 location = location 157 }; 158 159 fun mkValBinding (dec, exp, isRecursive, line) : valbind = 160 ValBind 161 { 162 dec = dec, 163 exp = exp, 164 isRecursive = isRecursive, 165 line = line, 166 variables = ref nil 167 }; 168 169 fun mkClausal(clauses, location) : fvalbind = 170 FValBind 171 { 172 clauses = clauses, 173 numOfPatts = ref 0, 174 functVar = ref undefinedValue, 175 argType = ref badType, 176 resultType = ref badType, 177 location = location 178 }; 179 180 (* A clause for a clausal function is initially parsed as a pattern because that is 181 the easiest way to handle it but that's actually more general than the syntax allows. 182 Process it at this point to check for some validity. *) 183 fun mkFunPattern (fPat, lex): funpattern * string * int = 184 let 185 fun makeId(name, loc) = 186 {name = name, expType = ref EmptyType, location = loc } 187 188 fun unpick (Applic{ f, arg, isInfix, ... }) = 189 (* "Application" of function to a parameter. *) 190 let 191 val () = 192 (* This could be an infixed application and since it has been parsed using the 193 normal infix handler the arguments could be prefixed constructor applications 194 or infixed constructor applications with a higher precedence. These are not 195 allowed because the arguments are supposed to just be "atpats". Any 196 applications should have been parenthesised. *) 197 case (isInfix, arg) of 198 (true, TupleTree{fields=[Applic _, _], location, ...}) => 199 errorMessage(lex, location, 200 "Constructor applications in fun bindings must be parenthesised.") 201 | (true, TupleTree{fields=[_, Applic _], location, ...}) => 202 errorMessage(lex, location, 203 "Constructor applications in fun bindings must be parenthesised.") 204 | _ => (); 205 val { ident, isInfix, args, ... } = unpick f 206 in 207 { ident=ident, isInfix=isInfix, args = args @ [arg], constraint = NONE } 208 end 209 210 | unpick (Ident{ name, location, ...}) = 211 { 212 ident={ name = name, location = location, expType = ref EmptyType}, 213 isInfix=false, args = [], constraint = NONE 214 } 215 216 | unpick (Parenthesised(Applic{ f = Ident { name, location, ...}, isInfix=true, arg, ... }, _)) = 217 { 218 ident={ name = name, location = location, expType = ref EmptyType}, 219 isInfix=true, args = [arg], constraint = NONE 220 } 221 222 | unpick (Parenthesised(_, location)) = 223 (* Only the bottom (i.e. first) application may be parenthesised and then 224 only if the application is infixed. *) 225 ( 226 errorMessage(lex, location, 227 "Parentheses are only allowed for infixed applications in fun bindings."); 228 { ident=makeId("", location), isInfix=false, args = [], constraint = NONE } 229 ) 230 231 | unpick _ = 232 ( 233 errorMessage(lex, location lex, 234 "Syntax error: fun binding is not an identifier applied to one or more patterns."); 235 { ident=makeId("", location lex), isInfix=false, args = [], constraint = NONE } 236 ) 237 238 val unpicked as { ident = { name, ...}, args, ...} = 239 (* The "pattern" may have a single constraint giving the result 240 type of the function. Otherwise it must be a set of one or more, 241 possibly infixed, applications. *) 242 case fPat of 243 Constraint { value = value as Applic _, given, ... } => 244 let 245 val { ident, isInfix, args, ... } = unpick value 246 in 247 { ident = ident, isInfix = isInfix, args = args, constraint = SOME given } 248 end 249 250 | Constraint { value = value as Parenthesised(Applic _, _), given, ... } => 251 let 252 val { ident, isInfix, args, ... } = unpick value 253 in 254 { ident = ident, isInfix = isInfix, args = args, constraint = SOME given } 255 end 256 257 | fPat as Parenthesised(Applic _, _) => 258 unpick fPat 259 260 | fPat as Applic _ => 261 unpick fPat 262 263 | _ => 264 ( 265 errorMessage(lex, location lex, 266 "Syntax error: fun binding is not an identifier applied to one or more patterns."); 267 { ident=makeId("", location lex), isInfix=false, args = [], constraint = NONE } 268 ) 269 in 270 (unpicked, name, List.length args) 271 end; 272 273 fun mkClause (dec, exp, line) : fvalclause = 274 FValClause 275 { 276 dec = dec, 277 exp = exp, 278 line = line, 279 breakPoint = ref NONE 280 } 281 282 fun mkList(elem, loc) = List{ elements = elem, location = loc, expType = ref EmptyType } 283 284 fun mkConstraint (value, given, location) : parsetree = 285 Constraint 286 { 287 value = value, 288 given = given, 289 location = location 290 }; 291 292 fun mkLayered (var, pattern, location) : parsetree = 293 Layered 294 { 295 var = var, 296 pattern = pattern, 297 location = location 298 }; 299 300 fun mkFn(matches, location) = 301 Fn { matches = matches, location = location, expType = ref EmptyType } 302 303 fun mkMatchTree (vars, exp, location) : matchtree = 304 MatchTree 305 { 306 vars = vars, 307 exp = exp, 308 location = location, 309 argType = ref badType, 310 resType = ref badType, 311 breakPoint = ref NONE 312 } 313 314 fun mkLocalDeclaration (decs, body, location, isLocal) : parsetree = 315 Localdec 316 { 317 decs = map (fn p => (p, ref NONE)) decs, 318 body = map (fn p => (p, ref NONE))body, 319 isLocal = isLocal, 320 varsInBody = ref [], 321 location = location 322 }; 323 324 val mkTypeDeclaration : typebind list * location -> parsetree = TypeDeclaration; 325 326 fun mkDatatypeDeclaration (typelist, withtypes, location) : parsetree = 327 AbsDatatypeDeclaration 328 { 329 isAbsType = false, 330 typelist = typelist, 331 withtypes = withtypes, 332 declist = [], 333 location = location, 334 equalityStatus = ref [] 335 }; 336 337 fun mkAbstypeDeclaration (typelist, withtypes, declist, location) : parsetree = 338 AbsDatatypeDeclaration 339 { 340 isAbsType = true, 341 typelist = typelist, 342 withtypes = withtypes, 343 declist = map (fn p => (p, ref NONE)) declist, 344 location = location, 345 equalityStatus = ref [] 346 }; 347 348 val mkDatatypeReplication = DatatypeReplication 349 350 fun mkTypeBinding (name, typeVars, decType, isEqtype, nameLoc, fullLoc) : typebind = 351 TypeBind 352 { 353 name = name, 354 typeVars = typeVars, 355 decType = decType, 356 isEqtype = isEqtype, 357 tcon = ref(TypeConstrSet(undefConstr, [])), 358 nameLoc = nameLoc, 359 fullLoc = fullLoc 360 }; 361 362 fun mkDatatypeBinding (name, typeVars, constrs, typeNameLoc, fullLoc) : datatypebind = 363 DatatypeBind 364 { 365 name = name, 366 typeVars = typeVars, 367 constrs = constrs, 368 tcon = ref(TypeConstrSet(undefConstr, [])), 369 nameLoc = typeNameLoc, 370 fullLoc = fullLoc 371 } 372 373 fun mkValueConstr (name, arg, locn) = 374 {constrName=name, constrArg=arg, idLocn=locn, constrVal=ref undefinedValue} 375 376 fun mkExBinding (name, previous, typeof, nameLoc, fullLoc) : exbind = 377 ExBind 378 { 379 name = name, 380 previous = previous, 381 ofType = typeof, 382 value = ref undefinedValue, 383 nameLoc = nameLoc, 384 fullLoc = fullLoc 385 }; 386 387 fun mkLabelledTree (recList, frozen, location) : parsetree = 388 Labelled 389 { 390 recList = recList, 391 frozen = frozen, 392 expType = ref EmptyType, 393 location = location 394 }; 395 396 fun mkLabelRecEntry (name, nameLoc, valOrPat, fullLocation) = 397 { 398 name = name, 399 nameLoc = nameLoc, 400 valOrPat = valOrPat, 401 fullLocation = fullLocation, 402 expType = ref EmptyType 403 } 404 405 fun mkSelector(name, location) : parsetree = 406 let 407 (* Make a type for this. It's equivalent to 408 fn { name = exp, ...} => exp. *) 409 val resType = makeGeneralTypeVar(); 410 val entryType = mkLabelEntry (name, resType); 411 val labType = mkLabelled ([entryType], false) (* Not frozen*); 412 in 413 Selector 414 { 415 name = name, 416 labType = labType, 417 typeof = mkFunctionType (labType, resType), 418 location = location 419 } 420 end; 421 422 val mkRaise : parsetree * location -> parsetree = Raise; 423 424 fun mkHandleTree (exp, hrules, location, listLocation) : parsetree = 425 HandleTree 426 { 427 exp = exp, 428 hrules = hrules, 429 location = location, 430 listLocation = listLocation 431 }; 432 433 fun mkWhile (test, body, location) : parsetree = 434 While 435 { 436 test = test, 437 body = body, 438 location = location, 439 breakPoint = ref NONE 440 } 441 442 fun mkCase (test, match, location, listLocation) : parsetree = 443 Case 444 { 445 test = test, 446 match = match, 447 location = location, 448 listLocation = listLocation, 449 expType = ref EmptyType 450 }; 451 452 fun mkAndalso (first, second, location) : parsetree = 453 Andalso 454 { 455 first = first, 456 second = second, 457 location = location 458 }; 459 460 fun mkOrelse (first, second, location) : parsetree = 461 Orelse 462 { 463 first = first, 464 second = second, 465 location = location 466 }; 467 468 fun mkDirective (tlist, fix, location) : parsetree = 469 Directive 470 { 471 tlist = tlist, 472 fix = fix, 473 location = location 474 }; 475 476 fun mkExpseq (pl: parsetree list, l: location) = ExpSeq (map (fn p => (p, ref NONE)) pl, l) 477 478 val mkExDeclaration : exbind list * location -> parsetree = ExDeclaration; 479 480 val mkParenthesised = Parenthesised 481 482 (* Types that can be shared. *) 483 structure Sharing = 484 struct 485 type lexan = lexan 486 and pretty = pretty 487 and environEntry = environEntry 488 and codetree = codetree 489 and codeBinding = codeBinding 490 and types = types 491 and values = values 492 and typeId = typeId 493 and structVals = structVals 494 and typeConstrs= typeConstrs 495 and typeVarForm=typeVarForm 496 and env = env 497 and infixity = infixity 498 and structureIdentForm = structureIdentForm 499 and typeParsetree = typeParsetree 500 and parsetree = parsetree 501 and valbind = valbind 502 and fvalbind = fvalbind 503 and fvalclause = fvalclause 504 and typebind = typebind 505 and datatypebind=datatypebind 506 and exbind = exbind 507 and labelRecEntry=labelRecEntry 508 and ptProperties = ptProperties 509 and matchtree = matchtree 510 and typeVarMap = typeVarMap 511 and level = level 512 and debuggerStatus = debuggerStatus 513 end 514 515end (* PARSETREE *); 516