![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to strs.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / parse|
Return to strs.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / parse |
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.