├── .gitignore ├── ElabData ├── basics │ ├── access.sig │ ├── access.sml │ ├── core-ptnum.sml │ ├── coresym.sml │ ├── env.sig │ ├── env.sml │ ├── lambdavar.sig │ ├── lambdavar.sml │ ├── primopid.sig │ ├── primopid.sml │ ├── stampmap.sml │ ├── stamps.sig │ ├── stamps.sml │ ├── sympaths.sig │ └── sympaths.sml ├── elabdata.cm ├── main │ ├── compinfo.sml │ ├── edcontrol.sig │ └── edcontrol.sml ├── modules │ ├── entityenv.sig │ ├── entityenv.sml │ ├── entpath.sml │ ├── epcontext.sml │ ├── moduleid.sml │ ├── modules.sig │ ├── modules.sml │ ├── moduleutil.sig │ └── moduleutil.sml ├── statenv │ ├── bindings.sig │ ├── bindings.sml │ ├── browse.sml │ ├── coreacc.sml │ ├── genmap.sml │ ├── lookup.sig │ ├── lookup.sml │ ├── statenv.sig │ └── statenv.sml ├── syntax │ ├── absyn.sig │ ├── absyn.sml │ ├── absynutil.sml │ ├── varcon.sig │ └── varcon.sml └── types │ ├── core-basictypes.sml │ ├── tuples.sml │ ├── types.sig │ ├── types.sml │ ├── typesutil.sig │ └── typesutil.sml ├── Elaborator ├── basics │ ├── conrep.sml │ ├── debindex.sig │ ├── debindex.sml │ ├── elabcontrol.sig │ ├── elabcontrol.sml │ └── ptnum.sml ├── elaborate.cm ├── elaborate │ ├── elabcore.sml │ ├── elabdebug.sml │ ├── elabmod.sml │ ├── elabsig.sml │ ├── elabtop.sml │ ├── elabtype.sig │ ├── elabtype.sml │ ├── elabutil.sig │ ├── elabutil.sml │ ├── include.sml │ ├── precedence.sml │ ├── specialsyms.sml │ └── tyvarset.sml ├── modules │ ├── evalent.sml │ ├── expandtycon.sml │ ├── instantiate.sml │ ├── sigmatch.sig │ └── sigmatch.sml ├── print │ ├── ppabsyn.sml │ ├── ppast.sig │ ├── ppast.sml │ ├── ppast.sml.old │ ├── ppmod.sml │ ├── ppprim.sml │ ├── pptype.sml │ ├── pputil-new.sig │ ├── pputil-new.sml │ ├── pputil.sig │ ├── pputil.sml │ └── ppval.sml └── types │ ├── basictypes.sig │ ├── basictypes.sml │ ├── eqtypes.sml │ ├── overload.sml │ ├── overloadlit.sml │ ├── typecheck.sig │ ├── typecheck.sml │ └── unify.sml ├── Parse ├── ast │ ├── ast.sig │ ├── ast.sml │ ├── astutil.sig │ └── astutil.sml ├── lex │ ├── .cvsignore │ ├── .gitignore │ ├── ml.lex │ ├── ml.lex.sml │ └── tokentable.sml ├── main │ ├── parser.sig │ ├── parser.sml │ ├── parsercontrol.sml │ └── smlfile.sml ├── parse │ ├── .cvsignore │ ├── .gitignore │ ├── ml.grm │ ├── ml.grm.desc │ └── ml.grm.sig └── parser.cm ├── infixes.sml ├── lint ├── lint.cm ├── lint.sml ├── mkfile ├── precedence.sml ├── report.sig ├── report.sml ├── smlnj-home └── top.sml /.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | *~ 3 | /*.x86-linux 4 | -------------------------------------------------------------------------------- /ElabData/basics/access.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* access.sig *) 3 | 4 | signature ACCESS = sig 5 | 6 | type lvar = LambdaVar.lvar 7 | 8 | datatype access 9 | = LVAR of lvar 10 | | EXTERN of PersStamps.persstamp 11 | | PATH of access * int 12 | | NO_ACCESS 13 | 14 | datatype conrep 15 | = UNTAGGED 16 | | TAGGED of int 17 | | TRANSPARENT 18 | | CONSTANT of int 19 | | REF 20 | | EXN of access 21 | | SUSP of (access * access) option 22 | | LISTCONS 23 | | LISTNIL 24 | 25 | datatype consig 26 | = CSIG of int * int 27 | | CNIL 28 | 29 | val prAcc : access -> string 30 | val prRep : conrep -> string 31 | val prCsig : consig -> string 32 | val isExn : conrep -> bool 33 | 34 | val selAcc : access * int -> access 35 | val dupAcc : lvar * (Symbol.symbol option -> lvar) -> access 36 | 37 | val namedAcc : Symbol.symbol * (Symbol.symbol option -> lvar) 38 | -> access 39 | 40 | val newAcc : (Symbol.symbol option -> lvar) -> access 41 | 42 | val extAcc : PersStamps.persstamp -> access 43 | val nullAcc : access 44 | 45 | val accLvar : access -> lvar option 46 | 47 | end (* signature ACCESS *) 48 | -------------------------------------------------------------------------------- /ElabData/basics/access.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* access.sml *) 3 | 4 | structure Access : ACCESS = 5 | struct 6 | 7 | local structure LV = LambdaVar 8 | structure EM = ErrorMsg 9 | structure PS = PersStamps 10 | structure S = Symbol 11 | in 12 | 13 | fun bug msg = EM.impossible("Bugs in Access: "^msg) 14 | 15 | type lvar = LV.lvar 16 | type persstamp = PS.persstamp 17 | 18 | (* 19 | * access: how to find the dynamic value corresponding to a variable. 20 | * An LVAR is just a lambda-bound variable --- a temporary used to denote 21 | * a binding in the current compilation unit. EXTERN refers to a binding 22 | * defined externally (in other modules). PATH is an absolute address from 23 | * a lambda-bound variable (i.e. we find the value of the lambda-bound 24 | * variable, and then do selects from that). PATH's are kept in reverse 25 | * order. NO_ACCESS is used to denote built-in structures that do not 26 | * have corresponding dynamic objects (e.g., the built-in InLine is a 27 | * structure that declares all the built-in primitives --- it is likely 28 | * that NO_ACCESS will go away in the future once we have cleaned up the 29 | * bootstrap procedure. 30 | *) 31 | datatype access 32 | = LVAR of lvar 33 | | EXTERN of persstamp 34 | | PATH of access * int 35 | | NO_ACCESS 36 | 37 | (* 38 | * conrep: how to decide the data representations for data constructors. 39 | * All true datatypes are divided into four categories, depending on the 40 | * pair of parameters (m,n) where m is the number of constant constructors 41 | * and n is the number of value carrying constructors. REF, EXN, SUSP 42 | * are special constructors for reference cells, exceptions, and suspensions; 43 | * treating them as data constructors simplifies the match compilation. 44 | * LISTCONS and LISTNIL are special conreps for unrolled lists. The process 45 | * of assigning conreps probably should be performed on the intermediate 46 | * language instead. 47 | *) 48 | datatype conrep 49 | = UNTAGGED (* 30 bit + 00; a pointer *) 50 | | TAGGED of int (* a pointer; 1st field is the tag *) 51 | | TRANSPARENT (* 32 bit value, singleton dcon dt *) 52 | | CONSTANT of int (* should be int31 *) 53 | | REF 54 | | EXN of access 55 | | SUSP of (access * access) option 56 | | LISTCONS 57 | | LISTNIL 58 | 59 | (* See ElabData/types/core-basictypes.sml and 60 | * Elaborator/types/basictypes.sml for samples 61 | * 62 | * FLINT/cps/switch.sml uses consig during representation analysis *) 63 | datatype consig 64 | = CSIG of int * int (* # dcon tagged, # untagged *) 65 | | CNIL 66 | 67 | (**************************************************************************** 68 | * UTILITY FUNCTIONS ON ACCESS * 69 | ****************************************************************************) 70 | 71 | (** printing the access *) 72 | fun prAcc (LVAR i) = "LVAR(" ^ LV.prLvar i ^ ")" 73 | | prAcc (PATH(a,i)) = "PATH(" ^ Int.toString i ^ ","^ prAcc a ^ ")" 74 | | prAcc (EXTERN pid) = "EXTERN(" ^ PS.toHex pid ^ ")" 75 | | prAcc (NO_ACCESS) = "NO_ACCESS" 76 | 77 | (** printing the conrep *) 78 | fun prRep (UNTAGGED) = "UT" 79 | | prRep (TAGGED i) = "TG(" ^ Int.toString i ^ ")" 80 | | prRep (TRANSPARENT) = "TN" 81 | | prRep (CONSTANT i) = "CN(" ^ Int.toString i ^ ")" 82 | | prRep (REF) = "RF" 83 | | prRep (EXN acc) = "EXN" ^ prAcc acc 84 | | prRep (LISTCONS) = "LC" 85 | | prRep (LISTNIL) = "LN" 86 | | prRep (SUSP _) = "SS" 87 | 88 | (** printing the data sign *) 89 | fun prCsig (CSIG(i,j)) = "B" ^ Int.toString i ^ "U" ^ Int.toString j 90 | | prCsig (CNIL) = "CNIL" 91 | 92 | (** testing if a conrep is an exception or not *) 93 | fun isExn (EXN _) = true 94 | | isExn _ = false 95 | 96 | (** fetching a component out of a structure access *) 97 | fun selAcc (NO_ACCESS, _) = NO_ACCESS (* bug "Selecting from a NO_ACCESS !" *) 98 | | selAcc (p, i) = PATH(p, i) 99 | 100 | (** duplicating an access variable *) 101 | fun dupAcc (v, mkv) = LVAR(mkv(LV.lvarSym(v))) 102 | 103 | fun namedAcc (s, mkv) = LVAR(mkv(SOME s)) 104 | fun newAcc (mkv) = LVAR (mkv(NONE)) 105 | fun extAcc pid = EXTERN pid 106 | val nullAcc = NO_ACCESS 107 | 108 | fun accLvar (LVAR v) = SOME v 109 | | accLvar _ = NONE 110 | 111 | end (* local *) 112 | end (* structure Access *) 113 | -------------------------------------------------------------------------------- /ElabData/basics/core-ptnum.sml: -------------------------------------------------------------------------------- 1 | (* core-ptnum.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * Generic set of primitive type constructor numbers (not SML/NJ-specific). 6 | *) 7 | signature CORE_PRIM_TYC_NUM = sig 8 | 9 | (* The numbers here are consecutive and fill [0...next_free_ptn) *) 10 | 11 | val ptn_void : int 12 | val ptn_int : int (* default int (31 bit in SML/NJ) *) 13 | val ptn_real : int 14 | val ptn_string : int 15 | val ptn_exn : int 16 | val ptn_arrow : int 17 | val ptn_ref : int 18 | val ptn_array : int 19 | val ptn_vector : int 20 | 21 | val next_free_ptn : int 22 | end 23 | 24 | structure CorePrimTycNum : CORE_PRIM_TYC_NUM = struct 25 | 26 | val ptn_void = 0 27 | val ptn_int = 1 28 | val ptn_real = 2 29 | val ptn_string = 3 30 | val ptn_exn = 4 31 | val ptn_arrow = 5 32 | val ptn_ref = 6 33 | val ptn_array = 7 34 | val ptn_vector = 8 35 | 36 | val next_free_ptn = 9 37 | end 38 | -------------------------------------------------------------------------------- /ElabData/basics/coresym.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * The internal symbol that is used to find "core" bindings. This symbol 3 | * is "structure _Core", which is something that cannot legally occur in 4 | * normal SML code, so there is no danger of accidentially overriding 5 | * this binding. 6 | * 7 | * (C) 2000 Lucent Technologies, Bell Laboratories 8 | * 9 | * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp) 10 | *) 11 | structure CoreSym = struct 12 | val coreSym = Symbol.strSymbol "_Core" 13 | end 14 | -------------------------------------------------------------------------------- /ElabData/basics/env.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* env.sig *) 3 | 4 | signature ENV = sig 5 | 6 | type 'b env 7 | exception Unbound 8 | 9 | val empty: 'b env 10 | val look: 'b env * Symbol.symbol -> 'b 11 | val bind: Symbol.symbol * 'b * 'b env -> 'b env 12 | 13 | val special: (Symbol.symbol -> 'b) * (unit -> Symbol.symbol list) -> 'b env 14 | 15 | val atop: 'b env * 'b env -> 'b env 16 | (* atop(e1,e2): place e1 on top of e2 *) 17 | 18 | val consolidate: 'b env -> 'b env 19 | val consolidateLazy: 'b env -> 'b env 20 | val app: (Symbol.symbol * 'b -> unit) -> 'b env -> unit 21 | val map: ('b -> 'b) -> 'b env -> 'b env 22 | val fold: ((Symbol.symbol * 'b) * 'a -> 'a) -> 'a -> 'b env -> 'a 23 | 24 | val symbols : 'b env -> Symbol.symbol list 25 | (* may contain duplicate symbols *) 26 | 27 | end (* signature ENV *) 28 | -------------------------------------------------------------------------------- /ElabData/basics/lambdavar.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* lambdavar.sig *) 3 | 4 | signature LAMBDA_VAR = 5 | sig 6 | 7 | type lvar 8 | 9 | val saveLvarNames : bool ref 10 | val lvarIsNamed : lvar -> bool 11 | val prLvar: lvar-> string 12 | val sameName : lvar * lvar -> unit 13 | 14 | val clear : unit -> unit 15 | val mkLvar : unit -> lvar 16 | val dupLvar : lvar -> lvar 17 | val namedLvar : Symbol.symbol -> lvar 18 | val lvarSym : lvar -> Symbol.symbol option 19 | val lvarName : lvar -> string 20 | 21 | end (* signature LAMBDA_VAR *) 22 | -------------------------------------------------------------------------------- /ElabData/basics/lambdavar.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* lambdavar.sml *) 3 | 4 | structure LambdaVar : LAMBDA_VAR = 5 | struct 6 | 7 | local 8 | 9 | structure S = Symbol 10 | structure IM = IntHashTable 11 | 12 | in 13 | 14 | fun inc r = r := !r + 1 15 | fun newLvar r () = (inc r; !r) 16 | val varcount = ref 0 17 | 18 | exception NoLvarName 19 | val lvarNames : string IM.hash_table = IM.mkTable(32, NoLvarName) 20 | val name = IM.lookup lvarNames 21 | val giveLvarName = IM.insert lvarNames 22 | 23 | type lvar = int (* lambda variable id number *) 24 | 25 | val saveLvarNames = ElabDataControl.saveLvarNames 26 | fun lvarIsNamed lv = (name lv; true) handle NoLvarName => false 27 | fun prLvar(lvar:lvar) = Int.toString(lvar) 28 | 29 | fun sameName(v,w) = 30 | if !saveLvarNames 31 | then giveLvarName(v,name w) handle NoLvarName => 32 | (giveLvarName(w, name v) handle NoLvarName => ()) 33 | else () 34 | 35 | val mkLvar = newLvar varcount 36 | 37 | fun clear () = (varcount := 0; IM.clear lvarNames) 38 | 39 | fun dupLvar v = 40 | let val nv = mkLvar() 41 | in if !saveLvarNames then 42 | (giveLvarName(nv,name v) handle NoLvarName => ()) 43 | else (); 44 | nv 45 | end 46 | 47 | fun namedLvar(id: S.symbol) = 48 | let val nv = mkLvar() 49 | in if !saveLvarNames then giveLvarName(nv,S.name id) else (); 50 | nv 51 | end 52 | 53 | fun lvarSym(lv : lvar) : S.symbol option 54 | = SOME (S.varSymbol (name lv)) handle NoLvarName => NONE 55 | 56 | fun lvarName(lv : lvar) : string = 57 | let val s = Int.toString lv 58 | in (name lv ^ s) handle NoLvarName => ("v" ^ s) 59 | end 60 | 61 | end (* local *) 62 | 63 | end (* structure LambdaVar *) 64 | -------------------------------------------------------------------------------- /ElabData/basics/primopid.sig: -------------------------------------------------------------------------------- 1 | (* primopid.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | 6 | (* PRIMOPID: front-end representation of information identifying 7 | * primops (either in variables, or in structures). Replaces 8 | * INL_INFO *) 9 | 10 | signature PRIMOPID = 11 | sig 12 | 13 | datatype primId = Prim of string | NonPrim 14 | 15 | datatype strPrimElem 16 | = PrimE of primId 17 | | StrE of strPrimInfo 18 | 19 | withtype strPrimInfo = strPrimElem list 20 | 21 | val isPrimop : primId -> bool 22 | 23 | val isPrimCallcc : primId -> bool 24 | val isPrimCast : primId -> bool 25 | 26 | val selStrPrimId : strPrimElem list * int -> strPrimElem list 27 | val selValPrimFromStrPrim : strPrimElem list * int -> primId 28 | 29 | val ppPrim : primId -> string 30 | val ppStrInfo : strPrimInfo -> unit 31 | 32 | end (* signature PRIMOPID *) 33 | -------------------------------------------------------------------------------- /ElabData/basics/primopid.sml: -------------------------------------------------------------------------------- 1 | (* primopid.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | 6 | (* [dbm, 6/19/06] 7 | Folded ii.sml into this structure, eliminating exn hack. 8 | Changed name of pureInfo to isPrimCast. 9 | Eliminated redundant INL_PRIM, INL_STR, INL_NO. *) 10 | 11 | structure PrimOpId : PRIMOPID = 12 | struct 13 | 14 | (* in the front end, primops are identified by a unique primop name, 15 | represented as a string. See the file DEVNOTES/Flint/primop-list 16 | for the catalog of primop names with their types and primop specs *) 17 | 18 | datatype primId = Prim of string | NonPrim 19 | 20 | datatype strPrimElem = PrimE of primId 21 | | StrE of strPrimInfo 22 | 23 | withtype strPrimInfo = strPrimElem list 24 | 25 | fun bug s = ErrorMsg.impossible ("PrimOpId: " ^ s) 26 | 27 | (* isPrimop : primId -> bool *) 28 | fun isPrimop (Prim _) = true 29 | | isPrimop NonPrim = false 30 | 31 | (* Used in TopLevel/main/compile.sml to identify callcc/capture primops *) 32 | fun isPrimCallcc (Prim("callcc" | "capture")) = true 33 | | isPrimCallcc _ = false 34 | 35 | (* Used in ElabData/modules/moduleutil.sml to identify cast primop *) 36 | fun isPrimCast (Prim "cast") = true 37 | | isPrimCast _ = false 38 | 39 | (* selStrPrimId : strPrimInfo * int -> strPrimInfo *) 40 | (* Select the prim ids for a substructure *) 41 | fun selStrPrimId([], slot) = [] 42 | | selStrPrimId(elems, slot) = 43 | (case List.nth(elems, slot) 44 | of StrE elems' => elems' 45 | | PrimE _ => bug "PrimOpId.selStrPrimId: unexpected PrimE") 46 | handle Subscript => (bug "PrimOpId.selStrPrimId Subscript") 47 | (* This bug happens if we got a primid for a value 48 | component when we expected a strPrimElem for a 49 | structure *) 50 | 51 | (* Select the prim id for a value component *) 52 | fun selValPrimFromStrPrim([], slot) = NonPrim 53 | | selValPrimFromStrPrim(elems, slot) = 54 | (case List.nth(elems, slot) 55 | of PrimE(id) => id 56 | | StrE _ => 57 | bug "PrimOpId.selValPrimFromStrPrim: unexpected StrE") 58 | handle Subscript => bug "PrimOpId.selValPrimFromStrPrim Subscript" 59 | (* This bug occurs if we got a substructure's 60 | strPrimElem instead of an expected value component's 61 | primId *) 62 | 63 | fun ppPrim NonPrim = "" 64 | | ppPrim (Prim p) = ("") 65 | 66 | fun ppStrInfo strelems = 67 | let fun ppElem [] = () 68 | | ppElem ((PrimE p)::xs) = (print (ppPrim p); ppElem xs) 69 | | ppElem ((StrE s)::xs) = (ppStrInfo s; ppElem xs) 70 | in (print "[ "; ppElem strelems; print " ]\n") 71 | end 72 | 73 | end (* structure PrimOpId *) 74 | -------------------------------------------------------------------------------- /ElabData/basics/stampmap.sml: -------------------------------------------------------------------------------- 1 | (* stampmap.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure StampMap = RedBlackMapFn (Stamps) 6 | -------------------------------------------------------------------------------- /ElabData/basics/stamps.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* Re-written by Matthias Blume (3/2000) *) 3 | (* stamps.sig *) 4 | 5 | signature STAMPS = 6 | sig 7 | type stamp 8 | type ord_key = stamp (* to match signature ORD_KEY *) 9 | type pid = PersStamps.persstamp (* for global stamps *) 10 | 11 | val eq : stamp * stamp -> bool 12 | val compare : stamp * stamp -> order (* instead of "cmp" (ORD_KEY) *) 13 | 14 | type generator 15 | val newGenerator : unit -> generator 16 | val fresh : generator -> stamp 17 | 18 | (* Make a new "special" stamp (for things in primEnv). *) 19 | val special : string -> stamp 20 | 21 | (* Make a "global" stamp (i.e., one that comes from a different 22 | * compilation unit). Used only by the unpickler. *) 23 | val global : { pid: pid, cnt: int } -> stamp 24 | 25 | (* Case analysis on the abstract type with built-in alpha-conversion 26 | * for fresh stamps. Used by the pickler. *) 27 | type converter 28 | val newConverter : unit -> converter 29 | val Case : converter -> stamp -> 30 | { fresh : int -> 'a, (* already alpha-converted *) 31 | global : { pid: pid, cnt: int } -> 'a, 32 | special : string -> 'a } -> 'a 33 | 34 | (* testing for freshness quickly... *) 35 | val isFresh : stamp -> bool 36 | 37 | (* for debugging: *) 38 | val toString : stamp -> string 39 | val toShortString : stamp -> string 40 | end 41 | -------------------------------------------------------------------------------- /ElabData/basics/stamps.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* Re-written by Matthias Blume (3/2000) *) 3 | (* stamps.sml *) 4 | 5 | structure Stamps :> STAMPS = 6 | struct 7 | 8 | type pid = PersStamps.persstamp (* for global stamps *) 9 | 10 | datatype stamp 11 | = Special of string 12 | | Global of { pid: pid, cnt: int } 13 | | Fresh of int 14 | 15 | type ord_key = stamp 16 | 17 | fun compare (Fresh i, Fresh i') = Int.compare (i, i') 18 | | compare (Fresh _, _) = GREATER 19 | | compare (_, Fresh _) = LESS 20 | | compare (Special s, Special s') = String.compare (s, s') 21 | | compare (Special _, _) = GREATER 22 | | compare (_, Special _) = LESS 23 | | compare (Global g, Global g') = 24 | (case Int.compare (#cnt g, #cnt g') 25 | of EQUAL => PersStamps.compare (#pid g, #pid g') 26 | | unequal => unequal) 27 | 28 | fun eq (s, s') = compare (s, s') = EQUAL 29 | 30 | type generator = int ref 31 | fun newGenerator () = ref 0 32 | fun fresh r = let val i = !r in r := i + 1; Fresh i end 33 | val special = Special 34 | val global = Global 35 | 36 | local 37 | structure M = IntRedBlackMap 38 | in 39 | type converter = int M.map ref * int ref 40 | fun newConverter () = (ref M.empty, ref 0) 41 | fun Case _ (Special s) { fresh, global, special } = special s 42 | | Case _ (Global g) { global, ... } = global g 43 | | Case (m, n) (Fresh i) { fresh, ... } = 44 | (case M.find (!m, i) of 45 | SOME i' => fresh i' 46 | | NONE => let val i' = !n 47 | in 48 | n := i' + 1; m := M.insert (!m, i, i'); 49 | fresh i' 50 | end) 51 | end 52 | 53 | fun isFresh (Fresh _) = true 54 | | isFresh _ = false 55 | 56 | fun toString (Fresh i) = concat ["FSTAMP(", Int.toString i, ")"] 57 | | toString (Global { pid, cnt }) = 58 | concat ["GSTAMP(", PersStamps.toHex pid, ",", Int.toString cnt, ")"] 59 | | toString (Special s) = concat ["SSTAMP(", s, ")"] 60 | 61 | fun toShortString (Fresh i) = "#F" ^ Int.toString i 62 | | toShortString (Special s) = "#S:" ^ s 63 | | toShortString (Global { pid, cnt }) = let 64 | fun trim3 s = substring (s, size s - 3, 3) 65 | in 66 | concat ["#G", trim3 (PersStamps.toHex pid), ".", Int.toString cnt] 67 | end 68 | 69 | end (* structure Stamps *) 70 | -------------------------------------------------------------------------------- /ElabData/basics/sympaths.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* sympaths.sig *) 3 | 4 | signature SYMPATH = 5 | sig 6 | datatype path = SPATH of Symbol.symbol list 7 | val empty : path 8 | val null : path -> bool 9 | val extend : path * Symbol.symbol -> path 10 | val prepend : Symbol.symbol * path -> path 11 | val append : path * path -> path 12 | val first : path -> Symbol.symbol 13 | val rest : path -> path 14 | val length : path -> int 15 | val last : path -> Symbol.symbol 16 | val equal : path * path -> bool 17 | val toString : path -> string 18 | end 19 | 20 | signature INVPATH = 21 | sig 22 | datatype path = IPATH of Symbol.symbol list 23 | val empty : path 24 | val null : path -> bool 25 | val extend: path * Symbol.symbol -> path 26 | val append: path * path -> path 27 | val last: path -> Symbol.symbol 28 | val lastPrefix: path -> path 29 | val equal : path * path -> bool 30 | val toString : path -> string 31 | end 32 | 33 | signature CONVERTPATHS = 34 | sig 35 | type spath 36 | type ipath 37 | val invertSPath : spath -> ipath 38 | val invertIPath : ipath -> spath 39 | end 40 | -------------------------------------------------------------------------------- /ElabData/basics/sympaths.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* sympaths.sml *) 3 | 4 | structure SymPath : SYMPATH = 5 | struct 6 | 7 | structure S = Symbol 8 | 9 | datatype path = SPATH of S.symbol list 10 | 11 | exception SymPath 12 | 13 | val empty = SPATH nil 14 | 15 | fun null(SPATH p) = List.null p 16 | 17 | fun extend(SPATH p: path, s: S.symbol) = SPATH(p @ [s]) 18 | 19 | fun prepend(s: S.symbol, SPATH p: path) = SPATH(s::p) 20 | 21 | fun append(SPATH front: path, SPATH back: path) = SPATH(front @ back) 22 | 23 | fun first(SPATH []: path) = raise SymPath 24 | | first(SPATH(s::_)) = s 25 | 26 | fun rest(SPATH []: path) = raise SymPath 27 | | rest(SPATH(_::p)) = SPATH p 28 | 29 | fun length(SPATH p: path) = List.length p 30 | 31 | (* the last element of a path *) 32 | fun last(SPATH p) = 33 | List.last p 34 | handle List.Empty => ErrorMsg.impossible "SymPath.last" 35 | 36 | fun equal(SPATH p1: path, SPATH p2: path) = ListPair.all Symbol.eq (p1, p2) 37 | 38 | val resultId = Symbol.strSymbol "" 39 | val returnId = Symbol.strSymbol "" 40 | 41 | fun toString(SPATH p: path) = 42 | let fun f [s] = [Symbol.name s] 43 | | f (a::r) = 44 | if (Symbol.eq(a,resultId)) orelse 45 | (Symbol.eq(a,returnId)) 46 | then f r 47 | else Symbol.name a :: "." :: f r 48 | | f nil = [""] 49 | in concat(f p) 50 | end 51 | 52 | end (* structure SymPath *) 53 | 54 | 55 | structure InvPath : INVPATH = 56 | struct 57 | 58 | structure S = Symbol 59 | 60 | datatype path = IPATH of S.symbol list 61 | 62 | exception InvPath 63 | 64 | val empty = IPATH nil 65 | 66 | fun null(IPATH p) = List.null p 67 | 68 | fun extend(IPATH p: path, s: S.symbol) = IPATH(s::p) 69 | 70 | fun append(IPATH front: path, IPATH back: path) = IPATH(back @ front) 71 | 72 | fun last(IPATH []: path) = raise InvPath 73 | | last(IPATH(s::_)) = s 74 | 75 | fun lastPrefix(IPATH []: path) = raise InvPath 76 | | lastPrefix(IPATH(_::p)) = IPATH p 77 | 78 | fun equal(IPATH p1:path, IPATH p2:path) = ListPair.all Symbol.eq (p1, p2) 79 | 80 | fun toString(IPATH p: path) = 81 | let fun f [s] = [Symbol.name s, ">"] 82 | | f (a::r) = Symbol.name a :: "." :: f r 83 | | f nil = [">"] 84 | in concat("<" :: f p) 85 | end 86 | 87 | end (* structure InvPath *) 88 | 89 | 90 | structure ConvertPaths : CONVERTPATHS = 91 | struct 92 | 93 | type spath = SymPath.path 94 | type ipath = InvPath.path 95 | 96 | fun invertSPath(SymPath.SPATH p : SymPath.path) : InvPath.path = 97 | InvPath.IPATH(rev p) 98 | fun invertIPath(InvPath.IPATH p : InvPath.path) : SymPath.path = 99 | SymPath.SPATH(rev p) 100 | 101 | end (* structure ConvertPaths *) 102 | -------------------------------------------------------------------------------- /ElabData/elabdata.cm: -------------------------------------------------------------------------------- 1 | (* elabdata.cm 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * A library defining data structures used by the SML/NJ elaborator. 6 | *) 7 | Group 8 | signature ELABDATA_CONTROL 9 | signature ACCESS 10 | signature TYPES 11 | signature TYPESUTIL 12 | signature TUPLES 13 | signature ABSYN 14 | signature SYMPATH 15 | signature INVPATH 16 | signature CONVERTPATHS 17 | signature LAMBDA_VAR 18 | signature STAMPS 19 | signature ENT_PATH 20 | signature VARCON 21 | signature MODULES 22 | signature MODULEUTIL 23 | signature MODULE_ID 24 | signature BINDINGS 25 | signature STATICENV 26 | signature CORE_PRIM_TYC_NUM 27 | signature ENTITY_ENV 28 | signature PRIMOPID 29 | 30 | structure ElabDataControl 31 | structure Access 32 | structure Types 33 | structure TypesUtil 34 | structure Tuples 35 | structure Absyn 36 | structure AbsynUtil 37 | structure SymPath 38 | structure InvPath 39 | structure ConvertPaths 40 | structure LambdaVar 41 | structure Stamps 42 | structure StampMap 43 | structure EntPath 44 | structure VarCon 45 | structure Modules 46 | structure ModuleUtil 47 | structure ModuleId 48 | structure EntityEnv 49 | structure EntPathContext 50 | structure Bindings 51 | structure StaticEnv 52 | structure Lookup 53 | structure CompInfo 54 | structure CoreSym 55 | structure CorePrimTycNum 56 | structure CoreBasicTypes 57 | structure GenModIdMap 58 | structure CoreAccess 59 | structure BrowseStatEnv 60 | structure PrimOpId 61 | 62 | is 63 | main/edcontrol.sig 64 | main/edcontrol.sml 65 | main/compinfo.sml 66 | 67 | basics/lambdavar.sig 68 | basics/lambdavar.sml 69 | basics/env.sig 70 | basics/env.sml 71 | basics/stamps.sig 72 | basics/stamps.sml 73 | basics/stampmap.sml 74 | basics/primopid.sig 75 | basics/primopid.sml 76 | basics/coresym.sml 77 | basics/access.sig 78 | basics/access.sml 79 | basics/sympaths.sig 80 | basics/sympaths.sml 81 | basics/core-ptnum.sml 82 | 83 | syntax/absyn.sig 84 | syntax/absyn.sml 85 | syntax/varcon.sig 86 | syntax/varcon.sml 87 | syntax/absynutil.sml 88 | 89 | types/types.sig 90 | types/types.sml 91 | types/tuples.sml 92 | types/core-basictypes.sml 93 | types/typesutil.sig 94 | types/typesutil.sml 95 | 96 | modules/modules.sig 97 | modules/modules.sml 98 | modules/entpath.sml 99 | modules/epcontext.sml 100 | modules/moduleutil.sig 101 | modules/moduleutil.sml 102 | modules/moduleid.sml 103 | modules/entityenv.sig 104 | modules/entityenv.sml 105 | 106 | statenv/bindings.sig 107 | statenv/bindings.sml 108 | statenv/statenv.sig 109 | statenv/statenv.sml 110 | statenv/lookup.sig 111 | statenv/lookup.sml 112 | statenv/genmap.sml 113 | statenv/coreacc.sml 114 | statenv/browse.sml 115 | 116 | $smlnj/viscomp/basics.cm 117 | $smlnj/viscomp/parser.cm 118 | $smlnj/smlnj-lib/smlnj-lib.cm 119 | $smlnj/smlnj-lib/controls-lib.cm 120 | $smlnj/basis/basis.cm 121 | -------------------------------------------------------------------------------- /ElabData/main/compinfo.sml: -------------------------------------------------------------------------------- 1 | (* compinfo.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure CompInfo = struct 6 | 7 | type 'absyn compInfo = { mkStamp: unit -> Stamps.stamp, 8 | mkLvar: Symbol.symbol option -> Access.lvar, 9 | anyErrors: bool ref, 10 | error: ErrorMsg.errorFn, 11 | errorMatch: SourceMap.region -> string, 12 | transform: 'absyn -> 'absyn, 13 | sourceName : string } 14 | 15 | fun mkCompInfo { source, transform : 'a -> 'a, mkMkStamp } = 16 | let val { error, errorMatch, anyErrors } = ErrorMsg.errors source 17 | val _ = LambdaVar.clear () 18 | val g = mkMkStamp () 19 | fun mkLvar NONE = LambdaVar.mkLvar () 20 | | mkLvar (SOME sym) = LambdaVar.namedLvar sym 21 | in { mkStamp = fn () => Stamps.fresh g, 22 | mkLvar = mkLvar, 23 | anyErrors = anyErrors, 24 | error = error, 25 | errorMatch = errorMatch, 26 | transform = transform, 27 | sourceName = #fileOpened source } : 'a compInfo 28 | end 29 | 30 | fun anyErrors (ci : 'a compInfo) = ! (#anyErrors ci) 31 | 32 | end (* structure CompBasic *) 33 | -------------------------------------------------------------------------------- /ElabData/main/edcontrol.sig: -------------------------------------------------------------------------------- 1 | (* edcontrol.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | 6 | signature ELABDATA_CONTROL = 7 | sig 8 | 9 | val saveLvarNames : bool ref 10 | val eedebugging : bool ref 11 | val mudebugging : bool ref 12 | 13 | val tudebugging : bool ref 14 | (* TypesUtil *) 15 | end 16 | -------------------------------------------------------------------------------- /ElabData/main/edcontrol.sml: -------------------------------------------------------------------------------- 1 | (* edcontrol.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure ElabDataControl : ELABDATA_CONTROL = struct 6 | 7 | val priority = [10, 10, 7] 8 | val obscurity = 6 9 | val prefix = "ed" 10 | 11 | val registry = ControlRegistry.new { help = "elaborator datastructures" } 12 | 13 | val _ = BasicControl.nest (prefix, registry, priority) 14 | 15 | val bool_cvt = ControlUtil.Cvt.bool 16 | 17 | val nextpri = ref 0 18 | 19 | fun new (n, h, d) = let 20 | val r = ref d 21 | val p = !nextpri 22 | val ctl = Controls.control { name = n, 23 | pri = [p], 24 | obscurity = obscurity, 25 | help = h, 26 | ctl = r } 27 | in 28 | nextpri := p + 1; 29 | ControlRegistry.register 30 | registry 31 | { ctl = Controls.stringControl bool_cvt ctl, 32 | envName = SOME (ControlUtil.EnvName.toUpper "ED_" n) }; 33 | r 34 | end 35 | 36 | 37 | val saveLvarNames = new ("save-lvar-names", "?", false) 38 | val eedebugging = new ("ee-debugging", "?", false) 39 | val mudebugging = new ("mu-debugging", "?", false) 40 | 41 | val tudebugging = new ("tu-debugging", "?", false) 42 | (* TypesUtil *) 43 | 44 | end 45 | -------------------------------------------------------------------------------- /ElabData/modules/entityenv.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* entityenv.sig *) 3 | 4 | signature ENTITY_ENV = 5 | sig 6 | 7 | type entVar = EntPath.entVar 8 | type entPath = EntPath.entPath 9 | type entityEnv = Modules.entityEnv 10 | 11 | exception Unbound 12 | 13 | val empty : entityEnv 14 | val mark : ((unit->Stamps.stamp) * entityEnv) -> entityEnv 15 | val bind : entVar * Modules.entity * entityEnv -> entityEnv 16 | val atop : entityEnv * entityEnv -> entityEnv 17 | val atopSp : entityEnv * entityEnv -> entityEnv 18 | 19 | val toList : entityEnv -> (entVar * Modules.entity) list 20 | 21 | val look : entityEnv * entVar -> Modules.entity 22 | val lookStrEnt : entityEnv * entVar -> Modules.strEntity 23 | val lookTycEnt : entityEnv * entVar -> Modules.tycEntity 24 | val lookFctEnt : entityEnv * entVar -> Modules.fctEntity 25 | 26 | val lookEP : entityEnv * entPath -> Modules.entity 27 | val lookTycEP : entityEnv * entPath -> Modules.tycEntity 28 | val lookStrEP : entityEnv * entPath -> Modules.strEntity 29 | val lookFctEP : entityEnv * entPath -> Modules.fctEntity 30 | 31 | val debugging : bool ref 32 | 33 | end (* signature ENTITY_ENV *) 34 | 35 | -------------------------------------------------------------------------------- /ElabData/modules/entityenv.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* entityenv.sml *) 3 | 4 | structure EntityEnv : ENTITY_ENV = 5 | struct 6 | 7 | local 8 | structure EP = EntPath 9 | structure ED = EntPath.EvDict 10 | structure ST = Stamps 11 | structure M = Modules 12 | structure T = Types 13 | in 14 | 15 | val say = Control_Print.say 16 | val debugging = ElabDataControl.eedebugging (* ref false *) 17 | fun debugmsg (msg: string) = 18 | if !debugging then (say msg; say "\n") else () 19 | fun bug msg = ErrorMsg.impossible("EntityEnv: "^msg) 20 | 21 | type entVar = EP.entVar 22 | type entPath = EP.entPath 23 | type entityEnv = M.entityEnv 24 | 25 | exception Unbound 26 | 27 | val empty = M.NILeenv 28 | 29 | fun mark(_,e as M.MARKeenv _) = e 30 | | mark(_,e as M.NILeenv) = e 31 | | mark(_,e as M.ERReenv) = e 32 | | mark(mkStamp,env) = 33 | M.MARKeenv { stamp = mkStamp(), env = env, stub = NONE } 34 | 35 | fun bind(v, e, M.BINDeenv(d, env)) = M.BINDeenv(ED.insert(d, v, e), env) 36 | | bind(v, e, env) = M.BINDeenv(ED.insert(ED.empty, v, e), env) 37 | 38 | fun atop(_, M.ERReenv) = M.ERReenv 39 | | atop(M.ERReenv, _) = M.ERReenv 40 | | atop(e1, M.NILeenv) = e1 41 | | atop(M.MARKeenv { env, ...}, e2) = atop (env, e2) 42 | | atop(M.BINDeenv(d,e1),e2) = M.BINDeenv(d,atop(e1,e2)) 43 | | atop(M.NILeenv, e2) = e2 44 | 45 | fun atopSp(_, M.ERReenv) = M.ERReenv 46 | | atopSp(M.ERReenv, _) = M.ERReenv 47 | | atopSp(e1, M.NILeenv) = e1 48 | | atopSp(M.MARKeenv { env, ... }, e2) = atopSp (env, e2) 49 | | atopSp(M.BINDeenv(d,e1),e2) = atopMerge(d,atop(e1,e2)) 50 | | atopSp(M.NILeenv, e2) = e2 51 | 52 | and atopMerge(d, M.NILeenv) = M.BINDeenv(d, M.NILeenv) 53 | | atopMerge(d, M.BINDeenv(d', e)) = M.BINDeenv (ED.unionWith #1 (d,d'),e) 54 | | atopMerge(d, M.MARKeenv { env, ... }) = atopMerge (d, env) 55 | | atopMerge (d, M.ERReenv) = M.ERReenv 56 | 57 | fun toList (M.MARKeenv { env, ... }) = toList env 58 | | toList (M.BINDeenv(d, ee)) = (*ED.fold((op ::), toList ee, d)*) 59 | ED.foldri (fn (key, value, base) => (key,value)::base) (toList ee) d 60 | | toList M.NILeenv = nil 61 | | toList M.ERReenv = nil 62 | 63 | fun look(env,v) = 64 | let fun scan(M.MARKeenv { env, ... }) = scan env 65 | | scan(M.BINDeenv(d, rest)) = 66 | (case ED.find(d, v) 67 | of SOME e => e 68 | | NONE => scan rest) 69 | (* 70 | if EP.eqEntVar(v,v') 71 | then (debugmsg("$EE.look: found " ^ EP.entVarToString v); e) 72 | else (debugmsg("$EE.look: looking for " ^ EP.entVarToString v ^ 73 | " saw " ^ EP.entVarToString v'); 74 | scan rest) 75 | *) 76 | | scan M.ERReenv = M.ERRORent 77 | | scan M.NILeenv = 78 | (debugmsg ("$EE.look: didn't find "^EP.entVarToString v); 79 | raise Unbound) 80 | in scan env 81 | end 82 | 83 | fun lookStrEnt(entEnv,entVar) = 84 | case look(entEnv,entVar) 85 | of M.STRent ent => ent 86 | | M.ERRORent => M.bogusStrEntity 87 | | _ => bug "lookStrEnt" 88 | 89 | fun lookTycEnt(entEnv,entVar) = 90 | case look(entEnv,entVar) 91 | of M.TYCent ent => ent 92 | | M.ERRORent => Types.ERRORtyc 93 | | _ => bug "lookTycEnt" 94 | 95 | fun lookFctEnt(entEnv,entVar) = 96 | case look(entEnv,entVar) 97 | of M.FCTent ent => ent 98 | | M.ERRORent => M.bogusFctEntity 99 | | _ => bug "lookFctEnt" 100 | 101 | fun lookEP(entEnv,[]) = bug "lookEP.1" 102 | | lookEP(entEnv,[v]) = look(entEnv,v) 103 | | lookEP(entEnv,ep as (v::rest)) = 104 | (case look(entEnv,v) 105 | of M.STRent { entities, ... } => lookEP (entities,rest) 106 | | M.ERRORent => M.ERRORent 107 | | ent => 108 | (say "lookEnt.1: expected STRent\n"; 109 | say "found entity: "; 110 | case ent 111 | of M.TYCent _ => say "TYCent\n" 112 | | M.FCTent _ => say "FCTent\n" 113 | | _ => say "ERRORent\n"; 114 | say "entpath: "; say (EP.entPathToString(ep)); say "\n"; 115 | bug "lookEnt.2")) 116 | 117 | fun lookTycEP(entEnv,entPath) = 118 | case lookEP(entEnv,entPath) 119 | of M.TYCent tycon => tycon 120 | | M.ERRORent => T.ERRORtyc 121 | | _ => bug "lookTycEP: wrong entity" 122 | 123 | fun lookStrEP(entEnv,entPath) = 124 | case lookEP(entEnv,entPath) 125 | of M.STRent rlzn => rlzn 126 | | M.ERRORent => M.bogusStrEntity 127 | | _ => bug "lookStrEP: wrong entity" 128 | 129 | fun lookFctEP(entEnv,entPath) = 130 | case lookEP(entEnv,entPath) 131 | of M.FCTent rlzn => rlzn 132 | | M.ERRORent => M.bogusFctEntity 133 | | _ => bug "lookFctEP: wrong entity" 134 | 135 | end (* local *) 136 | end (* structure EntityEnv *) 137 | 138 | -------------------------------------------------------------------------------- /ElabData/modules/entpath.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* entpath.sml *) 3 | 4 | signature ENT_PATH = sig 5 | 6 | type entVar = Stamps.stamp 7 | type entPath = entVar list 8 | type rEntPath 9 | 10 | val epnil : entPath 11 | val repnil : rEntPath 12 | val repcons : entVar * rEntPath -> rEntPath 13 | 14 | val ep2rep : entPath * rEntPath -> rEntPath 15 | val rep2ep : rEntPath -> entPath 16 | 17 | val eqEntVar : entVar * entVar -> bool 18 | val eqEntPath : entPath * entPath -> bool 19 | 20 | val cmpEntVar : entVar * entVar -> order 21 | val cmpEntPath : entPath * entPath -> order 22 | 23 | val nullEntPath : entPath -> bool 24 | val entVarToString : entVar -> string 25 | val entPathToString : entPath -> string 26 | 27 | val bogusEntVar : entVar 28 | 29 | structure EvDict : ORD_MAP where type Key.ord_key = entVar 30 | 31 | end (* signature ENT_PATH *) 32 | 33 | 34 | structure EntPath :> ENT_PATH = 35 | struct 36 | 37 | local 38 | structure ST = Stamps 39 | in 40 | 41 | type entVar = ST.stamp 42 | 43 | type entPath = entVar list 44 | (* entPath has entVars in direct order, outer first *) 45 | 46 | type rEntPath = entVar list (* reversed order; abstract *) 47 | 48 | val epnil = [] 49 | val repnil = [] 50 | val repcons = op :: 51 | 52 | val ep2rep = List.revAppend 53 | val rep2ep = rev 54 | 55 | val eqEntVar = ST.eq 56 | 57 | (* eqEntPath: elementwise equality of entPaths *) 58 | val eqEntPath = ListPair.allEq eqEntVar 59 | 60 | val cmpEntVar = ST.compare 61 | 62 | (* cmpEntPath: entPath * entPath -> order 63 | * lexicographic comparison of two entPaths *) 64 | fun cmpEntPath (ep1, ep2) = 65 | let fun f(a::ar, b::br) = 66 | (case ST.compare(a,b) of EQUAL => f(ar,br) | z => z) 67 | | f(a::ar, nil) = GREATER 68 | | f(nil, b::br) = LESS 69 | | f(nil,nil) = EQUAL 70 | in f(ep1,ep2) 71 | end 72 | 73 | structure EvDict = 74 | RedBlackMapFn(struct type ord_key = entVar 75 | val compare = cmpEntVar 76 | end) 77 | 78 | (* ListPair.all didn't cut it because it doesn't require lists of equal length 79 | length ep1 = length ep2 andalso 80 | ListPair.all eqEntVar (ep1, ep2) 81 | *) 82 | 83 | fun nullEntPath(ep: entPath) = List.null ep 84 | 85 | fun entVarToString (v: entVar) = ST.toShortString v 86 | 87 | fun entPathToString ([]: entPath) = "[]" 88 | | entPathToString (x::xs) = 89 | let val rest = foldr (fn (y,l) => ","::(ST.toShortString y)::l) ["]"] xs 90 | in String.concat("[" :: (ST.toShortString x) :: rest) 91 | end 92 | 93 | val bogusEntVar = ST.special "bogusEntVar" 94 | 95 | end (* local *) 96 | end (* structure EntPath *) 97 | -------------------------------------------------------------------------------- /ElabData/modules/epcontext.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* epcontext.sml *) 3 | 4 | signature ENT_PATH_CONTEXT = 5 | sig 6 | 7 | type context 8 | 9 | val initContext : context 10 | val isEmpty : context -> bool 11 | val enterOpen : context * EntPath.entVar option -> context 12 | val enterClosed : context -> context 13 | val lookTycPath : context * ModuleId.tycId -> EntPath.entPath option 14 | val lookStrPath : context * ModuleId.strId -> EntPath.entPath option 15 | val lookFctPath : context * ModuleId.fctId -> EntPath.entPath option 16 | val bindTycPath : context * ModuleId.tycId * EntPath.entVar -> unit 17 | val bindStrPath : context * ModuleId.strId * EntPath.entVar -> unit 18 | val bindFctPath : context * ModuleId.fctId * EntPath.entVar -> unit 19 | val bindTycLongPath : context * ModuleId.tycId * EntPath.entPath -> unit 20 | val bindStrLongPath : context * ModuleId.strId * EntPath.entPath -> unit 21 | val bindFctLongPath : context * ModuleId.fctId * EntPath.entPath -> unit 22 | 23 | end (* signature ENT_PATH_CONTEXT *) 24 | 25 | 26 | structure EntPathContext :> ENT_PATH_CONTEXT = 27 | struct 28 | 29 | local structure ST = Stamps 30 | structure EP = EntPath 31 | structure MI = ModuleId 32 | in 33 | 34 | type pathmap = EP.rEntPath MI.umap 35 | 36 | (* 37 | * A structure body (struct decls end) is "closed" if 38 | * it is a functor body structure 39 | * The idea is that the elements of a closed structure are not 40 | * directly referenced from outside the structure, so the pathEnv 41 | * local to the closed structure can be discarded after the structure 42 | * body is elaborated. 43 | *) 44 | 45 | (* pathmap maps stamps to full entPaths relative to current functor context *) 46 | (* each "closed" structure body pushes a new layer *) 47 | datatype context 48 | = EMPTY 49 | | LAYER of {locals: pathmap ref, 50 | lookContext: EP.entPath, 51 | bindContext: EP.rEntPath, 52 | outer: context} 53 | 54 | val initContext : context = EMPTY 55 | 56 | fun isEmpty(EMPTY : context) = true 57 | | isEmpty _ = false 58 | 59 | (* 60 | * called on entering a closed structure scope, whose elements will not 61 | * be accessed from outside (hence the null bindContext) 62 | *) 63 | fun enterClosed epc = 64 | LAYER {locals=ref(MI.emptyUmap), lookContext=EP.epnil, 65 | bindContext=EP.repnil, outer=epc} 66 | 67 | (* 68 | * called on entering an open structure scope (claim: this is always an 69 | * unconstrained structure decl body), where ev is the entVar of the 70 | * structure being elaborated. 71 | *) 72 | fun enterOpen (EMPTY, _) = EMPTY 73 | | enterOpen (epc, NONE) = epc 74 | | enterOpen (LAYER{locals,lookContext,bindContext,outer}, SOME ev) = 75 | LAYER{locals=locals, lookContext=lookContext@[ev], 76 | bindContext=EP.repcons (ev, bindContext), outer=outer} 77 | 78 | (* relative(path,ctx) - subtract common prefix of path and ctx from path *) 79 | fun relative([],_) = [] 80 | | relative(ep,[]) = ep 81 | | relative(p as (x::rest),y::rest') = 82 | if EP.eqEntVar(x,y) then relative(rest,rest') else p 83 | 84 | fun lookPath find (EMPTY, _) = NONE 85 | | lookPath find (LAYER { locals, lookContext, bindContext, outer }, id) = 86 | (case find (!locals, id) of 87 | NONE => lookPath find (outer, id) 88 | | SOME rp => SOME (relative (EP.rep2ep rp, lookContext))) 89 | 90 | val lookTycPath = lookPath MI.uLookTyc 91 | val lookStrPath = lookPath MI.uLookStr 92 | val lookFctPath = lookPath MI.uLookFct 93 | 94 | (* probe(ctx,s) checks whether a stamp has already be bound before *) 95 | fun probe find (EMPTY, s) = false 96 | | probe find (LAYER{locals, outer, ...}, s) = 97 | (case find(!locals, s) of 98 | NONE => probe find (outer, s) 99 | | _ => true) 100 | 101 | fun bindPath (find, insert) (EMPTY, _, _) = () 102 | | bindPath (find, insert) (xx as LAYER { locals, bindContext, ... }, s, ev) = 103 | if probe find (xx, s) then () 104 | else (locals := insert (!locals, s, EP.repcons (ev, bindContext))) 105 | 106 | val bindTycPath = bindPath (MI.uLookTyc, MI.uInsertTyc) 107 | val bindStrPath = bindPath (MI.uLookStr, MI.uInsertStr) 108 | val bindFctPath = bindPath (MI.uLookFct, MI.uInsertFct) 109 | 110 | fun bindLongPath (find, insert) (EMPTY, _, _) = () 111 | | bindLongPath (find, insert) 112 | (xx as LAYER { locals, bindContext, ... }, s, ep) = 113 | if probe find (xx, s) then () 114 | else (locals := insert (!locals, s, EP.ep2rep (ep, bindContext))) 115 | 116 | val bindTycLongPath = bindLongPath (MI.uLookTyc, MI.uInsertTyc) 117 | val bindStrLongPath = bindLongPath (MI.uLookStr, MI.uInsertStr) 118 | val bindFctLongPath = bindLongPath (MI.uLookFct, MI.uInsertFct) 119 | 120 | end (* local *) 121 | end (* structure EntPathContext *) 122 | -------------------------------------------------------------------------------- /ElabData/modules/moduleid.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* Re-written by M.Blume (3/2000) *) 3 | (* moduleid.sml *) 4 | 5 | signature MODULE_ID = sig 6 | 7 | type tycId 8 | type sigId 9 | type strId 10 | type fctId 11 | type envId 12 | 13 | val tycId : Types.gtrec -> tycId 14 | val sigId : Modules.sigrec -> sigId 15 | val strId : Modules.strrec -> strId 16 | val fctId : Modules.fctrec -> fctId 17 | val envId : Modules.envrec -> envId 18 | 19 | val strId2 : Modules.sigrec * Modules.strEntity -> strId 20 | val fctId2 : Modules.fctSig * Modules.fctEntity -> fctId 21 | 22 | val sameTyc : tycId * tycId -> bool 23 | val sameSig : sigId * sigId -> bool 24 | val sameStr : strId * strId -> bool 25 | val sameFct : fctId * fctId -> bool 26 | val sameEnv : envId * envId -> bool 27 | 28 | val freshTyc : tycId -> bool 29 | val freshSig : sigId -> bool 30 | val freshStr : strId -> bool 31 | val freshFct : fctId -> bool 32 | val freshEnv : envId -> bool 33 | 34 | type tmap 35 | 36 | val emptyTmap : tmap 37 | 38 | val lookTyc : tmap * tycId -> Types.gtrec option 39 | val lookSig : tmap * sigId -> Modules.sigrec option 40 | val lookStr : tmap * strId -> Modules.strEntity option 41 | val lookFct : tmap * fctId -> Modules.fctEntity option 42 | val lookEnv : tmap * envId -> Modules.envrec option 43 | 44 | val insertTyc : tmap * tycId * Types.gtrec -> tmap 45 | val insertSig : tmap * sigId * Modules.sigrec -> tmap 46 | val insertStr : tmap * strId * Modules.strEntity -> tmap 47 | val insertFct : tmap * fctId * Modules.fctEntity -> tmap 48 | val insertEnv : tmap * envId * Modules.envrec -> tmap 49 | 50 | val tycId' : Types.tycon -> tycId 51 | 52 | type 'a umap 53 | 54 | val emptyUmap : 'a umap 55 | 56 | val uLookTyc : 'a umap * tycId -> 'a option 57 | val uLookSig : 'a umap * sigId -> 'a option 58 | val uLookStr : 'a umap * strId -> 'a option 59 | val uLookFct : 'a umap * fctId -> 'a option 60 | val uLookEnv : 'a umap * envId -> 'a option 61 | 62 | val uInsertTyc : 'a umap * tycId * 'a -> 'a umap 63 | val uInsertSig : 'a umap * sigId * 'a -> 'a umap 64 | val uInsertStr : 'a umap * strId * 'a -> 'a umap 65 | val uInsertFct : 'a umap * fctId * 'a -> 'a umap 66 | val uInsertEnv : 'a umap * envId * 'a -> 'a umap 67 | 68 | end (* signature MODULE_ID *) 69 | 70 | structure ModuleId : MODULE_ID = struct 71 | 72 | structure M = Modules 73 | structure T = Types 74 | structure A = Access 75 | structure ST = Stamps 76 | 77 | fun bug m = ErrorMsg.impossible ("ModuleId: " ^ m) 78 | 79 | type stamp = ST.stamp 80 | 81 | type tycId = stamp 82 | type sigId = stamp 83 | type strId = { sign: stamp, rlzn: stamp } 84 | type fctId = { paramsig: stamp, bodysig: stamp, rlzn: stamp } 85 | type envId = stamp 86 | 87 | val freshTyc = ST.isFresh 88 | val freshSig = ST.isFresh 89 | fun freshStr { sign, rlzn } = ST.isFresh sign orelse ST.isFresh rlzn 90 | fun freshFct { paramsig, bodysig, rlzn } = 91 | ST.isFresh paramsig orelse ST.isFresh bodysig orelse ST.isFresh rlzn 92 | val freshEnv = ST.isFresh 93 | 94 | fun tycId (r: Types.gtrec) = #stamp r 95 | fun sigId (s: Modules.sigrec) = #stamp s 96 | fun strId2 (sign: M.sigrec, rlzn: M.strEntity) = 97 | { sign = #stamp sign, rlzn = #stamp rlzn } 98 | fun strId ({ sign = Modules.SIG s, rlzn, ... }: Modules.strrec) = 99 | { sign = #stamp s, rlzn = #stamp rlzn } 100 | | strId _ = bug "strId: bad signature" 101 | fun fctId2 (M.FSIG { paramsig = M.SIG psg, bodysig = M.SIG bsg, ... }, 102 | rlzn: M.fctEntity) = 103 | { paramsig = #stamp psg, bodysig = #stamp bsg, rlzn = #stamp rlzn } 104 | | fctId2 _ = bug "fctId2/fctId2: bad funsig" 105 | fun fctId ({ sign, rlzn, ... }: Modules.fctrec) = fctId2 (sign, rlzn) 106 | fun envId (e: Modules.envrec) = #stamp e 107 | 108 | structure StrKey = struct 109 | type ord_key = strId 110 | fun compare (i1: strId, i2: strId) = 111 | case ST.compare (#sign i1, #sign i2) of 112 | EQUAL => ST.compare (#rlzn i1, #rlzn i2) 113 | | unequal => unequal 114 | end 115 | structure FctKey = struct 116 | type ord_key = fctId 117 | fun compare (i1: fctId, i2: fctId) = 118 | case ST.compare (#paramsig i1, #paramsig i2) of 119 | EQUAL => (case ST.compare (#bodysig i1, #bodysig i2) of 120 | EQUAL => ST.compare (#rlzn i1, #rlzn i2) 121 | | unequal => unequal) 122 | | unequal => unequal 123 | end 124 | 125 | structure StampM = RedBlackMapFn (ST) 126 | structure StrM = RedBlackMapFn (StrKey) 127 | structure FctM = RedBlackMapFn (FctKey) 128 | 129 | val sameTyc = ST.eq 130 | val sameSig = ST.eq 131 | fun sameStr (x, y) = StrKey.compare (x, y) = EQUAL 132 | fun sameFct (x, y) = FctKey.compare (x, y) = EQUAL 133 | val sameEnv = ST.eq 134 | 135 | type tmap = { m_tyc: T.gtrec StampM.map, 136 | m_sig: M.sigrec StampM.map, 137 | m_str: M.strEntity StrM.map, 138 | m_fct: M.fctEntity FctM.map, 139 | m_env: M.envrec StampM.map } 140 | 141 | val emptyTmap = { m_tyc = StampM.empty, 142 | m_sig = StampM.empty, 143 | m_str = StrM.empty, 144 | m_fct = FctM.empty, 145 | m_env = StampM.empty } 146 | 147 | local 148 | fun look (sel, find) (m as { m_tyc, m_sig, m_str, m_fct, m_env }, k) = 149 | find (sel m, k) 150 | in 151 | fun lookTyc x = look (#m_tyc, StampM.find) x 152 | fun lookSig x = look (#m_sig, StampM.find) x 153 | fun lookStr x = look (#m_str, StrM.find) x 154 | fun lookFct x = look (#m_fct, FctM.find) x 155 | fun lookEnv x = look (#m_env, StampM.find) x 156 | end 157 | 158 | fun insertTyc ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) = 159 | { m_tyc = StampM.insert (m_tyc, k, t), 160 | m_sig = m_sig, m_str = m_str, m_fct = m_fct, m_env = m_env } 161 | 162 | fun insertSig ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) = 163 | { m_sig = StampM.insert (m_sig, k, t), 164 | m_tyc = m_tyc, m_str = m_str, m_fct = m_fct, m_env = m_env } 165 | 166 | fun insertStr ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) = 167 | { m_str = StrM.insert (m_str, k, t), 168 | m_tyc = m_tyc, m_sig = m_sig, m_fct = m_fct, m_env = m_env } 169 | 170 | fun insertFct ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) = 171 | { m_fct = FctM.insert (m_fct, k, t), 172 | m_tyc = m_tyc, m_sig = m_sig, m_str = m_str, m_env = m_env } 173 | 174 | fun insertEnv ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) = 175 | { m_env = StampM.insert (m_env, k, t), 176 | m_tyc = m_tyc, m_sig = m_sig, m_str = m_str, m_fct = m_fct } 177 | 178 | fun tycId' (T.GENtyc r) = tycId r 179 | | tycId' (T.DEFtyc { stamp, ... }) = stamp 180 | | tycId' _ = bug "tycId': neither GENtyc nor DEFtyc" 181 | 182 | (* and now for uniformely typed maps (implementations are shared)... *) 183 | 184 | type 'a umap = { m_tyc: 'a StampM.map, 185 | m_sig: 'a StampM.map, 186 | m_str: 'a StrM.map, 187 | m_fct: 'a FctM.map, 188 | m_env: 'a StampM.map } 189 | 190 | val emptyUmap = emptyTmap 191 | 192 | val uLookTyc = lookTyc 193 | val uLookSig = lookSig 194 | val uLookStr = lookStr 195 | val uLookFct = lookFct 196 | val uLookEnv = lookEnv 197 | 198 | val uInsertTyc = insertTyc 199 | val uInsertSig = insertSig 200 | val uInsertStr = insertStr 201 | val uInsertFct = insertFct 202 | val uInsertEnv = insertEnv 203 | 204 | end (* structure ModuleId *) 205 | -------------------------------------------------------------------------------- /ElabData/modules/modules.sig: -------------------------------------------------------------------------------- 1 | (* modules.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature MODULES = 6 | sig 7 | 8 | type sharespec = SymPath.path list 9 | 10 | datatype Signature 11 | = SIG of sigrec 12 | | ERRORsig 13 | 14 | and spec 15 | = TYCspec of {entVar : EntPath.entVar, info: tycSpecInfo} 16 | | STRspec of {entVar : EntPath.entVar, sign : Signature, 17 | def : (strDef * int) option, slot : int} 18 | | FCTspec of {entVar : EntPath.entVar, sign : fctSig, slot : int} 19 | | VALspec of {spec : Types.ty, slot : int} 20 | | CONspec of {spec : Types.datacon, slot : int option} 21 | 22 | and tycSpecInfo 23 | = RegTycSpec of {spec : Types.tycon, repl: bool, scope: int} (* normal signature *) 24 | | InfTycSpec of {name: Symbol.symbol, arity: int} (* inferred signature *) 25 | 26 | (* 27 | * and specEnv 28 | * = NILsenv 29 | * | BINDsenv of spec Env.env * specEnv 30 | * | INCLsenv of int * spec Env.env * specEnv 31 | *) 32 | 33 | and fctSig 34 | = FSIG of {kind : Symbol.symbol option, 35 | paramsig : Signature, 36 | paramvar : EntPath.entVar, 37 | paramsym : Symbol.symbol option, 38 | bodysig : Signature} 39 | | ERRORfsig 40 | 41 | and extDef 42 | = TYCdef of 43 | {path : SymPath.path, (* the (inward) path to the spec being defined *) 44 | tyc : Types.tycon, (* the definition, typically relativized *) 45 | relative : bool} (* does tyc contain entity paths *) 46 | | STRdef of SymPath.path * strDef 47 | 48 | and strDef 49 | = CONSTstrDef of Structure (* constant *) 50 | | VARstrDef of Signature * EntPath.entPath (* relative *) 51 | 52 | 53 | (* ------------------------- structures and functors ---------------------- *) 54 | 55 | and Structure 56 | = STR of strrec 57 | | STRSIG of {sign: Signature, entPath : EntPath.entPath} 58 | | ERRORstr 59 | 60 | and Functor 61 | = FCT of fctrec 62 | | ERRORfct 63 | 64 | (* ----------------------- entity-related definitions -------------------- *) 65 | 66 | and entity (* elements of a entityEnv *) 67 | = TYCent of tycEntity 68 | | STRent of strEntity 69 | | FCTent of fctEntity 70 | | ERRORent 71 | (* no entities for val, con, exn, but this may change *) 72 | 73 | and fctClosure (* realization for functors *) 74 | = CLOSURE of {param : EntPath.entVar, body : strExp, env : entityEnv} 75 | 76 | and stampExp 77 | = (* CONST of Stamps.stamp (* an existing stamp *) 78 | | *) GETSTAMP of strExp 79 | | NEW (* generate a new stamp *) 80 | 81 | and tycExp (* expression evaluating to a TYCentity *) 82 | = VARtyc of EntPath.entPath (* selection from current entityEnv *) 83 | | CONSTtyc of Types.tycon (* actual tycon *) 84 | | FORMtyc of Types.tycon (* formal tycon *) 85 | 86 | and strExp 87 | = VARstr of EntPath.entPath 88 | | CONSTstr of strEntity 89 | | STRUCTURE of {stamp : stampExp, entDec : entityDec} 90 | | APPLY of fctExp * strExp 91 | | LETstr of entityDec * strExp 92 | | ABSstr of Signature * strExp 93 | | FORMstr of fctSig 94 | | CONSTRAINstr of {boundvar : EntPath.entVar, raw : strExp, coercion: strExp} 95 | (* similar to LETstr(M.STRdec(boundvar, raw), coercion), 96 | * but with special treatment of rpath propagation to support 97 | * accurate type names in functor results where the functor has 98 | * a result signature constraint. *) 99 | 100 | and fctExp 101 | = VARfct of EntPath.entPath 102 | | CONSTfct of fctEntity 103 | | LAMBDA of {param : EntPath.entVar, body : strExp} 104 | | LAMBDA_TP of {param : EntPath.entVar, body : strExp, sign : fctSig} 105 | | LETfct of entityDec * fctExp 106 | 107 | and entityExp 108 | = TYCexp of tycExp 109 | | STRexp of strExp 110 | | FCTexp of fctExp 111 | | DUMMYexp 112 | | ERRORexp 113 | 114 | and entityDec 115 | = TYCdec of EntPath.entVar * tycExp 116 | | STRdec of EntPath.entVar * strExp * Symbol.symbol 117 | | FCTdec of EntPath.entVar * fctExp 118 | | SEQdec of entityDec list 119 | | LOCALdec of entityDec * entityDec 120 | | ERRORdec 121 | | EMPTYdec 122 | 123 | and entityEnv 124 | = MARKeenv of envrec 125 | | BINDeenv of entity EntPath.EvDict.map * entityEnv 126 | | NILeenv 127 | | ERReenv 128 | 129 | and modtree = 130 | TYCNODE of Types.gtrec 131 | | SIGNODE of sigrec 132 | | STRNODE of strrec 133 | | FCTNODE of fctrec 134 | | ENVNODE of envrec 135 | | BRANCH of modtree list 136 | 137 | withtype stubinfo = 138 | {owner : PersStamps.persstamp, 139 | lib : bool, 140 | tree : modtree} 141 | 142 | and elements = (Symbol.symbol * spec) list 143 | 144 | and sigrec = 145 | {stamp : Stamps.stamp, 146 | name : Symbol.symbol option, 147 | closed : bool, 148 | fctflag : bool, 149 | elements : elements, 150 | properties : PropList.holder, (* boundeps, lambdaty *) 151 | typsharing : sharespec list, 152 | strsharing : sharespec list, 153 | stub : stubinfo option} 154 | 155 | and envrec = 156 | {stamp : Stamps.stamp, 157 | env : entityEnv, 158 | stub : stubinfo option} 159 | 160 | and strEntity = 161 | {stamp : Stamps.stamp, 162 | entities : entityEnv, 163 | properties: PropList.holder, (* lambdaty *) 164 | rpath : InvPath.path, 165 | stub : stubinfo option} 166 | 167 | and strrec = 168 | {sign : Signature, 169 | rlzn : strEntity, 170 | access : Access.access, 171 | prim : PrimOpId.strPrimInfo} 172 | 173 | and fctEntity = 174 | {stamp : Stamps.stamp, 175 | closure : fctClosure, 176 | properties: PropList.holder, (* lambdaty *) 177 | tycpath : Types.tycpath option, 178 | rpath : InvPath.path, 179 | stub : stubinfo option} 180 | 181 | and fctrec = 182 | {sign : fctSig, 183 | rlzn : fctEntity, 184 | access : Access.access, 185 | prim : PrimOpId.strPrimInfo} 186 | 187 | (* the stamp and arith inside Types.tycon are critical *) 188 | and tycEntity = Types.tycon 189 | 190 | (* 191 | and constraint 192 | = {my_path : SymPath.path, its_ancestor : instrep, its_path : SymPath.path} 193 | *) 194 | 195 | val bogusStrEntity : strEntity 196 | val bogusFctEntity : fctEntity 197 | 198 | end (* signature MODULES *) 199 | -------------------------------------------------------------------------------- /ElabData/modules/moduleutil.sig: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1996 Bell Laboratories. *) 2 | (* moduleutil.sig *) 3 | 4 | signature MODULEUTIL = 5 | sig 6 | 7 | exception Unbound of Symbol.symbol 8 | 9 | val getSpec : Modules.elements * Symbol.symbol -> Modules.spec 10 | val getSpecVar : Modules.spec -> EntPath.entVar option 11 | 12 | val strDefToStr : Modules.strDef * Modules.entityEnv -> Modules.Structure 13 | 14 | (*** getTyc, getStr and getFct are used in modules/sigmatch.sml only ***) 15 | val getTyc : Modules.elements * Modules.entityEnv * Symbol.symbol 16 | -> Types.tycon * EntPath.entVar 17 | 18 | val getStr : Modules.elements * Modules.entityEnv 19 | * Symbol.symbol * Access.access * PrimOpId.strPrimInfo 20 | -> Modules.Structure * EntPath.entVar 21 | 22 | val getFct : Modules.elements * Modules.entityEnv 23 | * Symbol.symbol * Access.access * PrimOpId.strPrimInfo 24 | -> Modules.Functor * EntPath.entVar 25 | 26 | (*** these functions are used in eqtypes.sml ***) 27 | val getStrStamp : Modules.Structure -> Stamps.stamp 28 | val getStrName : Modules.Structure -> InvPath.path 29 | val getStrs : Modules.Structure -> Modules.Structure list 30 | val getTycs : Modules.Structure -> Types.tycon list 31 | val getStrSymbols : Modules.Structure -> Symbol.symbol list 32 | 33 | (*** these functions should be called in env/lookup.sml only ***) 34 | val getStrPath : Modules.Structure * SymPath.path * SymPath.path 35 | -> Modules.Structure 36 | 37 | val getStrDef : Modules.Structure * SymPath.path * SymPath.path 38 | -> Modules.strDef 39 | 40 | val getFctPath : Modules.Structure * SymPath.path * SymPath.path 41 | -> Modules.Functor 42 | val getTycPath : Modules.Structure * SymPath.path * SymPath.path 43 | -> Types.tycon 44 | val getValPath : Modules.Structure * SymPath.path * SymPath.path 45 | -> VarCon.value 46 | 47 | val checkPathSig : Modules.Signature * SymPath.path 48 | -> Symbol.symbol option 49 | 50 | val eqSign : Modules.Signature * Modules.Signature -> bool 51 | val eqOrigin : Modules.Structure * Modules.Structure -> bool 52 | 53 | val tycId : Types.tycon -> ModuleId.tycId 54 | val strId: Modules.Structure -> ModuleId.strId 55 | val strId2: Modules.Signature * Modules.strEntity -> ModuleId.strId 56 | val fctId: Modules.Functor -> ModuleId.fctId 57 | val fctId2: Modules.fctSig * Modules.fctEntity -> ModuleId.fctId 58 | 59 | (*** translate tycon or type in an entityEnv ***) 60 | val transTycon : Modules.entityEnv -> Types.tycon -> Types.tycon 61 | val transType : Modules.entityEnv -> Types.ty -> Types.ty 62 | 63 | (*** relativize type or tycon in an epcontext ***) 64 | val relativizeTyc : EntPathContext.context -> Types.tycon -> Types.tycon * bool 65 | val relativizeType : EntPathContext.context -> Types.ty -> Types.ty * bool 66 | 67 | val openStructure : StaticEnv.staticEnv * Modules.Structure 68 | -> StaticEnv.staticEnv 69 | 70 | (*** extract inl_info from a list of bindings *) 71 | val strPrimElemInBinds : Bindings.binding list -> PrimOpId.strPrimInfo 72 | 73 | val getElementsSymbols : Modules.elements -> Symbol.symbol list 74 | val getSigSymbols: Modules.Signature -> Symbol.symbol list 75 | 76 | val getSignatureNames : Modules.Structure -> Symbol.symbol list 77 | 78 | val debugging : bool ref 79 | 80 | end (* signature MODULEUTIL *) 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /ElabData/statenv/bindings.sig: -------------------------------------------------------------------------------- 1 | (* bindings.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature BINDINGS = sig 6 | 7 | datatype binding = 8 | VALbind of VarCon.var 9 | | CONbind of VarCon.datacon 10 | | TYCbind of Types.tycon 11 | | SIGbind of Modules.Signature 12 | | STRbind of Modules.Structure 13 | | FSGbind of Modules.fctSig 14 | | FCTbind of Modules.Functor 15 | | FIXbind of Fixity.fixity 16 | 17 | val binderGt : 18 | (Symbol.symbol * binding) * (Symbol.symbol * binding) -> bool 19 | 20 | end (* signature BINDINGS *) 21 | -------------------------------------------------------------------------------- /ElabData/statenv/bindings.sml: -------------------------------------------------------------------------------- 1 | (* bindings.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure Bindings : BINDINGS = 6 | struct 7 | 8 | local structure S = Symbol 9 | structure T = Types 10 | structure V = VarCon 11 | structure M = Modules 12 | in 13 | 14 | fun err s = ErrorMsg.impossible ("Bindings: "^s) 15 | 16 | datatype binding 17 | = VALbind of V.var 18 | | CONbind of V.datacon 19 | | TYCbind of T.tycon 20 | | SIGbind of M.Signature 21 | | STRbind of M.Structure 22 | | FSGbind of M.fctSig 23 | | FCTbind of M.Functor 24 | | FIXbind of Fixity.fixity 25 | 26 | (* used for statenv sorting in env/statenv.sml *) 27 | fun binderGt ((s1, rb1), (s2, rb2)) = let 28 | (* hopefully the following gets optimized into an identity function 29 | * on tags... *) 30 | fun bnum (VALbind _) = 0 31 | | bnum (CONbind _) = 1 32 | | bnum (TYCbind _) = 2 33 | | bnum (SIGbind _) = 3 34 | | bnum (STRbind _) = 4 35 | | bnum (FSGbind _) = 5 36 | | bnum (FCTbind _) = 6 37 | | bnum (FIXbind _) = 7 38 | in 39 | case Int.compare (bnum rb1, bnum rb2) of 40 | EQUAL => S.symbolGt (s1, s2) 41 | | GREATER => true 42 | | LESS => false 43 | end 44 | 45 | end (* local *) 46 | end (* structure Bindings *) 47 | -------------------------------------------------------------------------------- /ElabData/statenv/browse.sml: -------------------------------------------------------------------------------- 1 | (* browse.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure BrowseStatEnv : sig 6 | datatype bind_info = 7 | NoEnv 8 | | Env of { look : Symbol.symbol -> bind_info, 9 | symbols : unit -> Symbol.symbol list } 10 | 11 | val browse : StaticEnv.staticEnv -> Symbol.symbol -> bind_info 12 | 13 | val catalog : StaticEnv.staticEnv -> Symbol.symbol list 14 | 15 | end = struct 16 | 17 | fun bug m = ErrorMsg.impossible ("BrowseStatEnv: " ^ m) 18 | 19 | structure M = Modules 20 | structure MU = ModuleUtil 21 | structure B = Bindings 22 | structure S = Symbol 23 | structure SE = StaticEnv 24 | 25 | datatype bind_info = 26 | NoEnv 27 | | Env of { look : Symbol.symbol -> bind_info, 28 | symbols : unit -> Symbol.symbol list } 29 | 30 | fun lookElems elements sym = 31 | (case MU.getSpec(elements,sym) 32 | of M.STRspec{sign,...} => sigenv sign 33 | | M.FCTspec{sign,...} => fsgenv sign 34 | | _ => NoEnv) 35 | handle MU.Unbound _ => NoEnv 36 | 37 | and sigenv (s as M.SIG {elements,...}) = 38 | Env {look = lookElems elements, 39 | symbols = (fn () => MU.getSigSymbols s)} 40 | | sigenv _ = NoEnv 41 | 42 | (* 43 | * The following is a hack to make the browse function consistent 44 | * with the changes made on ast during the elaboration of ast into absyn. 45 | * Syntactic changes made on ast by the elaborator should be propagated 46 | * to this function so that CM can do the correct job. I personally think 47 | * that syntactic changes on curried functors and insertions of 48 | * s should be done on Ast directly, before the 49 | * elaboration --- this way, we don't have to write the following ugly 50 | * sigenvSp function. 51 | *) 52 | and sigenvSp (M.SIG {elements=[(sym,M.STRspec{sign,...})],...}) = 53 | if S.name sym = "" then sigenv sign 54 | else bug "unexpected case in sigenvSp" 55 | | sigenvSp (M.SIG {elements=[(sym,M.FCTspec{sign,...})],...}) = 56 | if S.name sym = "" then fsgenv sign 57 | else bug "unexpected case in sigenvSp" 58 | | sigenvSp _ = bug "unexpected case in signenvSp" 59 | 60 | and fsgenv (M.FSIG{bodysig,...}) = sigenvSp bodysig 61 | | fsgenv _ = NoEnv 62 | 63 | fun strenv(M.STR { sign, ... }) = sigenv sign 64 | | strenv _ = NoEnv 65 | 66 | fun fctenv(M.FCT { sign, ... }) = fsgenv sign 67 | | fctenv _ = NoEnv 68 | 69 | fun browse env sym = 70 | (case SE.look(env,sym) 71 | of B.SIGbind b => sigenv b 72 | | B.STRbind b => strenv b 73 | | B.FSGbind b => fsgenv b 74 | | B.FCTbind b => fctenv b 75 | | _ => NoEnv) 76 | handle SE.Unbound => NoEnv 77 | 78 | fun catalog se = map #1 (StaticEnv.sort se) 79 | end 80 | -------------------------------------------------------------------------------- /ElabData/statenv/coreacc.sml: -------------------------------------------------------------------------------- 1 | (* coreacc.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure CoreAccess : sig 6 | val getVar : StaticEnv.staticEnv -> string list -> VarCon.var 7 | val getCon : StaticEnv.staticEnv -> string list -> VarCon.datacon 8 | val getVar' : (unit -> VarCon.var) -> 9 | StaticEnv.staticEnv -> string list -> VarCon.var 10 | val getCon' : (unit -> VarCon.datacon) -> 11 | StaticEnv.staticEnv -> string list -> VarCon.datacon 12 | 13 | (* like getCon, but returns a bogus exn instead of failing *) 14 | val getExn : StaticEnv.staticEnv -> string list -> VarCon.datacon 15 | end = struct 16 | 17 | local 18 | fun impossible m = ErrorMsg.impossible ("CoreAccess: " ^ m) 19 | 20 | exception NoCore 21 | fun dummyErr _ _ _ = raise NoCore 22 | fun mkpath [] = impossible "mkpath" 23 | | mkpath [x] = [Symbol.varSymbol x] 24 | | mkpath (x :: xs) = Symbol.strSymbol x :: mkpath xs 25 | fun path xs = SymPath.SPATH (CoreSym.coreSym :: mkpath xs) 26 | fun getCore env xs = Lookup.lookVal (env, path xs, dummyErr) 27 | in 28 | fun getVar' err env xs = 29 | (case getCore env xs of 30 | VarCon.VAL r => r 31 | | _ => impossible "getVar") 32 | handle NoCore => err () 33 | 34 | fun getVar env xs = getVar' (fn () => impossible "getVar") env xs 35 | 36 | fun getCon' err env xs = 37 | (case getCore env xs of 38 | VarCon.CON c => c 39 | | _ => err ()) 40 | handle NoCore => err () 41 | 42 | fun getCon env xs = getCon' (fn () => impossible "getCon") env xs 43 | 44 | fun getExn env xs = getCon' (fn () => VarCon.bogusEXN) env xs 45 | end 46 | end 47 | -------------------------------------------------------------------------------- /ElabData/statenv/genmap.sml: -------------------------------------------------------------------------------- 1 | (* genmap.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * Rapid modmap generation based on modtrees. 6 | * (Modtrees are embedded into static environments during unpickling. 7 | * This module cannot deal with environments that did not come out 8 | * of the unpickler.) 9 | * 10 | * (March 2000, Matthias Blume) 11 | *) 12 | structure GenModIdMap : sig 13 | val mkMap : StaticEnv.staticEnv -> ModuleId.tmap 14 | val mkMap' : StaticEnv.staticEnv * ModuleId.tmap -> ModuleId.tmap 15 | end = struct 16 | 17 | structure M = Modules 18 | structure MI = ModuleId 19 | 20 | fun mkMap' (se: StaticEnv.staticEnv, initial) = let 21 | fun tree (t, m) = let 22 | fun rc (r, stubOf, treeOf, part, id, insert, look) = let 23 | val i = id r 24 | in 25 | case look (m, i) of 26 | SOME _ => m 27 | | NONE => let 28 | val m' = insert (m, i, part) 29 | in 30 | case stubOf part of 31 | NONE => ErrorMsg.impossible "ModIdSet:no stubinfo" 32 | | SOME stb => tree (treeOf stb, m') 33 | end 34 | end 35 | in 36 | case t of 37 | M.TYCNODE r => MI.insertTyc (m, MI.tycId r, r) 38 | | M.SIGNODE r => 39 | rc (r, #stub, #tree, r, MI.sigId, MI.insertSig, MI.lookSig) 40 | | M.STRNODE r => 41 | rc (r, #stub, #tree, #rlzn r, 42 | MI.strId, MI.insertStr, MI.lookStr) 43 | | M.FCTNODE r => 44 | rc (r, #stub, #tree, #rlzn r, 45 | MI.fctId, MI.insertFct, MI.lookFct) 46 | | M.ENVNODE r => 47 | rc (r, #stub, #tree, r, MI.envId, MI.insertEnv, MI.lookEnv) 48 | | M.BRANCH l => foldl tree m l 49 | end 50 | fun bnd ((_, (_, SOME t)), m) = tree (t, m) 51 | | bnd (_, m) = m 52 | in 53 | StaticEnv.realfold bnd initial se 54 | end 55 | 56 | val mkMap' = Stats.doPhase (Stats.makePhase "Compiler 923 genmap") mkMap' 57 | 58 | fun mkMap se = mkMap' (se, MI.emptyTmap) 59 | end 60 | -------------------------------------------------------------------------------- /ElabData/statenv/lookup.sig: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT 1996 Bell Laboratories *) 2 | (* lookup.sig *) 3 | 4 | signature LOOKUP = 5 | sig 6 | val lookFix : StaticEnv.staticEnv * Symbol.symbol -> Fixity.fixity 7 | 8 | val lookSig : StaticEnv.staticEnv * Symbol.symbol * ErrorMsg.complainer 9 | -> Modules.Signature 10 | 11 | val lookFsig : StaticEnv.staticEnv * Symbol.symbol * ErrorMsg.complainer 12 | -> Modules.fctSig 13 | 14 | val lookStr : StaticEnv.staticEnv * SymPath.path * ErrorMsg.complainer 15 | -> Modules.Structure 16 | 17 | val lookStrDef : StaticEnv.staticEnv * SymPath.path * ErrorMsg.complainer 18 | -> Modules.strDef 19 | 20 | val lookFct : StaticEnv.staticEnv * SymPath.path * ErrorMsg.complainer 21 | -> Modules.Functor 22 | 23 | val lookTyc : StaticEnv.staticEnv * SymPath.path * ErrorMsg.complainer 24 | -> Types.tycon 25 | 26 | val lookArTyc : StaticEnv.staticEnv * SymPath.path * int 27 | * ErrorMsg.complainer -> Types.tycon 28 | 29 | (* lookValSym and lookSym return value or constructor bindings *) 30 | val lookValSym : StaticEnv.staticEnv * Symbol.symbol * ErrorMsg.complainer 31 | -> VarCon.value 32 | 33 | val lookVal : StaticEnv.staticEnv * SymPath.path * ErrorMsg.complainer 34 | -> VarCon.value 35 | 36 | val lookExn : StaticEnv.staticEnv * SymPath.path * ErrorMsg.complainer 37 | -> VarCon.datacon 38 | 39 | end (* signature LOOKUP *) 40 | 41 | -------------------------------------------------------------------------------- /ElabData/statenv/lookup.sml: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1996 Bell Laboratories. *) 2 | (* lookup.sml *) 3 | 4 | structure Lookup : LOOKUP = 5 | struct 6 | 7 | local structure SP = SymPath 8 | structure CVP = ConvertPaths 9 | structure M = Modules 10 | structure MU = ModuleUtil 11 | structure T = Types 12 | structure TU = TypesUtil 13 | structure A = Access 14 | structure V = VarCon 15 | structure B = Bindings 16 | structure SE = StaticEnv 17 | structure EM = ErrorMsg 18 | structure S = Symbol 19 | in 20 | 21 | fun bug s = EM.impossible ("Lookup: "^s) 22 | 23 | fun spmsg spath = 24 | if SP.length spath > 1 then " in path "^(SP.toString spath) else "" 25 | 26 | fun unboundError(badsym, sp, err) = 27 | err EM.COMPLAIN ("unbound " ^ 28 | S.nameSpaceToString(S.nameSpace badsym) ^ 29 | ": " ^ S.name badsym ^ sp) EM.nullErrorBody 30 | 31 | fun otherError(s, err) = err EM.COMPLAIN s EM.nullErrorBody 32 | 33 | (* error values for undefined structure and functor variables *) 34 | val bogusSTR = M.ERRORstr 35 | val bogusFCT = M.ERRORfct 36 | val bogusVAL = V.VAL V.ERRORvar 37 | 38 | (*** look for a fixity binding ***) 39 | fun lookFix (env,id) : Fixity.fixity = 40 | let val b = case SE.look(env,id) 41 | of B.FIXbind fixity => fixity 42 | | _ => bug "lookFIX" 43 | in b 44 | end handle SE.Unbound => Fixity.NONfix 45 | 46 | (*** look for a signature ***) 47 | fun lookSig (env,id,err) : M.Signature = 48 | let val b = case SE.look(env,id) 49 | of B.SIGbind sign => sign 50 | | _ => bug "lookSIG" 51 | in b 52 | end handle SE.Unbound => (unboundError(id,"",err); M.ERRORsig) 53 | 54 | (*** look for a functor signature ***) 55 | fun lookFsig (env,id,err) : M.fctSig = 56 | let val b = case SE.look(env,id) 57 | of B.FSGbind fs => fs 58 | | _ => bug "lookFSIG" 59 | in b 60 | end handle SE.Unbound => (unboundError(id,"",err); M.ERRORfsig) 61 | 62 | (*** look for a variable or a constructor bound to a symbol ***) 63 | fun lookValSym (env,sym,err) : V.value = 64 | let val b = case SE.look(env,sym) 65 | of B.VALbind v => V.VAL v 66 | | B.CONbind c => V.CON c 67 | | _ => bug "lookValSym" 68 | in b 69 | end handle SE.Unbound => (unboundError(sym,"",err); bogusVAL) 70 | 71 | 72 | (*** lookup path ****) 73 | 74 | (* 75 | * lookGen: generic lookup function for identifiers which may occur in: 76 | * 1. environments 77 | * 2. actual structure environments 78 | * 3. signature parsing environments 79 | *) 80 | fun lookGen(env,spath,outBind,getPath,errorVal,err) = 81 | case spath of 82 | SP.SPATH [id] => 83 | (outBind(SE.look(env,id)) 84 | handle SE.Unbound => (unboundError(id,spmsg spath,err); errorVal)) 85 | | SP.SPATH(first::rest) => 86 | ((case SE.look(env,first) 87 | of B.STRbind str => 88 | (getPath(str,SP.SPATH rest,spath) 89 | handle MU.Unbound sym => 90 | (unboundError(sym,spmsg spath,err); errorVal)) 91 | | _ => bug "lookGen1") 92 | handle SE.Unbound => (unboundError(first,spmsg spath,err); 93 | errorVal)) 94 | | SP.SPATH [] => bug "lookGen:SP.SPATH[]" 95 | 96 | (*** look for a variable or a constructor (complete path) ***) 97 | fun lookVal (env,path,err) : V.value = 98 | let fun outVal(B.VALbind v) = V.VAL v 99 | | outVal(B.CONbind c) = V.CON c 100 | | outVal _ = bug "outVal" 101 | in lookGen(env,path,outVal,MU.getValPath,bogusVAL,err) 102 | end 103 | 104 | (*** look for a structure ***) 105 | fun lookStr (env,path,err) : M.Structure = 106 | let fun outStr(B.STRbind str) = str 107 | | outStr _ = bug "lookStr" 108 | in lookGen(env,path,outStr,MU.getStrPath,bogusSTR,err) 109 | end 110 | 111 | (*** look for a strDef; used in elabsig.sml ***) 112 | fun lookStrDef (env,path,err) : M.strDef = 113 | let fun outSD(B.STRbind s) = 114 | (case s of 115 | M.STRSIG{sign,entPath} => M.VARstrDef(sign,entPath) 116 | | sv => M.CONSTstrDef sv) 117 | | outSD _ = bug "lookStrDef" 118 | in lookGen(env,path,outSD,MU.getStrDef,M.CONSTstrDef bogusSTR,err) 119 | end 120 | 121 | (*** look for a functor ***) 122 | fun lookFct (env,path,err) : M.Functor = 123 | let fun outFct(B.FCTbind fct) = fct 124 | | outFct _ = bug "lookFct" 125 | in lookGen(env,path,outFct,MU.getFctPath,bogusFCT,err) 126 | end 127 | 128 | (*** look for a type constructor ***) 129 | fun lookTyc (env,path,err) : T.tycon = 130 | let fun outTyc(B.TYCbind tycon) = tycon 131 | | outTyc _ = bug "lookTyc" 132 | in lookGen(env,path,outTyc,MU.getTycPath,T.ERRORtyc,err) 133 | end 134 | 135 | (*** tycon lookup with arity checking ***) 136 | fun lookArTyc (env, path, arity, err) = 137 | (case lookTyc(env,path,err) 138 | of T.ERRORtyc => T.ERRORtyc 139 | | tycon => 140 | if TU.tyconArity(tycon) <> arity 141 | then (otherError("type constructor " ^ 142 | (SP.toString(CVP.invertIPath(TU.tycPath(tycon)))) ^ 143 | " given " ^ (Int.toString arity) ^ " arguments, wants " 144 | ^ (Int.toString (TU.tyconArity tycon)), err); 145 | T.ERRORtyc) 146 | else tycon) 147 | 148 | (*** looking for an exception ***) 149 | fun lookExn (env,path,err) : V.datacon = 150 | (case lookVal (env,path,err) 151 | of V.CON(c as T.DATACON{rep=(A.EXN _), ...}) => c 152 | | V.CON _ => 153 | (otherError("found data constructor instead of exception", err); 154 | V.bogusEXN) 155 | | V.VAL _ => 156 | (otherError("found variable instead of exception", err); 157 | V.bogusEXN)) 158 | 159 | end (* local *) 160 | end (* structure Lookup *) 161 | 162 | -------------------------------------------------------------------------------- /ElabData/statenv/statenv.sig: -------------------------------------------------------------------------------- 1 | (* statenv.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature STATICENV = 6 | sig 7 | 8 | (* Static environments now optionally contain modtrees anchored at 9 | * bindings. This allows for rapid on-demand construction of 10 | * modmaps (= pickling/unpickling contexts). 11 | * 12 | * March 2000, Matthias Blume *) 13 | type staticEnv 14 | type binding = Bindings.binding 15 | type real_binding = binding * Modules.modtree option 16 | 17 | exception Unbound 18 | 19 | val empty: staticEnv 20 | val look: staticEnv * Symbol.symbol -> binding 21 | val bind: Symbol.symbol * binding * staticEnv -> staticEnv 22 | val special: (Symbol.symbol -> binding) * (unit -> Symbol.symbol list) 23 | -> staticEnv 24 | 25 | val atop: staticEnv * staticEnv -> staticEnv 26 | val consolidate: staticEnv -> staticEnv 27 | val consolidateLazy: staticEnv -> staticEnv 28 | val app: (Symbol.symbol * binding -> unit) -> staticEnv -> unit 29 | val map: (binding -> binding) -> staticEnv -> staticEnv 30 | val fold: ((Symbol.symbol * binding) * 'a -> 'a) -> 'a -> staticEnv -> 'a 31 | val realfold : 32 | ((Symbol.symbol * real_binding) * 'a -> 'a) -> 'a -> staticEnv -> 'a 33 | val foldOverElems: ((Symbol.symbol * binding) * 'a -> 'a) * 'a * staticEnv * Symbol.symbol list -> 'a 34 | val sort: staticEnv -> (Symbol.symbol * binding) list 35 | 36 | val bind0: Symbol.symbol * real_binding * staticEnv -> staticEnv 37 | 38 | val symbols : staticEnv -> Symbol.symbol list 39 | 40 | 41 | val filter : staticEnv * Symbol.symbol list -> staticEnv 42 | 43 | end (* signature STATICENV *) 44 | -------------------------------------------------------------------------------- /ElabData/statenv/statenv.sml: -------------------------------------------------------------------------------- 1 | (* statenv.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure StaticEnv : STATICENV = 6 | struct 7 | 8 | local structure B = Bindings 9 | structure E = Env 10 | structure M = Modules 11 | in 12 | 13 | type binding = B.binding 14 | type real_binding = binding * M.modtree option 15 | type staticEnv = real_binding E.env 16 | 17 | exception Unbound = E.Unbound 18 | 19 | fun aug x = (x, NONE) 20 | fun strip (rb: real_binding) = #1 rb 21 | 22 | val empty = E.empty 23 | fun look (e, s) = strip (E.look (e, s)) 24 | val bind0 = E.bind 25 | fun bind (s, b, e) = E.bind (s, aug b, e) 26 | fun special (mkb, mks) = E.special (aug o mkb, mks) 27 | val atop = E.atop 28 | val consolidate = E.consolidate 29 | val consolidateLazy = E.consolidateLazy 30 | fun app f e = E.app (fn (s, b) => f (s, strip b)) e 31 | fun map f e = E.map (aug o f o strip) e 32 | fun fold f x0 e = E.fold (fn ((s, b), x) => f ((s, strip b), x)) x0 e 33 | val realfold = E.fold 34 | val symbols = E.symbols 35 | 36 | (* fold but only over the elements in the environment with the keys 37 | given in the key list (last parameter). This functions allows 38 | us to compute folds in arbitrary order over a consolidated list. 39 | In particular, this function is currently used in extractSig in 40 | elabmod to keep the inferred signature specs in the same order as 41 | the original structure decls. 42 | *) 43 | fun foldOverElems(f, x0, env, []) = x0 44 | | foldOverElems(f, x0, env, elem::rest) = 45 | foldOverElems(f, f((elem, look(env,elem)), x0), env, rest) 46 | (* 47 | * sort: sort the bindings in an environment. 48 | * 49 | * This is used for the assignment of dynamic access slots in structure 50 | * elaborate, for printing, and for other purposes. 51 | * The bindings are sorted in the following order: 52 | * 53 | * values 54 | * constructors 55 | * types 56 | * signatures 57 | * structures 58 | * funsigs 59 | * functors 60 | * fixity declarations 61 | * 62 | * It is only correct to sort environments which have no duplicate bindings. 63 | * All routines which build structure environments maintain this 64 | * invariant, so it is ok to sort any structure environment using 65 | * this function. 66 | *) 67 | 68 | fun sort env = ListMergeSort.sort B.binderGt (fold (op ::) nil env) 69 | 70 | fun filter (e, l) = 71 | let fun add (sy, e') = bind (sy, look (e, sy), e') handle Unbound => e' 72 | in foldl add empty l 73 | end 74 | 75 | end (* local *) 76 | end (* structure StaticEnv *) 77 | -------------------------------------------------------------------------------- /ElabData/syntax/absyn.sig: -------------------------------------------------------------------------------- 1 | (* absyn.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature ABSYN = 6 | sig 7 | 8 | type region 9 | 10 | datatype numberedLabel = LABEL of {name: Symbol.symbol, number: int} 11 | 12 | datatype exp 13 | = VARexp of VarCon.var ref * Types.tyvar list (* instance type *) 14 | | CONexp of VarCon.datacon * Types.tyvar list (* instance type *) 15 | | INTexp of IntInf.int * Types.ty 16 | | WORDexp of IntInf.int * Types.ty 17 | | REALexp of string 18 | | STRINGexp of string 19 | | CHARexp of string 20 | | RECORDexp of (numberedLabel * exp) list 21 | | SELECTexp of numberedLabel * exp 22 | | VECTORexp of exp list * Types.ty 23 | | PACKexp of exp * Types.ty * Types.tycon list 24 | | APPexp of exp * exp 25 | | HANDLEexp of exp * fnrules 26 | | RAISEexp of exp * Types.ty 27 | | CASEexp of exp * rule list * bool 28 | | IFexp of { test: exp, thenCase: exp, elseCase: exp } 29 | | ANDALSOexp of exp * exp 30 | | ORELSEexp of exp * exp 31 | | WHILEexp of { test: exp, expr: exp } 32 | | FNexp of fnrules 33 | | LETexp of dec * exp 34 | | SEQexp of exp list 35 | | CONSTRAINTexp of exp * Types.ty 36 | | MARKexp of exp * region 37 | 38 | and rule = RULE of pat * exp 39 | 40 | and pat 41 | = WILDpat 42 | | VARpat of VarCon.var 43 | | INTpat of IntInf.int * Types.ty 44 | | WORDpat of IntInf.int * Types.ty 45 | | REALpat of string 46 | | STRINGpat of string 47 | | CHARpat of string 48 | | CONpat of VarCon.datacon * Types.tyvar list (* instance type *) 49 | | RECORDpat of {fields : (Types.label * pat) list, 50 | flex : bool, typ : Types.ty ref} 51 | | APPpat of VarCon.datacon * Types.tyvar list * pat 52 | | CONSTRAINTpat of pat * Types.ty 53 | | LAYEREDpat of pat * pat 54 | | ORpat of pat * pat 55 | | VECTORpat of pat list * Types.ty 56 | | MARKpat of pat * region 57 | | NOpat 58 | 59 | and dec 60 | = VALdec of vb list 61 | | VALRECdec of rvb list 62 | | TYPEdec of Types.tycon list 63 | | DATATYPEdec of {datatycs: Types.tycon list, withtycs: Types.tycon list} 64 | | ABSTYPEdec of {abstycs: Types.tycon list, 65 | withtycs: Types.tycon list, body: dec} 66 | | EXCEPTIONdec of eb list 67 | | STRdec of strb list 68 | | ABSdec of strb list 69 | | FCTdec of fctb list 70 | | SIGdec of Modules.Signature list 71 | | FSIGdec of Modules.fctSig list 72 | | OPENdec of (SymPath.path * Modules.Structure) list 73 | | LOCALdec of dec * dec 74 | | SEQdec of dec list 75 | | OVLDdec of VarCon.var 76 | | FIXdec of {fixity: Fixity.fixity, ops: Symbol.symbol list} 77 | | MARKdec of dec * region 78 | 79 | and strexp 80 | = VARstr of Modules.Structure 81 | | STRstr of Bindings.binding list 82 | | APPstr of {oper: Modules.Functor, arg: Modules.Structure, 83 | argtycs: Types.tycpath list} 84 | | LETstr of dec * strexp 85 | | MARKstr of strexp * region 86 | 87 | and fctexp 88 | = VARfct of Modules.Functor 89 | | FCTfct of {param: Modules.Structure, argtycs: Types.tycpath list, 90 | def: strexp} 91 | | LETfct of dec * fctexp 92 | | MARKfct of fctexp * region 93 | 94 | and vb = VB of {pat: pat, exp: exp, boundtvs: Types.tyvar list, 95 | tyvars: Types.tyvar list ref} 96 | 97 | and rvb = RVB of {var: VarCon.var, exp: exp, boundtvs: Types.tyvar list, 98 | resultty: Types.ty option, tyvars: Types.tyvar list ref} 99 | 100 | and eb = EBgen of {exn: VarCon.datacon, etype: Types.ty option, ident: exp} 101 | | EBdef of {exn: VarCon.datacon, edef: VarCon.datacon} 102 | 103 | and strb = STRB of {name: Symbol.symbol, str: Modules.Structure, def: strexp} 104 | and fctb = FCTB of {name: Symbol.symbol, fct: Modules.Functor, def: fctexp} 105 | 106 | withtype fnrules = rule list * Types.ty 107 | 108 | end (* signature ABSYN *) 109 | -------------------------------------------------------------------------------- /ElabData/syntax/absyn.sml: -------------------------------------------------------------------------------- 1 | (* absyn.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure Absyn : ABSYN = 6 | struct 7 | 8 | local 9 | structure S = Symbol 10 | structure F = Fixity 11 | structure SP = SymPath 12 | structure B = Bindings 13 | open VarCon Modules Types 14 | in 15 | 16 | type region = Ast.region (* = int * int *) 17 | 18 | datatype numberedLabel = LABEL of {name: S.symbol, number: int} 19 | 20 | datatype exp 21 | = VARexp of var ref * tyvar list 22 | (* the 2nd arg is a type univar list used to capture the instantiation 23 | parameters for this occurence of var when its type is polymorphic. 24 | FLINT will use these to provide explicit type parameters for 25 | var if var is bound to a primop. These will then be used to specialize 26 | the primop. *) 27 | | CONexp of datacon * tyvar list (* ditto *) 28 | | INTexp of IntInf.int * ty 29 | | WORDexp of IntInf.int * ty 30 | | REALexp of string 31 | | STRINGexp of string 32 | | CHARexp of string 33 | | RECORDexp of (numberedLabel * exp) list 34 | | SELECTexp of numberedLabel * exp (* record selections *) 35 | | VECTORexp of exp list * ty 36 | | PACKexp of exp * ty * tycon list (* abstraction packing *) 37 | | APPexp of exp * exp 38 | | HANDLEexp of exp * fnrules 39 | | RAISEexp of exp * ty 40 | | CASEexp of exp * rule list * bool (* true: match; false: bind *) 41 | | IFexp of { test: exp, thenCase: exp, elseCase: exp } 42 | | ANDALSOexp of exp * exp 43 | | ORELSEexp of exp * exp 44 | | WHILEexp of { test: exp, expr: exp } 45 | | FNexp of fnrules 46 | | LETexp of dec * exp 47 | | SEQexp of exp list 48 | | CONSTRAINTexp of exp * ty 49 | | MARKexp of exp * region 50 | 51 | and rule = RULE of pat * exp 52 | 53 | and pat 54 | = WILDpat 55 | | VARpat of var 56 | | INTpat of IntInf.int * ty 57 | | WORDpat of IntInf.int * ty 58 | | REALpat of string 59 | | STRINGpat of string 60 | | CHARpat of string 61 | | CONpat of datacon * tyvar list (* See comment for VARexp *) 62 | | RECORDpat of {fields: (label * pat) list, flex: bool, typ: ty ref} 63 | | APPpat of datacon * tyvar list * pat 64 | | CONSTRAINTpat of pat * ty 65 | | LAYEREDpat of pat * pat 66 | | ORpat of pat * pat 67 | | VECTORpat of pat list * ty 68 | | MARKpat of pat * region 69 | | NOpat 70 | 71 | and dec 72 | = VALdec of vb list (* always a single element list (FLINT normalization) *) 73 | | VALRECdec of rvb list 74 | | TYPEdec of tycon list 75 | | DATATYPEdec of {datatycs: tycon list, withtycs: tycon list} 76 | | ABSTYPEdec of {abstycs: tycon list, withtycs: tycon list, body: dec} 77 | | EXCEPTIONdec of eb list 78 | | STRdec of strb list 79 | | ABSdec of strb list (* should be merged with STRdec in the future *) 80 | | FCTdec of fctb list 81 | | SIGdec of Signature list 82 | | FSIGdec of fctSig list 83 | | OPENdec of (SP.path * Structure) list 84 | | LOCALdec of dec * dec 85 | | SEQdec of dec list 86 | | OVLDdec of var 87 | | FIXdec of {fixity: F.fixity, ops: S.symbol list} 88 | | MARKdec of dec * region 89 | 90 | (* 91 | * The "argtycs" field in APPstr is used to record the list of instantiated 92 | * hotycs passed to functor during the functor application. 93 | *) 94 | and strexp 95 | = VARstr of Structure 96 | | STRstr of B.binding list 97 | | APPstr of {oper: Functor, arg: Structure, argtycs: tycpath list} 98 | | LETstr of dec * strexp 99 | | MARKstr of strexp * region 100 | 101 | (* 102 | * For typing purpose, a functor is viewed as a high-order type constructor 103 | * (hotyc) that takes a list of hotycs returns another list of hotycs. The 104 | * "argtycs" field in FCTfct records the list of formal hotyc paramaters. 105 | *) 106 | and fctexp 107 | = VARfct of Functor 108 | | FCTfct of {param: Structure, argtycs: tycpath list, def: strexp} 109 | | LETfct of dec * fctexp 110 | | MARKfct of fctexp * region 111 | 112 | (* 113 | * Each value binding vb only binds one variable identifier. That is, 114 | * pat is always a simple VARpat (with type constraints) or it simply 115 | * does not contain any variable patterns; boundtvs gives the list of 116 | * type variables that are being generalized at this binding. 117 | *) 118 | and vb = VB of {pat: pat, exp: exp, boundtvs: tyvar list, 119 | tyvars: tyvar list ref} 120 | 121 | (* 122 | * Like value binding vb, boundtvs gives a list of type variables 123 | * being generalized at this binding. However, the mutually recursive 124 | * list of RVBs could share type variables, that is, the boundtvs sets 125 | * used in these RVBs could contain overlapping set of type variables. 126 | *) 127 | and rvb = RVB of {var: var, exp: exp, boundtvs: tyvar list, 128 | resultty: ty option, tyvars: tyvar list ref} 129 | 130 | and eb = EBgen of {exn: datacon, etype: ty option, ident: exp} 131 | | EBdef of {exn: datacon, edef: datacon} 132 | 133 | and strb = STRB of {name: S.symbol, str: Structure, def: strexp} 134 | and fctb = FCTB of {name: S.symbol, fct: Functor, def: fctexp} 135 | 136 | withtype fnrules = rule list * Types.ty 137 | 138 | end (* local *) 139 | end 140 | -------------------------------------------------------------------------------- /ElabData/syntax/absynutil.sml: -------------------------------------------------------------------------------- 1 | (* absynutil.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * More stuff from ElabUtil should be moved here eventually. 6 | *) 7 | structure AbsynUtil : sig 8 | 9 | val unitExp : Absyn.exp 10 | 11 | val TUPLEexp : Absyn.exp list -> Absyn.exp 12 | val TUPLEpat : Absyn.pat list -> Absyn.pat 13 | val stripPatMarks : Absyn.pat -> Absyn.pat 14 | 15 | end = 16 | 17 | struct 18 | 19 | local open Absyn in 20 | 21 | val unitExp = RECORDexp [] 22 | 23 | fun TUPLEexp l = 24 | let fun build (_, []) = [] 25 | | build (i, e :: es) = 26 | (LABEL { number = i-1, name = Tuples.numlabel i }, e) 27 | :: build (i+1, es) 28 | in RECORDexp (build (1, l)) 29 | end 30 | 31 | fun TUPLEpat l = 32 | let fun build (_, []) = [] 33 | | build (i, e :: es) = (Tuples.numlabel i, e) :: build (i+1, es) 34 | in RECORDpat { fields = build (1, l), flex = false, 35 | typ = ref Types.UNDEFty } 36 | end 37 | 38 | fun stripPatMarks pat = 39 | case pat 40 | of (MARKpat(p,_)) => stripPatMarks p 41 | | RECORDpat{fields, flex, typ} => 42 | RECORDpat{fields = map (fn (l,p) => (l, stripPatMarks p)) fields, flex = flex, typ = typ} 43 | | APPpat (dc, tvs, p) => 44 | APPpat (dc, tvs, stripPatMarks p) 45 | | CONSTRAINTpat (p, ty) => CONSTRAINTpat (stripPatMarks p, ty) 46 | | LAYEREDpat(pat1, pat2) => 47 | LAYEREDpat(stripPatMarks pat1, stripPatMarks pat2) 48 | | ORpat (pat1, pat2) => 49 | ORpat (stripPatMarks pat1, stripPatMarks pat2) 50 | | VECTORpat (pats,ty) => 51 | VECTORpat (map stripPatMarks pats, ty) 52 | | p => p 53 | 54 | end (* local *) 55 | end (* structure AbsynUtil *) 56 | -------------------------------------------------------------------------------- /ElabData/syntax/varcon.sig: -------------------------------------------------------------------------------- 1 | (* varcon.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature VARCON = 6 | sig 7 | 8 | datatype var 9 | = VALvar of (* ordinary variables *) 10 | {path : SymPath.path, 11 | typ : Types.ty ref, 12 | btvs : Types.tyvar list ref, 13 | access : Access.access, 14 | prim : PrimOpId.primId} 15 | | OVLDvar of (* overloaded identifier *) 16 | {name : Symbol.symbol, 17 | options: {indicator: Types.ty, variant: var} list ref, 18 | scheme: Types.tyfun} 19 | | ERRORvar 20 | 21 | type datacon = Types.datacon 22 | 23 | datatype value 24 | = VAL of var 25 | | CON of datacon 26 | 27 | val mkVALvar : Symbol.symbol * Access.access -> var 28 | 29 | val bogusCON : datacon 30 | val bogusEXN : datacon 31 | 32 | end (* signature VARCON *) 33 | -------------------------------------------------------------------------------- /ElabData/syntax/varcon.sml: -------------------------------------------------------------------------------- 1 | (* varcon.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure VarCon : VARCON = 6 | struct 7 | 8 | local structure A = Access 9 | structure T = Types 10 | structure S = Symbol 11 | structure SP = SymPath 12 | in 13 | 14 | datatype var 15 | = VALvar of (* ordinary variables *) 16 | {path : SP.path, 17 | typ : T.ty ref, 18 | btvs : T.tyvar list ref, 19 | access : A.access, 20 | prim : PrimOpId.primId} 21 | | OVLDvar of (* overloaded identifier *) 22 | {name : S.symbol, 23 | options: {indicator: T.ty, variant: var} list ref, 24 | scheme: T.tyfun} 25 | | ERRORvar 26 | 27 | type datacon = T.datacon 28 | 29 | datatype value 30 | = VAL of var 31 | | CON of datacon 32 | 33 | fun mkVALvar (id, acc) = 34 | VALvar{path = SP.SPATH [id], 35 | typ = ref T.UNDEFty, 36 | access = acc, 37 | btvs = ref [], 38 | prim = PrimOpId.NonPrim} 39 | 40 | val bogusCON = T.DATACON{name=S.varSymbol "bogus", 41 | typ=T.WILDCARDty, 42 | rep=A.CONSTANT 0, 43 | const=true, 44 | lazyp=false, 45 | sign=A.CSIG(0,1)} 46 | 47 | val bogusEXN = T.DATACON{name=S.varSymbol "bogus", 48 | typ=CoreBasicTypes.exnTy, 49 | rep=A.CONSTANT 0, 50 | const=true, 51 | lazyp=false, 52 | sign=A.CNIL} 53 | 54 | end (* local *) 55 | end (* structure VarCon *) 56 | -------------------------------------------------------------------------------- /ElabData/types/core-basictypes.sml: -------------------------------------------------------------------------------- 1 | (* core-basictypes.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * a generic part of basictypes.sml (not SML/NJ specific) 6 | *) 7 | structure CoreBasicTypes : sig 8 | 9 | val arrowStamp : Stamps.stamp 10 | val arrowTycon : Types.tycon 11 | val --> : Types.ty * Types.ty -> Types.ty 12 | 13 | val refStamp : Stamps.stamp 14 | val refTycSym : Symbol.symbol 15 | val refConSym : Symbol.symbol 16 | val refTycon : Types.tycon 17 | val refDcon : Types.datacon 18 | val refPatType : Types.ty 19 | 20 | val boolStamp : Stamps.stamp 21 | val boolSym : Symbol.symbol 22 | val falseSym : Symbol.symbol 23 | val trueSym : Symbol.symbol 24 | val boolTycon : Types.tycon 25 | val boolTy : Types.ty 26 | val boolsign : Access.consig 27 | val falseDcon : Types.datacon 28 | val trueDcon : Types.datacon 29 | 30 | val unitSym : Symbol.symbol 31 | val unitTycon : Types.tycon 32 | val unitTy : Types.ty 33 | 34 | val intTycon : Types.tycon 35 | val intTy : Types.ty 36 | 37 | val stringTycon : Types.tycon 38 | val stringTy : Types.ty 39 | 40 | val charTycon : Types.tycon 41 | val charTy : Types.ty 42 | 43 | val realTycon : Types.tycon 44 | val realTy : Types.ty 45 | 46 | val exnTycon : Types.tycon 47 | val exnTy : Types.ty 48 | 49 | val tupleTy : Types.ty list -> Types.ty 50 | 51 | val recordTy : (Types.label * Types.ty) list -> Types.ty 52 | 53 | val arrayTycon : Types.tycon 54 | val vectorTycon : Types.tycon 55 | 56 | end = struct 57 | 58 | structure T = Types 59 | structure IP = InvPath 60 | structure PTN = CorePrimTycNum 61 | 62 | val arrowStamp = Stamps.special "->" 63 | val refStamp = Stamps.special "ref" 64 | val boolStamp = Stamps.special "bool" 65 | 66 | val unitSym = Symbol.tycSymbol "unit" 67 | val refTycSym = Symbol.tycSymbol "ref" 68 | val refConSym = Symbol.varSymbol "ref" 69 | val boolSym = Symbol.tycSymbol "bool" 70 | val falseSym = Symbol.varSymbol "false" 71 | val trueSym = Symbol.varSymbol "true" 72 | 73 | fun tc2t tyc = T.CONty (tyc, []) 74 | 75 | val unitTycon = 76 | T.DEFtyc { stamp = Stamps.special "unit", 77 | tyfun = T.TYFUN { arity = 0, 78 | body = T.CONty 79 | (Tuples.mkTUPLEtyc 0, []) }, 80 | strict = [], 81 | path = IP.IPATH [unitSym] } 82 | 83 | val unitTy = tc2t unitTycon 84 | 85 | fun pt2tc (sym, arity, eqprop, ptn) = 86 | T.GENtyc { stamp = Stamps.special sym, 87 | path = IP.IPATH [Symbol.tycSymbol sym], 88 | arity = arity, 89 | eq = ref eqprop, 90 | kind = T.PRIMITIVE ptn, 91 | stub = NONE } 92 | 93 | fun pt2tct args = let 94 | val tyc = pt2tc args 95 | in 96 | (tyc, tc2t tyc) 97 | end 98 | 99 | val (intTycon, intTy) = pt2tct ("int", 0, T.YES, PTN.ptn_int) 100 | val (stringTycon, stringTy) = pt2tct ("string", 0, T.YES, PTN.ptn_string) 101 | val (charTycon, charTy) = pt2tct ("char", 0, T.YES, PTN.ptn_int) 102 | val (realTycon, realTy) = pt2tct ("real", 0, T.NO, PTN.ptn_real) 103 | val (exnTycon, exnTy) = pt2tct ("exn", 0, T.NO, PTN.ptn_exn) 104 | 105 | val arrayTycon = pt2tc ("array", 1, T.OBJ, PTN.ptn_array) 106 | val vectorTycon = pt2tc ("vector", 1, T.YES, PTN.ptn_vector) 107 | 108 | val arrowTycon = 109 | T.GENtyc { stamp = arrowStamp, 110 | path = IP.IPATH [Symbol.tycSymbol "->"], 111 | arity = 2, 112 | eq = ref T.NO, 113 | kind = T.PRIMITIVE PTN.ptn_arrow, 114 | stub = NONE } 115 | 116 | infix --> 117 | fun t1 --> t2 = T.CONty (arrowTycon, [t1, t2]) 118 | 119 | fun recordTy (fields: (T.label * T.ty) list) = 120 | T.CONty (Tuples.mkRECORDtyc (map #1 fields), map #2 fields) 121 | 122 | fun tupleTy tys = T.CONty (Tuples.mkTUPLEtyc (length tys), tys) 123 | 124 | val (refTycon, refPatType, refDcon) = let 125 | val eqRef = ref T.OBJ 126 | val alpha = T.IBOUND 0 127 | val refDom = alpha 128 | val refsign = Access.CSIG (1, 0) 129 | val refTycon = T.GENtyc 130 | { stamp = refStamp, 131 | path = IP.IPATH [refTycSym], 132 | arity = 1, 133 | eq = eqRef, 134 | kind = T.DATATYPE 135 | { index = 0, 136 | stamps = #[refStamp], 137 | freetycs = [], 138 | root = NONE, 139 | family = { members = 140 | #[{ tycname = refTycSym, 141 | eq = eqRef, 142 | lazyp = false, 143 | arity = 1, 144 | sign = Access.CSIG(1, 0), 145 | dcons = [{ name = refConSym, 146 | rep = Access.REF, 147 | domain = SOME refDom }]}], 148 | properties = PropList.newHolder (), 149 | mkey = refStamp } }, 150 | stub = NONE } 151 | val refTyfun = 152 | T.TYFUN { arity = 1, body = alpha --> T.CONty (refTycon, [alpha]) } 153 | val refPatType = T.POLYty { sign = [false], tyfun = refTyfun } 154 | val refDcon = T.DATACON { name = refConSym, 155 | const = false, 156 | lazyp = false, 157 | rep = Access.REF, 158 | typ = refPatType, 159 | sign = refsign } 160 | in 161 | (refTycon, refPatType, refDcon) 162 | end 163 | 164 | val boolsign = Access.CSIG (0, 2) 165 | val (boolTycon, boolTy, falseDcon, trueDcon) = let 166 | val booleq = ref T.YES 167 | val boolTycon = 168 | T.GENtyc { stamp = boolStamp, 169 | path = IP.IPATH [boolSym], 170 | arity = 0, 171 | eq = booleq, 172 | kind = T.DATATYPE 173 | { index = 0, 174 | stamps = #[boolStamp], 175 | freetycs = [], 176 | root = NONE, 177 | family = 178 | { members = 179 | #[{ tycname = boolSym, 180 | eq = booleq, 181 | lazyp = false, 182 | arity = 0, 183 | sign = boolsign, 184 | dcons = [{ name = falseSym, 185 | rep = Access.CONSTANT 0, 186 | domain = NONE }, 187 | { name = trueSym, 188 | rep = Access.CONSTANT 1, 189 | domain = NONE }]}], 190 | properties = PropList.newHolder (), 191 | mkey = boolStamp }}, 192 | stub = NONE } 193 | val boolTy = T.CONty (boolTycon, []) 194 | val falseDcon = T.DATACON { name = falseSym, 195 | const = true, 196 | lazyp = false, 197 | rep = Access.CONSTANT 0, 198 | typ = boolTy, 199 | sign = boolsign } 200 | val trueDcon = T.DATACON { name = trueSym, 201 | const = true, 202 | lazyp = false, 203 | rep = Access.CONSTANT 1, 204 | typ = boolTy, 205 | sign = boolsign } 206 | in 207 | (boolTycon, boolTy, falseDcon, trueDcon) 208 | end 209 | end 210 | -------------------------------------------------------------------------------- /ElabData/types/tuples.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1989 by AT&T Bell Laboratories *) 2 | (* tuples.sml *) 3 | 4 | (* 5 | * TUPLES and Tuples should be called RECORDS and Records, since 6 | * records are the primary concept, and tuples are a derived form. 7 | *) 8 | signature TUPLES = 9 | sig 10 | 11 | val numlabel : int -> Types.label 12 | val mkTUPLEtyc : int -> Types.tycon 13 | val isTUPLEtyc : Types.tycon -> bool 14 | val mkRECORDtyc : Types.label list -> Types.tycon 15 | 16 | end (* signature TUPLES *) 17 | 18 | structure Tuples : TUPLES = struct 19 | 20 | open Types 21 | 22 | datatype labelOpt = NOlabel | SOMElabel of label 23 | datatype tyconOpt = NOtycon | SOMEtycon of tycon 24 | 25 | structure LabelArray = DynamicArrayFn ( 26 | struct 27 | open Array 28 | type array = labelOpt array 29 | type vector = labelOpt vector 30 | type elem = labelOpt 31 | end) 32 | 33 | structure TyconArray = DynamicArrayFn ( 34 | struct 35 | open Array 36 | type array = tyconOpt array 37 | type vector = tyconOpt vector 38 | type elem = tyconOpt 39 | end) 40 | 41 | exception New 42 | structure Tbl = WordStringHashTable 43 | val tyconTable = Tbl.mkTable (32, New) : tycon Tbl.hash_table 44 | val tyconMap = Tbl.lookup tyconTable 45 | val tyconAdd = Tbl.insert tyconTable 46 | 47 | fun labelsToSymbol(labels: label list) : Symbol.symbol = 48 | let fun wrap [] = ["}"] 49 | | wrap [id] = [Symbol.name id, "}"] 50 | | wrap (id::rest) = Symbol.name id :: "," :: wrap rest 51 | in Symbol.tycSymbol(concat("{" :: wrap labels)) 52 | end 53 | 54 | (* this is an optimization to make similar record tycs point to the same thing, 55 | thus speeding equality testing on them *) 56 | fun mkRECORDtyc labels = 57 | let val recordName = labelsToSymbol labels 58 | val number = Symbol.number recordName 59 | val name = Symbol.name recordName 60 | in tyconMap(number,name) 61 | handle New => 62 | let val tycon = RECORDtyc labels 63 | in tyconAdd((number,name),tycon); 64 | tycon 65 | end 66 | end 67 | 68 | val numericLabels = LabelArray.array(0,NOlabel) 69 | val tupleTycons = TyconArray.array(0,NOtycon) 70 | 71 | fun numlabel i = 72 | case LabelArray.sub(numericLabels,i) 73 | of NOlabel => 74 | let val newlabel = Symbol.labSymbol(Int.toString i) 75 | in LabelArray.update(numericLabels,i,SOMElabel(newlabel)); 76 | newlabel 77 | end 78 | | SOMElabel(label) => label 79 | 80 | fun numlabels n = 81 | let fun labels (0,acc) = acc 82 | | labels (i,acc) = labels (i-1, numlabel i :: acc) 83 | in labels (n,nil) 84 | end 85 | 86 | fun mkTUPLEtyc n = 87 | case TyconArray.sub(tupleTycons,n) 88 | of NOtycon => 89 | let val tycon = mkRECORDtyc(numlabels n) 90 | in TyconArray.update(tupleTycons,n,SOMEtycon(tycon)); 91 | tycon 92 | end 93 | | SOMEtycon(tycon) => tycon 94 | 95 | fun checklabels (2,nil) = false (* {1:t} is not a tuple *) 96 | | checklabels (n,nil) = true 97 | | checklabels (n, lab::labs) = 98 | Symbol.eq(lab, numlabel n) andalso checklabels(n+1,labs) 99 | 100 | fun isTUPLEtyc(RECORDtyc labels) = checklabels(1,labels) 101 | | isTUPLEtyc _ = false 102 | 103 | end (* structure Tuples *) 104 | -------------------------------------------------------------------------------- /ElabData/types/types.sig: -------------------------------------------------------------------------------- 1 | (* types.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature TYPES = 6 | sig 7 | 8 | (* not quite abstract types... *) 9 | type label (* = Symbol.symbol *) 10 | type polysign (* = bool list *) 11 | 12 | datatype eqprop = YES | NO | IND | OBJ | DATA | ABS | UNDEF 13 | 14 | datatype litKind = INT | WORD | REAL | CHAR | STRING 15 | 16 | datatype openTvKind 17 | = META 18 | | FLEX of (label * ty) list 19 | 20 | and tvKind 21 | = INSTANTIATED of ty 22 | | OPEN of {depth: int, eq: bool, kind: openTvKind} 23 | | UBOUND of {depth: int, eq: bool, name: Symbol.symbol} 24 | | LITERAL of {kind: litKind, region: SourceMap.region} 25 | | SCHEME of bool 26 | (* for marking a type variable so that it can be easily identified 27 | * (A type variable's ref cell provides an identity already, but 28 | * since ref cells are unordered, this is not enough for efficient 29 | * data structure lookups (binary trees...). TV_MARK is really 30 | * a hack for the benefit of later translation phases (FLINT), 31 | * but unlike the old "LBOUND" thing, it does not need to know about 32 | * specific types used by those phases. In any case, we should figure 33 | * out how to get rid of it altogether.) *) 34 | | LBOUND of {depth: int, eq: bool, index: int} 35 | (* FLINT-style de Bruijn index for notional "lambda"-bound type variables 36 | * associated with polymorphic bindings (including val bindings and 37 | * functor parameter bindings). The depth is depth of type lambda bindings, 38 | * (1-based), and the index is the index within a sequence of 39 | * type variables bound at a given binding site. LBOUNDs must carry 40 | * equality type information for signature matching because the OPENs 41 | * are turned into LBOUNDs before equality type information is matched. *) 42 | 43 | and tycpath 44 | = TP_VAR of exn 45 | | TP_TYC of tycon 46 | | TP_FCT of tycpath list * tycpath list 47 | | TP_APP of tycpath * tycpath list 48 | | TP_SEL of tycpath * int 49 | 50 | and tyckind 51 | = PRIMITIVE of int (* primitive kinds are abstractly numbered *) 52 | | ABSTRACT of tycon 53 | | DATATYPE of 54 | {index: int, 55 | stamps: Stamps.stamp vector, 56 | root : EntPath.entVar option, 57 | freetycs: tycon list, 58 | family : dtypeFamily} 59 | | FLEXTYC of tycpath 60 | | FORMAL 61 | | TEMP 62 | 63 | and tycon 64 | = GENtyc of gtrec 65 | | DEFtyc of 66 | {stamp : Stamps.stamp, 67 | tyfun : tyfun, 68 | strict: bool list, 69 | path : InvPath.path} 70 | | PATHtyc of 71 | {arity : int, 72 | entPath : EntPath.entPath, 73 | path : InvPath.path} 74 | | RECORDtyc of label list 75 | | RECtyc of int (* used only in domain type of dconDesc *) 76 | | FREEtyc of int (* used only in domain type of dconDesc *) 77 | | ERRORtyc 78 | 79 | and ty 80 | = VARty of tyvar 81 | | IBOUND of int 82 | | CONty of tycon * ty list 83 | | POLYty of {sign: polysign, tyfun: tyfun} 84 | | MARKty of ty * SourceMap.region 85 | | WILDCARDty 86 | | UNDEFty 87 | 88 | and tyfun 89 | = TYFUN of {arity : int, body : ty} 90 | 91 | (* datacon description used in dtmember *) 92 | withtype dconDesc = 93 | {name: Symbol.symbol, 94 | rep: Access.conrep, 95 | domain: ty option} 96 | 97 | (* member of a family of (potentially) mutually recursive datatypes *) 98 | and dtmember = 99 | {tycname: Symbol.symbol, 100 | arity: int, 101 | eq: eqprop ref, 102 | lazyp : bool, 103 | dcons: dconDesc list, 104 | sign: Access.consig} 105 | 106 | and dtypeFamily = 107 | {mkey: Stamps.stamp, 108 | members: dtmember vector, 109 | properties: PropList.holder} 110 | 111 | 112 | and stubinfo = 113 | {owner : PersStamps.persstamp, 114 | lib : bool} 115 | 116 | (* The "stub" field will be set for any GENtyc that comes out of the 117 | * unpickler. The stub owner pid is the pid of the compilation unit on whose 118 | * behalf this GENtyc was pickled. Normally, this is expected to be the 119 | * same as the pid in the (global) "stamp", but there are odd cases related 120 | * to recursive types where this assumption breaks. (Is there a way of 121 | * fixing this? -M.) *) 122 | and gtrec = 123 | {stamp : Stamps.stamp, 124 | arity : int, 125 | eq : eqprop ref, 126 | kind : tyckind, 127 | path : InvPath.path, 128 | stub : stubinfo option} 129 | 130 | and tyvar = tvKind ref 131 | 132 | val infinity : int 133 | val mkTyvar : tvKind -> tyvar 134 | val copyTyvar : tyvar -> tyvar 135 | 136 | datatype datacon (* data constructors *) 137 | = DATACON of 138 | {name : Symbol.symbol, 139 | typ : ty, 140 | rep : Access.conrep, 141 | lazyp : bool, (* LAZY *) 142 | const : bool, 143 | sign : Access.consig} 144 | 145 | end (* signature TYPES *) 146 | -------------------------------------------------------------------------------- /ElabData/types/types.sml: -------------------------------------------------------------------------------- 1 | (* types.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure Types : TYPES = 6 | struct 7 | 8 | local structure A = Access 9 | structure EP = EntPath 10 | structure IP = InvPath 11 | structure S = Symbol 12 | structure ST = Stamps 13 | in 14 | 15 | type label = S.symbol 16 | 17 | (* equality property indicators for polymorphically bound tyvars *) 18 | type polysign = bool list 19 | 20 | datatype eqprop = YES | NO | IND | OBJ | DATA | ABS | UNDEF 21 | 22 | datatype litKind = INT | WORD | REAL | CHAR | STRING 23 | 24 | datatype openTvKind 25 | = META (* metavariables: 26 | depth = infinity for meta-args 27 | depth < infinity for lambda bound *) 28 | | FLEX of (label * ty) list (* flex record variables *) 29 | 30 | and tvKind 31 | = INSTANTIATED of ty (* instantiation of an OPEN *) 32 | | OPEN of 33 | {depth: int, eq: bool, kind: openTvKind} 34 | | UBOUND of (* explicit type variables *) 35 | {depth: int, eq: bool, name: S.symbol} 36 | | LITERAL of (* type of a literal *) 37 | {kind: litKind, region: SourceMap.region} 38 | | SCHEME of bool (* overloaded operator type scheme variable 39 | * arg is true if must be instantiated to equality type *) 40 | | LBOUND of {depth: int, eq: bool, index: int} 41 | (* FLINT-style de Bruijn index for notional "lambda"-bound type variables 42 | * associated with polymorphic bindings (including val bindings and 43 | * functor parameter bindings). The depth is depth of type lambda bindings, 44 | * (1-based), and the index is the index within a sequence of 45 | * type variables bound at a given binding site. LBOUNDs must carry 46 | * equality type information for signature matching because the OPENs 47 | * are turned into LBOUNDs before equality type information is matched. *) 48 | 49 | and tycpath (* FLINT!!! *) 50 | = TP_VAR of exn (* exn carries some hidden FLINT data *) 51 | | TP_TYC of tycon 52 | | TP_FCT of tycpath list * tycpath list 53 | | TP_APP of tycpath * tycpath list 54 | | TP_SEL of tycpath * int 55 | 56 | and tyckind 57 | = PRIMITIVE of int 58 | | DATATYPE of 59 | {index: int, 60 | stamps: ST.stamp vector, 61 | root : EP.entVar option, (* the root field used by type spec only *) 62 | freetycs: tycon list, (* tycs derived from functor params *) 63 | family : dtypeFamily} 64 | | ABSTRACT of tycon 65 | | FLEXTYC of tycpath (* instantiated formal type constructor *) 66 | | FORMAL (* used only inside signatures *) 67 | | TEMP (* used only during datatype elaborations *) 68 | 69 | and tycon 70 | = GENtyc of gtrec 71 | | DEFtyc of 72 | {stamp : ST.stamp, 73 | tyfun : tyfun, 74 | strict: bool list, 75 | path : IP.path} 76 | | PATHtyc of (* used only inside signatures *) 77 | {arity : int, 78 | entPath : EP.entPath, 79 | path : IP.path} 80 | | RECORDtyc of label list 81 | | RECtyc of int (* used only in domain type of dconDesc *) 82 | | FREEtyc of int (* used only in domain type of dconDesc *) 83 | | ERRORtyc (* for error recovery, and used as a dummy 84 | tycon in ElabMod.extractSig *) 85 | 86 | and ty 87 | = VARty of tyvar 88 | | IBOUND of int 89 | | CONty of tycon * ty list 90 | | POLYty of {sign: polysign, tyfun: tyfun} 91 | | WILDCARDty 92 | | UNDEFty 93 | | MARKty of ty * SourceMap.region 94 | 95 | and tyfun 96 | = TYFUN of {arity: int, body: ty} 97 | 98 | withtype tyvar = tvKind ref 99 | 100 | (* datacon description used in dtmember *) 101 | and dconDesc = 102 | {name: S.symbol, 103 | rep: A.conrep, 104 | domain: ty option} 105 | 106 | (* member of a family of (potentially) mutually recursive datatypes *) 107 | and dtmember = 108 | {tycname: S.symbol, 109 | arity: int, 110 | eq: eqprop ref, 111 | lazyp: bool, 112 | dcons: dconDesc list, 113 | sign: A.consig} 114 | 115 | and dtypeFamily = 116 | {mkey: ST.stamp, 117 | members: dtmember vector, 118 | properties: PropList.holder} 119 | 120 | and stubinfo = 121 | {owner : PersStamps.persstamp, 122 | lib : bool} 123 | 124 | and gtrec = 125 | {stamp : ST.stamp, 126 | arity : int, 127 | eq : eqprop ref, 128 | kind : tyckind, 129 | path : IP.path, 130 | stub : stubinfo option} 131 | 132 | fun mkTyvar(kind: tvKind) : tyvar = ref kind 133 | 134 | fun copyTyvar(tv: tyvar) = ref(!tv) 135 | 136 | val infinity = 10000000 137 | 138 | datatype datacon (* data constructors *) 139 | = DATACON of 140 | {name : S.symbol, 141 | typ : ty, 142 | rep : A.conrep, 143 | lazyp : bool, (* LAZY: constructor belongs to lazy datatype? *) 144 | const : bool, (* redundant, could be determined from typ *) 145 | sign : A.consig} (* redundant, ditto *) 146 | 147 | end (* local *) 148 | end (* structure Types *) 149 | -------------------------------------------------------------------------------- /ElabData/types/typesutil.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* typesutil.sig *) 3 | 4 | signature TYPESUTIL = 5 | sig 6 | 7 | val eqpropToString : Types.eqprop -> string 8 | 9 | (* operations to build tyvars, VARtys *) 10 | val mkMETA : int -> Types.tvKind 11 | val mkFLEX : ((Symbol.symbol * Types.ty) list) * int -> Types.tvKind 12 | val mkUBOUND : Symbol.symbol -> Types.tvKind 13 | val mkLITERALty : Types.litKind * SourceMap.region -> Types.ty 14 | val mkSCHEMEty : unit -> Types.ty 15 | val mkMETAty : unit -> Types.ty 16 | val mkMETAtyBounded : int -> Types.ty 17 | 18 | (* primitive operations on tycons *) 19 | val tycName : Types.tycon -> Symbol.symbol 20 | val tycStamp : Types.tycon -> Stamps.stamp 21 | val tycPath : Types.tycon -> InvPath.path 22 | 23 | val tycEntPath : Types.tycon -> EntPath.entPath 24 | val tyconArity : Types.tycon -> int 25 | val setTycPath : Types.tycon * InvPath.path -> Types.tycon 26 | val eqTycon : Types.tycon * Types.tycon -> bool 27 | 28 | val prune : Types.ty -> Types.ty 29 | val pruneTyvar : Types.tyvar -> Types.ty 30 | 31 | val eqTyvar : Types.tyvar * Types.tyvar -> bool 32 | val bindTyvars : Types.tyvar list -> unit 33 | val bindTyvars1 : Types.tyvar list -> Types.polysign 34 | 35 | exception ReduceType 36 | val mapTypeFull: (Types.tycon -> Types.tycon) -> Types.ty -> Types.ty 37 | val applyTyfun : Types.tyfun * Types.ty list -> Types.ty 38 | val applyPoly : Types.ty * Types.ty list -> Types.ty 39 | val reduceType : Types.ty -> Types.ty 40 | val headReduceType : Types.ty -> Types.ty 41 | val nullReduceType : Types.ty -> Types.ty 42 | val equalType : Types.ty * Types.ty -> bool 43 | val equalTypeP : Types.ty * Types.ty -> bool 44 | val equalTycon : Types.tycon * Types.tycon -> bool 45 | 46 | (* making a "generic" copy of a type *) 47 | val typeArgs : int -> Types.ty list 48 | val mkPolySign : int -> Types.polysign 49 | 50 | val dconTyc : Types.datacon -> Types.tycon 51 | val dconType : Types.tycon * Types.ty option -> Types.ty 52 | 53 | (* matching a scheme against a target type -- used declaring overloadings *) 54 | val matchScheme : Types.tyfun * Types.ty -> Types.ty 55 | 56 | (* get rid of INSTANTIATED indirections in a type *) 57 | val compressTy : Types.ty -> unit 58 | 59 | type occ 60 | val Abstr : occ -> occ 61 | val LetDef: occ -> occ 62 | val Root : occ 63 | val lamdepth : occ -> int 64 | val toplevel : occ -> bool 65 | 66 | val instantiatePoly : Types.ty -> Types.ty * Types.tyvar list 67 | 68 | val compareTypes : Types.ty * Types.ty -> bool 69 | 70 | val indexBoundTyvars : int * Types.tyvar list -> unit 71 | 72 | val matchInstTypes : bool * int * Types.ty * Types.ty -> 73 | (Types.tyvar list * Types.tyvar list) option 74 | (* matchInstTypes probably supercedes compareTypes, and if so, 75 | * compareTypes should be deleted *) 76 | 77 | val tyvarType : Types.ty -> Types.tyvar 78 | 79 | (* 80 | * Check if a bound tyvar has occurred in some datatypes, e.g. 'a list. 81 | * this is useful for representation analysis; but it should be 82 | * obsolete very soon -- zsh. 83 | *) 84 | val getRecTyvarMap : int * Types.ty -> (int -> bool) 85 | val gtLabel : Symbol.symbol * Symbol.symbol -> bool 86 | 87 | val isValue : Absyn.exp -> bool 88 | (* checks whether an expression is nonexpansive; used to determine 89 | * when type generalization is permitted under the value rule *) 90 | (* 91 | dbm: where has this moved to? typecheck.sml? 92 | gk: restoring this function because PrimOpId is now self-contained. 93 | *) 94 | val isVarTy : Types.ty -> bool 95 | 96 | val sortFields : (Absyn.numberedLabel * 'a) list 97 | -> (Absyn.numberedLabel * 'a) list 98 | val mapUnZip : ('a -> 'b * 'c) -> 'a list -> 'b list * 'c list 99 | 100 | type tycset 101 | val mkTycSet : unit -> tycset 102 | val addTycSet : Types.tycon * tycset -> tycset 103 | val filterSet : Types.ty * tycset -> Types.tycon list 104 | 105 | val dtSibling : int * Types.tycon -> Types.tycon 106 | val extractDcons: Types.tycon -> Types.datacon list 107 | 108 | val wrapDef : Types.tycon * Stamps.stamp -> Types.tycon 109 | (* make a tycon into a DEFtyc by "eta-expanding" if necessary *) 110 | 111 | val unWrapDef1 : Types.tycon -> Types.tycon option 112 | val unWrapDefStar : Types.tycon -> Types.tycon 113 | 114 | val dummyTyGen : unit -> unit -> Types.ty 115 | (* create dummy type generators used to instantiate ungeneralizable 116 | * free type variables in Typechecking.generalizeTy *) 117 | 118 | end (* signature TYPESUTIL *) 119 | -------------------------------------------------------------------------------- /Elaborator/basics/conrep.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* conrep.sml *) 3 | 4 | signature CONREP = 5 | sig 6 | 7 | val infer : bool -> (Symbol.symbol * bool * Types.ty) list 8 | -> (Access.conrep list * Access.consig) 9 | 10 | end (* signature CONREP *) 11 | 12 | 13 | structure ConRep : CONREP = 14 | struct 15 | 16 | local open Access Types 17 | in 18 | 19 | fun err s = ErrorMsg.impossible ("Conrep: "^s) 20 | 21 | fun count predicate l = 22 | let fun test (a::rest,acc) = test (rest,if predicate a then 1+acc else acc) 23 | | test (nil,acc) = acc 24 | in test (l,0) 25 | end 26 | 27 | fun reduce ty = 28 | case TypesUtil.headReduceType ty 29 | of POLYty{tyfun=TYFUN{body,...},...} => reduce body 30 | | ty => ty 31 | 32 | fun notconst(_,true,_) = false 33 | (* 34 | | notconst(_,_,CONty(_,[t,_])) = 35 | (case (reduce t) 36 | of CONty(RECORDtyc nil,_) => false 37 | | _ => true) 38 | *) 39 | | notconst _ = true 40 | 41 | (* 42 | * fun show((sym,_,_)::syms, r::rs) = 43 | * (print(Symbol.name sym); print ": "; 44 | * PPBasics.ppRep r; print "\n"; show(syms,rs)) 45 | * | show _ = (print "\n") 46 | *) 47 | 48 | (* the first argument indicates whether this is a recursive datatypes *) 49 | fun infer false ([(_, false, CONty(_,[ty,_]))]) = 50 | (case (reduce ty) 51 | of (* (CONty(RECORDtyc nil, _)) => ([CONSTANT 0], CSIG (0,1)) 52 | | *) _ => ([UNTAGGED], CSIG(1,0)) (* [TRANSPARENT] *)) 53 | (* The TRANSPARENT conrep is temporarily turned off; 54 | it should be working very soon. Ask zsh. *) 55 | 56 | | infer _ cons = 57 | let val multiple = (count notconst cons) > 1 58 | 59 | fun decide (ctag,vtag, (_,true,_)::rest, reps) = 60 | if multiple andalso !ElabControl.boxedconstconreps 61 | then decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps) 62 | else decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps) 63 | 64 | | decide (ctag,vtag, (_,false,CONty(_,[ty,_]))::rest, reps) = 65 | (case (reduce ty, multiple) 66 | of (* 67 | (CONty(RECORDtyc nil,_),_) => 68 | decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps) 69 | | *) 70 | (_, true) => 71 | decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps) 72 | | (_, false) => 73 | decide(ctag, vtag+1, rest, (UNTAGGED :: reps))) 74 | | decide (_, _, _::_, _) = err "unexpected conrep-decide" 75 | | decide (ctag, vtag, [], reps) = (rev reps, CSIG(vtag,ctag)) 76 | 77 | in decide(0, 0, cons, []) 78 | end 79 | 80 | (*** val infer = fn l => let val l' = infer l in show(l,l'); l' end ***) 81 | 82 | end (* local *) 83 | end (* structure ConRep *) 84 | 85 | 86 | -------------------------------------------------------------------------------- /Elaborator/basics/debindex.sig: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *) 2 | (* debindex.sig *) 3 | 4 | (* I moved this into the elaborator library. It may be moved 5 | * back to FLINT if the elaborator gets "cleaned up", i.e., if 6 | * it is made to be unaware of such middle-end specifics. 7 | * (08/2001 Blume) *) 8 | 9 | signature DEB_INDEX = 10 | sig 11 | eqtype depth 12 | eqtype index 13 | 14 | val top : depth 15 | val next : depth -> depth 16 | val prev : depth -> depth 17 | val eq : depth * depth -> bool 18 | val calc : depth * depth -> index 19 | val cmp : depth * depth -> order 20 | 21 | val dp_print : depth -> string 22 | val dp_key : depth -> int 23 | val dp_toint: depth -> int 24 | val dp_fromint: int -> depth 25 | 26 | val di_print : index -> string 27 | val di_key : index -> int 28 | val di_toint: index -> int 29 | val di_fromint: int -> index 30 | 31 | val innermost : index 32 | val innersnd : index 33 | val di_inner : index -> index 34 | 35 | end (* signature DEB_INDEX *) 36 | 37 | 38 | -------------------------------------------------------------------------------- /Elaborator/basics/debindex.sml: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *) 2 | (* debindex.sml *) 3 | 4 | (* 5 | * This implements the abstraction of de Bruijn indices used 6 | * by the FLINT type and term language. The notion of depth 7 | * refers to the type-binding depth relative to the top level 8 | * of the current compilation unit. I can't make type depth 9 | * and index abstract because certain clients want to use 10 | * the values of these types as table indices. 11 | *) 12 | 13 | (* I moved this into the elaborator library. It may be moved 14 | * back to FLINT if the elaborator gets "cleaned up", i.e., if 15 | * it is made to be unaware of such middle-end specifics. 16 | * (08/2001 Blume) *) 17 | 18 | (* Basic PLambda type variables are pairs of 19 | * indices: (index, count) 20 | * where index (the deBruijn index) is the normal lambda binding distance 21 | * from the current type variable to its binder, starting with 1 to reference 22 | * the innermost binder. Each binder binds a tuple of variables, and 23 | * and the count is used to select from this tuple. The count is zero-based. 24 | * 25 | * depth is used to represent absolute type abstraction depth, with the top-level 26 | * being 0. The deBruijn index is calculated as the current abstraction depth 27 | * minus the abstraction depth of the binder of the type variable in question. 28 | * 29 | * At an abstraction, the binder depth is the then current depth (e.g. the outermost 30 | * binder will have depth=0), and the current depth is incremented when entering the 31 | * the scope of an abstraction. So the index of any bound type variable occurrence 32 | * is >= 1. 33 | *) 34 | 35 | structure DebIndex : DEB_INDEX = 36 | struct 37 | 38 | local structure EM = ErrorMsg 39 | in 40 | 41 | fun bug s = EM.impossible ("DebIndex: " ^ s) 42 | 43 | type depth = int (* INVARIANT: 0 <= depth *) 44 | type index = int (* INVARIANT: 1 <= index *) 45 | 46 | val top = 0 47 | 48 | fun next i = i + 1 49 | 50 | fun prev i = if (i > 0) then i-1 else bug "negative depth in prev" 51 | 52 | fun eq (i:int, j) = (i=j) 53 | 54 | fun dp_key (i : depth) = i 55 | 56 | fun dp_print i = Int.toString i 57 | 58 | fun dp_toint (i : depth) = i 59 | fun dp_fromint (i : int) = i 60 | 61 | fun calc (cur:int, def) = 62 | if def > cur then bug "the definition is deeper than the use" 63 | else (cur - def) 64 | 65 | val cmp = Int.compare 66 | 67 | fun di_key i = i 68 | 69 | fun di_print i = Int.toString i 70 | 71 | fun di_toint (i : index) = i 72 | fun di_fromint (i : int) = i 73 | 74 | val innermost = 1 75 | val innersnd = 2 76 | fun di_inner i = i+1 77 | 78 | end (* local *) 79 | end (* structure DebIndex *) 80 | 81 | 82 | -------------------------------------------------------------------------------- /Elaborator/basics/elabcontrol.sig: -------------------------------------------------------------------------------- 1 | (* elabcontrol.sig 2 | * 3 | * (C) SML Fellowship 4 | *) 5 | 6 | signature ELAB_CONTROL = 7 | sig 8 | 9 | val etdebugging : bool ref 10 | (* ElabType *) 11 | val esdebugging : bool ref 12 | (* ElabSig *) 13 | val insdebugging : bool ref 14 | (* Instantiate *) 15 | val smdebugging : bool ref 16 | (* Sigmatch *) 17 | val ecdebugging : bool ref 18 | (* ElabCore *) 19 | val emdebugging : bool ref 20 | (* ElabMod *) 21 | val tcdebugging : bool ref 22 | (* Typecheck *) 23 | val unidebugging : bool ref 24 | (* Unify *) 25 | val instantiateSigs : bool ref 26 | (* ElabMod, Control_MC *) 27 | 28 | val internals : bool ref 29 | 30 | val markabsyn : bool ref 31 | (* ElabCore, ElabTop, ElabUtil, Control_MC *) 32 | 33 | val boxedconstconreps : bool ref 34 | (* ConRep *) 35 | 36 | val multDefWarn : bool ref 37 | (* Instantiate, Control_MC (TopLevel/main/control.sml) *) 38 | 39 | val shareDefError : bool ref 40 | (* Instantiate, Control_MC *) 41 | 42 | val valueRestrictionLocalWarn : bool ref 43 | 44 | val valueRestrictionTopWarn : bool ref 45 | 46 | val showTypeErrorCulprits : bool ref 47 | 48 | end (* signature ELAB_CONTROL *) 49 | -------------------------------------------------------------------------------- /Elaborator/basics/elabcontrol.sml: -------------------------------------------------------------------------------- 1 | (* elabcontrol.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * Flags controlling the elaborator. 6 | *) 7 | 8 | structure ElabControl : ELAB_CONTROL = 9 | struct 10 | 11 | local 12 | val priority = [10, 10, 7] 13 | val clear = 2 14 | val obscure = 6 15 | val prefix = "elab" 16 | 17 | val registry = ControlRegistry.new { help = "elaborator flags" } 18 | 19 | val _ = BasicControl.nest (prefix, registry, priority) 20 | 21 | val nextpri = ref 0 22 | 23 | fun new ob (n, h, d) = let 24 | val r = ref d 25 | val p = !nextpri 26 | val ctl = Controls.control { name = n, 27 | pri = [p], 28 | obscurity = ob, 29 | help = h, 30 | ctl = r } 31 | in 32 | nextpri := p + 1; 33 | ControlRegistry.register 34 | registry 35 | { ctl = Controls.stringControl ControlUtil.Cvt.bool ctl, 36 | envName = SOME (ControlUtil.EnvName.toUpper "ELAB_" n) }; 37 | r 38 | end 39 | 40 | val cnew = new clear 41 | val onew = new obscure 42 | in 43 | 44 | val etdebugging = onew ("et-debugging", "ElabType debugging", false) 45 | (* ElabType *) 46 | val esdebugging = onew ("es-debugging", "ElabSig debugging", false) 47 | (* ElabSig *) 48 | val insdebugging = onew ("ins-debugging", "Instantiate debugging", false) 49 | (* Instantiate *) 50 | val smdebugging = onew ("sm-debugging", "Sigmatch debugging", false) 51 | (* Sigmatch *) 52 | val ecdebugging = onew ("ec-debugging", "ElabCore debugging", false) 53 | (* ElabCore *) 54 | val emdebugging = onew ("em-debugging", "ElabMod debugging", false) 55 | (* ElabMod *) 56 | val tcdebugging = onew ("tc-debugging", "TypeCheck debugging", false) 57 | (* Typecheck *) 58 | val unidebugging = onew ("uni-debugging", "Unify debugging", false) 59 | (* Unify *) 60 | val instantiateSigs = onew ("instantiate-sigs", "instantiate all sigs", true) 61 | (* ElabMod, Control_MC *) 62 | 63 | val internals = onew ("internals", "show internal reps", false) 64 | 65 | val markabsyn = onew ("markabsyn", "mark abstract syntax", true) 66 | (* ElabCore, ElabTop, ElabUtil, Control_MC *) 67 | 68 | val boxedconstconreps = onew ("boxedconstreps", "boxed const constructors", false) 69 | (* ConRep *) 70 | 71 | val multDefWarn = cnew ("mult-def-warn", "warn on multiple defs", false) 72 | (* Instantiate, Control_MC (TopLevel/main/control.sml) *) 73 | 74 | val shareDefError = cnew ("share-def-error", "check share defs", true) 75 | (* Instantiate, Control_MC *) 76 | 77 | val valueRestrictionLocalWarn = 78 | cnew ("value-restriction-local-warn", "warn on value restriction for local defs", false) 79 | 80 | val valueRestrictionTopWarn = 81 | cnew ("value-restriction-top-warn", "warn on value restriction at top level", true) 82 | 83 | val showTypeErrorCulprits = 84 | cnew ("show-type-error-culprits", "show culprits in type error messages", false) 85 | 86 | end (* local *) 87 | end (* structure ElabControl *) 88 | -------------------------------------------------------------------------------- /Elaborator/basics/ptnum.sml: -------------------------------------------------------------------------------- 1 | (* ptnum.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * All primitive type constructor numbers used in SML/NJ. 6 | *) 7 | signature PRIM_TYC_NUM = sig 8 | 9 | include CORE_PRIM_TYC_NUM 10 | 11 | val ptn_int31 : int 12 | val ptn_int32 : int 13 | val ptn_list : int 14 | val ptn_etag : int 15 | val ptn_cont : int 16 | val ptn_ccont : int 17 | val ptn_option : int 18 | val ptn_boxed : int 19 | val ptn_tgd : int 20 | val ptn_utgd : int 21 | val ptn_tnsp : int 22 | val ptn_dyn : int 23 | val ptn_obj : int 24 | val ptn_cfun : int 25 | val ptn_barray : int 26 | val ptn_rarray : int 27 | val ptn_slock : int 28 | val ptn_intinf : int 29 | end 30 | 31 | structure PrimTycNum : PRIM_TYC_NUM = struct 32 | open CorePrimTycNum 33 | 34 | val ptn_int31 = ptn_int 35 | 36 | local 37 | fun ptn i = next_free_ptn + i 38 | in 39 | 40 | val ptn_int32 = ptn 0 41 | val ptn_list = ptn 1 42 | val ptn_etag = ptn 2 43 | val ptn_cont = ptn 3 44 | val ptn_ccont = ptn 4 45 | val ptn_option = ptn 5 46 | val ptn_boxed = ptn 6 47 | val ptn_tgd = ptn 7 48 | val ptn_utgd = ptn 8 49 | val ptn_tnsp = ptn 9 50 | val ptn_dyn = ptn 10 51 | val ptn_obj = ptn 11 52 | val ptn_cfun = ptn 12 53 | val ptn_barray = ptn 13 54 | val ptn_rarray = ptn 14 55 | val ptn_slock = ptn 15 56 | val ptn_intinf = ptn 16 57 | 58 | val next_free_ptn = ptn 17 59 | end 60 | end 61 | -------------------------------------------------------------------------------- /Elaborator/elaborate.cm: -------------------------------------------------------------------------------- 1 | (* elaborate.cm 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | * 5 | * The SML/NJ elaborator. 6 | *) 7 | Group 8 | signature ELAB_CONTROL 9 | structure ElabControl 10 | 11 | signature PRIM_TYC_NUM 12 | signature DEB_INDEX 13 | signature BASICTYPES 14 | signature INSTANTIATE_PARAM 15 | signature INSTANTIATE 16 | signature EVALENTITY 17 | signature ELABTOP 18 | signature UNIFY 19 | signature TYPECHECK 20 | signature SIGMATCH 21 | 22 | functor InstantiateFn 23 | functor EvalEntityFn 24 | functor SigMatchFn 25 | functor ElabModFn 26 | functor ElabTopFn 27 | 28 | structure PrimTycNum 29 | structure DebIndex 30 | structure BasicTypes 31 | structure ElabUtil 32 | structure SpecialSymbols 33 | structure ElabDebug 34 | structure Unify 35 | structure Typecheck 36 | 37 | signature PPUTIL 38 | signature PPUTILNEW 39 | signature PPTYPE 40 | signature PPABSYN 41 | signature PPMOD 42 | signature PPVAL 43 | signature PPAST 44 | 45 | structure PPUtil 46 | structure PPUtilNew 47 | structure PPPrim 48 | structure PPType 49 | structure PPAbsyn 50 | structure PPModules 51 | structure PPVal 52 | structure PPAst 53 | is 54 | 55 | basics/elabcontrol.sig 56 | basics/elabcontrol.sml 57 | basics/debindex.sig 58 | basics/debindex.sml 59 | basics/conrep.sml 60 | basics/ptnum.sml 61 | 62 | types/basictypes.sig 63 | types/basictypes.sml 64 | types/eqtypes.sml 65 | types/unify.sml 66 | types/overload.sml 67 | types/overloadlit.sml 68 | types/typecheck.sml 69 | 70 | modules/expandtycon.sml 71 | modules/sigmatch.sml 72 | modules/instantiate.sml 73 | modules/evalent.sml 74 | 75 | elaborate/tyvarset.sml 76 | elaborate/elabutil.sig 77 | elaborate/elabutil.sml 78 | elaborate/specialsyms.sml 79 | elaborate/elabtype.sig 80 | elaborate/elabtype.sml 81 | elaborate/precedence.sml 82 | elaborate/elabcore.sml 83 | elaborate/include.sml 84 | elaborate/elabsig.sml 85 | elaborate/elabdebug.sml 86 | elaborate/elabmod.sml 87 | elaborate/elabtop.sml 88 | 89 | print/ppprim.sml 90 | print/pputil.sig 91 | print/pputil.sml 92 | print/pputil-new.sig 93 | print/pputil-new.sml 94 | print/pptype.sml 95 | print/ppval.sml 96 | print/ppabsyn.sml 97 | print/ppmod.sml 98 | print/ppast.sig 99 | print/ppast.sml 100 | 101 | $smlnj/viscomp/elabdata.cm 102 | $smlnj/viscomp/basics.cm 103 | $smlnj/viscomp/parser.cm 104 | 105 | $smlnj/MLRISC/MLRISC.cm 106 | 107 | $smlnj/smlnj-lib/smlnj-lib.cm 108 | $smlnj/smlnj-lib/controls-lib.cm 109 | $smlnj/basis/basis.cm 110 | -------------------------------------------------------------------------------- /Elaborator/elaborate/elabdebug.sml: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1996 Bell Laboratories*) 2 | (* elabdebug.sml *) 3 | 4 | signature ELABDEBUG = 5 | sig 6 | val debugPrint : bool ref 7 | -> (string * 8 | (PrettyPrintNew.stream -> 'a -> unit) * 9 | 'a) 10 | -> unit 11 | val ppSymList : PrettyPrintNew.stream -> Symbol.symbol list -> unit 12 | val envSymbols : StaticEnv.staticEnv -> Symbol.symbol list 13 | val checkEnv : StaticEnv.staticEnv * Symbol.symbol -> string 14 | val withInternals : (unit -> 'a) -> 'a 15 | 16 | end (* signature ELABDEBUG *) 17 | 18 | 19 | structure ElabDebug : ELABDEBUG = 20 | struct 21 | 22 | local 23 | structure S = Symbol 24 | structure SE = StaticEnv 25 | structure PP = PrettyPrintNew 26 | structure PU = PPUtilNew 27 | structure EM = ErrorMsg 28 | 29 | open PP 30 | 31 | in 32 | 33 | fun debugPrint (debugging: bool ref) 34 | (msg: string, printfn: PP.stream -> 'a -> unit, arg: 'a) = 35 | if (!debugging) then 36 | with_default_pp 37 | (fn ppstrm => 38 | (openHVBox ppstrm (PP.Rel 0); 39 | PP.string ppstrm msg; 40 | newline ppstrm; 41 | PP.nbSpace ppstrm 2; 42 | openHVBox ppstrm (PP.Rel 0); 43 | printfn ppstrm arg; 44 | closeBox ppstrm; 45 | newline ppstrm; 46 | closeBox ppstrm; 47 | PP.flushStream ppstrm)) 48 | else () 49 | 50 | fun ppSymList ppstrm (syms: S.symbol list) = 51 | PU.ppClosedSequence ppstrm 52 | {front=(fn ppstrm => PP.string ppstrm "["), 53 | sep=(fn ppstrm => (PP.string ppstrm ",")), 54 | back=(fn ppstrm => PP.string ppstrm "]"), 55 | style=PU.INCONSISTENT, 56 | pr=PU.ppSym} 57 | syms 58 | 59 | 60 | (* more debugging *) 61 | fun envSymbols (env: SE.staticEnv) = 62 | SE.fold (fn ((s,_),sl) => s::sl) nil env 63 | 64 | fun checkEnv (env: SE.staticEnv, sym: S.symbol) = 65 | (SE.look(env,sym); "YES") handle SE.Unbound => "NO" 66 | 67 | fun withInternals (f: unit -> 'a) = 68 | let val internals = !ElabControl.internals 69 | in ElabControl.internals := true; 70 | (f() before 71 | ElabControl.internals := internals) 72 | handle exn => (ElabControl.internals := internals; raise exn) 73 | end 74 | 75 | end (* local *) 76 | end (* structure ElabDebug *) 77 | -------------------------------------------------------------------------------- /Elaborator/elaborate/elabtype.sig: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1998 Bell Laboratories *) 2 | (* elabtype.sig *) 3 | 4 | signature ELABTYPE = 5 | sig 6 | 7 | val elabType : 8 | Ast.ty * StaticEnv.staticEnv * ErrorMsg.errorFn * SourceMap.region 9 | -> Types.ty * TyvarSet.tyvarset 10 | 11 | val elabTyvList : 12 | Ast.tyvar list * ErrorMsg.errorFn * SourceMap.region 13 | -> Types.tyvar list 14 | 15 | val elabTYPEdec : 16 | Ast.tb list * StaticEnv.staticEnv * InvPath.path 17 | * SourceMap.region * ElabUtil.compInfo 18 | -> Absyn.dec * StaticEnv.staticEnv 19 | 20 | val elabDATATYPEdec : 21 | {datatycs: Ast.db list, withtycs: Ast.tb list} * StaticEnv.staticEnv 22 | * ExpandTycon.sigContext * EntityEnv.entityEnv 23 | * (Types.tycon -> bool) * InvPath.path 24 | * SourceMap.region * ElabUtil.compInfo 25 | -> Types.tycon list * Types.tycon list * VarCon.datacon list 26 | * StaticEnv.staticEnv 27 | 28 | val debugging : bool ref 29 | 30 | end (* signature ELABTYPE *) 31 | -------------------------------------------------------------------------------- /Elaborator/elaborate/elabutil.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1992 by AT&T Bell Laboratories *) 2 | 3 | (* Utility functions to build absyn from ast *) 4 | 5 | signature ELABUTIL = 6 | sig 7 | 8 | datatype context 9 | = TOP (* at top level -- not inside any module, rigid *) 10 | | INSTR (* inside a rigid structure, i.e. not inside any functor body *) 11 | | INFCT of {flex: Stamps.stamp -> bool, depth: DebIndex.depth} 12 | (* predicate recognizing flexible stamps *) 13 | | INSIG (* within a signature body *) 14 | 15 | type compInfo = Absyn.dec CompInfo.compInfo 16 | 17 | val debugging : bool ref 18 | val for : 'a list -> ('a -> unit) -> unit 19 | val discard : 'a -> unit 20 | val single : 'a -> 'a list 21 | val sort3 : (Symbol.symbol * 'a * 'b) list -> (Symbol.symbol * 'a * 'b) list 22 | 23 | val EQUALsym : Symbol.symbol 24 | val bogusID : Symbol.symbol 25 | val bogusExnID : Symbol.symbol 26 | val anonParamName : Symbol.symbol 27 | 28 | val CONSexp : Absyn.exp 29 | val CONSpat : Absyn.pat -> Absyn.pat 30 | val FALSEexp : Absyn.exp 31 | val FALSEpat : Absyn.pat 32 | val NILexp : Absyn.exp 33 | val NILpat : Absyn.pat 34 | val TRUEexp : Absyn.exp 35 | val TRUEpat : Absyn.pat 36 | val TUPLEexp : Absyn.exp list -> Absyn.exp 37 | val TPSELexp : Absyn.exp * int -> Absyn.exp 38 | val TUPLEpat : Absyn.pat list -> Absyn.pat 39 | val unitExp : Absyn.exp 40 | val unitPat : Absyn.pat 41 | val bogusExp: Absyn.exp 42 | 43 | val bindVARp : Absyn.pat list * ErrorMsg.complainer -> StaticEnv.staticEnv 44 | 45 | val checkUniq : ErrorMsg.complainer * string * Symbol.symbol list -> unit 46 | 47 | val clean_pat : ErrorMsg.complainer -> Absyn.pat -> Absyn.pat 48 | 49 | (* 50 | val getCoreExn : (StaticEnv.staticEnv * string) -> VarCon.datacon 51 | val getCoreVar : (StaticEnv.staticEnv * string) -> VarCon.var 52 | *) 53 | val completeMatch : (StaticEnv.staticEnv * string) 54 | -> Absyn.rule list -> Absyn.rule list 55 | val completeMatch' : Absyn.rule -> Absyn.rule list -> Absyn.rule list 56 | 57 | val makeAPPpat : ErrorMsg.complainer -> Absyn.pat * Absyn.pat -> Absyn.pat 58 | val makeHANDLEexp : Absyn.exp * Absyn.rule list * compInfo -> Absyn.exp 59 | val makeLAYEREDpat : Absyn.pat * Absyn.pat * ErrorMsg.complainer -> Absyn.pat 60 | val makeRECORDexp : 61 | (Symbol.symbol * Absyn.exp) list * ErrorMsg.complainer -> Absyn.exp 62 | val makeRECORDpat : 63 | (Symbol.symbol * Absyn.pat) list * bool * ErrorMsg.complainer 64 | -> Absyn.pat 65 | 66 | val calc_strictness : int * Types.ty -> bool list 67 | 68 | val checkBoundTyvars : 69 | TyvarSet.tyvarset * Types.tyvar list * ErrorMsg.complainer -> unit 70 | 71 | val pat_id : 72 | SymPath.path * StaticEnv.staticEnv * ErrorMsg.complainer * compInfo 73 | -> Absyn.pat 74 | 75 | val sortRecord : 76 | (Symbol.symbol * 'a) list * ErrorMsg.complainer 77 | -> (Symbol.symbol * 'a) list 78 | 79 | val FUNdec : 80 | (Absyn.rule list -> Absyn.rule list) 81 | * {var : VarCon.var, 82 | clauses: {pats: Absyn.pat list, 83 | resultty: Types.ty option, 84 | exp: Absyn.exp} list, 85 | tyvars: Types.tyvar list ref, 86 | region: Ast.region } list 87 | * compInfo -> (Absyn.dec * StaticEnv.staticEnv) 88 | 89 | val wrapRECdec : Absyn.rvb list * compInfo 90 | -> (Absyn.dec * StaticEnv.staticEnv) 91 | 92 | val labsym : Absyn.numberedLabel -> Symbol.symbol 93 | 94 | val recDecs : Absyn.rvb list -> Absyn.dec 95 | 96 | val hasModules : Ast.dec -> bool 97 | 98 | end (* signature ELABUTIL *) 99 | -------------------------------------------------------------------------------- /Elaborator/elaborate/precedence.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* precedence.sml *) 3 | 4 | signature PRECEDENCE = 5 | sig 6 | val parse: {apply: 'a * 'a -> 'a, pair: 'a * 'a -> 'a} -> 7 | 'a Ast.fixitem list * StaticEnv.staticEnv * 8 | (Ast.region->ErrorMsg.complainer) -> 'a 9 | 10 | end (* signature PRECEDENCE *) 11 | 12 | 13 | structure Precedence : PRECEDENCE = 14 | struct 15 | 16 | local structure EM = ErrorMsg 17 | structure F = Fixity 18 | 19 | in 20 | 21 | datatype 'a precStack 22 | = INf of Symbol.symbol * int * 'a * 'a precStack 23 | | NONf of 'a * 'a precStack 24 | | NILf 25 | 26 | fun parse {apply,pair} = 27 | let fun ensureNONf((e,F.NONfix,_,err),p) = NONf(e,p) 28 | | ensureNONf((e,F.INfix _,SOME sym,err),p) = 29 | (err EM.COMPLAIN 30 | ("expression or pattern begins with infix identifier \"" 31 | ^ Symbol.name sym ^ "\"") EM.nullErrorBody; 32 | NONf(e,p)) 33 | | ensureNONf _ = EM.impossible "precedence:ensureNONf" 34 | 35 | fun start token = ensureNONf(token,NILf) 36 | 37 | (* parse an expression *) 38 | fun parse(NONf(e,r), (e',F.NONfix,_,err)) = NONf(apply(e,e'),r) 39 | | parse(p as INf _, token) = ensureNONf(token,p) 40 | | parse(p as NONf(e1,INf(_,bp,e2,NONf(e3,r))), 41 | (e4, f as F.INfix(lbp,rbp),SOME sym,err))= 42 | if lbp > bp then INf(sym,rbp,e4,p) 43 | else (if lbp = bp 44 | then err EM.WARN "mixed left- and right-associative \ 45 | \operators of same precedence" 46 | EM.nullErrorBody 47 | else (); 48 | parse(NONf(apply(e2,pair (e3,e1)),r),(e4,f,SOME sym,err))) 49 | 50 | | parse(p as NONf _, (e',F.INfix(lbp,rbp),SOME sym,_)) = 51 | INf(sym,rbp,e',p) 52 | | parse _ = EM.impossible "Precedence.parse" 53 | 54 | (* clean up the stack *) 55 | fun finish (NONf(e1,INf(_,_,e2,NONf(e3,r))),err) = 56 | finish(NONf(apply(e2,pair (e3,e1)),r),err) 57 | | finish (NONf(e1,NILf),_) = e1 58 | | finish (INf(sym,_,e1,NONf(e2,p)),err) = 59 | (err EM.COMPLAIN 60 | ("expression or pattern ends with infix identifier \"" 61 | ^ Symbol.name sym ^ "\"") EM.nullErrorBody; 62 | finish(NONf(apply(e2,e1),p),err)) 63 | | finish (NILf,err) = EM.impossible "Corelang.finish NILf" 64 | | finish _ = EM.impossible "Corelang.finish" 65 | 66 | in fn (items as item1 :: items',env,error) => 67 | let fun getfix{item,region,fixity} = 68 | (item, case fixity of NONE => F.NONfix 69 | | SOME sym => Lookup.lookFix(env,sym), 70 | fixity, error region) 71 | 72 | fun endloc[{region=(_,x),item,fixity}] = error(x,x) 73 | | endloc(_::a) = endloc a 74 | | endloc _ = EM.impossible "precedence:endloc" 75 | 76 | fun loop(state, a::rest) = loop(parse(state,getfix a),rest) 77 | | loop(state,nil) = finish(state, endloc items) 78 | 79 | in loop(start(getfix item1), items') 80 | end 81 | | _ => EM.impossible "precedence:parse" 82 | end 83 | 84 | end (* local *) 85 | end (* structure Precedence *) 86 | -------------------------------------------------------------------------------- /Elaborator/elaborate/specialsyms.sml: -------------------------------------------------------------------------------- 1 | (* specialsyms.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure SpecialSymbols = struct 6 | local 7 | structure S = Symbol 8 | in 9 | val paramId = S.strSymbol "" 10 | val functorId = S.fctSymbol "" 11 | val hiddenId = S.strSymbol "" 12 | val tempStrId = S.strSymbol "" 13 | val tempFctId = S.fctSymbol "" 14 | val fctbodyId = S.strSymbol "" 15 | val anonfsigId = S.fsigSymbol "" 16 | val resultId = S.strSymbol "" 17 | val returnId = S.strSymbol "" 18 | val internalVarId = S.varSymbol "" 19 | end 20 | end 21 | -------------------------------------------------------------------------------- /Elaborator/elaborate/tyvarset.sml: -------------------------------------------------------------------------------- 1 | (* tyvarset.sml 2 | * 3 | * COPYRIGHT (c) 1996 Bell Laboratories. 4 | * 5 | *) 6 | 7 | signature TYVARSET = 8 | sig 9 | type tyvarset 10 | val empty : tyvarset 11 | val singleton : Types.tyvar -> tyvarset 12 | val mkTyvarset : Types.tyvar list -> tyvarset 13 | val union : tyvarset * tyvarset * ErrorMsg.complainer -> tyvarset 14 | val diff : tyvarset * tyvarset * ErrorMsg.complainer -> tyvarset 15 | val diffPure : tyvarset * tyvarset -> tyvarset 16 | val elements: tyvarset -> Types.tyvar list 17 | end (* signature TYVARSET *) 18 | 19 | structure TyvarSet :> TYVARSET = 20 | struct 21 | 22 | local 23 | structure EM = ErrorMsg 24 | open Types 25 | fun bug msg = ErrorMsg.impossible("TyvarSet: "^msg) 26 | in 27 | 28 | type tyvarset = tyvar list 29 | 30 | val empty = nil 31 | fun singleton t = [t] 32 | fun mkTyvarset l = l 33 | fun elements s = s 34 | 35 | fun mem(a as ref(UBOUND{name=name_a,eq=eq_a,depth=depth_a}), 36 | (b as ref(UBOUND{name=name_b,eq=eq_b,depth=depth_b}))::rest,err) = 37 | if a=b then true 38 | else if Symbol.eq(name_a,name_b) then 39 | (if eq_a<>eq_b then 40 | err EM.COMPLAIN ("type variable " ^ (Symbol.name name_a) ^ 41 | " occurs with different equality properties \ 42 | \in the same scope") 43 | EM.nullErrorBody 44 | else (); 45 | if depth_a<>depth_b then bug "mem - depths differ" else (); 46 | (* UBOUND tyvars are created with depth infinity and 47 | * this should not change until type checking is done *) 48 | a := INSTANTIATED(VARty b); 49 | true) 50 | else mem(a,rest,err) 51 | | mem _ = false 52 | 53 | fun memP(a as ref(UBOUND{name=name_a,...}), 54 | (b as ref(UBOUND{name=name_b,...}))::rest) = 55 | if a=b then true 56 | else if Symbol.eq(name_a,name_b) then true 57 | else memP(a,rest) 58 | | memP _ = false 59 | 60 | fun union([],s,err) = s 61 | | union(s,[],err) = s 62 | | union(a::r,s,err) = 63 | if mem(a,s,err) then union(r,s,err) 64 | else a::union(r,s,err) 65 | 66 | fun diff(s,[],err) = s 67 | | diff([],_,err) = [] 68 | | diff(a::r,s,err) = 69 | if mem(a,s,err) then diff(r,s,err) 70 | else a::diff(r,s,err) 71 | 72 | fun diffPure(s,[]) = s 73 | | diffPure([],_) = [] 74 | | diffPure(a::r,s) = 75 | if memP(a,s) then diffPure(r,s) 76 | else a::diffPure(r,s) 77 | 78 | end (* local *) 79 | end (* abstraction TyvarSet *) 80 | 81 | -------------------------------------------------------------------------------- /Elaborator/modules/expandtycon.sml: -------------------------------------------------------------------------------- 1 | (* expandtycon.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature EXPAND_TYCON = 6 | sig 7 | type sigContext = Modules.elements list 8 | val expandTycon : Types.tycon * sigContext * EntityEnv.entityEnv -> Types.tycon 9 | val debugging : bool ref 10 | end 11 | 12 | structure ExpandTycon : EXPAND_TYCON = 13 | struct 14 | 15 | local (* imported structures *) 16 | structure T = Types 17 | structure TU = TypesUtil 18 | structure EP = EntPath 19 | structure M = Modules 20 | structure MU = ModuleUtil 21 | in 22 | 23 | (* debugging hooks *) 24 | val say = Control_Print.say 25 | val debugging = ref false 26 | fun debugmsg (msg: string) = 27 | if !debugging then (say msg; say "\n") else () 28 | fun bug s = ErrorMsg.impossible ("ExpandTycon: " ^ s) 29 | 30 | type sigContext = M.elements list 31 | 32 | exception OUTER 33 | 34 | (* ignoring FCTspec - won't find any types there *) 35 | fun lookEntVar(ev,(_,s as (M.TYCspec{entVar,...} | 36 | M.STRspec{entVar,...}))::rest) = 37 | if EP.eqEntVar(ev,entVar) then SOME s else lookEntVar(ev,rest) 38 | | lookEntVar(ev,_::rest) = lookEntVar(ev,rest) 39 | | lookEntVar(ev,nil) = NONE 40 | 41 | fun findContext(ev,context as elements0::outer) = 42 | (case lookEntVar(ev, elements0) 43 | of SOME(M.STRspec{sign as M.SIG {elements,...},...}) => 44 | elements :: context 45 | | NONE => findContext(ev,outer) 46 | | _ => bug "findContext - bad element") 47 | | findContext(ev,nil) = raise OUTER 48 | 49 | fun expandTycon(tycon,context,entEnv) = 50 | let fun expandTycVar(ev,context as elements::outer) : T.tycon = 51 | (case lookEntVar(ev, elements) 52 | of SOME(M.TYCspec{info=M.RegTycSpec{spec,...},...}) => 53 | (case spec 54 | of T.GENtyc _ => spec 55 | | T.DEFtyc{stamp,strict,path,tyfun} => 56 | T.DEFtyc{stamp=stamp,strict=strict,path=path, 57 | tyfun=expandTyfun(tyfun,context)} 58 | | _ => bug "expandTycon 2") 59 | | NONE => (* try outer context *) 60 | expandTycVar(ev,outer) 61 | | _ => bug "expandTycon 1") 62 | | expandTycVar(ev,nil) = raise OUTER 63 | 64 | and expandTyc context = 65 | fn (tyc as T.PATHtyc{entPath,...}) => 66 | (expandPath(entPath,context) 67 | handle OUTER => (* path outside current signature context *) 68 | MU.transTycon entEnv tyc) 69 | | tyc => tyc 70 | 71 | and expandTyfun(T.TYFUN{arity,body},context) = 72 | T.TYFUN{arity=arity, 73 | body=TU.mapTypeFull (expandTyc context) body} 74 | 75 | and expandPath(ep, context) = 76 | (case ep 77 | of nil => bug "expandPath 1" 78 | | ev :: nil => (* tycon! *) 79 | expandTycVar(ev,context) 80 | | ev :: rest => (* substructure! *) 81 | expandPath(rest,findContext(ev, context))) 82 | 83 | in expandTyc context tycon 84 | end 85 | 86 | end (* local *) 87 | end (* structure ExpandTycon *) 88 | -------------------------------------------------------------------------------- /Elaborator/modules/sigmatch.sig: -------------------------------------------------------------------------------- 1 | 2 | signature SIGMATCH = 3 | sig 4 | 5 | structure EvalEntity : EVALENTITY 6 | 7 | (*** these four functions are only called inside elabmod.sml ***) 8 | val matchStr : 9 | {sign : Modules.Signature, 10 | str : Modules.Structure, 11 | strExp : Modules.strExp, 12 | evOp : EntPath.entVar option, 13 | depth : DebIndex.depth, 14 | entEnv : Modules.entityEnv, 15 | rpath : InvPath.path, 16 | statenv : StaticEnv.staticEnv, 17 | region : SourceMap.region, 18 | compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, 19 | resStr : Modules.Structure, 20 | resExp : Modules.strExp} 21 | 22 | val matchFct : 23 | {sign : Modules.fctSig, 24 | fct : Modules.Functor, 25 | fctExp : Modules.fctExp, 26 | depth : DebIndex.depth, 27 | entEnv : Modules.entityEnv, 28 | rpath : InvPath.path, 29 | statenv : StaticEnv.staticEnv, 30 | region : SourceMap.region, 31 | compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, 32 | resFct : Modules.Functor, 33 | resExp : Modules.fctExp} 34 | 35 | val packStr : 36 | {sign : Modules.Signature, 37 | str : Modules.Structure, 38 | strExp : Modules.strExp, 39 | depth : DebIndex.depth, 40 | entEnv : Modules.entityEnv, 41 | rpath : InvPath.path, 42 | statenv : StaticEnv.staticEnv, 43 | region : SourceMap.region, 44 | compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, 45 | resStr : Modules.Structure, 46 | resExp : Modules.strExp} 47 | 48 | val applyFct : 49 | {fct : Modules.Functor, 50 | fctExp : Modules.fctExp, 51 | argStr : Modules.Structure, 52 | argExp : Modules.strExp, 53 | evOp : EntPath.entVar option, 54 | depth : DebIndex.depth, 55 | epc : EntPathContext.context, 56 | statenv : StaticEnv.staticEnv, 57 | rpath : InvPath.path, 58 | region : SourceMap.region, 59 | compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, 60 | resStr : Modules.Structure, 61 | resExp : Modules.strExp} 62 | 63 | 64 | val debugging : bool ref 65 | val showsigs : bool ref 66 | 67 | end (* signature SIGMATCH *) 68 | -------------------------------------------------------------------------------- /Elaborator/print/ppast.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 2003 by University of Chicago *) 2 | (* src/Elaborator/print/ppast.sig *) 3 | (* Jing Cao and Lukasz Ziarek *) 4 | 5 | signature PPAST = 6 | 7 | sig 8 | val ppExp :StaticEnv.staticEnv * Source.inputSource option 9 | -> PrettyPrintNew.stream -> Ast.exp * int -> unit 10 | val ppPat :StaticEnv.staticEnv * Source.inputSource option 11 | -> PrettyPrintNew.stream -> Ast.pat * int -> unit 12 | val ppStrExp :StaticEnv.staticEnv * Source.inputSource option 13 | -> PrettyPrintNew.stream -> Ast.strexp * int -> unit 14 | val ppFctExp :StaticEnv.staticEnv * Source.inputSource option 15 | -> PrettyPrintNew.stream -> Ast.fctexp * int -> unit 16 | val ppWhereSpec :StaticEnv.staticEnv * Source.inputSource option 17 | -> PrettyPrintNew.stream -> Ast.wherespec * int -> unit 18 | val ppSigExp :StaticEnv.staticEnv * Source.inputSource option 19 | -> PrettyPrintNew.stream -> Ast.sigexp * int -> unit 20 | val ppFsigExp :StaticEnv.staticEnv * Source.inputSource option 21 | -> PrettyPrintNew.stream -> Ast.fsigexp * int -> unit 22 | val ppSpec :StaticEnv.staticEnv * Source.inputSource option 23 | -> PrettyPrintNew.stream -> Ast.spec * int -> unit 24 | val ppDec :StaticEnv.staticEnv * Source.inputSource option 25 | -> PrettyPrintNew.stream -> Ast.dec * int -> unit 26 | val ppVb : StaticEnv.staticEnv * Source.inputSource option 27 | -> PrettyPrintNew.stream -> Ast.vb * int -> unit 28 | val ppRvb : StaticEnv.staticEnv * Source.inputSource option 29 | -> PrettyPrintNew.stream -> Ast.rvb * int -> unit 30 | val ppFb : StaticEnv.staticEnv * Source.inputSource option 31 | -> PrettyPrintNew.stream -> string -> Ast.fb * int -> unit 32 | val ppClause : StaticEnv.staticEnv * Source.inputSource option 33 | -> PrettyPrintNew.stream -> Ast.clause * int -> unit 34 | val ppTb : StaticEnv.staticEnv * Source.inputSource option 35 | -> PrettyPrintNew.stream -> Ast.tb * int -> unit 36 | val ppDb : StaticEnv.staticEnv * Source.inputSource option 37 | -> PrettyPrintNew.stream -> Ast.db * int -> unit 38 | val ppDbrhs : StaticEnv.staticEnv * Source.inputSource option 39 | -> PrettyPrintNew.stream -> (Symbol.symbol * Ast.ty option) list * int -> unit 40 | val ppEb : StaticEnv.staticEnv * Source.inputSource option 41 | -> PrettyPrintNew.stream -> Ast.eb * int -> unit 42 | val ppStrb : StaticEnv.staticEnv * Source.inputSource option 43 | -> PrettyPrintNew.stream -> Ast.strb * int -> unit 44 | val ppFctb : StaticEnv.staticEnv * Source.inputSource option 45 | -> PrettyPrintNew.stream -> Ast.fctb * int -> unit 46 | val ppTyvar : StaticEnv.staticEnv * Source.inputSource option 47 | -> PrettyPrintNew.stream -> Ast.tyvar * int -> unit 48 | val ppTy : StaticEnv.staticEnv * Source.inputSource option 49 | -> PrettyPrintNew.stream -> Ast.ty * int -> unit 50 | end 51 | -------------------------------------------------------------------------------- /Elaborator/print/ppprim.sml: -------------------------------------------------------------------------------- 1 | structure PPPrim = 2 | struct 3 | 4 | local 5 | structure PP = PrettyPrintNew 6 | structure PU = PPUtilNew 7 | open PPUtilNew 8 | in 9 | 10 | fun ppPrim ppstrm prim = 11 | let val pps = PU.pps ppstrm 12 | in (case prim 13 | of PrimOpId.NonPrim => pps "" 14 | | PrimOpId.Prim(name) => 15 | (pps "")) 16 | end (* function ppPrim *) 17 | 18 | fun ppStrPrimInfo ppstrm strPrimInfo = 19 | let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm 20 | fun ppStrPrimElem ppstrm (PrimOpId.PrimE p) = ppPrim ppstrm p 21 | | ppStrPrimElem ppstrm (PrimOpId.StrE ps) = ppStrPrimInfo ppstrm ps 22 | in 23 | ppSequence ppstrm 24 | {sep = fn ppstrm => (PP.string ppstrm ", "; 25 | PP.break ppstrm {nsp=1, offset=0}), 26 | pr = (fn _ => fn elem => 27 | (openHOVBox 1; 28 | pps "("; 29 | ppStrPrimElem ppstrm; 30 | pps ")"; 31 | closeBox())), 32 | style = INCONSISTENT} 33 | strPrimInfo 34 | end (* function ppStrPrimInfo *) 35 | 36 | end (* local *) 37 | 38 | end (* structure PPPrim *) 39 | -------------------------------------------------------------------------------- /Elaborator/print/pputil-new.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1989 by AT&T Bell Laboratories *) 2 | 3 | signature PPUTILNEW = 4 | sig 5 | 6 | datatype break_style = CONSISTENT | INCONSISTENT 7 | 8 | val openStyleBox : break_style -> PrettyPrintNew.stream -> PrettyPrintNew.indent -> unit 9 | 10 | val ppSequence : PrettyPrintNew.stream -> 11 | {sep: PrettyPrintNew.stream->unit, 12 | pr: PrettyPrintNew.stream->'a->unit, 13 | style: break_style} 14 | -> 'a list -> unit 15 | val ppClosedSequence : PrettyPrintNew.stream 16 | -> {front:PrettyPrintNew.stream->unit, 17 | sep:PrettyPrintNew.stream->unit, 18 | back:PrettyPrintNew.stream->unit, 19 | pr:PrettyPrintNew.stream->'a->unit, 20 | style:break_style} 21 | -> 'a list -> unit 22 | val ppSym : PrettyPrintNew.stream -> Symbol.symbol -> unit 23 | val mlstr : string -> string 24 | val pp_mlstr : PrettyPrintNew.stream -> string -> unit 25 | val pp_intinf : PrettyPrintNew.stream -> IntInf.int -> unit 26 | val ppvseq : PrettyPrintNew.stream 27 | -> int -> string -> (PrettyPrintNew.stream -> 'a -> unit) 28 | -> 'a list -> unit 29 | val ppvlist : PrettyPrintNew.stream 30 | -> string * string * (PrettyPrintNew.stream -> 'a -> unit) * 'a list 31 | -> unit 32 | val ppvlist' : PrettyPrintNew.stream 33 | -> string * string * (PrettyPrintNew.stream -> string -> 'a -> unit) 34 | * 'a list 35 | -> unit 36 | val ppIntPath : PrettyPrintNew.stream -> int list -> unit 37 | val ppSymPath : PrettyPrintNew.stream -> SymPath.path -> unit 38 | val ppInvPath : PrettyPrintNew.stream -> InvPath.path -> unit 39 | val nl_indent : PrettyPrintNew.stream -> int -> unit 40 | 41 | (* needed in PPTypes, PPModules *) 42 | val findPath : InvPath.path * ('a -> bool) * (SymPath.path -> 'a) 43 | -> (Symbol.symbol list * bool) 44 | 45 | val ppTuple: PrettyPrintNew.stream 46 | -> (PrettyPrintNew.stream -> 'a -> unit) -> 'a list -> unit 47 | 48 | val pps: PrettyPrintNew.stream -> string -> unit 49 | val ppi: PrettyPrintNew.stream -> int -> unit 50 | val ppcomma : PrettyPrintNew.stream -> unit 51 | val ppcomma_nl : PrettyPrintNew.stream -> unit 52 | val nl_app : PrettyPrintNew.stream -> (PrettyPrintNew.stream -> 'a -> unit) 53 | -> 'a list -> unit 54 | val br_app : PrettyPrintNew.stream -> (PrettyPrintNew.stream -> 'a -> unit) 55 | -> 'a list -> unit 56 | val en_pp : PrettyPrintNew.stream -> 57 | {break : {nsp: int, offset: int} -> unit, 58 | newline : unit -> unit, 59 | openHVBox : int -> unit, 60 | openHOVBox : int -> unit, 61 | closeBox : unit -> unit, 62 | pps : string -> unit, 63 | ppi : int -> unit} 64 | val ppArray : PrettyPrintNew.stream -> 65 | (PrettyPrintNew.stream -> 'a -> unit) * 'a array 66 | -> unit 67 | 68 | end (* signature PPUTILNEW *) 69 | -------------------------------------------------------------------------------- /Elaborator/print/pputil-new.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 2003 by The SML/NJ Fellowship *) 2 | (* basics/pputil.sml *) 3 | 4 | structure PPUtilNew : PPUTILNEW = 5 | struct 6 | 7 | structure S : SYMBOL = Symbol 8 | structure PP = PrettyPrintNew 9 | structure IP = InvPath 10 | structure SP = SymPath 11 | 12 | val pps = PP.string 13 | 14 | datatype break_style = CONSISTENT | INCONSISTENT 15 | 16 | fun openStyleBox style = 17 | case style 18 | of CONSISTENT => PP.openHVBox 19 | | INCONSISTENT => PP.openHOVBox 20 | 21 | fun ppSequence0 ppstream (sep:PP.stream->unit,pr,elems) = 22 | let fun prElems [el] = pr ppstream el 23 | | prElems (el::rest) = 24 | (pr ppstream el; 25 | sep ppstream; 26 | PP.break ppstream {nsp=0,offset=0}; 27 | prElems rest) 28 | | prElems [] = () 29 | in prElems elems 30 | end 31 | 32 | fun ppSequence ppstream {sep:PP.stream->unit, pr:PP.stream->'a->unit, 33 | style:break_style} (elems: 'a list) = 34 | (openStyleBox style ppstream (PP.Rel 0); 35 | ppSequence0 ppstream (sep,pr,elems); 36 | PP.closeBox ppstream) 37 | 38 | fun ppClosedSequence ppstream{front:PP.stream->unit,sep:PP.stream->unit, 39 | back:PP.stream->unit,pr:PP.stream->'a->unit, 40 | style:break_style} (elems:'a list) = 41 | (PP.openHVBox ppstream (PP.Rel 1); 42 | front ppstream; 43 | openStyleBox style ppstream (PP.Rel 0); 44 | ppSequence0 ppstream (sep,pr,elems); 45 | PP.closeBox ppstream; 46 | back ppstream; 47 | PP.closeBox ppstream) 48 | 49 | fun ppSym ppstream (s:S.symbol) = PP.string ppstream (S.name s) 50 | 51 | val stringDepth = Control_Print.stringDepth 52 | 53 | val mlstr = PrintUtil.mlstr 54 | fun pp_mlstr ppstream = PP.string ppstream o PrintUtil.pr_mlstr 55 | fun pp_intinf ppstream = PP.string ppstream o PrintUtil.pr_intinf 56 | 57 | fun ppvseq ppstream ind (sep:string) pr elems = 58 | let fun prElems [el] = pr ppstream el 59 | | prElems (el::rest) = (pr ppstream el; 60 | PP.string ppstream sep; 61 | PP.newline ppstream; 62 | prElems rest) 63 | | prElems [] = () 64 | in PP.openHVBox ppstream (PP.Rel ind); 65 | prElems elems; 66 | PP.closeBox ppstream 67 | end 68 | 69 | fun ppvlist ppstrm (header,separator,pr_item,items) = 70 | case items 71 | of nil => () 72 | | first::rest => 73 | (PP.string ppstrm header; 74 | pr_item ppstrm first; 75 | app (fn x => (PP.newline ppstrm; 76 | PP.string ppstrm separator; 77 | pr_item ppstrm x)) 78 | rest) 79 | 80 | fun ppvlist' ppstrm (header,separator,pr_item,items) = 81 | case items 82 | of nil => () 83 | | first::rest => 84 | (pr_item ppstrm header first; 85 | app (fn x => (PP.newline ppstrm; 86 | pr_item ppstrm separator x)) 87 | rest) 88 | 89 | (* debug print functions *) 90 | fun ppIntPath ppstream = 91 | ppClosedSequence ppstream 92 | {front=(fn pps => PP.string pps "["), 93 | sep=(fn pps => (PP.string pps ","; PP.break pps {nsp=0,offset=0})), 94 | back=(fn pps => PP.string pps "]"), 95 | style=INCONSISTENT, 96 | pr=(fn pps => PP.string pps o Int.toString)} 97 | 98 | fun ppSymPath ppstream (sp: SymPath.path) = 99 | PP.string ppstream (SymPath.toString sp) 100 | 101 | fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) = 102 | ppClosedSequence ppstream 103 | {front=(fn pps => PP.string pps "<"), 104 | sep=(fn pps => (PP.string pps ".")), 105 | back=(fn pps => PP.string pps ">"), 106 | style=INCONSISTENT, 107 | pr=ppSym} 108 | path 109 | 110 | 111 | (* findPath: convert inverse symbolic path names to a printable string in the 112 | context of an environment. 113 | 114 | Its arguments are the inverse symbolic path, a check predicate on static 115 | semantic values, and a lookup function mapping paths to their bindings 116 | (if any) in an environment and raising Env.Unbound on paths with no 117 | binding. 118 | 119 | It looks up each suffix of the path name, going from shortest to longest 120 | suffix, in the current environment until it finds one whose lookup value 121 | satisfies the check predicate. It then converts that suffix to a string. 122 | If it doesn't find any suffix, the full path (reversed, i.e. in the 123 | normal order) and the boolean value false are returned, otherwise the 124 | suffix and true are returned. 125 | 126 | Example: 127 | Given A.B.t as a path, and a lookup function for an 128 | environment, this function tries: 129 | t 130 | B.t 131 | A.B.t 132 | If none of these work, it returns ?.A.B.t 133 | 134 | Note: the symbolic path is passed in reverse order because that is 135 | the way all symbolic path names are stored within static semantic objects. 136 | *) 137 | 138 | val resultId = S.strSymbol "" 139 | val returnId = S.strSymbol "" 140 | 141 | fun findPath (IP.IPATH p: IP.path, check, look): (S.symbol list * bool) = 142 | let fun try(name::untried,tried) = 143 | (if (S.eq(name,resultId)) orelse (S.eq(name,returnId)) 144 | then try(untried,tried) 145 | else 146 | let val elem = look(SP.SPATH(name :: tried)) 147 | in if check elem 148 | then (name::tried,true) 149 | else try(untried,name::tried) 150 | end handle StaticEnv.Unbound => try(untried,name::tried)) 151 | | try([],tried) = (tried, false) 152 | in try(p,[]) 153 | end 154 | 155 | 156 | fun ppi ppstrm (i:int) = pps ppstrm (Int.toString i) 157 | 158 | fun ppcomma ppstrm = pps ppstrm "," 159 | 160 | fun ppcomma_nl ppstrm = (ppcomma ppstrm; PP.newline ppstrm) 161 | 162 | fun nl_indent ppstrm i = 163 | let val linewidth = 10000 164 | in PP.break ppstrm {nsp=linewidth,offset=i} 165 | end 166 | 167 | fun nl_app ppstrm f = 168 | let fun g [] = () 169 | | g [el] = f ppstrm el 170 | | g (el::rst) = (f ppstrm el; PP.newline ppstrm; g rst) 171 | in g 172 | end 173 | 174 | fun br_app ppstrm f = 175 | let fun g [] = () 176 | | g [el] = f ppstrm el 177 | | g (el::rst) = (f ppstrm el; PP.break ppstrm {nsp=1,offset=0}; g rst) 178 | in g 179 | end 180 | 181 | fun en_pp ppstrm = 182 | {openHVBox = (fn indent => PP.openHVBox ppstrm (PP.Rel indent)), (* CONSISTENT *) 183 | openHOVBox = (fn indent => PP.openHOVBox ppstrm (PP.Rel indent)), (* INCONSISTENT *) 184 | closeBox = fn () => PP.closeBox ppstrm, 185 | pps = pps ppstrm, 186 | ppi = ppi ppstrm, 187 | break = fn nsp_offset => PP.break ppstrm nsp_offset, 188 | newline = fn () => PP.newline ppstrm}; 189 | 190 | fun ppArray ppstrm (f:PP.stream -> 'a -> unit, a:'a array) = 191 | let val {openHVBox,openHOVBox,pps,break,closeBox,...} = en_pp ppstrm 192 | fun loop i = 193 | let val elem = Array.sub(a,i) 194 | in pps (Int.toString i); 195 | pps ": "; 196 | f ppstrm elem; 197 | break {nsp=1,offset=0}; 198 | loop (i+1) 199 | end 200 | in openHOVBox 0; 201 | loop 0 handle General.Subscript => (); 202 | closeBox() 203 | end 204 | 205 | fun C f x y = f y x; 206 | 207 | fun ppTuple ppstrm f = 208 | ppClosedSequence ppstrm 209 | {front=C pps "(", 210 | sep=fn ppstrm => (pps ppstrm ","; PP.break ppstrm {nsp=0,offset=0}), 211 | back=C pps ")", 212 | pr=f, style=INCONSISTENT} 213 | 214 | 215 | end (* structure PPUtilNew *) 216 | -------------------------------------------------------------------------------- /Elaborator/print/pputil.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1989 by AT&T Bell Laboratories *) 2 | 3 | signature PPUTIL = 4 | sig 5 | 6 | datatype break_style = CONSISTENT | INCONSISTENT 7 | 8 | val openStyleBox : break_style -> PrettyPrint.stream -> PrettyPrint.indent -> unit 9 | 10 | val ppSequence : PrettyPrint.stream -> 11 | {sep: PrettyPrint.stream->unit, 12 | pr: PrettyPrint.stream->'a->unit, 13 | style: break_style} 14 | -> 'a list -> unit 15 | val ppClosedSequence : PrettyPrint.stream 16 | -> {front:PrettyPrint.stream->unit, 17 | sep:PrettyPrint.stream->unit, 18 | back:PrettyPrint.stream->unit, 19 | pr:PrettyPrint.stream->'a->unit, 20 | style:break_style} 21 | -> 'a list -> unit 22 | val ppSym : PrettyPrint.stream -> Symbol.symbol -> unit 23 | val mlstr : string -> string 24 | val pp_mlstr : PrettyPrint.stream -> string -> unit 25 | val pp_intinf : PrettyPrint.stream -> IntInf.int -> unit 26 | val ppvseq : PrettyPrint.stream 27 | -> int -> string -> (PrettyPrint.stream -> 'a -> unit) 28 | -> 'a list -> unit 29 | val ppvlist : PrettyPrint.stream 30 | -> string * string * (PrettyPrint.stream -> 'a -> unit) * 'a list 31 | -> unit 32 | val ppvlist' : PrettyPrint.stream 33 | -> string * string * (PrettyPrint.stream -> string -> 'a -> unit) 34 | * 'a list 35 | -> unit 36 | val ppIntPath : PrettyPrint.stream -> int list -> unit 37 | val ppSymPath : PrettyPrint.stream -> SymPath.path -> unit 38 | val ppInvPath : PrettyPrint.stream -> InvPath.path -> unit 39 | val nl_indent : PrettyPrint.stream -> int -> unit 40 | 41 | (* needed in PPTypes, PPModules *) 42 | val findPath : InvPath.path * ('a -> bool) * (SymPath.path -> 'a) 43 | -> (Symbol.symbol list * bool) 44 | 45 | val ppTuple: PrettyPrint.stream 46 | -> (PrettyPrint.stream -> 'a -> unit) -> 'a list -> unit 47 | 48 | val ppi: PrettyPrint.stream -> int -> unit 49 | val ppcomma : PrettyPrint.stream -> unit 50 | val ppcomma_nl : PrettyPrint.stream -> unit 51 | val nl_app : PrettyPrint.stream -> (PrettyPrint.stream -> 'a -> unit) 52 | -> 'a list -> unit 53 | val br_app : PrettyPrint.stream -> (PrettyPrint.stream -> 'a -> unit) 54 | -> 'a list -> unit 55 | val en_pp : PrettyPrint.stream -> 56 | {break : {nsp: int, offset: int} -> unit, 57 | newline : unit -> unit, 58 | openHVBox : int -> unit, 59 | openHOVBox : int -> unit, 60 | closeBox : unit -> unit, 61 | pps : string -> unit} 62 | val ppArray : PrettyPrint.stream -> 63 | (PrettyPrint.stream -> 'a -> unit) * 'a array 64 | -> unit 65 | 66 | end (* signature PPUTIL *) 67 | -------------------------------------------------------------------------------- /Elaborator/print/pputil.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 2003 by The SML/NJ Fellowship *) 2 | (* basics/pputil.sml *) 3 | 4 | structure PPUtil : PPUTIL = 5 | struct 6 | 7 | structure S : SYMBOL = Symbol 8 | structure PP = PrettyPrint 9 | structure IP = InvPath 10 | structure SP = SymPath 11 | 12 | val pps = PP.string 13 | 14 | fun ppSequence0 ppstream (sep:PP.stream->unit,pr,elems) = 15 | let fun prElems [el] = pr ppstream el 16 | | prElems (el::rest) = 17 | (pr ppstream el; 18 | sep ppstream; 19 | prElems rest) 20 | | prElems [] = () 21 | in prElems elems 22 | end 23 | 24 | datatype break_style = CONSISTENT | INCONSISTENT 25 | 26 | fun openStyleBox style = 27 | case style 28 | of CONSISTENT => PP.openHVBox 29 | | INCONSISTENT => PP.openHOVBox 30 | 31 | fun ppSequence ppstream {sep:PP.stream->unit, pr:PP.stream->'a->unit, 32 | style:break_style} (elems: 'a list) = 33 | (openStyleBox style ppstream (PP.Rel 0); 34 | ppSequence0 ppstream (sep,pr,elems); 35 | PP.closeBox ppstream) 36 | 37 | fun ppClosedSequence ppstream{front:PP.stream->unit,sep:PP.stream->unit, 38 | back:PP.stream->unit,pr:PP.stream->'a->unit, 39 | style:break_style} (elems:'a list) = 40 | (PP.openHVBox ppstream (PP.Rel 0); 41 | front ppstream; 42 | openStyleBox style ppstream (PP.Rel 0); 43 | ppSequence0 ppstream (sep,pr,elems); 44 | PP.closeBox ppstream; 45 | back ppstream; 46 | PP.closeBox ppstream) 47 | 48 | fun ppSym ppstream (s:S.symbol) = PP.string ppstream (S.name s) 49 | 50 | val stringDepth = Control_Print.stringDepth 51 | 52 | val mlstr = PrintUtil.mlstr 53 | fun pp_mlstr ppstream = PP.string ppstream o PrintUtil.pr_mlstr 54 | fun pp_intinf ppstream = PP.string ppstream o PrintUtil.pr_intinf 55 | 56 | fun ppvseq ppstream ind (sep:string) pr elems = 57 | let fun prElems [el] = pr ppstream el 58 | | prElems (el::rest) = (pr ppstream el; 59 | PP.string ppstream sep; 60 | PP.newline ppstream; 61 | prElems rest) 62 | | prElems [] = () 63 | in PP.openHVBox ppstream (PP.Rel ind); 64 | prElems elems; 65 | PP.closeBox ppstream 66 | end 67 | 68 | fun ppvlist ppstrm (header,separator,pr_item,items) = 69 | case items 70 | of nil => () 71 | | first::rest => 72 | (PP.string ppstrm header; 73 | pr_item ppstrm first; 74 | app (fn x => (PP.newline ppstrm; 75 | PP.string ppstrm separator; 76 | pr_item ppstrm x)) 77 | rest) 78 | 79 | fun ppvlist' ppstrm (header,separator,pr_item,items) = 80 | case items 81 | of nil => () 82 | | first::rest => 83 | (pr_item ppstrm header first; 84 | app (fn x => (PP.newline ppstrm; 85 | pr_item ppstrm separator x)) 86 | rest) 87 | 88 | (* debug print functions *) 89 | fun ppIntPath ppstream = 90 | ppClosedSequence ppstream 91 | {front=(fn pps => PP.string pps "["), 92 | sep=(fn pps => (PP.string pps ","; PP.break pps {nsp=0,offset=0})), 93 | back=(fn pps => PP.string pps "]"), 94 | style=INCONSISTENT, 95 | pr=(fn pps => PP.string pps o Int.toString)} 96 | 97 | fun ppSymPath ppstream (sp: SymPath.path) = 98 | PP.string ppstream (SymPath.toString sp) 99 | 100 | fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) = 101 | ppClosedSequence ppstream 102 | {front=(fn pps => PP.string pps "<"), 103 | sep=(fn pps => (PP.string pps ".")), 104 | back=(fn pps => PP.string pps ">"), 105 | style=INCONSISTENT, 106 | pr=ppSym} 107 | path 108 | 109 | 110 | (* findPath: convert inverse symbolic path names to a printable string in the 111 | context of an environment. 112 | 113 | Its arguments are the inverse symbolic path, a check predicate on static 114 | semantic values, and a lookup function mapping paths to their bindings 115 | (if any) in an environment and raising Env.Unbound on paths with no 116 | binding. 117 | 118 | It looks up each suffix of the path name, going from shortest to longest 119 | suffix, in the current environment until it finds one whose lookup value 120 | satisfies the check predicate. It then converts that suffix to a string. 121 | If it doesn't find any suffix, the full path (reversed, i.e. in the 122 | normal order) and the boolean value false are returned, otherwise the 123 | suffix and true are returned. 124 | 125 | Example: 126 | Given A.B.t as a path, and a lookup function for an 127 | environment, this function tries: 128 | t 129 | B.t 130 | A.B.t 131 | If none of these work, it returns ?.A.B.t 132 | 133 | Note: the symbolic path is passed in reverse order because that is 134 | the way all symbolic path names are stored within static semantic objects. 135 | *) 136 | 137 | val resultId = S.strSymbol "" 138 | val returnId = S.strSymbol "" 139 | 140 | fun findPath (IP.IPATH p: IP.path, check, look): (S.symbol list * bool) = 141 | let fun try(name::untried,tried) = 142 | (if (S.eq(name,resultId)) orelse (S.eq(name,returnId)) 143 | then try(untried,tried) 144 | else 145 | let val elem = look(SP.SPATH(name :: tried)) 146 | in if check elem 147 | then (name::tried,true) 148 | else try(untried,name::tried) 149 | end handle StaticEnv.Unbound => try(untried,name::tried)) 150 | | try([],tried) = (tried, false) 151 | in try(p,[]) 152 | end 153 | 154 | 155 | fun ppi ppstrm (i:int) = pps ppstrm (Int.toString i) 156 | 157 | fun ppcomma ppstrm = pps ppstrm "," 158 | 159 | fun ppcomma_nl ppstrm = (ppcomma ppstrm; PP.newline ppstrm) 160 | 161 | fun nl_indent ppstrm i = 162 | let val linewidth = 10000 163 | in PP.break ppstrm {nsp=linewidth,offset=i} 164 | end 165 | 166 | fun nl_app ppstrm f = 167 | let fun g [] = () 168 | | g [el] = f ppstrm el 169 | | g (el::rst) = (f ppstrm el; PP.newline ppstrm; g rst) 170 | in g 171 | end 172 | 173 | fun br_app ppstrm f = 174 | let fun g [] = () 175 | | g [el] = f ppstrm el 176 | | g (el::rst) = (f ppstrm el; PP.break ppstrm {nsp=1,offset=0}; g rst) 177 | in g 178 | end 179 | 180 | fun en_pp ppstrm = 181 | {openHVBox = (fn indent => PP.openHVBox ppstrm (PP.Rel indent)), (* CONSISTENT *) 182 | openHOVBox = (fn indent => PP.openHOVBox ppstrm (PP.Rel indent)), (* INCONSISTENT *) 183 | closeBox = fn () => PP.closeBox ppstrm, 184 | pps = PP.string ppstrm, 185 | break = fn nsp_offset => PP.break ppstrm nsp_offset, 186 | newline = fn () => PP.newline ppstrm}; 187 | 188 | fun ppArray ppstrm (f:PP.stream -> 'a -> unit, a:'a array) = 189 | let val {openHVBox,openHOVBox,pps,break,closeBox,...} = en_pp ppstrm 190 | fun loop i = 191 | let val elem = Array.sub(a,i) 192 | in pps (Int.toString i); 193 | pps ": "; 194 | f ppstrm elem; 195 | break {nsp=1,offset=0}; 196 | loop (i+1) 197 | end 198 | in openHOVBox 0; 199 | loop 0 handle General.Subscript => (); 200 | closeBox() 201 | end 202 | 203 | fun C f x y = f y x; 204 | 205 | fun ppTuple ppstrm f = 206 | ppClosedSequence ppstrm 207 | {front=C pps "(", 208 | sep=fn ppstrm => (pps ppstrm ","; PP.break ppstrm {nsp=0,offset=0}), 209 | back=C pps ")", 210 | pr=f, style=INCONSISTENT} 211 | 212 | 213 | end (* structure PPUtil *) 214 | -------------------------------------------------------------------------------- /Elaborator/print/ppval.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* Copyright 2003 by The SML/NJ Fellowship *) 3 | (* ppval.sml *) 4 | 5 | (* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *) 6 | 7 | signature PPVAL = 8 | sig 9 | val ppAccess: PrettyPrintNew.stream -> Access.access -> unit 10 | val ppRep: PrettyPrintNew.stream -> Access.conrep -> unit 11 | val ppDcon: PrettyPrintNew.stream -> VarCon.datacon -> unit 12 | val ppVar: PrettyPrintNew.stream -> VarCon.var -> unit 13 | val ppDebugDcon : PrettyPrintNew.stream 14 | -> StaticEnv.staticEnv -> VarCon.datacon -> unit 15 | val ppDebugVar: (PrimOpId.primId -> string) -> 16 | PrettyPrintNew.stream 17 | -> StaticEnv.staticEnv -> VarCon.var -> unit 18 | end (* signature PPVAL *) 19 | 20 | structure PPVal : PPVAL = 21 | struct 22 | 23 | local 24 | structure PP = PrettyPrintNew 25 | structure PU = PPUtilNew 26 | structure TU = TypesUtil 27 | structure LU = Lookup 28 | structure A = Access 29 | open PrettyPrintNew PPUtilNew VarCon Types 30 | 31 | in 32 | 33 | val internals = ElabControl.internals 34 | 35 | fun C f x y = f y x 36 | 37 | val pps = PP.string 38 | val ppType = PPType.ppType 39 | val ppTycon = PPType.ppTycon 40 | val ppTyfun = PPType.ppTyfun 41 | 42 | fun ppAccess ppstrm a = pps ppstrm (" ["^(A.prAcc a)^"]") 43 | 44 | fun ppInfo ii2string ppstrm a = pps ppstrm (" ["^(ii2string a)^"]") 45 | 46 | fun ppRep ppstrm rep = PP.string ppstrm (A.prRep rep) 47 | 48 | fun ppCsig ppstrm csig = PP.string ppstrm (A.prCsig csig) 49 | 50 | fun ppDcon ppstrm = 51 | let fun ppD(DATACON{name, rep=A.EXN acc, ...}) = 52 | (ppSym ppstrm name; 53 | if !internals then ppAccess ppstrm acc else ()) 54 | | ppD(DATACON{name,...}) = ppSym ppstrm name 55 | in ppD 56 | end 57 | 58 | fun ppDebugDcon ppstrm env (DATACON{name,rep,const,typ,sign,lazyp}) = 59 | let val {openHVBox, openHOVBox,closeBox,pps,break,...} = en_pp ppstrm 60 | val ppSym = ppSym ppstrm 61 | in openHVBox 3; 62 | pps "DATACON"; 63 | break{nsp=0,offset=0}; 64 | pps "{name = "; ppSym name; ppcomma_nl ppstrm; 65 | pps "const = "; pps (Bool.toString const); ppcomma_nl ppstrm; 66 | pps "typ = "; ppType env ppstrm typ; ppcomma_nl ppstrm; 67 | pps "lazyp = "; pps (Bool.toString lazyp); ppcomma_nl ppstrm; 68 | pps "conrep ="; ppRep ppstrm rep; ppcomma_nl ppstrm; 69 | pps "sign = ["; ppCsig ppstrm sign; pps "]}"; 70 | closeBox() 71 | end 72 | 73 | fun ppDatacon (env:StaticEnv.staticEnv,DATACON{name,typ,...}) ppstrm = 74 | let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm 75 | in openHOVBox 0; 76 | ppSym ppstrm name; pps " : "; ppType env ppstrm typ; 77 | closeBox() 78 | end 79 | 80 | fun ppConBinding ppstrm = 81 | let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm 82 | fun ppCon (DATACON{name, typ, rep=A.EXN _, ...}, env) = 83 | (openHVBox 0; 84 | pps "exception "; ppSym ppstrm name; 85 | if BasicTypes.isArrowType typ then 86 | (pps " of "; 87 | ppType env ppstrm (BasicTypes.domain typ)) 88 | else (); 89 | closeBox()) 90 | | ppCon (con,env) = 91 | let exception Hidden 92 | val visibleDconTyc = 93 | let val tyc = TU.dconTyc con 94 | in 95 | (TypesUtil.equalTycon 96 | (LU.lookTyc 97 | (env,SymPath.SPATH 98 | [InvPath.last(TypesUtil.tycPath tyc)], 99 | fn _ => raise Hidden), 100 | tyc) 101 | handle Hidden => false) 102 | end 103 | in if !internals orelse not visibleDconTyc 104 | then (openHVBox 0; 105 | pps "con "; 106 | ppDatacon(env,con) ppstrm; 107 | closeBox()) 108 | else () 109 | end 110 | in ppCon 111 | end 112 | 113 | fun ppVar ppstrm (VALvar {access,path,...}) = 114 | (pps ppstrm (SymPath.toString path); 115 | if !internals then ppAccess ppstrm access else ()) 116 | | ppVar ppstrm (OVLDvar {name,...}) = ppSym ppstrm (name) 117 | | ppVar ppstrm (ERRORvar) = PP.string ppstrm "" 118 | 119 | fun ppDebugVar ii2string ppstrm env = 120 | let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm 121 | val ppAccess = ppAccess ppstrm 122 | val ppInfo = ppInfo ii2string ppstrm 123 | fun ppDV(VALvar {access,path, btvs, typ,prim}) = 124 | (openHVBox 0; 125 | pps "VALvar"; 126 | openHVBox 3; 127 | pps "({access="; ppAccess access; ppcomma_nl ppstrm; 128 | pps "prim="; ppInfo prim; ppcomma_nl ppstrm; 129 | pps "path="; pps (SymPath.toString path); ppcomma_nl ppstrm; 130 | pps "typ=ref "; ppType env ppstrm (!typ); 131 | pps "})"; 132 | closeBox(); closeBox()) 133 | | ppDV (OVLDvar {name,options,scheme}) = 134 | (openHVBox 0; 135 | pps "OVLDvar"; 136 | openHVBox 3; 137 | pps "({name="; ppSym ppstrm (name); ppcomma_nl ppstrm; 138 | pps "options=["; 139 | (ppvseq ppstrm 0 "," 140 | (fn ppstrm => fn {indicator,variant} => 141 | (pps "{indicator=";ppType env ppstrm indicator; 142 | ppcomma_nl ppstrm; 143 | pps " variant ="; 144 | ppDebugVar ii2string ppstrm env variant; pps "}")) 145 | (!options)); 146 | pps "]"; ppcomma_nl ppstrm; 147 | pps "scheme="; ppTyfun env ppstrm scheme; pps "})"; 148 | closeBox(); 149 | closeBox()) 150 | | ppDV (ERRORvar) = pps "" 151 | in ppDV 152 | end 153 | 154 | fun ppVariable ppstrm = 155 | let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm 156 | fun ppV(env:StaticEnv.staticEnv,VALvar{btvs,path,access,typ,prim}) = 157 | (openHVBox 0; 158 | pps(SymPath.toString path); 159 | if !internals then ppAccess ppstrm access else (); 160 | pps " : "; ppType env ppstrm (!typ); 161 | closeBox()) 162 | | ppV (env,OVLDvar {name,options=ref optl,scheme=TYFUN{body,...}}) = 163 | (openHVBox 0; 164 | ppSym ppstrm (name); pps " : "; ppType env ppstrm body; 165 | pps " as "; 166 | ppSequence ppstrm 167 | {sep=C PP.break {nsp=1,offset=0}, 168 | pr=(fn ppstrm => fn{variant,...} => ppV(env,variant)), 169 | style=CONSISTENT} 170 | optl; 171 | closeBox()) 172 | | ppV(_,ERRORvar) = pps "" 173 | in ppV 174 | end 175 | 176 | end (* local *) 177 | end (* structure PPVal *) 178 | -------------------------------------------------------------------------------- /Elaborator/types/basictypes.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* basictypes.sig *) 3 | 4 | signature BASICTYPES = 5 | sig 6 | 7 | val arrowStamp : Stamps.stamp 8 | val arrowTycon : Types.tycon 9 | val --> : Types.ty * Types.ty -> Types.ty 10 | val isArrowType : Types.ty -> bool 11 | val domain : Types.ty -> Types.ty 12 | val range : Types.ty -> Types.ty 13 | 14 | val intTycon : Types.tycon 15 | val intTy : Types.ty 16 | 17 | val int32Tycon : Types.tycon 18 | val int32Ty : Types.ty 19 | 20 | val int64Tycon : Types.tycon 21 | val int64Ty : Types.ty 22 | 23 | val intinfTycon : Types.tycon 24 | val intinfTy : Types.ty 25 | 26 | val realTycon : Types.tycon 27 | val realTy : Types.ty 28 | 29 | val wordTycon : Types.tycon 30 | val wordTy : Types.ty 31 | 32 | val word8Tycon : Types.tycon 33 | val word8Ty: Types.ty 34 | 35 | val word32Tycon : Types.tycon 36 | val word32Ty: Types.ty 37 | 38 | val word64Tycon : Types.tycon 39 | val word64Ty : Types.ty 40 | 41 | val stringTycon : Types.tycon 42 | val stringTy : Types.ty 43 | 44 | val charTycon : Types.tycon 45 | val charTy : Types.ty 46 | 47 | val exnTycon : Types.tycon 48 | val exnTy : Types.ty 49 | 50 | val contTycon : Types.tycon 51 | val ccontTycon : Types.tycon 52 | 53 | val arrayTycon : Types.tycon 54 | 55 | val vectorTycon : Types.tycon 56 | 57 | val objectTycon : Types.tycon 58 | val c_functionTycon : Types.tycon 59 | val word8arrayTycon : Types.tycon 60 | val real64arrayTycon : Types.tycon 61 | val spin_lockTycon : Types.tycon 62 | 63 | val unitTycon : Types.tycon 64 | val unitTy : Types.ty 65 | 66 | val recordTy : (Types.label * Types.ty) list -> Types.ty 67 | val tupleTy : Types.ty list -> Types.ty 68 | (* get the types of a tuple-type's fields *) 69 | val getFields : Types.ty -> Types.ty list option 70 | 71 | val boolTycon : Types.tycon 72 | val boolTy : Types.ty 73 | val boolsign : Access.consig 74 | val falseDcon : Types.datacon 75 | val trueDcon : Types.datacon 76 | 77 | (* 78 | * Unnecessary; removed by appel 79 | * val optionTycon : Types.tycon 80 | * val NONEDcon : Types.datacon 81 | * val SOMEDcon : Types.datacon 82 | *) 83 | 84 | val refTycon : Types.tycon 85 | val refPatType : Types.ty 86 | val refDcon : Types.datacon 87 | 88 | val listTycon : Types.tycon 89 | val nilDcon : Types.datacon 90 | val consDcon : Types.datacon 91 | 92 | val ulistTycon : Types.tycon 93 | val unilDcon : Types.datacon 94 | val uconsDcon : Types.datacon 95 | 96 | val fragTycon : Types.tycon 97 | val ANTIQUOTEDcon : Types.datacon 98 | val QUOTEDcon : Types.datacon 99 | 100 | val suspTycon : Types.tycon 101 | val suspPatType : Types.ty 102 | val dollarDcon : Types.datacon 103 | 104 | end (* signature BASICTYPES *) 105 | -------------------------------------------------------------------------------- /Elaborator/types/overload.sml: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT 1996 AT&T Bell Laboratories. *) 2 | (* overload.sml *) 3 | 4 | signature OVERLOAD = sig 5 | val new : unit -> 6 | { push : VarCon.var ref * ErrorMsg.complainer -> Types.ty, 7 | resolve : StaticEnv.staticEnv -> unit } 8 | end (* signature OVERLOAD *) 9 | 10 | structure Overload : OVERLOAD = 11 | struct 12 | 13 | local 14 | structure EM = ErrorMsg 15 | structure BT = BasicTypes 16 | structure TU = TypesUtil 17 | structure ED = ElabDebug 18 | structure PP = PrettyPrintNew 19 | structure PU = PPUtilNew 20 | open VarCon Types 21 | in 22 | 23 | fun bug msg = EM.impossible("Overload: "^msg) 24 | 25 | type subst = (tyvar * tvKind) list 26 | 27 | exception SoftUnify 28 | 29 | fun copyScheme (tyfun as TYFUN{arity,...}) : ty * ty = 30 | let fun typeArgs n = if n>0 then TU.mkSCHEMEty() :: typeArgs(n-1) else [] 31 | val tvs = typeArgs arity 32 | in (TU.applyTyfun(tyfun,tvs),if arity>1 then BT.tupleTy tvs else hd tvs) 33 | end 34 | 35 | fun rollBack subst = 36 | let fun loop (nil,trace) = trace 37 | | loop (((tv as ref kind),oldkind)::subst,trace) = 38 | (tv := oldkind; 39 | loop(subst,(tv,kind)::trace)) 40 | in loop(subst,nil) 41 | end 42 | 43 | fun redoSubst nil = () 44 | | redoSubst ((tv as ref(OPEN{kind=META, ...}),INSTANTIATED ty)::rest) = 45 | (tv := INSTANTIATED ty; redoSubst rest) 46 | | redoSubst (_) = bug "Overload--redoSubst" 47 | 48 | fun softUnify(ty1: ty, ty2: ty): unit = 49 | let val subst: subst ref = ref nil 50 | fun softInst(tv as ref info: tyvar, ty: ty) : unit = 51 | let fun scan eq (ty: ty) : unit = (* simple occurrence check *) 52 | case ty 53 | of VARty(tv') => 54 | if TU.eqTyvar(tv, tv') 55 | then raise SoftUnify 56 | else (case tv' 57 | of ref(OPEN{kind=FLEX fields,...}) => 58 | (* DBM: can this happen? *) 59 | app (fn (_,ty') => scan eq ty') fields 60 | | _ => ()) 61 | | CONty(tycon, args) => 62 | (* check equality property if necessary *) 63 | if eq 64 | then (case tycon 65 | of DEFtyc _ => 66 | scan eq (TU.headReduceType ty) 67 | | GENtyc gt => 68 | (case ! (#eq gt) 69 | of YES => app (scan eq) args 70 | | OBJ => app (scan false) args 71 | (* won't happen *) 72 | | _ => raise SoftUnify) 73 | | _ => raise SoftUnify) (* won't happen? *) 74 | else app (scan eq) args 75 | | MARKty(tyc, region) => scan eq tyc 76 | | ty => () (* propagate error *) 77 | in case info 78 | of (SCHEME eq | OPEN{kind=META,eq,...}) => 79 | (scan eq ty; 80 | subst := (tv, info)::(!subst); 81 | tv := INSTANTIATED ty) 82 | | _ => raise SoftUnify 83 | end 84 | 85 | fun unify(ty1: ty, ty2: ty): unit = 86 | let val ty1 = TU.prune ty1 87 | and ty2 = TU.prune ty2 88 | in case (ty1,ty2) 89 | of (WILDCARDty, _) => () (* wildcards unify with anything *) 90 | | (_, WILDCARDty) => () (* wildcards unify with anything *) 91 | | (VARty(tv1),VARty(tv2)) => 92 | if TU.eqTyvar(tv1,tv2) then () else softInst(tv1,ty2) 93 | | (VARty(tv1),_) => softInst(tv1,ty2) 94 | | (_,VARty(tv2)) => softInst(tv2,ty1) 95 | | (CONty(tycon1, args1), CONty(tycon2, args2)) => 96 | if TU.eqTycon(tycon1, tycon2) 97 | then unifyLists(args1, args2) 98 | else (unify(TU.reduceType ty1, ty2) 99 | handle TU.ReduceType => 100 | unify(ty1, TU.reduceType ty2) 101 | handle TU.ReduceType => raise SoftUnify) 102 | | (MARKty(ty1, region), ty2) => unify(ty1, ty2) 103 | | (ty1, MARKty(ty2,region)) => unify(ty1, ty2) 104 | | _ => raise SoftUnify 105 | end 106 | 107 | and unifyLists([],[]) = () 108 | | unifyLists(ty1::rest1, ty2::rest2) = 109 | (unify(ty1,ty2); unifyLists(rest1,rest2)) 110 | | unifyLists(_) = raise SoftUnify 111 | 112 | in unify(ty1,ty2) 113 | handle SoftUnify => (rollBack(!subst); raise SoftUnify) 114 | end 115 | 116 | (* overloaded functions *) 117 | fun new () = let 118 | val overloaded = ref (nil: (var ref * ErrorMsg.complainer * ty) list) 119 | fun push (refvar as ref(OVLDvar{options,scheme,...}), err) = 120 | let val (scheme',ty) = copyScheme(scheme) 121 | in 122 | overloaded := (refvar,err,ty) :: !overloaded; 123 | scheme' 124 | end 125 | | push _ = bug "overload.1" 126 | 127 | (* this resolveOverloaded implements defaulting behavior -- if more 128 | * than one variant matches the context type, the first one matching 129 | * (which will always be the first variant) is used as the default *) 130 | fun resolve env = 131 | let fun resolveOVLDvar(rv as ref(OVLDvar{name,options,...}),err,context) = 132 | let fun firstMatch({indicator, variant}::rest) = 133 | let val (nty,_) = TU.instantiatePoly indicator 134 | in (softUnify(nty, context); rv := variant) 135 | handle SoftUnify => firstMatch(rest) 136 | end 137 | | firstMatch(nil) = 138 | (err EM.COMPLAIN "overloaded variable not defined at type" 139 | (fn ppstrm => 140 | (PPType.resetPPType(); 141 | PP.newline ppstrm; 142 | PP.string ppstrm "symbol: "; 143 | PU.ppSym ppstrm name; 144 | PP.newline ppstrm; 145 | PP.string ppstrm "type: "; 146 | PPType.ppType env ppstrm context)); 147 | ()) 148 | 149 | in firstMatch(!options) 150 | end 151 | | resolveOVLDvar _ = bug "overload.2" 152 | in 153 | app resolveOVLDvar (!overloaded) 154 | end 155 | in 156 | { push = push, resolve = resolve } 157 | end (* new *) 158 | 159 | end (* local *) 160 | end (* structure Overload *) 161 | -------------------------------------------------------------------------------- /Elaborator/types/overloadlit.sml: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT 1997 Bell Laboratories *) 2 | (* overloadlit.sml *) 3 | 4 | (* overloaded literals *) 5 | signature OVERLOADLIT = 6 | sig 7 | 8 | (* functions for setting up, recording, and resolving literal overloadings *) 9 | val new : unit -> { push : Types.ty -> unit, resolve : unit -> unit } 10 | 11 | (* isLiteralTy is for checking compatability when instantiating 12 | overloaded literal type variables *) 13 | val isLiteralTy : Types.litKind * Types.ty -> bool 14 | end (* signature OVERLOADLIT *) 15 | 16 | structure OverloadLit : OVERLOADLIT = 17 | struct 18 | 19 | structure T = Types 20 | structure BT = BasicTypes 21 | structure TU = TypesUtil 22 | 23 | (* eventually, these may be defined elsewhere, perhaps via some 24 | compiler configuration mechanism *) 25 | val intTypes = [BT.intTy, BT.int32Ty, BT.int64Ty, BT.intinfTy] 26 | val wordTypes = [BT.wordTy, BT.word8Ty, BT.word32Ty, BT.word64Ty] 27 | val realTypes = [BT.realTy] 28 | val charTypes = [BT.charTy] 29 | val stringTypes = [BT.stringTy] 30 | 31 | fun inClass(ty, tys) = List.exists (fn ty' => TU.equalType(ty,ty')) tys 32 | 33 | fun isLiteralTy(T.INT,ty) = inClass(ty,intTypes) 34 | | isLiteralTy(T.WORD,ty) = inClass(ty,wordTypes) 35 | | isLiteralTy(T.REAL,ty) = inClass(ty,realTypes) 36 | | isLiteralTy(T.CHAR,ty) = inClass(ty,charTypes) 37 | | isLiteralTy(T.STRING,ty) = inClass(ty,stringTypes) 38 | 39 | fun default T.INT = BT.intTy 40 | | default T.WORD = BT.wordTy 41 | | default T.REAL = BT.realTy 42 | | default T.CHAR = BT.charTy 43 | | default T.STRING = BT.stringTy 44 | 45 | fun new () = let 46 | val lits = ref [] 47 | fun push x = lits := x :: !lits 48 | fun resolve () = 49 | let fun resolveLit ty = 50 | case TU.prune ty 51 | of (T.VARty(tv as ref(T.LITERAL{kind,...})) | 52 | T.MARKty(T.VARty(tv as ref(T.LITERAL{kind,...})),_)) => 53 | tv := T.INSTANTIATED(default kind) 54 | | _ => () (* ok, must have been successfully instantiated *) 55 | in app resolveLit (!lits) 56 | end 57 | in { push = push, resolve = resolve } 58 | end 59 | 60 | end (* structure OverloadLit *) 61 | -------------------------------------------------------------------------------- /Elaborator/types/typecheck.sig: -------------------------------------------------------------------------------- 1 | 2 | signature TYPECHECK = 3 | sig 4 | 5 | val decType : StaticEnv.staticEnv * Absyn.dec * bool 6 | * ErrorMsg.errorFn * SourceMap.region -> Absyn.dec 7 | val debugging : bool ref 8 | 9 | end (* signature TYPECHECK *) -------------------------------------------------------------------------------- /Parse/ast/astutil.sig: -------------------------------------------------------------------------------- 1 | (* Copyright 1992 by AT&T Bell Laboratories 2 | * 3 | *) 4 | signature ASTUTIL = 5 | sig 6 | 7 | val checkFix : int * ErrorMsg.complainer -> int 8 | 9 | (* BUILDS VARIOUS CONSTRUCTIONS *) 10 | val makeSEQdec : Ast.dec * Ast.dec -> Ast.dec 11 | 12 | val layered : Ast.pat * Ast.pat * ErrorMsg.complainer -> Ast.pat 13 | 14 | (* SYMBOLS *) 15 | val arrowTycon : Symbol.symbol 16 | val bogusID : Symbol.symbol 17 | val exnID : Symbol.symbol 18 | val symArg : Symbol.symbol 19 | val itsym : Symbol.symbol list 20 | 21 | val unitExp : Ast.exp 22 | val unitPat : Ast.pat 23 | 24 | (* QUOTES *) 25 | val QuoteExp : string -> Ast.exp 26 | val AntiquoteExp : Ast.exp -> Ast.exp 27 | 28 | end (* signature ASTUTIL *) 29 | 30 | 31 | -------------------------------------------------------------------------------- /Parse/ast/astutil.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1992 by AT&T Bell Laboratories 2 | *) 3 | 4 | structure AstUtil:ASTUTIL = struct 5 | 6 | open Symbol Fixity Ast PrintUtil ErrorMsg 7 | 8 | val unitPat = RecordPat{def=nil,flexibility=false} 9 | val unitExp = RecordExp nil 10 | val trueDcon = [varSymbol "true"] 11 | val falseDcon = [varSymbol "false"] 12 | val quoteDcon = [strSymbol "SMLofNJ", varSymbol "QUOTE"] 13 | val antiquoteDcon = [strSymbol "SMLofNJ", varSymbol "ANTIQUOTE"] 14 | val arrowTycon = tycSymbol "->" 15 | val exnID = Symbol.tycSymbol "exn" 16 | val bogusID = varSymbol "BOGUS" 17 | val symArg = strSymbol "" 18 | val itsym = [varSymbol "it"] 19 | 20 | fun checkFix (i, err) = 21 | if (i < 0) orelse (9 < i) 22 | then ( 23 | err COMPLAIN "fixity precedence must be between 0 and 9" nullErrorBody; 24 | 9) 25 | else i 26 | 27 | (* layered patterns *) 28 | 29 | fun lay3 ((x as VarPat _), y, _) = LayeredPat{varPat=x,expPat=y} 30 | | lay3 (ConstraintPat{pattern,constraint}, y, err) = 31 | (err COMPLAIN "illegal (multiple?) type constraints in AS pattern" 32 | nullErrorBody; 33 | case lay3 (pattern,y,err) 34 | of LayeredPat{varPat,expPat} => 35 | LayeredPat{varPat=varPat, 36 | expPat=ConstraintPat{pattern=expPat, 37 | constraint=constraint}} 38 | | pat => pat) 39 | | lay3 (MarkPat(x,_),y, err) = lay3 (x,y,err) 40 | | lay3 (FlatAppPat[x],y,err) = (err COMPLAIN "parentheses illegal around variable in AS pattern" nullErrorBody; y) 41 | | lay3 (x,y,err) = (err COMPLAIN "pattern to left of AS must be variable" 42 | nullErrorBody; y) 43 | 44 | fun lay2 (ConstraintPat{pattern,constraint}, y, err) = 45 | (err COMPLAIN "illegal (multiple?) type constraints in AS pattern" 46 | nullErrorBody; 47 | case lay2 (pattern,y,err) 48 | of LayeredPat{varPat,expPat} => 49 | LayeredPat{varPat=varPat, 50 | expPat=ConstraintPat{pattern=expPat, 51 | constraint=constraint}} 52 | | pat => pat) 53 | | lay2 (MarkPat(x,_),y, err) = lay2 (x,y,err) 54 | | lay2 (FlatAppPat[{item,...}],y,err) = lay3(item,y,err) 55 | | lay2 p = lay3 p 56 | 57 | fun lay (ConstraintPat{pattern,constraint}, y, err) = 58 | (case lay2 (pattern,y,err) 59 | of LayeredPat{varPat,expPat} => 60 | LayeredPat{varPat=varPat, 61 | expPat=ConstraintPat{pattern=expPat, 62 | constraint=constraint}} 63 | | pat => pat) 64 | | lay (MarkPat(x,_),y, err) = lay (x,y,err) 65 | | lay p = lay2 p 66 | 67 | val layered = lay 68 | 69 | (* sequence of declarations *) 70 | fun makeSEQdec (SeqDec a, SeqDec b) = SeqDec(a@b) 71 | | makeSEQdec (SeqDec a, b) = SeqDec(a@[b]) 72 | | makeSEQdec (a, SeqDec b) = SeqDec(a::b) 73 | | makeSEQdec (a,b) = SeqDec[a,b] 74 | 75 | 76 | fun QuoteExp s = AppExp{function=VarExp quoteDcon,argument=StringExp s} 77 | fun AntiquoteExp e = AppExp{function=VarExp antiquoteDcon,argument= e} 78 | 79 | end (* structure *) 80 | 81 | 82 | -------------------------------------------------------------------------------- /Parse/lex/.cvsignore: -------------------------------------------------------------------------------- 1 | ml.lex.sml 2 | -------------------------------------------------------------------------------- /Parse/lex/.gitignore: -------------------------------------------------------------------------------- 1 | ml.lex.sml 2 | -------------------------------------------------------------------------------- /Parse/lex/tokentable.sml: -------------------------------------------------------------------------------- 1 | (* tokentable.sml 2 | * 3 | * COPYRIGHT (c) 1996 Bell Laboratories. 4 | * 5 | *) 6 | 7 | (*************************************************************************** 8 | 9 | TOKEN.SML: hash table for token recognition 10 | 11 | ***************************************************************************) 12 | 13 | functor TokenTable (Tokens:ML_TOKENS) : sig 14 | 15 | val checkId : (string * int) -> (Tokens.svalue,int) Tokens.token 16 | val checkSymId : (string * int) -> (Tokens.svalue,int) Tokens.token 17 | val checkTyvar : (string * int) -> (Tokens.svalue,int) Tokens.token 18 | 19 | end = struct 20 | 21 | exception NotToken 22 | 23 | structure Tbl = WordStringHashTable 24 | 25 | val hashStr = HashString.hashString 26 | 27 | fun mkTable (sz, l) = let 28 | val t = Tbl.mkTable (sz, NotToken) 29 | fun ins (str, tokfn) = 30 | Tbl.insert t ((hashStr str, str), tokfn) 31 | in 32 | List.app ins l; 33 | t 34 | end 35 | 36 | val symIdTbl = mkTable (16, [ 37 | ("*" , fn yypos => Tokens.ASTERISK(yypos,yypos+1)), 38 | ("|" , fn yypos => Tokens.BAR(yypos,yypos+1)), 39 | (":" , fn yypos => Tokens.COLON(yypos,yypos+1)), 40 | (":>" , fn yypos => Tokens.COLONGT(yypos,yypos+1)), 41 | ("=" , fn yypos => Tokens.EQUALOP(yypos,yypos+1)), 42 | ("#" , fn yypos => Tokens.HASH(yypos,yypos+1)), 43 | ("->" , fn yypos => Tokens.ARROW(yypos,yypos+2)), 44 | ("=>" , fn yypos => Tokens.DARROW(yypos,yypos+2)) 45 | ]) 46 | 47 | val idTbl = mkTable (64, [ 48 | ("and" , fn yypos => Tokens.AND(yypos,yypos+3)), 49 | ("abstype" , fn yypos => Tokens.ABSTYPE(yypos,yypos+7)), 50 | ("as" , fn yypos => Tokens.AS(yypos,yypos+2)), 51 | ("case" , fn yypos => Tokens.CASE(yypos,yypos+4)), 52 | ("datatype" , fn yypos => Tokens.DATATYPE(yypos,yypos+8)), 53 | ("else" , fn yypos => Tokens.ELSE(yypos,yypos+4)), 54 | ("end" , fn yypos => Tokens.END(yypos,yypos+3)), 55 | ("eqtype" , fn yypos => Tokens.EQTYPE(yypos,yypos+6)), 56 | ("exception", fn yypos => Tokens.EXCEPTION(yypos,yypos+9)), 57 | ("do" , fn yypos => Tokens.DO(yypos,yypos+2)), 58 | ("fn" , fn yypos => Tokens.FN(yypos,yypos+2)), 59 | ("fun" , fn yypos => Tokens.FUN(yypos,yypos+3)), 60 | ("functor" , fn yypos => Tokens.FUNCTOR(yypos,yypos+7)), 61 | ("funsig" , fn yypos => Tokens.FUNSIG(yypos,yypos+7)), 62 | ("handle" , fn yypos => Tokens.HANDLE(yypos,yypos+6)), 63 | ("if" , fn yypos => Tokens.IF(yypos,yypos+2)), 64 | ("in" , fn yypos => Tokens.IN(yypos,yypos+2)), 65 | ("include" , fn yypos => Tokens.INCLUDE(yypos,yypos+7)), 66 | ("infix" , fn yypos => Tokens.INFIX(yypos,yypos+5)), 67 | ("infixr" , fn yypos => Tokens.INFIXR(yypos,yypos+6)), 68 | ("lazy" , fn yypos => 69 | if !ParserControl.lazysml then 70 | Tokens.LAZY(yypos,yypos+4) 71 | else raise NotToken), 72 | ("let" , fn yypos => Tokens.LET(yypos,yypos+3)), 73 | ("local" , fn yypos => Tokens.LOCAL(yypos,yypos+5)), 74 | ("nonfix" , fn yypos => Tokens.NONFIX(yypos,yypos+6)), 75 | ("of" , fn yypos => Tokens.OF(yypos,yypos+2)), 76 | ("op" , fn yypos => Tokens.OP(yypos,yypos+2)), 77 | ("open" , fn yypos => Tokens.OPEN(yypos,yypos+4)), 78 | ("overload" , fn yypos => 79 | if !ParserControl.overloadKW then 80 | Tokens.OVERLOAD(yypos,yypos+8) 81 | else raise NotToken), 82 | ("raise" , fn yypos => Tokens.RAISE(yypos,yypos+5)), 83 | ("rec" , fn yypos => Tokens.REC(yypos,yypos+3)), 84 | ("sharing" , fn yypos => Tokens.SHARING(yypos,yypos+7)), 85 | ("sig" , fn yypos => Tokens.SIG(yypos,yypos+3)), 86 | ("signature", fn yypos => Tokens.SIGNATURE(yypos,yypos+9)), 87 | ("struct" , fn yypos => Tokens.STRUCT(yypos,yypos+6)), 88 | ("structure", fn yypos => Tokens.STRUCTURE(yypos,yypos+9)), 89 | ("then" , fn yypos => Tokens.THEN(yypos,yypos+4)), 90 | ("type" , fn yypos => Tokens.TYPE(yypos,yypos+4)), 91 | ("val" , fn yypos => Tokens.VAL(yypos,yypos+3)), 92 | ("where" , fn yypos => Tokens.WHERE(yypos,yypos+5)), 93 | ("while" , fn yypos => Tokens.WHILE(yypos,yypos+5)), 94 | ("with" , fn yypos => Tokens.WITH(yypos,yypos+4)), 95 | ("withtype" , fn yypos => Tokens.WITHTYPE(yypos,yypos+8)), 96 | ("orelse" , fn yypos => Tokens.ORELSE(yypos,yypos+6)), 97 | ("andalso" , fn yypos => Tokens.ANDALSO(yypos,yypos+7)) 98 | ]) 99 | 100 | val overloadHash = hashStr "overload" 101 | val lazyHash = hashStr "lazy" 102 | 103 | (* look-up an identifier. If the symbol is found, the corresponding token is 104 | * generated with the position of its begining. Otherwise it is a regular 105 | *) 106 | fun checkId (str, yypos) = let 107 | val hash = hashStr str 108 | fun mkId () = 109 | Tokens.ID(FastSymbol.rawSymbol(hash,str), yypos, yypos+size(str)) 110 | in 111 | Tbl.lookup idTbl (hash, str) yypos 112 | handle NotToken => mkId () 113 | end 114 | 115 | fun checkSymId (str, yypos) = let 116 | val hash = hashStr str 117 | in 118 | Tbl.lookup symIdTbl (hash, str) yypos 119 | handle NotToken => 120 | Tokens.ID(FastSymbol.rawSymbol(hash,str), yypos, yypos+size(str)) 121 | end 122 | 123 | fun checkTyvar (str, yypos) = let 124 | val hash = hashStr str 125 | in 126 | Tokens.TYVAR (FastSymbol.rawSymbol(hash,str),yypos,yypos+size (str)) 127 | end 128 | 129 | end 130 | -------------------------------------------------------------------------------- /Parse/main/parser.sig: -------------------------------------------------------------------------------- 1 | (* parser.sig 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature MLPARSER = sig 6 | 7 | datatype parseResult = 8 | EOF 9 | | ERROR 10 | | ABORT 11 | | PARSE of Ast.dec 12 | 13 | val parse : Source.inputSource -> unit -> parseResult 14 | end 15 | -------------------------------------------------------------------------------- /Parse/main/parser.sml: -------------------------------------------------------------------------------- 1 | (* parser.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | structure MLParser : MLPARSER = struct 6 | 7 | structure MLLrVals = MLLrValsFun(structure Token = LrParser.Token) 8 | structure Lex = MLLexFun(structure Tokens = MLLrVals.Tokens) 9 | structure MLP = JoinWithArg(structure ParserData = MLLrVals.ParserData 10 | structure Lex=Lex 11 | structure LrParser = LrParser) 12 | 13 | (* the following two functions are also defined in build/computil.sml *) 14 | val addLines = Stats.addStat(Stats.makeStat "Source Lines") 15 | 16 | open ErrorMsg 17 | 18 | datatype parseResult 19 | = EOF (* end of file reached *) 20 | | ERROR (* parsed successfully, but with syntactic or semantic errors *) 21 | | ABORT (* could not even parse to end of declaration *) 22 | | PARSE of Ast.dec 23 | 24 | val dummyEOF = MLLrVals.Tokens.EOF(0,0) 25 | val dummySEMI = MLLrVals.Tokens.SEMICOLON(0,0) 26 | 27 | fun parse (source as {sourceStream,errConsumer,interactive, 28 | sourceMap, anyErrors,...}: Source.inputSource) = 29 | let val err = ErrorMsg.error source 30 | val complainMatch = ErrorMsg.matchErrorString source 31 | 32 | fun parseerror(s,p1,p2) = err (p1,p2) COMPLAIN s nullErrorBody 33 | 34 | val lexarg = {comLevel = ref 0, 35 | sourceMap = sourceMap, 36 | charlist = ref (nil : string list), 37 | stringtype = ref false, 38 | stringstart = ref 0, 39 | err = err, 40 | brack_stack = ref (nil: int ref list)} 41 | 42 | val doprompt = ref true 43 | val prompt = ref (!ParserControl.primaryPrompt) 44 | 45 | fun inputc_sourceStream _ = TextIO.input(sourceStream) 46 | 47 | exception AbortLex 48 | fun getline k = 49 | (if !doprompt 50 | then (if !anyErrors then raise AbortLex else (); 51 | Control_Print.say 52 | (if !(#comLevel lexarg) > 0 53 | orelse !(#charlist lexarg) <> nil 54 | then !ParserControl.secondaryPrompt 55 | else !prompt); 56 | Control_Print.flush(); 57 | doprompt := false) 58 | else (); 59 | let val s = inputc_sourceStream k 60 | in doprompt := ((String.sub(s,size s - 1) = #"\n") 61 | handle _ => false); 62 | s 63 | end) 64 | 65 | val lexer = 66 | Lex.makeLexer (if interactive then getline 67 | else inputc_sourceStream) lexarg 68 | val lexer' = ref(LrParser.Stream.streamify lexer) 69 | val lookahead = if interactive then 0 else 30 70 | 71 | fun oneparse () = 72 | let val _ = prompt := !ParserControl.primaryPrompt 73 | val (nextToken,rest) = LrParser.Stream.get(!lexer') 74 | in (*if interactive then SourceMap.forgetOldPositions sourceMap 75 | else ();*) 76 | if MLP.sameToken(nextToken,dummySEMI) 77 | then (lexer' := rest; oneparse ()) 78 | else if MLP.sameToken(nextToken,dummyEOF) 79 | then EOF 80 | else let val _ = prompt := !ParserControl.secondaryPrompt; 81 | val initialLinePos = SourceMap.lastLinePos sourceMap 82 | val (result, lexer'') = 83 | MLP.parse(lookahead,!lexer',parseerror,err) 84 | val linesRead = SourceMap.newlineCount sourceMap 85 | (initialLinePos, SourceMap.lastLinePos sourceMap) 86 | in addLines(linesRead); 87 | lexer' := lexer''; 88 | if !anyErrors then ERROR else PARSE result 89 | end 90 | end handle LrParser.ParseError => ABORT 91 | | AbortLex => ABORT 92 | (* oneparse *) 93 | in fn () => (anyErrors := false; oneparse ()) 94 | end 95 | 96 | end 97 | -------------------------------------------------------------------------------- /Parse/main/parsercontrol.sml: -------------------------------------------------------------------------------- 1 | (* parsercontrol.sml 2 | * 3 | * (C) 2001 Lucent Technologies, Bell Labs 4 | *) 5 | signature PARSER_CONTROL = sig 6 | val primaryPrompt : string ref 7 | val secondaryPrompt : string ref 8 | 9 | (* turn on lazy keywords and lazy declaration processing *) 10 | val lazysml : bool ref (* default false *) 11 | (* controls "overload" as keyword *) 12 | val overloadKW : bool ref 13 | (* controls backquote quotation *) 14 | val quotation : bool ref 15 | end 16 | 17 | structure ParserControl : PARSER_CONTROL = struct 18 | 19 | val priority = [10, 10, 3] 20 | val obscurity = 3 21 | val prefix = "parser" 22 | 23 | val registry = ControlRegistry.new { help = "parser settings" } 24 | 25 | val _ = BasicControl.nest (prefix, registry, priority) 26 | 27 | val string_cvt = ControlUtil.Cvt.string 28 | val flag_cvt = ControlUtil.Cvt.bool 29 | 30 | val nextpri = ref 0 31 | 32 | fun new (c, n, h, d) = let 33 | val r = ref d 34 | val p = !nextpri 35 | val ctl = Controls.control { name = n, 36 | pri = [p], 37 | obscurity = obscurity, 38 | help = h, 39 | ctl = r } 40 | in 41 | nextpri := p + 1; 42 | ControlRegistry.register 43 | registry 44 | { ctl = Controls.stringControl c ctl, 45 | envName = SOME (ControlUtil.EnvName.toUpper "PARSER_" n) }; 46 | r 47 | end 48 | 49 | 50 | val primaryPrompt = 51 | new (string_cvt, "primary-prompt", "primary prompt", "- ") 52 | 53 | val secondaryPrompt = 54 | new (string_cvt, "secondary-prompt", "secondary prompt","= ") 55 | 56 | val lazysml = 57 | new (flag_cvt, "lazy-keyword", 58 | "whether `lazy' is considered a keyword", false) 59 | 60 | val overloadKW = 61 | new (flag_cvt, "overload", 62 | "whether (_)overload keyword is enabled", false) 63 | 64 | val quotation = 65 | new (flag_cvt, "quotations", 66 | "whether (anti-)quotations are recognized", false) 67 | end 68 | -------------------------------------------------------------------------------- /Parse/main/smlfile.sml: -------------------------------------------------------------------------------- 1 | (* COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies *) 2 | (* smlfile.sml *) 3 | 4 | signature SMLFILE = sig 5 | val parseOne : Source.inputSource -> unit -> Ast.dec option 6 | val parse : Source.inputSource -> Ast.dec 7 | end 8 | 9 | structure SmlFile :> SMLFILE = struct 10 | 11 | structure P = MLParser 12 | 13 | val parsePhase = Stats.makePhase "Compiler 010 parse" 14 | 15 | fun fail s = raise (CompileExn.Compile s) 16 | 17 | fun parseOne source = let 18 | val parser = P.parse source 19 | val parser = Stats.doPhase parsePhase parser (* for correct timing *) 20 | fun doit () = 21 | case parser () of 22 | P.EOF => NONE 23 | | P.ABORT => fail "syntax error" 24 | | P.ERROR => fail "syntax error" 25 | | P.PARSE ast => SOME ast 26 | in 27 | doit 28 | end 29 | 30 | fun parse source = let 31 | val parser = P.parse source 32 | val parser = Stats.doPhase parsePhase parser (* for correct timing *) 33 | fun loop asts = 34 | case parser () of 35 | P.EOF => Ast.SeqDec(rev asts) 36 | | P.ABORT => fail "syntax error" 37 | | P.ERROR => fail "syntax error" 38 | | P.PARSE ast => loop(ast::asts) 39 | in 40 | loop nil 41 | end 42 | end 43 | -------------------------------------------------------------------------------- /Parse/parse/.cvsignore: -------------------------------------------------------------------------------- 1 | ml.grm.desc 2 | ml.grm.sig 3 | ml.grm.sml 4 | -------------------------------------------------------------------------------- /Parse/parse/.gitignore: -------------------------------------------------------------------------------- 1 | ml.grm.desc 2 | ml.grm.sig 3 | ml.grm.sml 4 | /ml.grm.sml 5 | -------------------------------------------------------------------------------- /Parse/parse/ml.grm.sig: -------------------------------------------------------------------------------- 1 | signature ML_TOKENS = 2 | sig 3 | type ('a,'b) token 4 | type svalue 5 | val AQID: (FastSymbol.raw_symbol) * 'a * 'a -> (svalue,'a) token 6 | val OBJL: (string) * 'a * 'a -> (svalue,'a) token 7 | val ENDQ: (string) * 'a * 'a -> (svalue,'a) token 8 | val BEGINQ: 'a * 'a -> (svalue,'a) token 9 | val VECTORSTART: 'a * 'a -> (svalue,'a) token 10 | val FUNSIG: 'a * 'a -> (svalue,'a) token 11 | val ANDALSO: 'a * 'a -> (svalue,'a) token 12 | val ORELSE: 'a * 'a -> (svalue,'a) token 13 | val RPAREN: 'a * 'a -> (svalue,'a) token 14 | val RBRACKET: 'a * 'a -> (svalue,'a) token 15 | val RBRACE: 'a * 'a -> (svalue,'a) token 16 | val LPAREN: 'a * 'a -> (svalue,'a) token 17 | val LBRACKET: 'a * 'a -> (svalue,'a) token 18 | val LBRACE: 'a * 'a -> (svalue,'a) token 19 | val COMMA: 'a * 'a -> (svalue,'a) token 20 | val COLONGT: 'a * 'a -> (svalue,'a) token 21 | val COLON: 'a * 'a -> (svalue,'a) token 22 | val ASTERISK: 'a * 'a -> (svalue,'a) token 23 | val WITHTYPE: 'a * 'a -> (svalue,'a) token 24 | val WITH: 'a * 'a -> (svalue,'a) token 25 | val WILD: 'a * 'a -> (svalue,'a) token 26 | val WHILE: 'a * 'a -> (svalue,'a) token 27 | val WHERE: 'a * 'a -> (svalue,'a) token 28 | val VAL: 'a * 'a -> (svalue,'a) token 29 | val TYPE: 'a * 'a -> (svalue,'a) token 30 | val THEN: 'a * 'a -> (svalue,'a) token 31 | val STRUCTURE: 'a * 'a -> (svalue,'a) token 32 | val STRUCT: 'a * 'a -> (svalue,'a) token 33 | val SIGNATURE: 'a * 'a -> (svalue,'a) token 34 | val SIG: 'a * 'a -> (svalue,'a) token 35 | val SHARING: 'a * 'a -> (svalue,'a) token 36 | val REC: 'a * 'a -> (svalue,'a) token 37 | val RAISE: 'a * 'a -> (svalue,'a) token 38 | val OVERLOAD: 'a * 'a -> (svalue,'a) token 39 | val OPEN: 'a * 'a -> (svalue,'a) token 40 | val OP: 'a * 'a -> (svalue,'a) token 41 | val OF: 'a * 'a -> (svalue,'a) token 42 | val NONFIX: 'a * 'a -> (svalue,'a) token 43 | val LOCAL: 'a * 'a -> (svalue,'a) token 44 | val LET: 'a * 'a -> (svalue,'a) token 45 | val LAZY: 'a * 'a -> (svalue,'a) token 46 | val INFIXR: 'a * 'a -> (svalue,'a) token 47 | val INFIX: 'a * 'a -> (svalue,'a) token 48 | val INCLUDE: 'a * 'a -> (svalue,'a) token 49 | val IN: 'a * 'a -> (svalue,'a) token 50 | val IF: 'a * 'a -> (svalue,'a) token 51 | val HASH: 'a * 'a -> (svalue,'a) token 52 | val HANDLE: 'a * 'a -> (svalue,'a) token 53 | val FUNCTOR: 'a * 'a -> (svalue,'a) token 54 | val FUN: 'a * 'a -> (svalue,'a) token 55 | val FN: 'a * 'a -> (svalue,'a) token 56 | val DARROW: 'a * 'a -> (svalue,'a) token 57 | val DOT: 'a * 'a -> (svalue,'a) token 58 | val DO: 'a * 'a -> (svalue,'a) token 59 | val EXCEPTION: 'a * 'a -> (svalue,'a) token 60 | val EQTYPE: 'a * 'a -> (svalue,'a) token 61 | val EQUALOP: 'a * 'a -> (svalue,'a) token 62 | val END: 'a * 'a -> (svalue,'a) token 63 | val ELSE: 'a * 'a -> (svalue,'a) token 64 | val DOTDOTDOT: 'a * 'a -> (svalue,'a) token 65 | val DATATYPE: 'a * 'a -> (svalue,'a) token 66 | val CASE: 'a * 'a -> (svalue,'a) token 67 | val BAR: 'a * 'a -> (svalue,'a) token 68 | val AS: 'a * 'a -> (svalue,'a) token 69 | val ARROW: 'a * 'a -> (svalue,'a) token 70 | val AND: 'a * 'a -> (svalue,'a) token 71 | val ABSTYPE: 'a * 'a -> (svalue,'a) token 72 | val CHAR: (string) * 'a * 'a -> (svalue,'a) token 73 | val STRING: (string) * 'a * 'a -> (svalue,'a) token 74 | val REAL: (string) * 'a * 'a -> (svalue,'a) token 75 | val WORD: (IntInf.int) * 'a * 'a -> (svalue,'a) token 76 | val INT0: (IntInf.int) * 'a * 'a -> (svalue,'a) token 77 | val INT: (IntInf.int) * 'a * 'a -> (svalue,'a) token 78 | val TYVAR: (FastSymbol.raw_symbol) * 'a * 'a -> (svalue,'a) token 79 | val ID: (FastSymbol.raw_symbol) * 'a * 'a -> (svalue,'a) token 80 | val SEMICOLON: 'a * 'a -> (svalue,'a) token 81 | val EOF: 'a * 'a -> (svalue,'a) token 82 | end 83 | signature ML_LRVALS= 84 | sig 85 | structure Tokens : ML_TOKENS 86 | structure ParserData:PARSER_DATA 87 | sharing type ParserData.Token.token = Tokens.token 88 | sharing type ParserData.svalue = Tokens.svalue 89 | end 90 | -------------------------------------------------------------------------------- /Parse/parser.cm: -------------------------------------------------------------------------------- 1 | (* parser.cm 2 | * 3 | * The part of the SML/NJ frontend that is concerned with parsing. 4 | * 5 | * (C) 2001 Lucent Technologies, Bell Labs 6 | *) 7 | Group 8 | signature PARSER_CONTROL 9 | structure ParserControl 10 | 11 | signature AST 12 | signature ASTUTIL 13 | signature MLPARSER 14 | signature SMLFILE 15 | 16 | structure Ast 17 | structure AstUtil 18 | structure MLParser 19 | structure SmlFile 20 | is 21 | ast/ast.sig 22 | ast/ast.sml 23 | ast/astutil.sig 24 | ast/astutil.sml 25 | 26 | lex/tokentable.sml 27 | 28 | #if defined (NO_PLUGINS) 29 | lex/ml.lex.sml 30 | parse/ml.grm.sig 31 | parse/ml.grm.sml 32 | #else 33 | lex/ml.lex : MLLex 34 | parse/ml.grm : MLYacc 35 | #endif 36 | 37 | main/parsercontrol.sml 38 | main/parser.sig 39 | main/parser.sml 40 | main/smlfile.sml 41 | 42 | $smlnj/viscomp/basics.cm 43 | 44 | $smlnj/ml-yacc/ml-yacc-lib.cm 45 | 46 | $smlnj/smlnj-lib/smlnj-lib.cm 47 | $smlnj/smlnj-lib/controls-lib.cm 48 | $smlnj/basis/basis.cm 49 | -------------------------------------------------------------------------------- /infixes.sml: -------------------------------------------------------------------------------- 1 | infix 7 * / mod div 2 | infix 6 + - ^ 3 | infixr 5 :: @ 4 | infix 4 = <> > >= < <= 5 | infix 3 := o 6 | infix 0 before 7 | -------------------------------------------------------------------------------- /lint: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec sml @SMLcmdname="$0" @SMLload=lint.x86-linux "$@" 4 | -------------------------------------------------------------------------------- /lint.cm: -------------------------------------------------------------------------------- 1 | group 2 | structure Lint 3 | functor LintFn 4 | signature REPORT 5 | structure ReportErr 6 | is 7 | Parse/parser.cm 8 | top.sml 9 | lint.sml 10 | report.sig 11 | report.sml 12 | 13 | precedence.sml 14 | 15 | 16 | $smlnj/viscomp/elabdata.cm 17 | $smlnj/viscomp/basics.cm 18 | $smlnj/basis/basis.cm 19 | -------------------------------------------------------------------------------- /mkfile: -------------------------------------------------------------------------------- 1 | SMLNJHOME=`smlnj-home` 2 | SUFFIX=`$SMLNJHOME/bin/.arch-n-opsys | sed 's/.*HEAP_SUFFIX=//'` 3 | SRC=`find * -name '*.sml' -o -name '*.sig'` 4 | 5 | test:V: 6 | sml <<'EOF' 7 | CM.make "lint.cm"; 8 | Lint.parse "top.sml"; 9 | EOF 10 | 11 | ltest:V: 12 | sml <<'EOF' 13 | CM.make "lint.cm"; 14 | Lint.parse "lint.sml"; 15 | EOF 16 | 17 | lint:V: lint.$SUFFIX 18 | 19 | lint.$SUFFIX: $SRC 20 | ml-build lint.cm Lint.run lint 21 | 22 | install:V: $LIB/lint.$SUFFIX 23 | $LIB/lint.$SUFFIX: lint.$SUFFIX 24 | cp -av $prereq $target 25 | 26 | -------------------------------------------------------------------------------- /precedence.sml: -------------------------------------------------------------------------------- 1 | (* Copyright 1996 by AT&T Bell Laboratories *) 2 | (* precedence.sml *) 3 | 4 | signature PRECEDENCE_STANDALONE = 5 | sig 6 | type env 7 | val parse: {apply: 'a * 'a -> 'a, infixapp: 'a * 'a * 'a -> 'a} -> 8 | 'a Ast.fixitem list * env * 9 | (Ast.region->ErrorMsg.complainer) -> 'a 10 | 11 | end (* signature PRECEDENCE *) 12 | 13 | 14 | functor PrecedenceFn (type env 15 | val lookup : env * Symbol.symbol -> Fixity.fixity) 16 | : PRECEDENCE_STANDALONE = 17 | struct 18 | 19 | local structure EM = ErrorMsg 20 | structure F = Fixity 21 | 22 | in 23 | 24 | type env = env 25 | 26 | datatype 'a precStack 27 | = INf of Symbol.symbol * int * 'a * 'a precStack 28 | | NONf of 'a * 'a precStack 29 | | NILf 30 | 31 | fun parse {apply,infixapp} = 32 | let fun ensureNONf((e,F.NONfix,_,err),p) = NONf(e,p) 33 | | ensureNONf((e,F.INfix _,SOME sym,err),p) = 34 | (err EM.COMPLAIN 35 | ("expression or pattern begins with infix identifier \"" 36 | ^ Symbol.name sym ^ "\"") EM.nullErrorBody; 37 | NONf(e,p)) 38 | | ensureNONf _ = EM.impossible "precedence:ensureNONf" 39 | 40 | fun start token = ensureNONf(token,NILf) 41 | 42 | (* parse an expression *) 43 | fun parse(NONf(e,r), (e',F.NONfix,_,err)) = NONf(apply(e,e'),r) 44 | | parse(p as INf _, token) = ensureNONf(token,p) 45 | | parse(p as NONf(e1,INf(_,bp,e2,NONf(e3,r))), 46 | (e4, f as F.INfix(lbp,rbp),SOME sym,err))= 47 | if lbp > bp then INf(sym,rbp,e4,p) 48 | else (if lbp = bp 49 | then err EM.WARN "mixed left- and right-associative \ 50 | \operators of same precedence" 51 | EM.nullErrorBody 52 | else (); 53 | parse(NONf(infixapp(e3, e2, e1),r),(e4,f,SOME sym,err))) 54 | 55 | | parse(p as NONf _, (e',F.INfix(lbp,rbp),SOME sym,_)) = 56 | INf(sym,rbp,e',p) 57 | | parse _ = EM.impossible "Precedence.parse" 58 | 59 | (* clean up the stack *) 60 | fun finish (NONf(e1,INf(_,_,e2,NONf(e3,r))),err) = 61 | finish(NONf(infixapp(e3, e2, e1),r),err) 62 | | finish (NONf(e1,NILf),_) = e1 63 | | finish (INf(sym,_,e1,NONf(e2,p)),err) = 64 | (err EM.COMPLAIN 65 | ("expression or pattern ends with infix identifier \"" 66 | ^ Symbol.name sym ^ "\"") EM.nullErrorBody; 67 | finish(NONf(apply(e2,e1),p),err)) 68 | | finish (NILf,err) = EM.impossible "Corelang.finish NILf" 69 | | finish _ = EM.impossible "Corelang.finish" 70 | 71 | in fn (items as item1 :: items',env:env,error) => 72 | let fun getfix{item,region,fixity} = 73 | (item, case fixity of NONE => F.NONfix 74 | | SOME sym => lookup(env,sym), 75 | fixity, error region) 76 | 77 | fun endloc[{region=(_,x),item,fixity}] = error(x,x) 78 | | endloc(_::a) = endloc a 79 | | endloc _ = EM.impossible "precedence:endloc" 80 | 81 | fun loop(state, a::rest) = loop(parse(state,getfix a),rest) 82 | | loop(state,nil) = finish(state, endloc items) 83 | 84 | in loop(start(getfix item1), items') 85 | end 86 | | _ => EM.impossible "precedence:parse" 87 | end 88 | 89 | end (* local *) 90 | end (* structure Precedence *) 91 | -------------------------------------------------------------------------------- /report.sig: -------------------------------------------------------------------------------- 1 | 2 | signature REPORT = sig 3 | type t 4 | type name 5 | type pos 6 | type region = pos * pos (* starting and ending position *) 7 | val mk : SourceMap.sourcemap -> t 8 | val pushDef : name * t -> t 9 | val popDef : t -> t 10 | val brackets : string * region * t -> t 11 | val report : t * TextIO.outstream -> unit 12 | end 13 | 14 | -------------------------------------------------------------------------------- /report.sml: -------------------------------------------------------------------------------- 1 | structure ReportErr : REPORT = struct 2 | fun eprint s = TextIO.output (TextIO.stdErr, s) 3 | 4 | type t = SourceMap.sourcemap 5 | type name = Symbol.symbol 6 | type pos = SourceMap.charpos 7 | type region = pos * pos 8 | fun mk m = m 9 | fun pushDef (_, m) = m 10 | fun popDef m = m 11 | 12 | fun brackets (around, (pos, _), m) = 13 | let val {fileName, line, column} = SourceMap.filepos m pos 14 | val () = app eprint [fileName, ", line ", Int.toString line, 15 | ", column ", Int.toString column, ": ", 16 | "redundant parentheses ", around, "\n"] 17 | in m 18 | end 19 | 20 | fun report _ = () 21 | end 22 | 23 | -------------------------------------------------------------------------------- /smlnj-home: -------------------------------------------------------------------------------- 1 | #!/bin/ksh 2 | 3 | for i in /usr/lib/smlnj /usr/lib32/smlnj /usr/sup/smlnj-110.74 4 | do 5 | if [[ -r $i/bin/.arch-n-opsys ]]; then 6 | echo $i 7 | exit 0 8 | fi 9 | done 10 | 11 | echo "Cannot find SMLNJHOME" >&2 12 | exit 1 13 | -------------------------------------------------------------------------------- /top.sml: -------------------------------------------------------------------------------- 1 | structure LintErr = LintFn(structure Report = ReportErr) 2 | 3 | structure Lint = struct 4 | (* val _ = LintErr.debugging := true *) 5 | fun lint (source : Source.inputSource) dec = 6 | let val rpt = ReportErr.mk (#sourceMap source) 7 | val rpt = LintErr.elabDec({source=source}, dec, 8 | LintErr.initEnv, SourceMap.nullRegion, rpt) 9 | in rpt 10 | end 11 | 12 | 13 | fun parse filename = 14 | let val fd = TextIO.openIn (filename) 15 | val dev = PrettyPrintNew.defaultDevice 16 | val source = Source.newSource (filename, fd, false, ( dev)) 17 | in case MLParser.parse source () 18 | of MLParser.PARSE dec => SOME (lint source dec; dec) 19 | | _ => NONE 20 | end 21 | 22 | 23 | fun run (prog, argv) = 24 | (app (ignore o parse) argv; OS.Process.success) 25 | end 26 | --------------------------------------------------------------------------------