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     ! 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.