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/trunk/src/compiler/Semant/pickle/pickmod-new.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/pickle/pickmod-new.sml

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

revision 476, Wed Nov 10 22:59:58 1999 UTC revision 489, Tue Nov 23 12:55:00 1999 UTC
# Line 386  Line 386 
386          cs arg          cs arg
387      end      end
388    
389        fun tkind x = let
390            val op $ = PU.$ TK
391            fun tk x =
392                case LK.tk_out x of
393                LK.TK_MONO => %TK "A"
394              | LK.TK_BOX => %TK "B"
395              | LK.TK_SEQ ks => "C" $ list tkind ks
396              | LK.TK_FUN (ks, kr) => "D" $ list tkind ks & tkind kr
397        in
398            share TKs tk x
399        end
400    
401      fun mkAccess lvar = let      fun mkAccess lvar = let
402          val op $ = PU.$ A          val op $ = PU.$ A
403          fun access (A.LVAR i) = "A" $ lvar i          fun access (A.LVAR i) = "A" $ lvar i
# Line 409  Line 421 
421      end      end
422    
423      (* lambda-type stuff; this is used in both picklers *)      (* lambda-type stuff; this is used in both picklers *)
424        and lty alpha x = let
425            val lty = lty alpha
426            val tyc = tyc alpha
427      fun ltyI x = let      fun ltyI x = let
428          val op $ = PU.$ LT          val op $ = PU.$ LT
429      in      in
# Line 421  Line 436 
436            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"
437            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"
438      end      end
439        in
     and lty x =  
440          if LK.ltp_norm x then share LTs ltyI x          if LK.ltp_norm x then share LTs ltyI x
441          else (* bug "unexpected complex lambda type in mkPickleLty" *) ltyI x          else (* bug "unexpected complex lambda type in mkPickleLty" *) ltyI x
442        end
443    
444      and tycI x = let      and tyc alpha x = let
445            val tyc = tyc alpha
446            val lty = lty alpha
447            fun tycI x = let
448          val op $ = PU.$ TC          val op $ = PU.$ TC
449      in      in
450          case LK.tc_out x of          case LK.tc_out x of
451              LK.TC_VAR (db, i) => "A" $ int (DI.di_toint db) & int i              LK.TC_VAR (db, i) => "A" $ int (DI.di_toint db) & int i
452            | LK.TC_NVAR (n, dp, i) =>                | LK.TC_NVAR n => "B" $ (int o alpha) n
                 "B" $ int n & int (DI.dp_toint dp) & int i  
453            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)
454            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc
455            | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l            | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l
# Line 448  Line 465 
465                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2
466            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
467                  "N" $ list tyc ts1 & list tyc ts2                  "N" $ list tyc ts1 & list tyc ts2
468            | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"                | LK.TC_PARROW _ => bug "unexpected TC_PARROW in mkPickleLty"
469            | LK.TC_TOKEN (tk, t) => "O" $ int (LK.token_int tk) & tyc t            | LK.TC_TOKEN (tk, t) => "O" $ int (LK.token_int tk) & tyc t
470            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
471            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
472            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
473      end      end
474        in
     and tyc x =  
475          if LK.tcp_norm x then share TCs tycI x          if LK.tcp_norm x then share TCs tycI x
476          else (* bug "unexpected complex lambda tyc in mkPickleLty" *) tycI x          else (* bug "unexpected complex lambda tyc in mkPickleLty" *) tycI x
   
     and tkind x = let  
         val op $ = PU.$ TK  
         fun tk x =  
             case LK.tk_out x of  
             LK.TK_MONO => %TK "A"  
           | LK.TK_BOX => %TK "B"  
           | LK.TK_SEQ ks => "C" $ list tkind ks  
           | LK.TK_FUN (ks, kr) => "D" $ list tkind ks & tkind kr  
     in  
         share TKs tk x  
477      end      end
478    
479      (* the FLINT pickler *)      (* the FLINT pickler *)
480      fun flint flint_exp = let      fun flint flint_exp = let
481          val alphaConvert = mkAlphaConvert ()          val alphaConvert = mkAlphaConvert ()
482          val lvar = int o alphaConvert          val lvar = int o alphaConvert
483            val lty = lty alphaConvert
484            val tyc = tyc alphaConvert
485          val { access, conrep } = mkAccess lvar          val { access, conrep } = mkAccess lvar
486    
487          val op $ = PU.$ V          val op $ = PU.$ V
# Line 552  Line 559 
559              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e
560          end          end
561    
562          and tfundec (v, tvks, e) = let          and tfundec (tfk, v, tvks, e) = let
563              val op $ = PU.$ TFUNDEC              val op $ = PU.$ TFUNDEC
564          in          in
565              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e
# Line 560  Line 567 
567    
568          and fkind arg = let          and fkind arg = let
569              val op $ = PU.$ FK              val op $ = PU.$ FK
570              fun fk F.FK_FCT = %FK "2"              fun fk { isrec, cconv=F.CC_FCT, known, inline } = %FK "2"
571                | fk (F.FK_FUN { isrec, fixed, known, inline }) =                | fk { isrec, cconv=F.CC_FUN fixed, known, inline } =
572                  case fixed of                  case fixed of
573                      LK.FF_VAR (b1, b2) =>                      LK.FF_VAR (b1, b2) =>
574                          "3" $ option (list lty) isrec &                          "3" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &
575                          bool b1 & bool b2 & bool known & bool inline                          bool b1 & bool b2 & bool known &
576                            bool (case inline of F.IH_ALWAYS => true | _ => false)
577                    | LK.FF_FIXED =>                    | LK.FF_FIXED =>
578                          "4" $ option (list lty) isrec &                          "4" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &
579                          bool known & bool inline                          bool known &
580                            bool (case inline of F.IH_ALWAYS => true | _ => false)
581          in          in
582              fk arg              fk arg
583          end          end

Legend:
Removed from v.476  
changed lines
  Added in v.489

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