![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ml.grm 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 ml.grm CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / parse |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: open ErrorMsg Symbol PrintUtil
3: open Access Basics BasicTypes TypesUtil Absyn
4: open Env
5: open EnvAccess
6: open ModUtil
7: open SigMatch
8: open Misc
9: open CoreLang
10: open Signs
11: open Strs
12: %%
13: %term
14: EOF | ID of Symbol.symbol | IDDOT of Symbol.symbol | TYVAR of Symbol.symbol
15: | INT of int | REAL of string | STRING of string | ABSTRACTION | ABSTYPE | AND
16: | ARROW | AS | BAR | CASE | DATATYPE | DOTDOTDOT | ELSE | END | EQUAL
17: | EQTYPE | EXCEPTION | DO | DARROW | FN | FUN | FUNCTOR | HANDLE | HASH
18: | IF | IN | INCLUDE | INFIX | INFIXR | LET | LOCAL | NONFIX | OF | OP
19: | OPEN | OVERLOAD | QUERY | RAISE | REC | SHARING | SIG | SIGNATURE | STRUCT
20: | STRUCTURE | THEN | TYPE | VAL | WHILE | WILD | WITH | WITHTYPE | ASTERISK
21: | COLON | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE | RBRACKET | RPAREN |
22: SEMICOLON | ORELSE | ANDALSO | IMPORT
23:
24: %nonterm ident of symbol
25: | optional_op of unit
26: | opid of symbol
27: | qid of symbol list
28: | selector of symbol
29: | tycon of symbol list
30: | tlabel of (symbol * ty) susp
31: | tlabels of (symbol * ty) list susp
32: | ty' of ty susp
33: | tuple_ty of ty list susp
34: | ty of ty susp
35: | ty0_pc of ty list susp
36: | match of rule list stamped
37: | rule of rule stamped
38: | elabel of (symbol * exp) stamped
39: | elabels of (symbol * exp) list stamped
40: | exp_ps of exp list stamped
41: | exp of exp stamped
42: | app_exp of exp precStack stamped
43: | aexp of exp stamped
44: | bexp of exp stamped
45: | cexp of exp stamped
46: | dexp of exp stamped
47: | exp_list of exp list stamped
48: | exp_2c of exp list stamped
49: | pat of pat susp
50: | app_pat of appat precStack susp
51: | apat of pat susp
52: | plabel of (symbol * pat) susp
53: | plabels of ((symbol * pat) list * bool) susp
54: | pat_2c of pat list susp
55: | pat_list of pat list susp
56: | vb of vb list stamped
57: | constraint of ty option susp
58: | rvb of rawrvb list susp
59: | fb' of rawclause list susp
60: | fb of rawclause list list susp
61: | clause of rawclause susp
62: | tb of bool -> tb list pathstamped
63: | tyvars of tyvar list
64: | tyvar_pc of tyvar list
65: | db of tycon ref list pathstamped
66: | db' of tycon ref pathstamped
67: | constrs of ty -> (symbol * bool * ty) list
68: | constr of ty -> symbol * bool * ty
69: | eb of eb list susp
70: | qid_p of structureVar list susp
71: | fixity of fixity
72: | ldec of dec pathstamped
73: | exp_pa of exp list stamped
74: | ldecs of dec pathstamped
75: | ops of symbol list
76: | spec_s of spectype
77: | spec of spectype
78: | strspec of spectype
79: | tyspec of bool3 -> spectype
80: | valspec of spectype
81: | exnspec of spectype
82: | sharespec of spectype
83: | patheqn of symbol list list
84: | sign of signtype
85: | sigconstraint_op of Structure option susp
86: | sigb of signatureVar list susp
87: | str of strArg -> strexp * Structure * thinning
88: | sdecs of dec list pathstamped
89: | sdec of dec pathstamped
90: | strb of bool -> (symbol*structureVar*strb) list pathstamped
91: | fparam of (symbol * access * Structure * bool) susp
92: | fctb of (symbol * functorVar * fctb) list susp
93: | importdec of string list
94: | interdec of dec susp
95:
96: %verbose
97: %pure
98: %start interdec
99: %eop EOF SEMICOLON
100:
101: %nonassoc WITHTYPE
102: %right AND
103: %right ARROW
104: %right AS
105: %right HANDLE
106: %right BAR
107: %left ORELSE
108: %left ANDALSO
109: %left COLON
110:
111: %name ML
112:
113: %keyword ABSTRACTION ABSTYPE AND AS CASE DATATYPE DOTDOTDOT ELSE END
114: EQTYPE EXCEPTION DO DARROW FN FUN FUNCTOR HANDLE
115: IF IN INCLUDE INFIX INFIXR LET LOCAL NONFIX OF OP
116: OPEN OVERLOAD RAISE REC SHARING SIG SIGNATURE STRUCT
117: STRUCTURE THEN TYPE VAL WHILE WITH WITHTYPE
118: ORELSE ANDALSO IMPORT
119:
120: %subst EQUAL for DARROW | DARROW for EQUAL | ANDALSO for AND
121:
122: %prefer VAL THEN ELSE
123: %header (structure MLLrValues)
124: %%
125:
126: ident : ID (ID)
127: | ASTERISK (ASTERISKsym)
128: | EQUAL (EQUALsym)
129:
130: optional_op : OP (warn "unnecessary `op' in datatype or exception declaration")
131: | ()
132:
133: opid : ID (ID)
134: | ASTERISK (ASTERISKsym)
135: | OP ident (ident)
136:
137: qid : IDDOT qid (IDDOT :: qid)
138: | ident ([ident])
139:
140: selector: ID (ID)
141: | INT (let val s = makestring INT
142: in if INT < 1
143: then complain ("nonpositive integer label in \
144: \selector, found " ^ s)
145: else ();
146: Symbol.symbol s
147: end)
148:
149: tycon : IDDOT tycon (IDDOT :: tycon)
150: | ID ([ID])
151:
152: tlabel : selector COLON ty (fn()=>(selector, ty()))
153:
154: tlabels : tlabel COMMA tlabels (fn()=>tlabel()::tlabels())
155: | tlabel (fn()=>[tlabel()])
156:
157: ty' : TYVAR (fn()=>VARty(lookTyvar TYVAR))
158: | LBRACE tlabels RBRACE (fn()=>make_recordTy(tlabels()))
159: | LBRACE RBRACE (fn()=>make_recordTy nil)
160: | LPAREN ty0_pc
161: RPAREN tycon (fn()=>let val ts = ty0_pc()
162: in CONty(!lookPathArTYC(tycon,length ts),ts)
163: end)
164: | LPAREN ty RPAREN (ty)
165: | ty' tycon (fn()=>CONty(lookArTYCp(tycon,1),[ty'()]))
166: | tycon (fn()=>CONty(lookArTYCp(tycon,0),[]))
167:
168: tuple_ty : ty' ASTERISK tuple_ty (fn()=> ty'() :: tuple_ty())
169: | ty' ASTERISK ty' (fn()=>[ty'1(),ty'2()])
170:
171: ty : tuple_ty (fn()=>tupleTy(tuple_ty()))
172: | ty ARROW ty (fn()=>CONty(arrowTycon, [ty1(),ty2()]))
173: | ty' (ty')
174:
175: ty0_pc : ty COMMA ty (fn() => [ty1(),ty2()])
176: | ty COMMA ty0_pc (fn() => ty()::ty0_pc())
177:
178: match : rule (fn st => [rule st])
179: | rule BAR match (fn st => rule st :: match st)
180:
181: rule : pat DARROW exp (makeRULE(pat,exp))
182:
183: elabel : selector EQUAL exp (fn st => (selector,exp st))
184:
185: elabels : elabel COMMA elabels (fn st => (elabel st :: elabels st))
186: | elabel (fn st => [elabel st])
187:
188: exp_ps : exp (fn st => [exp st])
189: | exp SEMICOLON exp_ps (fn st => exp st :: exp_ps st)
190:
191: exp : app_exp bexp (fn st => exp_finish(exp_parse(app_exp st,
192: bexp st, NONfix)))
193: | bexp (bexp)
194: | cexp (cexp)
195:
196: bexp : FN match (fn st=> FNexp(match st))
197: | CASE exp OF match (fn st=> CASEexp(exp st, match st))
198: | WHILE exp DO exp (fn st=> WHILEexp(exp1 st, exp2 st))
199: | IF exp THEN exp
200: ELSE exp (fn st=> IFexp(exp1 st, exp2 st, exp3 st))
201:
202: cexp : cexp HANDLE match (fn st=> HANDLEexp(cexp st,
203: HANDLER(FNexp(match st))))
204: | RAISE exp (fn st=> RAISEexp(exp st))
205: | dexp (dexp)
206:
207: dexp : app_exp (fn st=> exp_finish(app_exp st))
208: | dexp COLON ty (fn st=> CONSTRAINTexp(dexp st, ty()))
209: | dexp ANDALSO dexp (fn st=> ANDALSOexp(dexp1 st, dexp2 st))
210: | dexp ORELSE dexp (fn st=> ORELSEexp(dexp1 st, dexp2 st))
211:
212: app_exp : aexp (fn st => exp_start(aexp st, NONfix))
213: | ident (fn st => exp_start(lookID ident, lookFIX ident))
214: | app_exp aexp (fn st => exp_parse(app_exp st, aexp st, NONfix))
215: | app_exp ident (fn st => exp_parse(app_exp st, lookID ident,
216: lookFIX ident))
217:
218: aexp : OP ident (fn st=> lookID ident)
219: | IDDOT qid (fn st=> lookPath(IDDOT::qid,lookIDinStr))
220: | INT (fn st => INTexp INT)
221: | REAL (fn st => REALexp REAL)
222: | STRING (fn st => STRINGexp STRING)
223: | HASH selector (fn st => SELECTORexp selector)
224: | LBRACE elabels RBRACE (fn st=> makeRECORDexp(elabels st))
225: | LBRACE RBRACE (fn st=> RECORDexp nil)
226: | LPAREN RPAREN (fn st=> unitExp)
227: | LPAREN exp_ps RPAREN (fn st=> SEQexp(exp_ps st))
228: | LPAREN exp_2c RPAREN (fn st=> TUPLEexp(exp_2c st))
229: | LBRACKET exp_list RBRACKET (fn st=> LISTexp(exp_list st))
230: | LBRACKET RBRACKET (fn st=> LISTexp nil)
231: | LET ldecs IN exp_ps END (fn st=> protect(protectScope,fn()=>
232: LETexp(ldecs([],st),
233: SEQexp(exp_ps st))))
234:
235: exp_2c : exp COMMA exp_2c (fn st=> exp st :: exp_2c st)
236: | exp COMMA exp (fn st=> [exp1 st, exp2 st])
237:
238: exp_list : exp (fn st=> [exp st])
239: | exp COMMA exp_list (fn st=> exp st :: exp_list st)
240:
241: pat : pat AS pat (fn()=> layered(pat1(), pat2()))
242: | app_pat (fn()=> pat_finish(app_pat()))
243: | app_pat COLON ty (fn()=> CONSTRAINTpat(pat_finish(app_pat()),ty()))
244:
245: app_pat : apat (fn()=> pat_start(apat(), NONfix))
246: | app_pat apat (fn()=> pat_parse(app_pat(),apat(), NONfix))
247: | ID (pat_start_id ID)
248: | ASTERISK (pat_start_id ASTERISKsym)
249: | app_pat ID (pat_parse_id(app_pat,ID))
250: | app_pat ASTERISK (pat_parse_id(app_pat,ASTERISKsym))
251:
252: apat : OP ident (pat_id ident)
253: | IDDOT qid (fn()=>qid_pat(IDDOT::qid))
254: | INT (fn()=>INTpat INT)
255: | REAL (fn()=>REALpat REAL)
256: | STRING (fn()=>STRINGpat STRING)
257: | WILD (fn()=>WILDpat)
258: | LPAREN RPAREN (fn()=>unitPat)
259: | LPAREN pat RPAREN (pat)
260: | LPAREN pat_2c RPAREN (fn()=>TUPLEpat(pat_2c()))
261: | LBRACKET RBRACKET (fn()=>LISTpat nil)
262: | LBRACKET pat_list RBRACKET (fn()=>LISTpat(pat_list()))
263: | LBRACE RBRACE (fn()=>makeRECORDpat(nil,false))
264: | LBRACE plabels RBRACE (fn()=>makeRECORDpat(plabels()))
265:
266: plabel : selector EQUAL pat (fn()=> (selector,pat()))
267: | ID (fn()=> (ID, pat_id ID ()))
268: | ID AS pat (fn()=> (ID, LAYEREDpat(pat_id ID (), pat())))
269: | ID COLON ty (fn()=> (ID, CONSTRAINTpat(pat_id ID(), ty())))
270: | ID COLON ty AS pat (fn()=> (ID, LAYEREDpat(CONSTRAINTpat(pat_id ID(), ty()),pat())))
271:
272: plabels : plabel COMMA plabels (fn()=>let val (a,(b,fx))=(plabel(),plabels())
273: in (a::b, fx)
274: end)
275: | plabel (fn()=> ([plabel()],false))
276: | DOTDOTDOT (fn()=> (nil, true))
277:
278: pat_2c : pat COMMA pat_2c (fn()=> pat() :: pat_2c())
279: | pat COMMA pat (fn()=>[pat1(), pat2()])
280:
281: pat_list: pat (fn()=> [pat()])
282: | pat COMMA pat_list (fn()=> pat() :: pat_list())
283:
284: vb : vb AND vb (fn st=> vb1 st @ vb2 st)
285: | pat EQUAL exp (fn st=> protect(protectTyvars NONE, fn()=>
286: [valbind(pat(),exp st,currentTyvars())]))
287:
288: constraint : (fn()=>NONE)
289: | COLON ty (fn()=>SOME(ty()))
290:
291: rvb : opid constraint
292: EQUAL FN match (fn()=>[{name=opid,ty=constraint(),match=match}])
293: | rvb AND rvb (fn()=> rvb1() @ rvb2())
294:
295:
296: fb' : clause (fn()=>[clause()])
297: | clause BAR fb' (fn()=>clause()::fb'())
298:
299: fb : fb' (fn() => [checkFB(fb'())])
300: | fb' AND fb (fn() => checkFB(fb'()) :: fb())
301:
302: clause : app_pat constraint EQUAL exp (makeCLAUSE(app_pat,constraint,exp))
303:
304: tb : tyvars ident EQUAL ty (makeTB(tyvars,ident,ty))
305: | tb AND tb (fn nw => fn $ => tb1 nw $ @ tb2 nw $)
306:
307: tyvars : TYVAR ([mkTyvar(mkUBOUND TYVAR)])
308: | LPAREN tyvar_pc RPAREN (tyvar_pc)
309: | (nil)
310:
311: tyvar_pc: TYVAR ([mkTyvar(mkUBOUND TYVAR)])
312: | TYVAR COMMA tyvar_pc (mkTyvar(mkUBOUND TYVAR) :: tyvar_pc)
313:
314: db : db' AND db (fn $ => db' $ :: db $)
315: | db' (fn $ => [db' $])
316:
317: db' : tyvars ident EQUAL constrs (makeDB'(tyvars,ident,constrs))
318:
319: constrs : constr (fn t => [constr t])
320: | constr BAR constrs (fn t => constr t :: constrs t)
321:
322: constr : optional_op ident (fn t=> (ident,true,t))
323: | optional_op ident OF ty (fn t=> (ident,false,
324: CONty(arrowTycon,[ty(),t])))
325:
326: eb : optional_op ident (makeEB ident)
327: | optional_op ident OF ty (makeEBof(ident,ty))
328: | optional_op ident EQUAL qid (makeEBeq(ident,qid))
329: | eb AND eb (fn()=> eb1() @ eb2())
330:
331: qid_p : qid (fn()=> [getSTRpath qid])
332: | qid qid_p (fn()=> getSTRpath qid :: qid_p())
333:
334:
335: fixity : INFIX (infixleft 0)
336: | INFIX INT (infixleft INT)
337: | INFIXR (infixright 0)
338: | INFIXR INT (infixright INT)
339: | NONFIX (NONfix)
340:
341: ldec : VAL vb (makeVALdec vb)
342: | VAL REC rvb (makeVALRECdec rvb)
343: | FUN fb (makeFUNdec fb)
344: | TYPE tb (fn ps => TYPEdec(tb true ps))
345: | DATATYPE db (makeDB(db, fn _ => fn _ => nil))
346: | DATATYPE db WITHTYPE tb (makeDB(db, tb))
347: | ABSTYPE db WITH ldecs END (makeABSTYPEdec(db,ldecs))
348: | EXCEPTION eb (fn ps => EXCEPTIONdec(eb()))
349: | OPEN qid_p (makeOPENdec qid_p)
350: | fixity ops (makeFIXdec(fixity,ops))
351: | OVERLOAD ident
352: COLON ty AS exp_pa (makeOVERLOADdec(ident,ty,exp_pa))
353:
354: exp_pa : exp (fn st => [exp st])
355: | exp AND exp_pa (fn st => exp st :: exp_pa st)
356:
357: ldecs : (fn $ => SEQdec nil)
358: | ldec ldecs (makeSEQdec(ldec,ldecs))
359: | ldec SEMICOLON ldecs (fn $ => SEQdec nil)
360: | LOCAL ldecs IN ldecs END ldecs (makeSEQdec(
361: makeLOCALdec(ldecs1,ldecs2),ldecs3))
362:
363: ops : ident ([ident])
364: | ident ops (ident::ops)
365:
366: spec_s : (fn $ => nil)
367: | spec spec_s (fn $ => spec $ @ spec_s $)
368: | spec SEMICOLON spec_s (fn $ => spec $ @ spec_s $)
369:
370: spec : STRUCTURE strspec (strspec)
371: | DATATYPE db (make_dtyspec db)
372: | TYPE tyspec (tyspec NO)
373: | EQTYPE tyspec (tyspec YES)
374: | VAL valspec (valspec)
375: | EXCEPTION exnspec (exnspec)
376: | fixity ops (make_fixityspec(fixity,ops))
377: | SHARING sharespec (sharespec)
378: | INCLUDE ident (make_includespec ident)
379:
380: strspec : strspec AND strspec (fn $ => strspec1 $ @ strspec2 $)
381: | ident COLON sign (make_strspec(ident,sign))
382:
383: tyspec : tyspec AND tyspec (fn eq => fn $ =>
384: tyspec1 eq $ @ tyspec2 eq $)
385: | tyvars ident (fn eq => make_tyspec(eq,tyvars,ident))
386:
387: valspec : valspec AND valspec (fn $ => valspec1 $ @ valspec2 $)
388: | opid COLON ty (make_valspec(opid,ty))
389:
390: exnspec : exnspec AND exnspec (fn $ => exnspec1 $ @ exnspec2 $)
391: | ident (make_exnspec ident)
392: | ident OF ty (make_exnspecOF (ident,ty))
393:
394: sharespec: sharespec AND sharespec (fn $ => sharespec1 $ @ sharespec2 $)
395: | TYPE patheqn (make_type_sharespec patheqn)
396: | patheqn (make_str_sharespec patheqn)
397:
398: patheqn: qid EQUAL qid ([qid1,qid2])
399: | qid EQUAL patheqn (qid :: patheqn)
400:
401: sign : ID (makeSIGid ID)
402: | SIG spec_s END (makeSIG spec_s)
403:
404: sigconstraint_op : (fn()=>NONE)
405: | COLON sign (fn()=>SOME(sign(1,Stampset.newStampsets())))
406:
407: sigb : sigb AND sigb (fn()=> sigb1() @ sigb2())
408: | ident EQUAL sign (make_sigb(ident,sign))
409:
410: str : qid (make_str_qid qid)
411: | STRUCT sdecs END (make_str_struct sdecs)
412: | ID LPAREN sdecs RPAREN (make_str_app(ID,spread_args sdecs))
413: | ID LPAREN str RPAREN (make_str_app(ID,single_arg str))
414: | LET sdecs IN str END (make_str_let(sdecs,str))
415:
416: sdecs : sdec sdecs (fn $ => sdec $ :: sdecs $)
417: | sdec SEMICOLON sdecs (fn $ => sdec $ :: sdecs $)
418: | LOCAL sdecs IN sdecs
419: END sdecs (fn $ =>makeLOCALsdecs(sdecs1,sdecs2) $
420: @ sdecs $)
421: | (fn $ => nil)
422:
423: sdec : STRUCTURE strb (makeSTRBs(strb false))
424: | ABSTRACTION strb (makeSTRBs(strb true))
425: | SIGNATURE sigb (makeSIGdec sigb)
426: | FUNCTOR fctb (makeFCTdec fctb)
427: | ldec (fn (pa,_,st)=>
428: let val dec = ldec(pa,st)
429: in Typecheck.decType dec; dec
430: end)
431:
432: strb : ident sigconstraint_op
433: EQUAL str (makeSTRB(ident,sigconstraint_op,str))
434: | strb AND strb (fn a => fn $ => strb1 a $ @ strb2 a $)
435:
436: fparam : ID COLON sign (single_formal(ID,sign))
437: | spec_s (spread_formal spec_s)
438:
439: fctb : ident LPAREN fparam RPAREN
440: sigconstraint_op EQUAL str (makeFCTB(ident,fparam,sigconstraint_op,str))
441: | fctb AND fctb (fn $ => fctb1 $ @ fctb2 $)
442:
443: importdec: STRING ([STRING])
444: | STRING importdec (STRING :: importdec)
445:
446: interdec: sdec (fn()=> sdec([],Stampset.globalStamps))
447: | IMPORT importdec (fn()=>IMPORTdec importdec)
448: | exp (fn()=>toplevelexp exp)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.