Return to buildmod.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / env

Annotation of researchv10no/cmd/sml/src/env/buildmod.sml, revision 1.1.1.1

1.1       root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
                      2: (* buildmod.sml *)
                      3: 
                      4: (* building structures *)
                      5: 
                      6: structure BuildMod : BUILDMOD =
                      7: struct
                      8: 
                      9: open ErrorMsg Symbol Access Basics TypesUtil Env NameSpace
                     10: 
                     11: (* ordering of binders -- comparing by bound symbol for runtime components *)
                     12: fun binderGt(bind1: binder, bind2: binder) =
                     13:     case (bind1,bind2)
                     14:       of ((ind1,_,FIXbind(_)),(ind2,_,FIXbind(_))) => ind1 > ind2
                     15:        | ((_,_,FIXbind(_)),_) => true
                     16:        | (_,(_,_,FIXbind(_))) => false
                     17:        | ((_,n1,VARbind(_)),(_,n2,VARbind(_))) => n1 > n2
                     18:        | ((_,_,VARbind(_)),_) => true
                     19:        | (_,(_,_,VARbind(_))) => false
                     20:        | ((_,n1,CONbind(_)),(_,n2,CONbind(_))) => n1 > n2
                     21:        | ((_,_,CONbind(_)),_) => true
                     22:        | (_,(_,_,CONbind(_))) => false
                     23:        | ((ind1,_,TYCbind(_)),(ind2,_,TYCbind(_))) => ind1 > ind2
                     24:        | ((_,_,TYCbind(_)),_) => true
                     25:        | (_,(_,_,TYCbind(_))) => false
                     26:        | ((_,n1,STRbind(_)),(_,n2,STRbind(_))) => n1 > n2
                     27:        | ((_,_,STRbind(_)),_) => true
                     28:        | (_,(_,_,STRbind(_))) => false
                     29:        | ((ind1,_,FCTbind(_)),(ind2,_,FCTbind(_))) => ind1 > ind2
                     30:        | ((_,_,FCTbind(_)),_) => true
                     31:        | (_,(_,_,FCTbind(_))) => false
                     32:        | ((ind1,_,SIGbind(_)),(ind2,_,SIGbind(_))) => ind1 > ind2
                     33:        | _ => impossible "EnvAccess.binderGt"
                     34: 
                     35: fun extendPath(LVAR(v): access, []: path) = PATH[v] (* locally defined *)
                     36:   | extendPath(SLOT(n), p) = PATH(n::p)  (* element of opened structure *)
                     37:   | extendPath(x as PATH _, _) = x  (* defined exception *)
                     38:   | extendPath(x as INLINE _, _) = x
                     39:   | extendPath(access,path) = impossible "extendPath in envaccess"
                     40: 
                     41: fun dconInStr(dc as DATACON{name,const,typ,rep,sign},env,slotNo) : datacon =
                     42:     DATACON{name = name, const = const, sign = sign,
                     43:             rep = (case rep
                     44:                     of VARIABLE(access) => VARIABLE(SLOT slotNo)
                     45:                      | _ => rep),
                     46:             typ = ref(typeInContext(!typ,env))}
                     47: 
                     48: fun last (x as [_]) = x | last(a::b) = last b | last [] = impossible "last"
                     49: 
                     50: fun buildStrTable () : trans list * symtable =
                     51:     let val newtable = newTable()
                     52:        val add = IntStrMap.add newtable
                     53:        val look = IntStrMap.map newtable
                     54:        fun getBindings() =
                     55:            (* no sorting done, except chronological by collectTable *)
                     56:            let val r = ref (nil : (binder * info) list)
                     57:                fun add x = r := x :: !r
                     58:             in collectTable add;
                     59:                !r
                     60:            end
                     61:        fun fill (nil,count) = nil
                     62:          | fill ((bdg as (i,s,binding),{path,strenv})::rest,count) =
                     63:               (look(i,s); fill(rest,count)) handle UnboundTable =>     
                     64:             case binding
                     65:              of VARbind(var as VALvar{access,name,typ}) =>
                     66:                   (add(i,s,
                     67:                        VARbind(
                     68:                          case access
                     69:                           of INLINE(_) => var
                     70:                            | _ =>
                     71:                                VALvar{access = SLOT count,
                     72:                                       typ = ref(typeInContext(!typ,strenv)),
                     73:                                       name = last name}));
                     74:                    VALtrans(extendPath(access,path))::fill(rest,count+1))
                     75:               | CONbind(exn as DATACON{rep=VARIABLE(access),...}) =>
                     76:                   (add(i,s,CONbind(dconInStr(exn,strenv,count)));
                     77:                    VALtrans(extendPath(access,path))::fill(rest,count+1))
                     78:               | STRbind(STRvar{name,access,binding}) =>
                     79:                   let val newbinding =
                     80:                           case binding
                     81:                            of INDstr i =>
                     82:                               (case strenv
                     83:                                 of REL{s=senv,...} => senv sub i
                     84:                                  | DIR => impossible "buildStrTable.fill 1")
                     85:                             | SHRstr(i::r) =>
                     86:                               (case strenv
                     87:                                 of REL{s=senv,...} => getEpath(r,senv sub i)
                     88:                                  | DIR => impossible "buildStrTable.fill 2")
                     89:                             | _ => binding
                     90:                    in add(i,s, STRbind(STRvar{name=last name,
                     91:                                               binding=newbinding,
                     92:                                               access=SLOT(count)}));
                     93:                       VALtrans(extendPath(access,path))::fill(rest,count+1)
                     94:                   end
                     95:               | TYCbind(tyconRef) =>
                     96:                   (add(i,s,TYCbind(ref(tyconInContext strenv (!tyconRef))));
                     97:                    fill(rest,count))
                     98:               | CONbind(dcon) =>
                     99:                   (add(i,s,CONbind(dconInStr(dcon,strenv,0)));
                    100:                    fill(rest,count))
                    101:               | _ => (add bdg; fill(rest,count))
                    102:      in (fill(getBindings(),0), newtable)
                    103:     end
                    104: 
                    105: end (* structure BuildMod *)

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