Return to strs.sml CVS log

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

Annotation of researchv10no/cmd/sml/src/parse/strs.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: signature STRS = 
        !             3: sig type strArg
        !             4:     type strtype type spectype
        !             5:     type functorFormal
        !             6:     type 'a pathstamped
        !             7:     type 'a susp
        !             8:     type functorActual
        !             9:     type symbol type structureVar type strb type signatureVar
        !            10:     type dec type Functor type functorVar type strexp type Structure
        !            11:     type signtype type fctb
        !            12:     val makeSTRBs:     (symbol*structureVar*strb) list pathstamped
        !            13:                         -> dec pathstamped
        !            14:     val makeSTRB:      symbol * Structure option susp * strtype -> bool -> 
        !            15:                         (symbol * structureVar * strb) list pathstamped
        !            16:     val make_str_qid:  symbol list -> strtype
        !            17:     val make_str_struct: dec list pathstamped -> strtype
        !            18:     val spread_args:   dec list pathstamped -> functorActual
        !            19:     val single_arg:    strtype -> functorActual
        !            20:     val make_str_app:  symbol * functorActual -> strtype
        !            21:     val make_str_let:  dec list pathstamped * strtype -> strtype
        !            22:     val make_sigb:     symbol * signtype -> signatureVar list susp
        !            23:     val makeSIGdec:    signatureVar list susp -> dec pathstamped
        !            24:     val single_formal: symbol * signtype -> functorFormal
        !            25:     val spread_formal: spectype -> functorFormal
        !            26:     val makeFCTB:      symbol * functorFormal * Structure option susp * strtype ->
        !            27:                            (symbol * functorVar * fctb) list susp
        !            28:     val makeFCTdec: (symbol * functorVar * fctb) list susp ->
        !            29:                        dec pathstamped
        !            30:     val makeLOCALsdecs:        dec list pathstamped * dec list pathstamped
        !            31:                           -> dec list pathstamped
        !            32: end
        !            33: 
        !            34: structure Strs: STRS = 
        !            35: struct
        !            36: 
        !            37:   open ErrorMsg Symbol PrintUtil
        !            38:   open Access Basics BasicTypes TypesUtil Absyn
        !            39:   open Env
        !            40:   open EnvAccess
        !            41:   open ModUtil
        !            42:   open SigMatch
        !            43:   open Misc
        !            44: 
        !            45: type stampsets = Stampset.stampsets
        !            46: type 'a susp = unit -> 'a
        !            47: type 'a pathstamped = symbol list * stampsets -> 'a
        !            48: type signtype = Signs.signtype
        !            49: type spectype = Signs.spectype
        !            50: 
        !            51: type strArg = {abstract:bool,constraint: Structure option,
        !            52:                path:symbol list, param: Structure,
        !            53:                stamps:Stampset.stampsets}
        !            54: type strtype = strArg -> strexp * Structure * thinning
        !            55: 
        !            56: type functorFormal = (symbol * access * Structure * bool) susp
        !            57: type functorActual = Functor * strArg -> strexp * Structure
        !            58: fun makeSTRBs strb' $ =
        !            59:   STRdec(map (fn (name,strVar,strSyn) => (bindSTR(name,strVar); strSyn)) (strb' $))
        !            60: 
        !            61: fun makeSTRB(name,constraint,str) abstract ($ as (path,stamps)) =
        !            62:  case (constraint(),abstract)
        !            63:   of (NONE,true) =>
        !            64:        (complain "abstraction requires a signature constraint";
        !            65:         makeSTRB(name,fn()=>NONE,str) false $)
        !            66:    | (signopt,_) =>
        !            67:   let val (strexp,str,thin)=
        !            68:                str{abstract=abstract,constraint=signopt,path=name::path,
        !            69:                    param=NULLstr,stamps=stamps}
        !            70:       val strVar = STRvar{access=LVAR(namedLvar(name)),        name=[name],
        !            71:                                binding=str}
        !            72:    in [(name, strVar,
        !            73:             STRB{strvar=strVar, def=strexp, constraint=signopt, thin=thin})]
        !            74:   end
        !            75: 
        !            76: fun make_str_qid qid ({abstract,path,stamps,constraint,...}:strArg) =
        !            77:    let val strVar as STRvar{binding,...} = lookPath(qid,lookSTRinStr)
        !            78:     in case constraint
        !            79:         of NONE => (VARstr strVar, binding, NONE)
        !            80:          | SOME sgn =>
        !            81:              let val (str,thin) =
        !            82:                    SigMatch.match(abstract,path,stamps,sgn,binding,param)
        !            83:               in (VARstr strVar, str, thin)
        !            84:              end
        !            85:    end
        !            86: 
        !            87: fun make_str_struct sdecs ({abstract,path,param,stamps,constraint,...}:strArg) =
        !            88:     let val _ = openStr()
        !            89:        val body = sdecs(path,stamps)
        !            90:      in case constraint
        !            91:         of NONE => let val (thin,table) = BuildMod.buildStrTable ()
        !            92:                     in (STRUCTstr{body=body,locations=thin},
        !            93:                         mkSTR(path,table,DIR,stamps),
        !            94:                         NONE)
        !            95:                    end
        !            96:          | SOME sgn => let val (str,thin) =
        !            97:                                 SigMatch.realize(abstract,path,stamps,
        !            98:                                    Stampset.newStamp(#strStamps stamps),
        !            99:                                    sgn,param)
        !           100:                         in closeStr();
        !           101:                            (STRUCTstr{body=body,locations=thin}, str, NONE)
        !           102:                        end
        !           103:     end
        !           104: 
        !           105: fun spread_args sdecs (_,({stamps,...}:strArg)) =
        !           106:   let val _ = openStr()
        !           107:       val body = sdecs([anonParamName],stamps)
        !           108:       val (thin,table) = BuildMod.buildStrTable ()
        !           109:    in (STRUCTstr{body=body,locations=thin},
        !           110:        mkSTR([anonParamName],table,DIR,stamps))
        !           111:   end
        !           112: 
        !           113: fun single_arg str (fct,({stamps,...}:strArg)) =
        !           114:     let val FUNCTOR{paramName,...} = fct
        !           115:         val (strexp,str,_) = str{abstract=false,constraint=NONE,
        !           116:                         path=[paramName],param=NULLstr,stamps=stamps}
        !           117:      in (strexp,str)
        !           118:     end
        !           119: 
        !           120: fun make_str_app (id,arg) (info as ({abstract,path,stamps,constraint,...}:strArg)) =
        !           121:     let val fctVar as FCTvar{binding=fct,...} = lookFCT id
        !           122:        val (argexp,argstr) = arg(fct,info)
        !           123:        val (result,thin1) = Functor.applyFunctor(fct,argstr,path,stamps)
        !           124:        val strexp = APPstr{oper=fctVar, argexp=argexp, argthin=thin1}
        !           125:      in case constraint
        !           126:          of NONE => (strexp,result,NONE)
        !           127:           | SOME sgn =>
        !           128:               let val (thinned,thin2) =
        !           129:                       SigMatch.match(abstract,path,stamps,sgn,result,param)
        !           130:                in (strexp,thinned,thin2)
        !           131:               end
        !           132:     end
        !           133: 
        !           134: fun make_str_let (sdecs,str) (info as ({path,stamps,...}:strArg)) =
        !           135:    protect(protectScope,fn()=>
        !           136:       let val locals = sdecs(path,stamps)
        !           137:          val (bodyexp,bodystr,thin) = str info
        !           138:        in (LETstr(SEQdec locals, bodyexp),bodystr,thin)
        !           139:       end)
        !           140: 
        !           141: fun make_sigb(name,sign) () =
        !           142:    let val sigvar = SIGvar{name=name,binding= sign(1,Stampset.newStampsets())}
        !           143:     in bindSIG(name, sigvar); [sigvar]
        !           144:    end
        !           145: 
        !           146: fun makeSIGdec sigb ([],stamps) = SIGdec(sigb())
        !           147:   | makeSIGdec sigb (path,stamps) =
        !           148:                         (warn "signature found inside structure or functor"; 
        !           149:                          makeSIGdec sigb ([],stamps))
        !           150: 
        !           151: fun single_formal(name,sign) () =
        !           152:    let val senv = array(2, NULLstr) and tenv = array(0, NULLtyc)
        !           153:        val _ = openNew({path=[~1], strenv=REL{t=tenv,s=senv}}, newTable())
        !           154:        val access = LVAR(namedLvar name)
        !           155:        val param = sign(1,Stampset.newStampsets())
        !           156:     in update(senv,1,param);
        !           157:        bindSTR(name,STRvar{name=[name], access=access, binding=INDstr(1)});
        !           158:        (name,access,param,false)
        !           159:    end
        !           160: 
        !           161: fun spread_formal spec_s () =
        !           162:     let val plvar = namedLvar anonParamName
        !           163:         val param as STRstr{env,table,...} =
        !           164:               Signs.makeSIG spec_s (2,Stampset.newStampsets())
        !           165:      in openOld({path=[~1,1],strenv=env},table);
        !           166:         (anonParamName,LVAR(plvar),param,true)
        !           167:     end
        !           168: 
        !           169: fun makeFCTB(name,fparam,constraint_op,str) () =
        !           170:    let val mEntry = openScope()
        !           171:        val (pname,paccess,param,spreadParams) = fparam()
        !           172:        val resSign = constraint_op ()
        !           173:        val _ = if spreadParams
        !           174:                then let val STRstr{table,env,...} = param
        !           175:                                 and LVAR plvar = paccess
        !           176:                      in resetEnv(mEntry);
        !           177:                         openOld({path=[plvar],strenv=env},table)
        !           178:                     end
        !           179:                else ()
        !           180:        val bodystamps = Stampset.newStampsets()
        !           181:        val (bodyexp,bodystr,thin) = 
        !           182:                str{abstract=false,constraint=resSign,path=[],
        !           183:                        stamps=bodystamps,param=param}
        !           184:        val openBody = case bodystr
        !           185:                       of STRstr{stamp=bodystamp,env=DIR,...} =>
        !           186:                           Stampset.member(bodystamp,(#strStamps bodystamps))
        !           187:                        | _ => false
        !           188:        val paramVis = case resSign of SOME _ => true | NONE => openBody
        !           189:        val body = if openBody
        !           190:                    then Functor.abstractBody(bodystr,param,bodystamps,
        !           191:                           Stampset.newStamp(Stampset.sigStamps))
        !           192:                    else bodystr
        !           193:        val paramvar = STRvar{name=[pname], access=paccess, binding=param}
        !           194:        val fctv = FCTvar{name=name, 
        !           195:                         access=LVAR(namedLvar(name)),
        !           196:                                 binding=FUNCTOR{paramName=pname, param=param,
        !           197:                                                 body=body, paramVis=paramVis,
        !           198:                                                 stamps=bodystamps}}
        !           199:        val fb = FCTB{fctvar=fctv, param=paramvar, def=bodyexp, thin=thin,
        !           200:                      constraint=resSign}
        !           201:     in resetEnv(mEntry);
        !           202:        [(name,fctv,fb)]
        !           203:    end
        !           204: 
        !           205: fun makeFCTdec fctb ([],stamps) =
        !           206:   FCTdec(map (fn(name,fctVar,fctSyn)=>(bindFCT(name,fctVar); fctSyn)) (fctb()))
        !           207:   | makeFCTdec fctb (path,stamps) =
        !           208:    (warn "functor found inside structure or functor"; 
        !           209:     makeFCTdec fctb ([],stamps))
        !           210: 
        !           211: fun makeLOCALsdecs(sdecs1,sdecs2) $ =
        !           212:   let val envLocal = openScope()
        !           213:       val ld1 = sdecs1 $
        !           214:       val envIn = (openScope(); current())
        !           215:       val ld2 = sdecs2 $
        !           216:    in splice(envLocal,envIn);
        !           217:       [LOCALdec(SEQdec ld1, SEQdec ld2)]
        !           218:   end
        !           219: 
        !           220: end

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