Return to runtime.sml CVS log

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

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

1.1     ! root        1: 
        !             2: (* April 1989, Jussi Rintanen, Helsinki University of Technology *)
        !             3: 
        !             4: (* This is the signature of a specification generated by ML-Twig *)
        !             5: 
        !             6: signature TWIG_SPECIFICATION =
        !             7:   sig
        !             8:     type cost and tree and result
        !             9:     eqtype rule and symbol
        !            10: 
        !            11:     val get_subtrees : tree -> tree list
        !            12:     val node_value : tree -> symbol
        !            13:     val cost_less : cost * cost -> bool
        !            14: 
        !            15:     datatype skeletal = Skeleton of rule * cost * tree * skeletal list
        !            16: 
        !            17:     exception MatchAbort and InternalError of string
        !            18: 
        !            19:     val execute_cost : rule * tree * skeletal list -> cost
        !            20:     val execute : skeletal -> result
        !            21:     val getreplacement : result -> tree
        !            22:     val rewriterule : rule -> bool
        !            23:     val matches : rule -> int
        !            24: 
        !            25: (* Definitions for unit rule matches and the tree pattern matching automaton *)
        !            26: 
        !            27:     eqtype state
        !            28: 
        !            29:     datatype matchtree = Chain of rule * symbol * matchtree list
        !            30:     val unitmatches : symbol -> matchtree list
        !            31: 
        !            32:     val childsymbol : int -> symbol
        !            33:     val initialstate : state
        !            34:     val go : state * symbol -> state
        !            35:     val go_f : state * symbol -> (int * rule * symbol) list
        !            36: end;
        !            37: 
        !            38: (* This functor maps a specification to a structure containing a complete tree
        !            39:    processor program and associated definitions. *)
        !            40: 
        !            41: functor MAKEtreeprocessor ( Specification : TWIG_SPECIFICATION) =
        !            42:   struct
        !            43:     structure Spec : TWIG_SPECIFICATION = Specification
        !            44: 
        !            45:     open Spec
        !            46: 
        !            47:     exception NoCover
        !            48:     
        !            49:     fun internal s = raise InternalError ("FATAL:"^s)
        !            50: 
        !            51: (* The structure representation implements a data type for
        !            52:    maintaining information of the matching tree pattern
        !            53:    matching process. The actual implementation is left
        !            54:    unspecified in the signature. However, because of the
        !            55:    match mode rewrite, an implementation without side effects
        !            56:    is required. *)
        !            57: 
        !            58:     structure Representation :
        !            59:       sig
        !            60:        type 's table
        !            61:        structure Spec : TWIG_SPECIFICATION
        !            62: 
        !            63:        val empty_table : unit -> 's table
        !            64:        val new_level : 's table -> 's table
        !            65:        val contribute0 : 's table * int * Spec.rule * Spec.symbol -> 's table
        !            66:        val contribute1 : 's table * int * Spec.rule * Spec.symbol * 's -> 's table
        !            67:        val get_level : 's table -> (Spec.symbol * (Spec.rule * int * 's list) list) list * 's table
        !            68:       end
        !            69:     =
        !            70:     struct
        !            71: 
        !            72: (* The table is a list, where the head contains the match information
        !            73:    for the current node of the user tree. The tail of the list
        !            74:    contains the match information for the ancestors of the current
        !            75:    node. The match information for a node is an ordered list of pairs,
        !            76:    where the first member is the number of the non-terminal, to which
        !            77:    the matches in the second member contribute.
        !            78:      The matches for a non-terminal are in an ordered list of triples
        !            79:    rule * number of matches * children skeletons. *)
        !            80: 
        !            81:       structure Spec = Spec
        !            82: 
        !            83:       open Spec
        !            84: 
        !            85:       type 's table = (symbol * (rule * int * 's list) list) list list
        !            86:       fun empty_table () = []
        !            87:       fun new_level l = []::l
        !            88:       fun insert0' (r:rule,nil) = [(r,1,[])]
        !            89:        | insert0' (r:rule,(h as (r',m',s'))::hs) =
        !            90:          if r' <> r
        !            91:            then h :: insert0' (r,hs)
        !            92:          else (r,m'+1,s')::hs
        !            93:       fun insert0 (nil,r,t:symbol) = [(t,[(r,1,[])])]
        !            94:        | insert0 ((h as (t',a))::hs,r,t) =
        !            95:          if t' <> t
        !            96:            then h :: insert0 (hs,r,t)
        !            97:          else (t,insert0' (r,a))::hs
        !            98:       fun insert1' (r:rule,s,nil) = [(r,1,[s])]
        !            99:        | insert1' (r,s,(h as (r',m',s'))::hs) =
        !           100:          if r' <> r
        !           101:            then h :: insert1' (r,s,hs)
        !           102:          else (r,m'+1,s::s')::hs
        !           103:       fun insert1 (nil,r,t:symbol,s) = [(t,[(r,1,[s])])]
        !           104:        | insert1 ((h as (t',a))::hs,r,t,s) =
        !           105:          if t' <> t
        !           106:            then h :: insert1 (hs,r,t,s)
        !           107:          else (t,insert1' (r,s,a)):: hs
        !           108:       fun contribute0 (a::l,1,r,t) = insert0 (a,r,t) :: l
        !           109:        | contribute0 (a::l,n,r,t) = a::contribute0(l,n-1,r,t)
        !           110:        | contribute0 _ = internal "run out of levels"
        !           111:       fun contribute1 (a::l,1,r,t,s) = insert1(a,r,t,s) :: l
        !           112:         | contribute1 (a::l,n,r,t,s) = a::contribute1(l,n-1,r,t,s)
        !           113:        | contribute1 _ = internal "run out of levels"
        !           114:       fun get_level (a::l) = (a,l)
        !           115:        | get_level _ = internal "run out of levels"
        !           116:     end
        !           117: 
        !           118:   open Representation
        !           119: 
        !           120: (* Utility functions *)
        !           121: 
        !           122:   val accum = revfold
        !           123: 
        !           124:   fun cost (Skeleton(_,c,_,_)) = c
        !           125:     
        !           126:   fun insert (i:symbol, s, nil) = [(i,s)]
        !           127:     | insert (i, s, (head as (i',s'))::rest) =
        !           128:          if i = i'
        !           129:            then
        !           130:              if cost_less (cost s,cost s')
        !           131:                then (i,s)::rest
        !           132:              else head::rest
        !           133:          else head :: (insert (i,s,rest))
        !           134: 
        !           135:   fun build_skeleton (ar as (r,t,cs)) = Skeleton (r,execute_cost ar,t,rev cs)
        !           136: 
        !           137: (* get_closure takes four arguments. The first is a unit rule tree.
        !           138: The second is the sub-skeleton in the unit rule match. The third
        !           139: is the ir-tree of the current node, and the fourth is the list
        !           140: of skeletons generated so far. The skeleton list consists of pairs:
        !           141: the first element is the number of the non-terminal of the rule,
        !           142: and the second element is the skeleton. *)
        !           143: 
        !           144:   fun get_closure (ct,ss,t,ac) =
        !           145:     accum (fn (Chain(r,n,cs),ac') =>
        !           146:           let val skel = build_skeleton(r,t,ss)
        !           147:           in
        !           148:             get_closure (cs,[skel],t,insert (n,skel,ac'))
        !           149:           end handle MatchAbort => ac')
        !           150:           ct ac
        !           151: 
        !           152:   fun someone (t,still_best, nil) = [still_best]
        !           153:     | someone (t,still_best, (r,m,cs)::rest) =
        !           154:       if matches r = m
        !           155:        then
        !           156:          let val skel = build_skeleton (r,t,cs)
        !           157:          in someone (t,if cost_less (cost skel,cost still_best)
        !           158:                        then skel
        !           159:                      else still_best,rest)
        !           160:          end handle MatchAbort => someone (t,still_best,rest)
        !           161:        else someone(t,still_best,rest)
        !           162: 
        !           163:   fun still_no_one (t,nil) = nil
        !           164:     | still_no_one (t,(r,m,cs)::rest) =
        !           165:       if matches r = m
        !           166:        then someone (t,build_skeleton (r,t,cs),rest)
        !           167:          handle MatchAbort => still_no_one (t,rest)
        !           168:       else still_no_one (t,rest)
        !           169: 
        !           170:   fun leave_best_alone (t,nil) = internal "matcher state inconsistent. lba."
        !           171:     | leave_best_alone (t,l) = still_no_one (t,l)
        !           172: 
        !           173:   fun skeletons_of (state,node,tab) =
        !           174:     let val (t,s) =
        !           175:       case get_subtrees node of
        !           176:        nil =>
        !           177:          let val tab' =
        !           178:            accum (fn ((h,r,n),t) => contribute0 (t,h-1,r,n))
        !           179:              (go_f(state, node_value node)) tab
        !           180:          in
        !           181:            (tab', get_closure ((unitmatches o node_value) node,[],node,[]))
        !           182:          end
        !           183:       | ls =>
        !           184:          let val state' = go (state, node_value node)
        !           185:            val (table, _) =
        !           186:              accum (fn (l,(t,i)) =>
        !           187:                     let val state'' = go (state',childsymbol i)
        !           188:                       val (t', ss) = skeletons_of (state'',l,t)
        !           189:                     in (accum (fn ((r,s),t'') =>
        !           190:                                let val finals = go_f (state'',r)
        !           191:                                in
        !           192:                                  accum
        !           193:                                  (fn ((h,r,n),t''') =>
        !           194:                                     contribute1 (t''',h-1,r,n,s))
        !           195:                                     finals t''
        !           196:                                end) ss t',i+1)
        !           197:                     end)
        !           198:                     ls
        !           199:                     (new_level tab, 1)
        !           200:            val (toplevel, table') = get_level table
        !           201:          in
        !           202:            (table',
        !           203:             let val unclosurized = accum (fn ((_,nil),l) => l | ((n,[e]),l) => (n,e)::l | _ => internal "inconsistency. 01l")
        !           204:               (map (fn (n,sl) => (n,leave_best_alone (node,sl))) toplevel)
        !           205:                  nil
        !           206:             in
        !           207:               accum (fn ((n,s),al) =>
        !           208:                      get_closure (unitmatches n,[s],node,al)) unclosurized unclosurized
        !           209:             end)
        !           210:          end
        !           211:     in
        !           212:       case s of
        !           213:        [] => (t,[])
        !           214:       | [(_,S as Skeleton(r,_,_,_))] =>
        !           215:          if rewriterule r
        !           216:            then skeletons_of(state,(getreplacement o execute) S,tab)
        !           217:          else (t,s)
        !           218:       |  (_,sk)::rest =>
        !           219:            let val best as Skeleton (r,_,_,_) =
        !           220:              accum (fn ((n,s),bs) =>
        !           221:                     if cost_less (cost s,cost bs) then s else bs) rest sk
        !           222:            in
        !           223:              if rewriterule r
        !           224:                then skeletons_of(state,
        !           225:                                  (getreplacement o execute) best,
        !           226:                                   tab)
        !           227:              else (t,s)
        !           228:            end
        !           229:     end
        !           230: 
        !           231:   fun translate t = execute
        !           232:     (case (skeletons_of (initialstate,t,empty_table())) of
        !           233:        (_,(_,s)::t) =>
        !           234:          accum (fn ((n,s),bs) =>
        !           235:                 if cost_less (cost s,cost bs) then s else bs) t s
        !           236:     | (_,nil) => raise NoCover)
        !           237: 
        !           238:   end;

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