Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-gkuan/compiler/FLINT/trans/reptycprops.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-gkuan/compiler/FLINT/trans/reptycprops.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2947, Sat Feb 16 00:17:56 2008 UTC revision 2948, Sat Feb 16 18:11:07 2008 UTC
# Line 15  Line 15 
15  local  local
16        structure M = Modules        structure M = Modules
17        structure TP = Types        structure TP = Types
18          structure T = TypesTP
19        structure EE = EntityEnv        structure EE = EntityEnv
20        structure EP = EntPath        structure EP = EntPath
21        structure SE = StaticEnv        structure SE = StaticEnv
# Line 24  Line 25 
25        structure TU = TypesUtil        structure TU = TypesUtil
26        structure S = Symbol        structure S = Symbol
27        structure AT = AbsynTP        structure AT = AbsynTP
28          structure V = VarCon
29    
30          (* A map from entity TYC or FCT stamps to the first corresponding EP  *)          (* A map from entity TYC or FCT stamps to the first corresponding EP  *)
31        structure EPMap = RedBlackMapFn (type ord_key = Stamps.stamp        structure EPMap = RedBlackMapFn (type ord_key = Stamps.stamp
# Line 43  Line 45 
45            fun with_pp f = PP.with_default_pp f            fun with_pp f = PP.with_default_pp f
46        in        in
47        fun ppTP tp = print "<tycpath>"        fun ppTP tp = print "<tycpath>"
48          (* ED.withInternals( fn() => with_pp (fn ppstrm => (print "\n"; PPType.ppTycPath SE.empty ppstrm tp; print "\n"))) *)          (* ED.withInternals(
49                    fn() => with_pp (
50                    fn ppstrm => (print "\n";
51                                  PPType.ppTycPath SE.empty ppstrm tp;
52                                  print "\n"))) *)
53        fun ppSig sign =        fun ppSig sign =
54          ED.withInternals ( fn() => with_pp (fn ppstrm => (PPModules.ppSignature ppstrm (sign, SE.empty, 20); print "\n")))          ED.withInternals (
55                              fn() =>
56                                with_pp
57                                    (fn ppstrm =>
58                                        (PPModules.ppSignature ppstrm
59                                                               (sign,
60                                                                SE.empty, 20);
61                                                               print "\n")))
62        fun ppEnt ent =        fun ppEnt ent =
63          with_pp (fn ppstrm => (PPModules.ppEntity ppstrm (ent, SE.empty, 20); print "\n"))          with_pp (fn ppstrm => (PPModules.ppEntity ppstrm (ent, SE.empty, 20); print "\n"))
64        fun ppEntities entenv =        fun ppEntities entenv =
# Line 66  Line 79 
79                 (ListPair.allEq pk_eqv (pks, pks')) andalso (pk_eqv(bk,bk'))                 (ListPair.allEq pk_eqv (pks, pks')) andalso (pk_eqv(bk,bk'))
80               | _ => false) *)               | _ => false) *)
81    
82        fun eqTycPath(AT.TP_VAR x, AT.TP_VAR x') =        fun eqTycon(T.NoTP tc, T.NoTP tc') = TU.equalTycon(tc,tc')
83            | eqTycon _ = raise Fail "Unimplemented"
84    
85          fun eqTycPath(T.TP_VAR x, T.TP_VAR x') =
86            (case (x, x')            (case (x, x')
87              of (v1 as {tdepth, num, kind},              of (v1 as {tdepth, num, kind},
88                  v2 as {tdepth=tdepth', num=num', kind=kind'}) =>                  v2 as {tdepth=tdepth', num=num', kind=kind'}) =>
# Line 87  Line 103 
103                         else ();                         else ();
104             false             false
105                      end)                      end)
106          | eqTycPath(AT.TP_TYC tyc, AT.TP_TYC tyc') =          | eqTycPath(T.TP_TYC tyc, T.TP_TYC tyc') =
107              (debugmsg "--eqTycPath Tycon"; TU.equalTycon(tyc, tyc'))              (debugmsg "--eqTycPath Tycon"; eqTycon(tyc, tyc'))
108              (* typeutils eqTycon only compares DEFtyc stamps. equalTycon              (* typeutils eqTycon only compares DEFtyc stamps. equalTycon
109                 resolves DEFtycs. Unfortunately, it appears that the tycs                 resolves DEFtycs. Unfortunately, it appears that the tycs
110                 this module obtains are reduced forms of the ones                 this module obtains are reduced forms of the ones
111                 Instantiate produces.                 Instantiate produces.
112               *)               *)
113          | eqTycPath(AT.TP_FCT(partps, bodytps), AT.TP_FCT(partps',bodytps')) =          | eqTycPath(T.TP_FCT(partps, bodytps), T.TP_FCT(partps',bodytps')) =
114                  ListPair.allEq eqTycPath (partps, partps') andalso                  ListPair.allEq eqTycPath (partps, partps') andalso
115                  ListPair.allEq eqTycPath (bodytps, bodytps')                  ListPair.allEq eqTycPath (bodytps, bodytps')
116          | eqTycPath(AT.TP_APP(tp, argtps), AT.TP_APP(tp',argtps')) =          | eqTycPath(T.TP_APP(tp, argtps), T.TP_APP(tp',argtps')) =
117                  eqTycPath(tp,tp')                  eqTycPath(tp,tp')
118                  andalso ListPair.allEq eqTycPath (argtps, argtps')                  andalso ListPair.allEq eqTycPath (argtps, argtps')
119          | eqTycPath(AT.TP_SEL(tp, i), AT.TP_SEL(tp', i')) =          | eqTycPath(T.TP_SEL(tp, i), T.TP_SEL(tp', i')) =
120                  eqTycPath(tp,tp') andalso i = i'                  eqTycPath(tp,tp') andalso i = i'
121          | eqTycPath _ = (debugmsg "--eqTycPath other"; false)          | eqTycPath _ = (debugmsg "--eqTycPath other"; false)
122    
# Line 267  Line 283 
283                                            buildKind arity                                            buildKind arity
284                                 val var = {tdepth=DI.top,num=i,                                 val var = {tdepth=DI.top,num=i,
285                                            kind=kind}                                            kind=kind}
286                                 val tp' = AT.TP_VAR var                               val tp' = T.TP_VAR var
287                                 (* val _ = checkTycPath(tp, tp') *)                                 (* val _ = checkTycPath(tp, tp') *)
288                             in tp'::loop(entenv, rest, i+1, fs)                             in tp'::loop(entenv, rest, i+1, fs)
289                             end                             end
290                         | M.TYCent tyc =>                         | M.TYCent tyc =>
291                              (debugmsg "TYCent\n";                              (debugmsg "TYCent\n";
292                               (AT.TP_TYC tyc)::loop(entenv, rest, i+1, fs))                               T.TP_TYC(T.NoTP tyc)::loop(entenv, rest, i+1, fs))
293                                (* [TODO] What to do about GENtyc FORMAL? *)
294                         | M.FCTent {(* tycpath=SOME tp,*) paramEnts, ...} =>                         | M.FCTent {(* tycpath=SOME tp,*) paramEnts, ...} =>
295                             (debugmsg "--getTPsforEPs[FCTent SOME]";                             (debugmsg "--getTPsforEPs[FCTent SOME]";
296                              (case fs                              (case fs
# Line 293  Line 310 
310                                       val _ = debugmsg "<<kinds done\n"                                       val _ = debugmsg "<<kinds done\n"
311                                       val var = {tdepth=DI.top, num=i,                                       val var = {tdepth=DI.top, num=i,
312                                                  kind=kind}                                                  kind=kind}
313                                       val tp' = AT.TP_VAR var                                       val tp' = T.TP_VAR var
314                                  (* val _ = checkTycPath(tp, tp') *)                                  (* val _ = checkTycPath(tp, tp') *)
315                                   in tp'::loop(entenv, rest, i, srest)                                   in tp'::loop(entenv, rest, i, srest)
316                                   end)) (* FIXME *)                                   end)) (* FIXME *)
# Line 302  Line 319 
319                  in loop(entenv, eps, 0, fsigs)                  in loop(entenv, eps, 0, fsigs)
320                  end (* fun getTPsforEPs *)                  end (* fun getTPsforEPs *)
321    
322                fun getTk(M.FSIG{paramsig=M.SIG ps, ...}, dummyEnts, argEnts, fsigs) =                fun getTk(M.FSIG{paramsig=M.SIG ps, ...}, dummyEnts, argEnts,
323                            fsigs) =
324                    let                    let
325                        val alleps =                        val alleps =
326                            entpaths(#elements ps)                            entpaths(#elements ps)
# Line 316  Line 334 
334    
335        end (* local *)        end (* local *)
336    
337        fun procCloSE(se) =
338            (case se
339              of M.VARstr _ => se
340               | M.CONSTstr _ => se
341               | M.STRUCTURE _ => se
342               | M.APPLY(fctExp, strExp) =>
343                 M.APPLY(procCloFE fctExp, procCloSE strExp)
344               | M.LETstr(entDec, strExp) =>
345                 M.LETstr(entDec, procCloSE strExp)
346               | M.ABSstr(sign, strExp) =>
347                 M.ABSstr(sign, procCloSE strExp)
348               | M.CONSTRAINstr{boundvar,raw,coercion} =>
349                 M.CONSTRAINstr{boundvar=boundvar,raw=raw,
350                                coercion=procCloSE coercion}
351               | M.FORMstr _ => bug "unexpected FORMstr in procCloSE")
352        and procCloFE(fe) =
353            (case fe
354              of M.VARfct _ => fe
355               | M.CONSTfct _ => fe
356               | M.LAMBDA{body,param,paramEnts} =>
357                 M.LAMBDA{param=param, body=procCloSE body, paramEnts=paramEnts}
358               | M.LETfct(entDec, fexp) => M.LETfct(entDec, procCloFE fexp)
359               | M.LAMBDA_TP _ => bug "procCloFE bug LAMBDA_TP")
360    
361        (* exception TransVar
362        fun transVar V.ERRORvar = raise TransVar
363          | transVar(V.OVLDvar{name,options,scheme}) =
364            let
365                fun transopts([]) = []
366                  | transopts({indicator,variant}::rest) =
367                    let val indicator' = T.TyNoTP indicator
368                        val opt = {indicator=indicator',
369                                   variant=transVar variant}
370                    in opt::transopts(rest)
371                    end
372            in
373                AT.OVLDvar{name=name, options=ref (transopts (!options)),
374                           scheme=scheme}
375            end
376          | transVar(V.VALvar{path,typ,access,prim}) =
377            AT.VALvar{path=path,typ=ref (T.TyNoTP (!typ)), access=access,
378                      prim=prim}
379        (* end transVar *) *)
380    
381    
382          (* dec * DebIndex.depth ->          (* dec * DebIndex.depth ->
383               dec with tycpaths and memoized ep * tkind lists               dec with tycpaths and memoized ep * tkind lists
384             This code needs EPMap (don't forgot EPMap in the local ... in             This code needs EPMap (don't forgot EPMap in the local ... in
# Line 330  Line 393 
393                                           as M.FCT{sign=fctsign                                           as M.FCT{sign=fctsign
394                                                    as M.FSIG {paramsig=fsparsig                                                    as M.FSIG {paramsig=fsparsig
395                                                                  as M.SIG fsr,...},                                                                  as M.SIG fsr,...},
396                                                     rlzn=fctRlzn,...},                                         rlzn=fctRlzn,access,prim},
397                                         arg=arg as M.STR{sign=argsig as M.SIG{elements,...},                               arg=arg
398                                                   rlzn=argRlzn as {entities,...},...}, ...                                  as M.STR{sign=argsig
399                                         }) =>                                              as M.SIG{elements,...},
400                                  let val {paramEnts=dummyEnts, closure=M.CLOSURE{body,...},...} =                          rlzn=argRlzn as {entities,...},...}, ...}) =>
401                         let val {paramEnts=dummyEnts,
402                                  closure=M.CLOSURE{body,param=fclparam,
403                                                    env=fclenv},
404                                  stamp=fstmp,
405                                  properties=fprops,
406                                  rpath=frp,
407                                  stub=fstub} =
408                                          fctRlzn                                          fctRlzn
409                                      val _ = debugmsg "--strBinds APPstr"                                      val _ = debugmsg "--strBinds APPstr"
410                                      (* val _ = (debugmsg "===fsparsig===";                                      (* val _ = (debugmsg "===fsparsig===";
# Line 352  Line 422 
422                                      val argtycs' =                                      val argtycs' =
423                                          getTPsforEPs(entities, eps,                                          getTPsforEPs(entities, eps,
424                                                       fsigs)                                                       fsigs)
425                             val body' = procCloSE(body)
426                             val fcl' =
427                                 M.CLOSURE{param=fclparam,
428                                           env=fclenv,
429                                           body=body'}
430                             val fctRlzn' =
431                                 {paramEnts=dummyEnts,
432                                  stamp=fstmp,
433                                  properties=fprops,
434                                  rpath=frp,
435                                  stub=fstub,
436                                  closure=fcl'}
437                             val oper' =
438                                 M.FCT{sign=fctsign,
439                                       access=access,
440                                       prim=prim,
441                                       rlzn=fctRlzn'}
442                                      (* getTycPaths(fsparsig, dummyEnts) *)                                      (* getTycPaths(fsparsig, dummyEnts) *)
443                                      val se' = AT.APPstr {oper=oper, arg=arg,                           val se' = AT.APPstr {oper=oper', arg=arg,
444                                                           argtycs=argtycs'}                                                           argtycs=argtycs'}
445                                      (* Check that argtycs = argtycs' here *)                                      (* Check that argtycs = argtycs' here *)
446                                      (* val _ = if checkTycPaths(argtycs, argtycs')                                      (* val _ = if checkTycPaths(argtycs, argtycs')
# Line 398  Line 484 
484                                of VARfct f =>                                of VARfct f =>
485                                   AT.VARfct f                                   AT.VARfct f
486                                 | FCTfct{param=param                                 | FCTfct{param=param
487                                                    as                                        as M.STR{sign=paramsig
                                                   M.STR{sign=paramsig  
488                                                                   as M.SIG sr,                                                                   as M.SIG sr,
489                                                          rlzn=rlzn                                                          rlzn=rlzn
490                                                                   as {entities,                                                                   as {entities,
# Line 439  Line 524 
524                                                    print "\nparamsig':\n";                                                    print "\nparamsig':\n";
525                                                    ppSig paramsig'; print "\n"                                                    ppSig paramsig'; print "\n"
526                                                    bug "wrong arg tycs mkFctexp") *)                                                    bug "wrong arg tycs mkFctexp") *)
527                                    in AT.FCTfct{param=param,def=procStrexp def,argtycs=argtycs'}                                in AT.FCTfct{param=param,def=procStrexp def,
528                                               argtycs=argtycs'}
529                                    end)                                    end)
530                                 | MARKfct(fe',region) => AT.MARKfct(mkFctexp fe',region)                             | MARKfct(fe',region) =>
531                                 AT.MARKfct(mkFctexp fe',region)
532                                 | LETfct(dec', fe') =>                                 | LETfct(dec', fe') =>
533                                     AT.LETfct(procDec(dec',d), mkFctexp fe')                                     AT.LETfct(procDec(dec',d), mkFctexp fe')
534                                 | _ => bug "mkFctexp 0")                                 | _ => bug "mkFctexp 0")
535                          in AT.FCTB{name=name, fct=fct, def=mkFctexp(def)} :: fctBinds(rest)                  in AT.FCTB{name=name, fct=fct,
536                               def=mkFctexp(def)} :: fctBinds(rest)
537                          end                          end
538                  | fctBinds _ = bug "fctBinds: unexpected binding"                  | fctBinds _ = bug "fctBinds: unexpected binding"
539    
540                fun strBinds([]) = []                fun strBinds([]) = []
541                  | strBinds((b as STRB{name, str, def})::rest) =                  | strBinds((b as STRB{name, str, def})::rest) =
542                      let val _ = debugmsg (">>strBinds "^Symbol.symbolToString name)                  let val _ = debugmsg (">>strBinds "^
543                          val sb' = AT.STRB{name=name, str=str, def=procStrexp def}                                        Symbol.symbolToString name)
544                            val sb' = AT.STRB{name=name, str=str,
545                                              def=procStrexp def}
546                      in                      in
547                          sb' :: strBinds(rest)                          sb' :: strBinds(rest)
548                      end (* fun strBinds *)                      end (* fun strBinds *)
549    
550                fun transVB(VB {pat,exp,boundtvs,tyvars}) =                fun transVB(VB {pat,exp,boundtvs,tyvars}) =
551                    AT.VB{pat=pat,exp=transExp d exp,boundtvs=boundtvs,tyvars=tyvars}                  AT.VB{pat=pat,exp=transExp d exp,boundtvs=boundtvs,
552                          tyvars=tyvars}
553                fun transRVB(RVB{var,exp,boundtvs,resultty,tyvars}) =                fun transRVB(RVB{var,exp,boundtvs,resultty,tyvars}) =
554                    AT.RVB{var=var,exp=transExp d exp,boundtvs=boundtvs,                    AT.RVB{var=var,exp=transExp d exp,boundtvs=boundtvs,
555                          resultty=resultty,tyvars=tyvars}                          resultty=resultty,tyvars=tyvars}
# Line 489  Line 580 
580                                                 | (EBdef{exn,edef}) =>                                                 | (EBdef{exn,edef}) =>
581                                                   AT.EBdef{exn=exn,edef=edef})                                                   AT.EBdef{exn=exn,edef=edef})
582                                                       ebs)                                                       ebs)
583                        | OVLDdec v => AT.OVLDdec v                 | OVLDdec v => AT.OVLDdec(v)
584                        | FIXdec x => AT.FIXdec x)                        | FIXdec x => AT.FIXdec x)
585            end            end
586          and transExp d e =          and transExp d e =
# Line 498  Line 589 
589                         fun transFnRules(rules, ty) = (map transRule rules, ty)                         fun transFnRules(rules, ty) = (map transRule rules, ty)
590                     in                     in
591                    (case e                    (case e
592                      of (VARexp d) => AT.VARexp d                 of VARexp(v,tyvars) => AT.VARexp(v,tyvars)
593                       | (CONexp d) => AT.CONexp d                       | (CONexp d) => AT.CONexp d
594                       | (INTexp d) => AT.INTexp d                       | (INTexp d) => AT.INTexp d
595                       | (WORDexp d) => AT.WORDexp d                       | (WORDexp d) => AT.WORDexp d

Legend:
Removed from v.2947  
changed lines
  Added in v.2948

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0