open List;open Fnlib Config Mixture Const Smlexc;open Globals Location Units Asynt Asyntfn Types;open Primdec Smlprim;   type UEnv = (string * Type) list;   (* Syntax TyVars to TypeVars *) val piRef = mkPrimInfo 1 MLPref; fun mkPrimStatus arity name =  PRIMname(mkPrimInfo arity (findPrimitive arity name)); (* --- Warning printing --- *) fun isFunType tau =  case normType tau of      ARROWt _ => true    |        _ => false; fun unitResultExpected exp tau =  if isFunType tau then    (msgIBlock 0;     errLocation (xLR exp);     errPrompt "Warning: function-type result is being discarded.";     msgEOL(); msgEOL();     msgEBlock())  else (); (* --- Error printing --- *) fun typeClash tau1 tau2 reason =  under_binder   (fn (tau1,tau2,reason) =>    let fun isEqVar tau = case normType tau of 	                       VARt var => #tvEqu (!var)			     | _        => false	fun isExVar tau = case normType tau of 	                       VARt var => isExplicit var			     | _        => false	fun msgTy tau = 	    if (case reason of 		    UnifyEquality => true 		  | _ => false)		andalso isEqVar tau then 		(msgString "equality type "; printNextType tau)	    else if (case reason of 			 UnifyExplicit => true 		       | UnifyOther => true		       | UnifyEquality => true		       | UnifyScope _ => true		       | _ => false) 		    andalso isExVar tau then 		(msgString "explicit type "; printNextType tau)	    else 		(msgString "type"; msgEOL();		 errPrompt "  "; printNextType tau)     in        collectExplicitVars tau1;	collectExplicitVars tau2;         msgString " of "; msgTy tau1; msgEOL();	errPrompt "cannot have "; msgTy tau2; msgEOL();	(case reason of	     UnifyCircular => 		 (errPrompt "because of circularity"; msgEOL())	   | UnifyEquality => ()           | UnifyExplicit => ()	   | UnifyScope (var,TYNAMEsv tn) => 		 (errPrompt "because of a scope violation:";		  msgEOL();                  errPrompt "the type constructor ";		  prTyName false tn;                  msgString " is a parameter " ;                  msgEOL();		  errPrompt "that is declared within \                	    \the scope of ";		  prTypeVar var;		  msgEOL()) 	   | UnifyScope (var,TYPEVARsv tv) => 		 (errPrompt "because of a scope violation:";                  msgEOL();                  errPrompt "the type variable ";		  prTypeVar tv;                  msgString " is a parameter " ;                  msgEOL();		  errPrompt "that is declared within \                	    \the scope of ";		  prTypeVar var;		  msgEOL())	   | UnifyTup      => 		 (errPrompt "because the tuple has the\		             \ wrong number of components"; 		  msgEOL())	   | UnifyRec lab  => 		 (errPrompt "because record label  "; 		  printLab lab; msgString "  is missing"; msgEOL())           | UnifyMod (reasonopt,reasonopt') =>		 (case reasonopt of 		       NONE => () 		     | SOME reason => 			   (errPrompt "because the first module type \			               \does not match the second module type ...";			    msgEOL();			    errMatchReason "first module type" "second module type" reason);		   case reasonopt' of 		       NONE => () 		     | SOME reason => 			   (errPrompt "because the second module type \			               \does not match the first module type ...";			    msgEOL();			    errMatchReason "second module type" "first module type" reason))           | UnifyOther  => ())    end)  (tau1,tau2,reason); fun typeClashId (ii : IdInfo) tau1 tau2 reason =  let val {qualid, info} = ii in    msgIBlock 0;    errLocation (#idLoc info);    errPrompt "Type clash: identifier "; msgString (showQualId qualid);    typeClash tau1 tau2 reason;    msgEBlock();    raise Toplevel  end; fun unifyId ii tau1 tau2 =  unify tau1 tau2  handle Unify reason => typeClashId ii tau1 tau2 reason; fun typeClashPat pat tau1 tau2 reason =(  msgIBlock 0;  errLocation (xLR pat);  errPrompt "Type clash: pattern";  typeClash tau1 tau2 reason;  msgEBlock();  raise Toplevel); fun unifyPat pat tau1 tau2 =  unify tau1 tau2  handle Unify reason => typeClashPat pat tau1 tau2 reason; fun typeClashExp exp tau1 tau2 reason =(  msgIBlock 0;  errLocation (xLR exp);  errPrompt "Type clash: expression";  typeClash tau1 tau2 reason;  msgEBlock();  raise Toplevel); fun unifyExp exp tau1 tau2 =  unify tau1 tau2  handle Unify reason => typeClashExp exp tau1 tau2 reason; fun unifyMatch mrules tau1 tau2 =  unify tau1 tau2  handle Unify reason =>  let val MRule(ref pats, exp) = hd mrules in    msgIBlock 0;    errLocation (xxLR (hd pats) exp);    errPrompt "Type clash: match rule";    typeClash tau1 tau2 reason;    msgEBlock();    raise Toplevel  end; fun looksLikeInfixId (ii : IdInfo) =  case ii of      {qualid={qual="", id = [_]}, info={withOp=false, ...}} => true    | _ => false; fun isPairPat (_, pat') =  case pat' of      RECpat(ref (RECrp(fs, NONE))) => isPairRow fs    | _ => false; (*fun looksLikeInfixExp (_, exp') =  case exp' of    VARexp(ref(RESve{qualid={qual=[],...}, info={withOp=false,...}}))      => true  | VARexp(ref(OVLve({qualid={qual=[],...}, info={withOp=false,...}}, _, _)))      => true  | _ => false;*) fun looksLikeInfixExp (_, exp') =  case exp' of    VIDPATHexp(ref(RESvidpath ({qualid={qual="",id=[_]}, info={withOp=false,...}})))      => true  | VIDPATHexp(ref(OVLvidpath ({qualid={qual="",id=[_]}, info={withOp=false,...}}, _, _)))      => true  | _ => false;   fun isPairExp (_, exp') =  case exp' of    RECexp(ref (RECre fs)) => isPairRow fs  | _ => false; fun newUnknownPair() = type_pair (newUnknown()) (newUnknown()); infix 6 U; infix 7 \\; fun list_union [] ys = ys  | list_union (x :: xs) ys =      if member x ys then (list_union xs ys) else (x :: list_union xs ys) fun list_subtract xs [] = xs  | list_subtract xs ys =      let fun h [] = []            | h (x :: xs) = if member x ys then (h xs) else (x :: h xs)      in h xs end; fun xs U ys = list_union xs ys;fun U_map f = foldR_map list_union f [];fun xs \\ ys = list_subtract xs ys; infix 7 without; fun xs without (tyvarseq:TyVarSeq) =     xs \\ (map (fn ii => hd(#id(#qualid ii))) tyvarseq); fun unguardedExp (_, exp') =  case exp' of    SCONexp _ => []  | VIDPATHexp (ref (RESvidpath (_))) => []  | VIDPATHexp (ref (OVLvidpath (_,ovlty,ty))) => []  | RECexp(ref (RECre fields)) =>      U_map (fn(_, e) => unguardedExp e) fields  | RECexp(ref (TUPLEre es)) =>       U_map unguardedExp es  | VECexp es =>      U_map unguardedExp es  | LETexp(dec, exp) =>      unguardedDec dec U unguardedExp exp  | PARexp exp => unguardedExp exp  | APPexp(exp1, exp2) =>      unguardedExp exp1 U unguardedExp exp2  | INFIXexp (ref (UNRESinfixexp es)) =>       U_map unguardedExp es  | INFIXexp (ref (RESinfixexp e)) => unguardedExp e  | TYPEDexp(exp, ty) =>      unguardedExp exp U unguardedTy ty  | ANDALSOexp(exp1, exp2) =>      unguardedExp exp1 U unguardedExp exp2  | ORELSEexp(exp1, exp2) =>      unguardedExp exp1 U unguardedExp exp2  | HANDLEexp(exp, mrules) =>      unguardedExp exp U U_map unguardedMRule mrules  | RAISEexp exp =>      unguardedExp exp  | IFexp(e0, e1, e2) =>      unguardedExp e0 U unguardedExp e1 U unguardedExp e2  | FNexp mrules =>      U_map unguardedMRule mrules  | WHILEexp(exp1, exp2) =>      unguardedExp exp1 U unguardedExp exp2  | SEQexp(exp1, exp2) =>      unguardedExp exp1 U unguardedExp exp2  | STRUCTUREexp(modexp,sigexp,_) =>       unguardedModExp modexp U unguardedSigExp sigexp  | FUNCTORexp(modexp,sigexp,_) =>       unguardedModExp modexp U unguardedSigExp sigexpand unguardedMRule (MRule(ref pats, exp)) =  U_map unguardedPat pats U unguardedExp expand unguardedPat (_, pat') =  case pat' of    SCONpat _ => []  | VARpat _ => []  | WILDCARDpat => []  | NILpat _ => []  | CONSpat(_, p) => unguardedPat p  | EXNILpat _ => []  | EXCONSpat(_,p) => unguardedPat p  | EXNAMEpat _ => fatalError "unguardedPat"(* cvr: TODO review *)  | REFpat p => unguardedPat p  | RECpat(ref (RECrp(fs, _))) =>      U_map (fn(_, p) => unguardedPat p) fs  | RECpat(ref (TUPLErp _)) => fatalError "unguardedPat"(* cvr: TODO review *)  | VECpat ps =>      U_map unguardedPat ps  | INFIXpat (ref (RESinfixpat p))  => unguardedPat p  | INFIXpat (ref (UNRESinfixpat _)) => fatalError "unguardedPat"(* cvr: TODO review *)  | PARpat pat => unguardedPat pat  | TYPEDpat(pat, ty) =>      unguardedPat pat U unguardedTy ty  | LAYEREDpat(pat1, pat2) =>      unguardedPat pat1 U unguardedPat pat2 and unguardedDec (_, dec') =  case dec' of    VALdec _ => []  | PRIM_VALdec _ => []  | FUNdec (ref (UNRESfundec (tyvarseq, fvbds))) => fatalError "unguardedDec"(* cvr: TODO review *)  | FUNdec (ref (RESfundec dec)) => unguardedDec dec  | TYPEdec tbds => 	U_map unguardedTypBind tbds  | PRIM_TYPEdec _ => []  | DATATYPEdec (dbds,SOME tbds) => 	(U_map unguardedDatBind dbds) U 	(U_map unguardedTypBind tbds)  | DATATYPEdec (dbds,NONE) =>  	 U_map unguardedDatBind dbds  | DATATYPErepdec (tycon, tyconpath) =>       	 unguardedTyConPath tyconpath  | ABSTYPEdec(dbds,SOME tbds,dec) =>      (U_map unguardedDatBind dbds) U       (U_map unguardedTypBind tbds) U       unguardedDec dec  | ABSTYPEdec(dbds,NONE,dec) =>      (U_map unguardedDatBind dbds) U       unguardedDec dec  | EXCEPTIONdec ebs =>      U_map unguardedExBind ebs  | LOCALdec (dec1, dec2) =>      unguardedDec dec1 U unguardedDec dec2  | OPENdec _ => []  | EMPTYdec => []  | SEQdec (dec1, dec2) =>      unguardedDec dec1 U unguardedDec dec2  | FIXITYdec _ => []  | STRUCTUREdec mbds =>       U_map unguardedModBind mbds  | FUNCTORdec fbds =>       U_map unguardedFunBind fbds  | SIGNATUREdec sbds =>       U_map unguardedSigBind sbdsand unguardedExBind (EXDECexbind(_, SOME ty)) = unguardedTy ty  | unguardedExBind (EXDECexbind(_, NONE)) = []  | unguardedExBind (EXEQUALexbind(_,_)) = []and unguardedValBind (ValBind(ref pat, exp)) =  unguardedPat pat U unguardedExp expand unguardedPrimValBindList (pbs) =  (U_map (fn (ii,ty,arity,n) => unguardedTy ty) pbs)and unguardedValDec (pvbs, rvbs) =  (U_map unguardedValBind pvbs) U  (U_map unguardedValBind rvbs)and unguardedTy (_, ty') =  case ty' of    TYVARty ii => [hd(#id(#qualid ii))]  | RECty fs =>      U_map (fn(_, ty) => unguardedTy ty) fs  | CONty(tys, tyconpath) =>       (U_map unguardedTy tys) U unguardedTyConPath tyconpath  | FNty(ty1, ty2) =>      unguardedTy ty1 U unguardedTy ty2  | PACKty(sigexp) =>      unguardedSigExp sigexp  | PARty(ty) =>      unguardedTy tyand unguardedModBind (MODBINDmodbind(modid,modexp)) =      unguardedModExp modexp  | unguardedModBind (ASmodbind(modid,sigexp,exp)) =      (unguardedSigExp sigexp;       unguardedExp exp)and unguardedSigBind (SIGBINDsigbind(sigid,sigexp)) =      unguardedSigExp sigexpand unguardedFunBind (FUNBINDfunbind(funid,modexp)) =     unguardedModExp modexp  | unguardedFunBind (ASfunbind(funid,sigexp,exp)) =      (unguardedSigExp sigexp;       unguardedExp exp)and unguardedModExp (_,(modexp,_)) =     case modexp of      DECmodexp dec => 	  unguardedDec dec   | LONGmodexp _ => []   | LETmodexp (dec,modexp) =>	  unguardedDec dec U unguardedModExp modexp   | PARmodexp modexp => 	  unguardedModExp modexp   | CONmodexp (modexp,sigexp) =>	  unguardedModExp modexp U unguardedSigExp sigexp   | ABSmodexp (modexp,sigexp) =>	  unguardedModExp modexp U unguardedSigExp sigexp   | FUNCTORmodexp (_,modid,_, sigexp, modexp) =>	  unguardedSigExp sigexp U unguardedModExp modexp    | APPmodexp (modexp,modexp') =>	  unguardedModExp modexp U unguardedModExp modexp'              | RECmodexp (modid,_,sigexp, modexp) =>	  unguardedSigExp sigexp U unguardedModExp modexp and unguardedSigExp (_,sigexp) =  case sigexp of    SPECsigexp spec => unguardedSpec spec  | SIGIDsigexp _ => []  | WHEREsigexp (sigexp, tyvarseq, longtycon, ty) =>           (unguardedSigExp sigexp U (unguardedTy ty without tyvarseq))  | FUNSIGsigexp (_,modid, sigexp,sigexp') =>           (unguardedSigExp sigexp U unguardedSigExp sigexp')  | RECsigexp (modid, sigexp,sigexp') =>           (unguardedSigExp sigexp U unguardedSigExp sigexp')and unguardedSpec (_, spec') =   case spec' of    VALspec _ => []  | PRIM_VALspec _ => []  | TYPEDESCspec _ => []  | TYPEspec tbds => U_map unguardedTypBind tbds  | DATATYPEspec (dbds,SOME tbds) =>        (U_map unguardedDatBind dbds) U        (U_map unguardedTypBind tbds)  | DATATYPEspec (dbds,NONE) =>        U_map unguardedDatBind dbds  | DATATYPErepspec (tycon, tyconpath) =>              unguardedTyConPath tyconpath  | EXCEPTIONspec eds => U_map unguardedExDesc eds  | LOCALspec(spec1, spec2) =>       unguardedSpec spec1 U unguardedSpec spec2  | OPENspec _ => []  | EMPTYspec => []  | SEQspec(spec1, spec2) =>       unguardedSpec spec1 U unguardedSpec spec2  | INCLUDEspec sigexp =>        unguardedSigExp sigexp  | STRUCTUREspec moddescs =>        U_map unguardedModDesc moddescs  | FUNCTORspec fundescs =>        U_map unguardedFunDesc fundescs  | SHARINGTYPEspec (spec, longtycons) =>        unguardedSpec spec  | SHARINGspec (spec, longmodids) =>        unguardedSpec spec  | FIXITYspec _ =>        []  | SIGNATUREspec sigdescs =>      U_map unguardedSigBind sigdescsand unguardedModDesc (MODDESCmoddesc(modid,sigexp)) =    unguardedSigExp sigexpand unguardedFunDesc (FUNDESCfundesc(funid,sigexp)) =    unguardedSigExp sigexpand unguardedTyConPath (_,LONGtyconpath _) = []  | unguardedTyConPath (_,WHEREtyconpath (_,_,modexp)) =        unguardedModExp modexpand unguardedTypBind (tyvarseq,tycon,ty) =       unguardedTy ty without tyvarseqand unguardedExDesc (_,SOME ty) =       unguardedTy ty  | unguardedExDesc (_,NONE) = []and unguardedDatBind (tyvarseq, tycon, cbds) =       (U_map unguardedConBind cbds) without tyvarseqand unguardedConBind (ConBind (ii, NONE)) = []  | unguardedConBind (ConBind (ii, SOME ty)) = unguardedTy tyand unguardedValDescList (vds) =  (U_map (fn (ii,ty) => unguardedTy ty) vds); (* cvr: TODO the original definition of scopedTyVars appears to be wrong,   since a variable in pars will not be scoped,   if it is already scoped in UE fun scopedTyVars UE pars unguardedTyVars =  list_subtract (pars U unguardedTyVars) (map fst UE);*)(* cvr: REVIEW I think the correct definitions should be: *)fun scopedTyVars loc UE pars unguardedTyVars =   let val scopedtyvars = map fst UE   in       if (!currentCompliance) <> Liberal 	   then (app (fn v =>		      if member v scopedtyvars			  then case !currentCompliance of			      Orthodox => 				  (msgIBlock 0;				   errLocation loc;				   errPrompt "Compliance Error: ";msgEOL();				   errPrompt "The phrase, although accepted as a Moscow ML extension,";msgEOL();				   errPrompt "is not supported by the Definition of Standard ML:"; msgEOL();				   errPrompt "the explicit type variable ";msgEOL();				   errPrompt "  "; msgString v;msgEOL();				   errPrompt "is already in scope and should not be redeclared";				   msgEOL();				   msgEBlock();				   raise Toplevel)			    |  Conservative => 				  (msgIBlock 0;				   errLocation loc;				   errPrompt "Compliance Warning: ";msgEOL();				   errPrompt "The phrase, although accepted as a Moscow ML extension,";msgEOL();

Lines 1–500 of 3405. Load more