Return to main.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / lib / twig

Annotation of researchv10no/cmd/sml/lib/twig/main.sml, revision 1.1

1.1     ! root        1: (* May 1989, Jussi Rintanen, Helsinki University of Technology *)
        !             2: 
        !             3: functor MAKEmain (structure Parser : PARSER
        !             4:                  and Automata : AUTOMATA
        !             5:                    sharing Automata.Parser = Parser)
        !             6:                    : sig val main : string -> unit end =
        !             7:   struct
        !             8: 
        !             9:     open Parser Automata
        !            10: 
        !            11:     val int2str : int -> string = makestring
        !            12: 
        !            13:     val accum = revfold
        !            14: 
        !            15:     fun count (a,nil) = 0
        !            16:       | count (a,h::t) = (if a = h then 1 else 0) + count (a,t)
        !            17: 
        !            18:     fun member p = (count p) <> 0
        !            19: 
        !            20: (* Output *)
        !            21: 
        !            22:     fun labellist (Leaf (Label l)) = [l]
        !            23:       | labellist (Tree (_,cs)) = accum (fn (c,ac) => ac@(labellist c)) cs []
        !            24:       | labellist _ = []
        !            25: 
        !            26:     fun index (passed,nil) = []
        !            27:       | index (passed,h::t) =
        !            28:        (if member (h,passed) orelse member (h,t)
        !            29:           then h^(int2str (count (h,passed) + 1))
        !            30:         else h):: (index (h::passed,t))
        !            31: 
        !            32:     fun emitlist' (e,nil) = ()
        !            33:       | emitlist' (e,[a]) = e a
        !            34:       | emitlist' (e,h::t) = (e h;e",";emitlist' (e,t))
        !            35: 
        !            36:     fun emitlist (e,l) = (e"[";emitlist'(e,l);e"]")
        !            37: 
        !            38:     fun emitcost (emit, rules, defaultcost) =
        !            39:       (emit "fun execute_cost (n:rule, ir, children) =\nlet open User\n";
        !            40:        case defaultcost of
        !            41:         NoCost => ()
        !            42:        | Cost code => (emit "val DC = ( "; app emit code; emit ") (map cost children)\n");
        !            43:        emit "val ABORT = (fn () => raise MatchAbort)\n in\ncase n of\n  ";
        !            44:        app (fn (Rule(n,_,_,p,Cost ss,_)) =>
        !            45:            (emit (int2str n);
        !            46:             emit " => (case map cost children of ";
        !            47:             emitlist (emit, index ([],labellist p));
        !            48:             emit " => (";
        !            49:             app emit ss;
        !            50:             emit ") | _ => raise InternalError \"S4\")\n  | ")
        !            51:               | (Rule(n,_,_,_,NoCost,_)) => (emit (int2str n);emit" => DC\n  | "))
        !            52:                   rules;
        !            53:        emit "_ => raise InternalError \"S4.3.\"\nend\n\n")
        !            54: 
        !            55:     fun tokens (passed,h::t) =
        !            56:       let val suffix =
        !            57:        if member (h,passed) orelse member (h,t)
        !            58:          then (int2str (count (h,passed)+1))
        !            59:        else ""
        !            60:       in
        !            61:        ("_"^h^" "^h^suffix,
        !            62:         "execute (nth(children,"^(int2str (length passed))^"))"
        !            63:         )::(tokens (h::passed,t))
        !            64:       end
        !            65:     | tokens _ = []
        !            66: 
        !            67:     fun reftokens ls = tokens ([],ls)
        !            68: 
        !            69:     fun DOtokens (passed,h::t) =
        !            70:       let val suffix =
        !            71:        if member (h,passed) orelse member (h,t)
        !            72:          then (int2str (count (h,passed)+1))
        !            73:        else ""
        !            74:       in
        !            75:        ("DO"^h^suffix,
        !            76: (*      "let val C = nth(children,"^(int2str (length passed))^")in fn () => let val _"^h^" V = execute C in V end end" *)
        !            77:         "let val C = nth(children,"^(int2str (length passed))^")in fn () => case execute C of _"^h^" V => V | _ => raise InternalError \"S4.3\" end"
        !            78:         )::(DOtokens (h::passed,t))
        !            79:       end
        !            80:       | DOtokens _ = []
        !            81: 
        !            82:     fun DOreftokens ls = DOtokens ([],ls)
        !            83: 
        !            84:     fun emittuple'(e,nil) = ()
        !            85:       | emittuple'(e,[a]) = e a
        !            86:       | emittuple'(e,h::t) = (e h;e",";emittuple'(e,t))
        !            87:        
        !            88:     fun emittuple (e,t) = (e"(";emittuple'(e,t);e")")
        !            89:       
        !            90:     fun emitval (e,l) =
        !            91:       (emittuple (e,map (fn (_,a) => a) l);
        !            92:        e" of ";
        !            93:        emittuple (e,map (fn (a,_) => a) l))
        !            94: 
        !            95:     fun emitaction (emit, rules) =
        !            96:       (emit "fun execute (Skeleton (n,_, ir, children)) =\n\
        !            97:        \ let open User\n";
        !            98:        emit "in\ncase n of\n";
        !            99:        app (fn (Rule(n,t,Label l,p,_,Action ss)) =>
        !           100:            let val labels = labellist p
        !           101:              in
        !           102:                emit (int2str n);
        !           103:                emit " => ";
        !           104:                  (case t of
        !           105:                     Ordinary => emit ("_"^l)
        !           106:                   | Topdown => emit ("_"^l)
        !           107:                   | Rewrite => emit "__rewrite");
        !           108:                     if labels <> nil
        !           109:                       then (emit " ( case ";
        !           110:                             (case t of
        !           111:                                Ordinary =>
        !           112:                                  emitval (emit,reftokens (labellist p))
        !           113:                              | Topdown =>
        !           114:                                  emitval (emit,DOreftokens (labellist p))
        !           115:                              | Rewrite => emitval (emit,[("_","()")]));
        !           116:                                emit " => ")
        !           117:                     else ();
        !           118:                     app emit ss;
        !           119:                     if labels <> nil
        !           120:                       then
        !           121:                         case t of
        !           122:                           Ordinary => emit " | _ => raise InternalError \"S5\" )"
        !           123:                         | Topdown => emit" )"
        !           124:                         | Rewrite => emit" )"
        !           125:                     else ();
        !           126:                     emit "\n  | "
        !           127:            end | _ => ())
        !           128:              rules;
        !           129:              emit "_ => raise Match\n";
        !           130:                emit "end\n\n")
        !           131: 
        !           132:     fun emitrewrite (emit, rules) =
        !           133:       (emit "fun rewriterule (r:rule) =\n\
        !           134:        \ case r of\n";
        !           135:        app (fn (Rule(n,Rewrite,_,_,_,_)) =>
        !           136:            (emit (int2str n); emit " => true |") | _ => ())
        !           137:               rules;
        !           138:        emit "_ => false\n")
        !           139: 
        !           140: (* Symbol datatype declaration *)
        !           141: 
        !           142:     fun symbol2str (Label s) = "__"^s
        !           143:       | symbol2str (Node (s,_)) = s
        !           144: 
        !           145:     fun emitsymbols (emit,symbols) =
        !           146:       let val maxarity =
        !           147:        accum
        !           148:        (fn (Node (_,a),max) => if a > max then a else max | (_,a) => a )
        !           149:           symbols 0
        !           150:       in
        !           151:        emit "ARC of int";
        !           152:        map
        !           153:        (fn s => emit (" | "^(symbol2str s)))
        !           154:           symbols;
        !           155:        emit "\n"
        !           156:       end
        !           157: 
        !           158: (* Unit match trees *)
        !           159:            
        !           160:     fun leafs (Leaf _) = 1
        !           161:       | leafs (Tree(_,cs)) = fold (op +) (map leafs cs) 0
        !           162: 
        !           163:     fun emitmatches (_,nil) = ()
        !           164:       | emitmatches (emit, (Rule(n0,_,_,p,_,_)::rules)) =
        !           165:       (emit "val matchcounts = [\n";
        !           166:       let val n =
        !           167:        (emit ("(" ^ (int2str n0) ^ "," ^ (int2str (leafs p)) ^ ")");
        !           168:         accum
        !           169:         (fn (Rule(n,_,_,p,_,_),m) =>
        !           170:            (emit (",\n(" ^ (int2str n) ^ "," ^ (int2str (leafs p)) ^ ")");
        !           171:            if n > m then n else m))
        !           172:              rules n0)
        !           173:       in
        !           174:         emit "]\nval matchtable = let val a = array(";
        !           175:         emit (int2str (n+1));
        !           176:         emit ",0) in ((app (fn(r,m)=>update (a,r,m)) matchcounts); a) end\n\n\
        !           177:           \fun matches r = matchtable sub r\n\n"
        !           178:       end)
        !           179: 
        !           180: (* Unit rules *)
        !           181: 
        !           182:     datatype matchtree = Chain of int * symbol * matchtree list
        !           183: 
        !           184:     fun closurize unitrules =
        !           185:       let val rec member =
        !           186:        (fn (a,nil) => false | (a,h::t) => if a=h then true else member (a,t))
        !           187:          val initials =
        !           188:            accum
        !           189:            (fn ((_,_,i),a) => if member (i,a) then a else i::a)
        !           190:               unitrules nil
        !           191:          fun build_unittree (nt,visited) =
        !           192:            accum (fn ((r,n,p),ac) =>
        !           193:                   if p = nt andalso not (member (n,visited))
        !           194:                     then Chain(r,n,build_unittree(n,n::visited))::ac
        !           195:                   else ac) unitrules nil
        !           196:       in
        !           197:        map (fn i => (i,build_unittree (i,[i]))) initials
        !           198:       end
        !           199:     
        !           200:     fun emitmatchtreelist (emit,nil) = ()
        !           201:       | emitmatchtreelist (emit,[m]) = emitmatchtree (emit, m)
        !           202:       | emitmatchtreelist (emit,(h::t)) = (emitmatchtree (emit,h); emit ","; emitmatchtreelist (emit,t))
        !           203:     and emitmatchtree (emit, Chain (i, j, ml)) =
        !           204:       (emit "Chain (";
        !           205:        emit (int2str i);
        !           206:        emit ",";
        !           207:        emit (symbol2str j);
        !           208:        emit ",[";
        !           209:        emitmatchtreelist (emit,ml);
        !           210:        emit "])")
        !           211: 
        !           212:     fun emitunitrules (emit, matchtrees,symbols) =
        !           213:       (emit "datatype matchtree = Chain of int * symbol * matchtree list\n";
        !           214:        emit "fun unitmatches nt = (case nt of\n";
        !           215:        app (fn (s,ms) => (emit (symbol2str s);
        !           216:                          emit " => [";
        !           217:                          emitmatchtreelist (emit,ms);
        !           218:                          emit "]\n  | "))
        !           219:            matchtrees;
        !           220:        emit "_ => [])\n\n")
        !           221: 
        !           222:     fun partition' (nil,u,n) = (u,n)
        !           223:       | partition' (Rule(r,_,l,Leaf s,_,_)::t,u,n) = partition' (t,(r,l,s)::u,n)
        !           224:       | partition' (r::t,u,n) = partition' (t,u,r::n)
        !           225: 
        !           226:     fun partition l = partition' (l,nil,nil)
        !           227: 
        !           228: (* Main *)
        !           229: 
        !           230:     fun fatal s = output std_out ("Fatal error: "^s^"\n")
        !           231: 
        !           232:     fun main inputfilename =
        !           233:       let
        !           234:        val outputfilename = inputfilename ^ ".sml"
        !           235:        val (inputf, outputf) = (open_in inputfilename,open_out outputfilename)
        !           236:        val emit = output outputf
        !           237:        val (inserts, rules, dcost, structuren, label_type, symbols) = specification inputf
        !           238:        val (unitrules, otherrules) = partition rules
        !           239:       in
        !           240:        emit "structure ";
        !           241:        emit structuren;
        !           242:        emit " =\n\
        !           243:        \struct\n\
        !           244:        \  structure User =\n\
        !           245:        \  struct\n\
        !           246:        \datatype symbol =\n";
        !           247:        emitsymbols (emit,symbols);
        !           248:        app (fn Prologue ss => (app emit ss) | Insert ss => (app emit ss)) inserts;
        !           249:        emit "\n\ndatatype result = __rewrite of tree | ";
        !           250:        emit label_type;
        !           251:        emit "\n end\n\n\
        !           252:        \structure Specification =\n\
        !           253:        \  struct\n\
        !           254:        \structure User = User\n\nopen User\n\
        !           255:        \type rule = int\n\
        !           256:        \datatype skeletal = Skeleton of (rule * cost * tree * skeletal list)\n\
        !           257:        \exception MatchAbort\n\
        !           258:        \fun cost (Skeleton(_,c,_,_)) = c\n\
        !           259:        \exception InternalError of string\n\n\
        !           260:        \fun get_subtree (n,t) = nth (get_subtrees t,n-1)\n\n";
        !           261:        emitcost (emit,rules,dcost);
        !           262:        emitaction (emit,rules);
        !           263:        emitmatches (emit, rules);
        !           264:        build_automaton (outputf,symbols,otherrules);
        !           265:        emitunitrules(emit, closurize unitrules,symbols);
        !           266:        emitrewrite (emit,rules);
        !           267:        emit "fun getreplacement (__rewrite t) = t | getreplacement _ = raise InternalError \"problem with rewrite 996\"\n\
        !           268:        \  end\n\
        !           269:         \structure Internal = MAKEtreeprocessor(Specification)\n\
        !           270:        \exception NoCover = Internal.NoCover\n\
        !           271:        \exception InternalError = Internal.InternalError\n\
        !           272:        \val translate = Internal.translate\n\
        !           273:         \end;\n";
        !           274:        close_in inputf;
        !           275:        close_out outputf
        !           276:       end
        !           277:     handle ParserError s => fatal s
        !           278:         | AutomatonError s => fatal s
        !           279:           
        !           280:   end;
        !           281: 
        !           282: structure Parser = MAKEparser(structure Symboltable = Symboltable
        !           283:                              and Lexer = Lexer);
        !           284: 
        !           285: structure Main = MAKEmain(structure Parser = Parser
        !           286:                          and Automata = MAKEautomata(structure Parser = Parser));

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