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-2/src/compiler/FLINT/kernel/lty.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/lty.sml

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

revision 2035, Fri Aug 18 23:54:34 2006 UTC revision 2036, Mon Aug 21 20:38:36 2006 UTC
# Line 454  Line 454 
454  fun lt_key (ref (h : int, _ : ltyI, _ : aux_info)) = h  fun lt_key (ref (h : int, _ : ltyI, _ : aux_info)) = h
455    
456  (** checking if a tyc or an lty is in the normal form *)  (** checking if a tyc or an lty is in the normal form *)
457  fun tcp_norm ((ref(_, _, AX_REG(b,_,_))) : tyc) =  b  fun  tcp_norm ((ref(_, TC_IND _, AX_REG(true,_,_))) : tyc) =  bug "TC_IND is norm?!"
458       | tcp_norm ((ref(_, _, AX_REG(b,_,_))) : tyc) =  b
459    | tcp_norm _ = false    | tcp_norm _ = false
460    
461  fun ltp_norm ((ref(_, _, AX_REG(b,_,_))) : lty) =  b  fun ltp_norm ((ref(_, LT_TYC (ref (_,TC_IND _, _)), AX_REG(true,_,_))) : lty) =
462        bug "LT_TYC (TC_IND ) is norm?!"
463      | ltp_norm ((ref(_, LT_IND _, AX_REG(true,_,_))) : lty) =  bug "LT_IND is norm?!"
464      | ltp_norm ((ref(_, _, AX_REG(b,_,_))) : lty) =  b
465    | ltp_norm _ = false    | ltp_norm _ = false
466    
467  (** accessing free named tyvars *)  (** accessing free named tyvars *)
# Line 603  Line 607 
607    
608  (** testing the "pointer" equality on normalized tkind, tyc, and lty *)  (** testing the "pointer" equality on normalized tkind, tyc, and lty *)
609  fun tk_eq (x: tkind, y) = (x = y)  fun tk_eq (x: tkind, y) = (x = y)
 fun tc_eq (x: tyc, y) = (x = y)  
 fun lt_eq (x: lty, y) = (x = y)  
610    
611    local
612          fun stripIND tyc =
613              (case tc_outX tyc
614                of (TC_IND(new,_)) => stripIND new
615                 | _ => tyc)
616      fun verify(ref(_, TC_IND _, AX_REG(true,_,_))) =  bug "TC_IND is norm?!"
617        | verify _ = ()
618    in
619    fun tc_eq (x: tyc, y) =  (verify x; verify y; x = y)
620    end
621    
622    local
623      fun verify(ref(_, LT_IND _, AX_REG(true,_,_))) =  bug "LT_IND is norm?!"
624        | verify(ref(_, LT_TYC(ref(_,TC_IND _,_)), AX_REG(true,_,_))) = bug "LT_TYC (TC_IND) is norm?!"
625        | verify(ref(_, _, AX_REG(true, _, _))) = ()
626        | verify(ref(_, _, AX_REG(false, _, _))) = bug "Non-normalized (AX_REG false).\n"
627        | verify(ref(_, _, AX_NO)) = bug "Non-normalized (AX_NO)\n"
628    in
629    fun lt_eq (x: lty, y) =
630        (verify x; verify y;
631        if not (x = y) then
632            ((case (lt_outX x, lt_outX y)
633              of (LT_TYC tyc1, LT_TYC tyc2) =>
634                 (x = y)
635               | _ => x = y))
636        else (x = y)  )
637    end (*
638                 (case (tc_outX tyc1, tc_outX tyc2)
639                   of (TC_PRIM pt1, TC_PRIM pt2) =>
640                        print "PRIM\n"
641                    | (TC_FN _, _) =>
642                        print "FN\n"
643                    | (TC_FIX _, _) => print "FIX\n"
644                    | (TC_VAR _, _) => print "VAR\n"
645                    | (TC_NVAR _, _) => print "NVAR\n"
646                    | (TC_APP _, _) => print "APP\n"
647                    | (TC_SEQ _, _) => print "SEQ\n"                | (TC_PROJ _, _) => print "PROJ\n"
648                    | (TC_SUM _, _) => print "SUM\n"
649                    | (TC_TUPLE _, _) => print "TUPLE\n"
650                    | (TC_ARROW _, _) => print "ARROW\n"
651                    | (TC_PARROW _, _) => print "PARROW\n"
652                    | (TC_BOX _, _) => print "BOX\n"
653                    | (TC_ABS _, _) => print "ABS\n"
654                    | (TC_TOKEN _, _) => print "TOKEN\n"
655                    | (TC_CONT _, _) => print "CONT\n"
656                    | (TC_IND _, _) => print "IND\n"
657                    | (TC_ENV _, _) => print "ENV\n"
658                    | (TC_PRIM _, tyc2') =>
659                        (print "unmatched PRIM\n";
660                         case tyc2'
661                          of (TC_FN _) =>
662                             print "FN\n"
663                           | (TC_FIX _) => print "FIX\n"
664                           | (TC_VAR _) => print "VAR\n"
665                           | (TC_NVAR _) => print "NVAR\n"
666                           | (TC_APP _) => print "APP\n"
667                           | (TC_SEQ _) => print "SEQ\n"
668                           | (TC_PROJ _) => print "PROJ\n"
669                           | (TC_SUM _) => print "SUM\n"
670                           | (TC_TUPLE _) => print "TUPLE\n"
671                           | (TC_ARROW _) => print "ARROW\n"
672                           | (TC_PARROW _) => print "PARROW\n"
673                           | (TC_BOX _) => print "BOX\n"
674                           | (TC_ABS _) => print "ABS\n"
675                           | (TC_TOKEN _) => print "TOKEN\n"
676                           | (TC_CONT _) => print "CONT\n"
677                           | (TC_IND _) => print "IND\n"
678                           | (TC_ENV _) => print "ENV\n"
679                           | (TC_PRIM _) => print "PRIM\n")
680                             )); x = y)
681        else (x = y) *)
682    
683  (** utility functions for updating tycs and ltys *)  (** utility functions for updating tycs and ltys *)
684  fun tyc_upd (tgt as ref(i : int, old : tycI, AX_NO), nt) =  fun tyc_upd (tgt as ref(i : int, old : tycI, AX_NO), nt) =

Legend:
Removed from v.2035  
changed lines
  Added in v.2036

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