Return to parse.sml CVS log

Up to [Research Unix] / researchv10dc / cmd / sml / doc / examples / spread

Annotation of researchv10dc/cmd/sml/doc/examples/spread/parse.sml, revision 1.1.1.1

1.1       root        1: functor Parse(F : FORMULA) : PARSE = 
                      2: struct
                      3:   structure F = F
                      4:   
                      5:   exception Syntax of string
                      6: 
                      7:   datatype token = NUMtok of int 
                      8:                 | ALPHAtok of string
                      9:                 | PUNCTtok of string 
                     10:                 | EOFtok
                     11: 
                     12:   fun for (i,j) f = if i<=j then (f i; for(i+1,j) f) else ()
                     13:   fun forall (a::r) f = (f a; forall r f)
                     14:     | forall nil f = ()
                     15: 
                     16:   datatype class = DIGIT | BLANK | ALPHA | PUNCT | OTHER | EOF
                     17:   val class = array(257,OTHER)
                     18:   val _ = 
                     19:       (for (ord "0", ord "9") (fn s => update(class,s,DIGIT));
                     20:        for (ord "a", ord "z") (fn s => update(class,s,ALPHA));
                     21:        for (ord "A", ord "Z") (fn s => update(class,s,ALPHA));
                     22:        forall [" ","\t","\n"] (fn s => update(class,(ord s),BLANK));
                     23:        forall ["(",")","[","]",",","+","-","*","/"]
                     24:               (fn s => update(class,(ord s),PUNCT));
                     25:        update(class, 256, EOF))
                     26:              
                     27:   fun parse(str : string) : F.formula =
                     28:     let fun gettoken pos = 
                     29:            let fun char(p) = ordof(str,p) handle Ord => 256
                     30:                fun digit(z,p) = 
                     31:                    let val c = char p
                     32:                     in case class sub c 
                     33:                         of DIGIT => digit(z*10+c-ord("0"), p+1)
                     34:                          | _ => (p, NUMtok z)
                     35:                    end
                     36:                fun alpha(s,p) =
                     37:                    let val c = char p
                     38:                     in case class sub c 
                     39:                         of ALPHA => alpha(s,p+1)
                     40:                          | _ => (p, ALPHAtok(substring(str,s,p-s)))
                     41:                    end
                     42:                val c = char pos
                     43:             in case class sub c
                     44:                 of BLANK => gettoken(pos+1)
                     45:                  | ALPHA => alpha(pos,pos)
                     46:                  | DIGIT => digit(0,pos)
                     47:                  | PUNCT => (pos+1, PUNCTtok(chr c))
                     48:                  | EOF => (pos, EOFtok)
                     49:                  | _ => raise (Syntax "illegal character")
                     50:            end
                     51: 
                     52:        fun atom (p, NUMtok n)  =  (gettoken p, F.NUM n)
                     53:          | atom (p, PUNCTtok "[") =
                     54:                (case exp(gettoken p)
                     55:                  of ((p1, PUNCTtok ","), e1) =>
                     56:                           (case exp(gettoken p1)
                     57:                             of ((p2, PUNCTtok "]"), e2) =>
                     58:                                      (gettoken p2, F.CELLREF(e1,e2))
                     59:                              | _ => raise (Syntax "] expected"))
                     60:                   | _ => raise (Syntax ", expected"))
                     61:           | atom (p, PUNCTtok "(") =
                     62:                (case exp(gettoken p)
                     63:                  of ((p1, PUNCTtok ")"), e1) => (gettoken p1, e1)
                     64:                   | _ => raise (Syntax ") expected"))
                     65:          | atom _ = raise (Syntax "bogus atom")
                     66: 
                     67:        and term' ((p, PUNCTtok "*"), e1) = 
                     68:            let val (s, e2) = atom(gettoken p)
                     69:             in term'(s, F.BINOP(Integer.*, e1, e2))
                     70:             end
                     71:          | term' ((p, PUNCTtok "/"), e1) = 
                     72:            let val (s, e2) = atom(gettoken p)
                     73:             in term'(s, F.BINOP(Integer.div, e1, e2))
                     74:             end
                     75:          | term' x = x
                     76: 
                     77:         and term s = term' (atom s)
                     78: 
                     79:        and exp' ((p, PUNCTtok "+"), e1) = 
                     80:            let val (s, e2) = term(gettoken p)
                     81:             in exp'(s, F.BINOP(Integer.+, e1, e2))
                     82:             end
                     83:          | exp' ((p, PUNCTtok "-"), e1) = 
                     84:            let val (s, e2) = term(gettoken p)
                     85:             in exp'(s, F.BINOP(Integer.-, e1, e2))
                     86:             end
                     87:          | exp' x = x
                     88: 
                     89:        and exp (p, ALPHAtok "if") = 
                     90:            (case exp(gettoken p)
                     91:              of ((p',ALPHAtok "then"),e1) =>
                     92:                (case exp(gettoken p')
                     93:                  of ((p'', ALPHAtok "else"),e2) =>
                     94:                     (case exp(gettoken p'')
                     95:                       of (s,e3) => (s, F.IF(e1,e2,e3)))
                     96:                   | _ => raise (Syntax "else expected"))
                     97:                | _ => raise (Syntax "then expected"))
                     98:          | exp s = exp' (term s)
                     99: 
                    100:      in case exp (gettoken 0)
                    101:          of ( (_, EOFtok), e) => e
                    102:           | _ => raise (Syntax "garbage at end of formula")
                    103:     end
                    104: 
                    105: end

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.