src/sml/tag-parser.sml

   1 (* Tag Parser *)
   2
   3 signature TAG_PARSER =
   4 sig
   5     val stringToPE : string -> Expr;
   6     val stringToPEs : string -> Expr list;
   7 end;
   8
   9 (* *********************************************************** Tag Parser *)
  10
  11 exception ErrorReservedWordUsedImproperly of string;
  12 exception ErrorMalformedLambdaArgList of string;
  13 exception UnrecognizedAST of Sexpr;
  14 exception NotASymbol of Sexpr;
  15
  16 structure TagParser : TAG_PARSER =
  17 struct
  18 val reservedSymbols = ["and", "begin", "cond", "define", "else",
  19                "if", "lambda", "let", "let*", "letrec",
  20                "or", "quote", "set!"];
  21
  22 fun reservedWord(str) =
  23     ormap (fn rs => (String.compare(rs, str) = EQUAL)) reservedSymbols;
  24
  25 fun scmRdcAndRac(Nil, retRdcRac) = retRdcRac(Nil, Nil)
  26   | scmRdcAndRac(Pair(car, cdr), retRdcRac) =
  27     scmRdcAndRac(cdr, (fn (rdc, rac) =>
  28               retRdcRac(Pair(car, rdc), rac)))
  29   | scmRdcAndRac(e, retRdcRac) = retRdcRac(Nil, e);
  30
  31 fun parseExpr(Void) = Const(Void)
  32   | parseExpr(Nil) = Const(Nil)
  33   | parseExpr(e as Number(_)) = Const(e)
  34   | parseExpr(e as Char(_)) = Const(e)
  35   | parseExpr(e as Bool(_)) = Const(e)
  36   | parseExpr(e as String(_)) = Const(e)
  37   | parseExpr(Pair(Symbol("quote"),Pair(e, Nil))) = Const(e)
  38   | parseExpr(Symbol(e)) =
  39         if reservedWord(e) then
  40             raise ErrorReservedWordUsedImproperly(e)
  41         else
  42             Var(e)
  43   | parseExpr(Pair(Symbol("if"),Pair(test,Pair(dit, Nil)))) =
  44         If(parseExpr(test), parseExpr(dit), Const(Void))
  45   | parseExpr(Pair(Symbol("if"),Pair(test,Pair(dit,Pair(dif, Nil))))) =
  46         If(parseExpr(test), parseExpr(dit), parseExpr(dif))
  47
  48   | parseExpr(sexpr as Pair(Symbol("lambda"),Pair(argl,body))) =
  49     (* (lambda <argl> se)
  50        or
  51        (lambda <argl> se1 se2 ...
  52        [lambda with implicit sequence] *)
  53         parseImplicitSeq(body,
  54             (fn (pe) => parseAbs(argl,pe)),
  55             (fn () => raise UnrecognizedAST(sexpr)))
  56
  57   | parseExpr(Pair(Symbol("define"),Pair(Symbol(s),Pair(se,Nil)))) =
  58     (* (define <symbol> <expr>) *)
  59         Def( Var(s), parseExpr(se) )
  60
  61   | parseExpr(sexpr as Pair(Symbol("define"),
  62                    Pair(Pair(Symbol(s),argl),
  63                         body))) =
  64     (* (define (<symbol> [argl]) <expr>)
  65        or:
  66        (define (<symbol> [argl]) <expr> ...
  67        [define with implicit sequence] *)
  68         parseImplicitSeq(body,
  69             (fn (pe) => Def( Var(s), parseAbs(argl,pe) )),
  70             (fn () => raise UnrecognizedAST(sexpr)))
  71
  72   | parseExpr(Pair(Symbol("set!"),Pair(Symbol(s),Pair(sexpr,Nil)))) =
  73     (* (set! <symbol> <expr>) *)
  74         Set( Var(s), parseExpr(sexpr) )
  75
  76   | parseExpr(orexpr as Pair(Symbol("or"),sexprs)) =
  77     (* (or <expr> ... *)
  78         let
  79             val peList = parseExprs( schemeListToML(sexprs) )
  80             handle NotAList(_) =>
  81                 raise UnrecognizedAST(orexpr)
  82         in
  83             case peList of
  84                 []   => Const(Bool(false))
  85               | [pe] => pe
  86               | _    => Or(peList)
  87         end
  88
  89   | parseExpr(andexpr as Pair(Symbol("and"),sexprs)) =
  90     (* (and <expr> ... *)
  91         let
  92             val peList = parseExprs(schemeListToML(sexprs))
  93             handle NotAList(_) => raise UnrecognizedAST(andexpr)
  94         in
  95             expandAnd( peList )
  96         end
  97
  98   | parseExpr(condexpr as Pair(Symbol("cond"),Nil)) =
  99         raise ErrorReservedWordUsedImproperly("cond")
 100
 101   | parseExpr(condexpr as Pair(Symbol("cond"),condpairs)) =
 102     (* (cond ... *)
 103         let
 104             val pairs = schemeListToML(condpairs)
 105             handle NotAList(_) => raise UnrecognizedAST(condexpr)
 106         in
 107             parseCondPairs( pairs )
 108         end
 109
 110   | parseExpr(letexpr as Pair(Symbol("let"),Pair(bindings,body))) =
 111     (* (let <bindings> <body>) *)
 112         let
 113             val bindingsList = schemeListToML(bindings)
 114             handle NotAList(_) => raise UnrecognizedAST(letexpr)
 115         in
 116             parseImplicitSeq(body,
 117                 (fn (pe) =>
 118                     parseLetBindings(bindingsList,
 119                         (fn (names,values) =>
 120                             App( Abs(names,pe), parseExprs(values) )),
 121                         (fn () => App( Abs([],pe),[])))),
 122                 (fn () =>
 123                     raise ErrorReservedWordUsedImproperly("let")))
 124         end
 125
 126   | parseExpr(letstarexpr as Pair(Symbol("let*"),Pair(bindings,body))) =
 127     (* (let* <bindings> <body>) *)
 128         let
 129             val bindingsList = schemeListToML(bindings)
 130             handle NotAList(_) => raise UnrecognizedAST(letstarexpr)
 131         in
 132             parseExpr( expandLetStar(bindingsList,body) )
 133         end
 134
 135   | parseExpr(letrecexpr as Pair(Symbol "letrec",Pair(bindings,body))) =
 136     (* (letrec <bindings> <body>) *)
 137         let
 138             val bindingsList = schemeListToML(bindings)
 139             handle NotAList(_) => raise UnrecognizedAST(letrecexpr)
 140         in
 141             expandLetRec(bindingsList,body)
 142         end
 143
 144   | parseExpr(Pair(Symbol "begin",seq)) =
 145         parseImplicitSeq(seq,
 146             (fn (pe) => pe),
 147             (fn () => raise ErrorReservedWordUsedImproperly("begin")))
 148
 149   | parseExpr(sexpr as Vector(_)) =
 150         Const(sexpr)
 151
 152   | parseExpr (e as Pair(p, q)) =
 153         scmRdcAndRac(q,
 154             (fn (rdc, Nil) =>
 155                 App(parseExpr(p), map parseExpr(schemeListToML(rdc)))
 156               | _ =>
 157                 raise UnrecognizedAST(e)))
 158
 159 and parseLetBindings([],retNamesAndValues,retNone) = retNone()
 160
 161   | parseLetBindings([Pair(Symbol(name),Pair(value,Nil))],
 162     retNamesAndValues, retNone) =
 163         retNamesAndValues([name],[value])
 164
 165   | parseLetBindings(Pair(Symbol(name),Pair(value,Nil)) :: rest,
 166     retNamesAndValues, retNone) =
 167         parseLetBindings(rest,
 168             (fn (names,values) =>
 169                 retNamesAndValues(name :: names,value :: values)),
 170             (fn () => retNone()))
 171
 172   | parseLetBindings(sexpr :: _,_,_) = raise UnrecognizedAST(sexpr)
 173
 174 and parseCondPairs([]) = Const(Void)
 175   | parseCondPairs([Pair(Symbol("else"),exprs)]) =
 176         parseImplicitSeq(exprs,
 177             (fn (pe) => pe),
 178             (fn () => raise ErrorReservedWordUsedImproperly("else")))
 179   | parseCondPairs(Pair(Symbol("else"),_) :: _) =
 180         raise ErrorReservedWordUsedImproperly("cond")
 181   | parseCondPairs(Pair(test,exprs) :: restpairs) =
 182         parseImplicitSeq(exprs,
 183             (fn (pe) => If( parseExpr(test), pe, parseCondPairs(restpairs) )),
 184 (*            (fn () => raise ErrorReservedWordUsedImproperly("cond"))) *)
 185             (fn () => Or [parseExpr(test),parseCondPairs(restpairs)] ))
 186   | parseCondPairs(_) =
 187         raise ErrorReservedWordUsedImproperly("cond")
 188
 189 and expandAnd([]) = Const(Bool(true))
 190   | expandAnd([pe]) = pe
 191   | expandAnd([pe1,pe2]) = If( pe1, expandAnd([pe2]), Const(Bool(false)) )
 192   | expandAnd(pe :: rest) = If( pe, expandAnd(rest), Const(Bool(false)) )
 193
 194 and expandLetStar([],body) =
 195         Pair(Symbol "let",Pair(Nil,body))
 196   | expandLetStar([pair],body) =
 197         Pair(Symbol "let",Pair(Pair(pair,Nil),body))
 198   | expandLetStar(pair :: rest,body) =
 199     (* [(x 4),...], body *)
 200         Pair(Symbol "let",Pair(Pair(pair,Nil),Pair(expandLetStar(rest,body),Nil)))
 201
 202     (* Expands
 203          (letrec ((n1 v1)
 204                   ...
 205                   (nk vk))
 206             e1 .. en)
 207        to
 208          (let ((n1 #f)
 209                ...
 210                (nk #f))
 211             (set! n1 v1)
 212             ...
 213             (set! nk vk)
 214             (let ()
 215               e1 .. en))
 216     *)
 217 and expandLetRec(bindingsList,Nil) =
 218         raise ErrorReservedWordUsedImproperly("letrec")
 219   | expandLetRec(bindingsList,body) =
 220         parseLetBindings(bindingsList,
 221             (fn (names,values) =>
 222                 let
 223                     val newBindings = MLListToScheme(map makeInitPair names)
 224                     val setPairs = makeSetPairs(names,values)
 225                 in
 226                     parseExpr(Pair(Symbol "let",Pair(newBindings,
 227                             combine(MLListToScheme(setPairs),
 228                                 Pair(Pair(Symbol "let", Pair(Nil,body)),Nil)
 229                             ))))
 230                 end),
 231             (fn () => parseExpr(Pair (Symbol "let", Pair (Nil,body)))))
 232
 233 and makeInitPair(name) = Pair(Symbol name,Pair(Bool false,Nil))
 234
 235 and makeSetPairs([],[]) = []
 236   | makeSetPairs(name :: restNames, value :: restValues) =
 237         MLListToScheme( [Symbol "set!",Symbol name, value] ) ::
 238         makeSetPairs(restNames,restValues)
 239   | makeSetPairs(_,_) = raise UnrecognizedAST(Void)
 240
 241 and parseImplicitSeq(schemeList,retPE,retNone) =
 242     let
 243         val peList = (map parseExpr (schemeListToML schemeList))
 244         handle NotAList(_) =>
 245             raise UnrecognizedAST(schemeList)
 246     in
 247         case peList of
 248             []   => retNone()
 249           | [pe] => retPE(pe)
 250           | _    => retPE( Seq peList )
 251     end
 252
 253 and parseAbs(argl,body) =
 254         case argl of
 255             Pair(_,_) =>
 256             (* argl is either simple: (<symbol> ... <symbol>)
 257                          or optional: (<symbol> ... <symbol> . <symbol>) *)
 258             parseAbsArgsList(argl,
 259                 (fn (argsNames) =>
 260                     Abs(argsNames,body)),
 261                 (fn (argsNames,optArgsName) =>
 262                     AbsOpt(argsNames,optArgsName,body)))
 263
 264           | Symbol(s) =>
 265             (* argl is variadic: <symbol> *)
 266             if reservedWord(s) then
 267                 raise ErrorReservedWordUsedImproperly(s)
 268             else
 269                 AbsVar(s, body )
 270
 271           | Nil =>
 272             (* no args at all *)
 273             Abs([],body)
 274
 275           | _ =>
 276             raise ErrorMalformedLambdaArgList("not a var/list/improper-list")
 277
 278 and parseAbsArgsList(sexpr,retArgsNames,retArgsNamesAndOptsName) =
 279     case sexpr of
 280         Pair(Symbol(argName),Nil) =>
 281         if reservedWord(argName) then
 282             raise ErrorReservedWordUsedImproperly(argName)
 283         else
 284             retArgsNames([argName])
 285
 286       | Pair(Symbol(argName),Symbol(optsName)) =>
 287         if reservedWord(argName) then
 288             raise ErrorReservedWordUsedImproperly(argName)
 289         else
 290             if reservedWord(optsName) then
 291                 raise ErrorReservedWordUsedImproperly(optsName)
 292             else
 293                 retArgsNamesAndOptsName([argName],optsName)
 294
 295       | Pair(Symbol(argName),rest) =>
 296         if reservedWord(argName) then
 297             raise ErrorReservedWordUsedImproperly(argName)
 298         else
 299             parseAbsArgsList(rest,
 300                 (fn (argsNames) =>
 301                     retArgsNames(argName :: argsNames)),
 302                 (fn (argsNames,optsName) =>
 303                     retArgsNamesAndOptsName(argName :: argsNames,optsName)))
 304
 305       | _ =>
 306         raise ErrorMalformedLambdaArgList("not a list/improper-list")
 307
 308 and parseExprs([]) = []
 309   | parseExprs(sexpr :: rest) = parseExpr(sexpr) :: parseExprs(rest);
 310
 311 fun stringToPE string = parseExpr(Reader.stringToSexpr string);
 312
 313 fun stringToPEs string = parseExprs( Reader.stringToSexprs string );
 314
 315 end; (* of structure TagParser *)