(*
    Copyright (c) 2000
        Cambridge University Technical Services Limited

    Modified David C.J. Matthews 2008-9, 2013, 2015.

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.
    
    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.
    
    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

(*
    Title:      Operations on global and local values.
    Author:     Dave Matthews, Cambridge University Computer Laboratory
    Copyright   Cambridge University 1986
*)

functor VALUE_OPS (

structure LEX : LEXSIG;
structure CODETREE : CODETREESIG
structure STRUCTVALS : STRUCTVALSIG;
structure TYPESTRUCT : TYPETREESIG

structure PRINTTABLE :
sig
    type typeConstrs
    type codetree
  
    val addOverload: string * typeConstrs * codetree -> unit
    val getOverload: string * typeConstrs * (unit->codetree) -> codetree
    val getOverloads: string -> (typeConstrs * codetree) list
end;

structure UNIVERSALTABLE:
sig
    type universal = Universal.universal
    type univTable
    val app: (string * universal -> unit) -> univTable -> unit
end;

structure DEBUG : DEBUGSIG

structure MISC :
sig
    exception InternalError of string; (* compiler error *)
    exception Conversion of string     (* string to int conversion failure *)

    val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list
end;

structure PRETTY : PRETTYSIG
structure ADDRESS : AddressSig

structure UTILITIES :
sig
  val splitString: string -> { first:string,second:string }
end;

structure COPIER: COPIERSIG

structure TYPEIDCODE: TYPEIDCODESIG

structure DATATYPEREP: DATATYPEREPSIG

sharing STRUCTVALS.Sharing = TYPESTRUCT.Sharing = LEX.Sharing = PRETTY.Sharing
      = COPIER.Sharing = CODETREE.Sharing = PRINTTABLE = ADDRESS = UNIVERSALTABLE = MISC
      = TYPEIDCODE.Sharing = DATATYPEREP.Sharing

) : VALUEOPSSIG =

(*****************************************************************************)
(*                  VALUEOPS functor body                                    *)
(*****************************************************************************)
struct
  open MISC; 
  open PRETTY;
  
  open LEX;
  open CODETREE;
  open TYPESTRUCT; (* Open this first because unitType is in STRUCTVALS as well. *)
  open Universal; (* for tag etc. *)
  open STRUCTVALS;
  open PRINTTABLE;
  open DEBUG;
  open ADDRESS;
  open RuntimeCalls; (* for POLY_SYS and EXC numbers *)
  open UTILITIES;
  open TYPEIDCODE
  open COPIER
  open DATATYPEREP
  
    (* Functions to construct the values. *)

    fun mkGconstr (name, typeof, code, nullary, constrs, location) =
       makeValueConstr (name, typeof, nullary, constrs, Global code, location);

    (* Global variable *)
    fun mkGvar (name, typeOf, code, locations) : values =
        Value{ name = name, typeOf = typeOf, access = Global code, class = ValBound,
            locations = locations, references = NONE, instanceTypes=NONE };

    (* Local variable - Generated by the second pass. *)
    local
        fun makeLocalV class (name, typeOf, locations) =
            Value{ name = name, typeOf = typeOf, access = Local {addr = ref ~1 (* Must be set later *), level = ref baseLevel},
                    class = class, locations = locations, references = makeRef(),
                    instanceTypes=SOME(ref []) };
    in
        val mkValVar = makeLocalV ValBound
        and mkPattVar = makeLocalV PattBound
    end

    (* Value in a local structure or a functor argument.  May be simple value, exception
        or constructor. *)
    fun mkSelectedVar (Value { access = Formal addr, name, typeOf, class, locations, ...}, base, openLocs) =
        (* If the argument is "formal" set the base to the base structure. *)
        Value{name=name, typeOf=typeOf, class=class,
              access=Selected{addr=addr, base=base},
              locations=openLocs @ locations, references = NONE, instanceTypes=NONE}

    |   mkSelectedVar (Value { access = Global code, name, typeOf, class, locations, ...}, _, openLocs) =
        (* Global: We need to add the location information. *)
        Value{name=name, typeOf=typeOf, class=class, access=Global code,
              locations=openLocs @ locations, references = NONE, instanceTypes=NONE}

    |   mkSelectedVar(selected, _, _) = selected (* Overloaded? *);

    (* Construct a global exception. *)
    fun mkGex (name, typeof, code, locations) =
        Value{ name = name, typeOf = typeof, access = Global code,
           class = Exception, locations = locations, references = NONE, instanceTypes=NONE }
 
    (* Construct a local exception. *)
    fun mkEx (name, typeof, locations) = 
        Value{ name = name, typeOf = typeof,
           access = Local{addr = ref 0, level = ref baseLevel},
           class = Exception, locations=locations, references = NONE, instanceTypes=NONE }

    (* Locations in exception packets.  In order to have a defined ordering of the fields,
       when we put the location in an exception packet we use this datatype rather than
       the "location" type. *)
     (* *)
    datatype RuntimeLocation =
        NoLocation
    |   SomeLocation of
            (* file: *) string * 
            (*startLine:*) int *  (*startPosition:*) int *
            (*endLine:*) int * (*endPosition:*) int

    fun codeLocation({file="", startLine=0, startPosition=0, ...}) =
        mkConst(toMachineWord NoLocation) (* No useful information *)
    |   codeLocation({file, startLine, startPosition, endLine, endPosition}) =
        mkConst(toMachineWord(file, startLine, startPosition, endLine, endPosition))

(*****************************************************************************)
  (* Look-up functions. *)

    (* Look up a structure. *)
    fun lookupStructure (kind, {lookupStruct:string -> structVals option},
               name, errorMessage) =
    let
        val {first = prefix, second = suffix} = splitString name;
        val strLookedUp =
            if prefix = ""
            then lookupStruct suffix
            else case lookupStructure
                        ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of
                NONE => NONE (* Already reported *)
            |   SOME(str as Struct { signat, locations, ...}) =>
                let  (* Look up the first part in the structure environment. *)
                    val Signatures { tab, typeIdMap, firstBoundIndex, ... } = signat
                    val Env{lookupStruct, ...} = makeEnv tab
                    (* If we have a DeclaredAt location for the structure use this as the StructureAt.*)
                    val baseLoc =
                    case List.find (fn DeclaredAt _ => true | _ => false) locations of
                        SOME (DeclaredAt loc) => [StructureAt loc]
                    |   _ => []
                in
                    case lookupStruct suffix of
                        SOME (Struct {signat, access, name=structName, locations, ...})  =>
                        let
                            val Signatures { name=sigName, tab, typeIdMap = childMap, locations=sigLocs, ... } = signat
                            (* We need to apply the map from the parent structure to the child. *)
                            val copiedSig =
                                makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(childMap, typeIdMap), [])
                            (* Convert Formal access to Selected and leave the others (Global?). *)
                            val newAccess =
                                case access of
                                    Formal sel => makeSelected (sel, str)
                                |   access => access
                        
                            val newStruct =
                                Struct { name = structName, signat = copiedSig,
                                         access = newAccess, locations = baseLoc @ locations}
                        in
                            SOME newStruct
                        end
                    |   NONE => NONE
                end
    in
        case strLookedUp of
           SOME s => SOME s
        |  NONE =>
             (* Not declared? *)
                (errorMessage (kind ^ " (" ^ suffix ^  ") has not been declared" ^
                   (if prefix = "" then "" else " in structure " ^ prefix));
                NONE)
    end

    fun mkEnv x = let val Env e = makeEnv x in e end

    (* Look up a structure but ignore the access. This is used in sharing constraints
       where we're only interested in the signature. *)
    (* It's simpler to use the common code for this. *)
    fun lookupStructureAsSignature (lookupStruct, name, errorMessage) =
        lookupStructure("Structure", { lookupStruct = lookupStruct}, name, errorMessage)

    (* Look up a value, possibly in a structure. If it is in
       a structure we may have to apply a selection. *)
    fun lookupValue (kind, {lookupVal,lookupStruct}, name, errorMessage) =
    let
        val {first = prefix, second = suffix} = splitString name;
        val found =
        if prefix = "" then lookupVal suffix
        (* Look up the first part in the structure environment. *)
        else case lookupStructure
                    ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of
            NONE => SOME undefinedValue
        |   SOME (baseStruct as Struct { signat, locations, ...}) =>
            let
                val Signatures { tab, typeIdMap, ...} = signat
                (* If we have a DeclaredAt location for the structure use this as the StructureAt.*)
                val baseLoc =
                    case List.find (fn DeclaredAt _ => true | _ => false) locations of
                        SOME (DeclaredAt loc) => [StructureAt loc]
                    |   _ => []
            in
                case #lookupVal (mkEnv tab) suffix of
                    SOME (Value{ name, typeOf, access, class, locations, ... }) =>
                    let
                        fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(typeIdMap offset)
                        |   copyId _ = NONE
                        val copiedType =
                            copyType (typeOf, fn x => x,
                                fn tcon =>
                                    copyTypeConstr (tcon, copyId, fn x => x, fn s => prefix^"."^s))                            
                    in
                        SOME(mkSelectedVar (
                                Value{ name=name, typeOf=copiedType, access=access, class=class, locations=locations,
                                       references = NONE, instanceTypes=NONE },
                                baseStruct, baseLoc))
                    end
                |   NONE => NONE
            end
    in
        case found of
            SOME v => v
        |   NONE => (* Not declared? *)
            (
                errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^
                    (if prefix = "" then "" else " in structure " ^ prefix));
                undefinedValue
            )
    end

    fun lookupTyp ({lookupType,lookupStruct}, name, errorMessage) =
    let
        val {first = prefix, second = suffix} = splitString name;
        val found =
        if prefix = "" then lookupType suffix
        else (* Look up the first part in the structure environment. *)
            case lookupStructure
                    ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of
            NONE => SOME(TypeConstrSet(undefConstr, []))
        |   SOME (Struct { signat, ...}) =>
            let
                val Signatures { tab, typeIdMap, ...} = signat
            in
                case #lookupType (mkEnv tab) suffix of
                    SOME typeConstr => SOME(fullCopyDatatype(typeConstr, typeIdMap, prefix^"."))
                |   NONE => NONE
            end
    in
        case found of
            SOME v => v
        |   NONE => (* Not declared? *)
            (
                errorMessage ("Type constructor" ^ " (" ^ suffix ^ ") has not been declared" ^
                (if prefix = "" then "" else " in structure " ^ prefix));
                TypeConstrSet(undefConstr, [])
            )
    end 

 
      (* Printing. *)

    (* This name space is used to help find type identifiers.
       However, because the functions are passed through to the resulting environment
       by INITIALISE we have to use the same type as the normal top-level environment. *)
    type nameSpace =
      { 
        lookupVal:    string -> values option,
        lookupType:   string -> typeConstrSet option,
        lookupFix:    string -> fixStatus option,
        lookupStruct: string -> structVals option,
        lookupSig:    string -> signatures option,
        lookupFunct:  string -> functors option,

        enterVal:     string * values      -> unit,
        enterType:    string * typeConstrSet -> unit,
        enterFix:     string * fixStatus   -> unit,
        enterStruct:  string * structVals  -> unit,
        enterSig:     string * signatures  -> unit,
        enterFunct:   string * functors    -> unit,

        allVal:       unit -> (string*values) list,
        allType:      unit -> (string*typeConstrSet) list,
        allFix:       unit -> (string*fixStatus) list,
        allStruct:    unit -> (string*structVals) list,
        allSig:       unit -> (string*signatures) list,
        allFunct:     unit -> (string*functors) list
      };

  val nullEnvironment : nameSpace =
     {
        lookupVal = fn _ => NONE,
        lookupType = fn _ => NONE,
        lookupFix = fn _ => NONE,
        lookupStruct = fn _ => NONE,
        lookupSig = fn _ => NONE,
        lookupFunct = fn _ => NONE,
        enterVal = fn _ => (),
        enterType = fn _ => (),
        enterFix = fn _ => (),
        enterStruct = fn _ => (),
        enterSig = fn _ => (),
        enterFunct = fn _ => (),
        allVal = fn () => [],
        allType = fn () => [],
        allFix = fn () => [],
        allStruct = fn () => [],
        allSig = fn () => [],
        allFunct = fn () => []
        }

    (* Print a value given its type. *)
    fun printValueForType (value:machineWord, types, depth): pretty =
    let
        (* Constuct printer code applied to the argument and the depth.
           Code-generate and evaluate it. *)
        (* If this is polymorphic apply it to a dummy set of instance types.
           This may happen if we have val it = NONE at the top level.
           The equality attributes of the type variables must match so that
           this works correctly with justForEqualityTypes set. *)
        val addrs = ref 0 (* Make local declarations for any type values. *)
        local
            fun mkAddr n = !addrs before (addrs := !addrs + n)
        in
            val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, baseLevel)
        end
        val dummyTypes =
            List.map(fn tv => {value=TYPESTRUCT.unitType, equality=tvEquality tv, printity=false})
                (getPolyTypeVars(types, fn _ => NONE))
        val polyCode = applyToInstance(dummyTypes, baseLevel, typeVarMap, fn _ => mkConst value)
        val printerCode =
            mkEval(
                printerForType(types, baseLevel, typeVarMap),
                [mkTuple[polyCode, mkConst(toMachineWord depth)]])
        val pretty =
            RunCall.unsafeCast(
                valOf(evalue(genCode(CODETREE.mkEnv(TypeVarMap.getCachedTypeValues typeVarMap, printerCode), [], !addrs)())))
    in
        pretty
    end

    (* These are used to display the declarations made. *)
    fun displayFixStatus(FixStatus(name, f)): pretty =
    let
        open PRETTY
        
        val status =
            case f of
                Nonfix => PrettyString "nonfix"
            |   Infix prec =>
                    PrettyBlock(0, false, [],
                        [ PrettyString "infix", PrettyBreak (1, 0), PrettyString (Int.toString prec) ])
            |   InfixR prec =>
                    PrettyBlock(0, false, [],
                        [ PrettyString "infixr", PrettyBreak (1, 0), PrettyString (Int.toString prec) ])
    in
        PrettyBlock (0, false, [],
            [status, PrettyBreak (1, 0), PrettyString name])
    end

    (* Returns the declaration location as the location for the context. *)
    fun getLocation locations =
        case List.find(fn DeclaredAt _ => true | _ => false) locations of
            SOME(DeclaredAt loc) => [ContextLocation loc]
        |   _ => []


    (* Displays value as a block, with no external formatting.  This is used at the
       top level but it can be applied to values extracted with #lookup globalNameSpace.
       That can include constructors and overloaded functions. *)
    fun displayValues (Value{name, typeOf, class, access, locations, ...}, depth, nameSpace, sigMap): pretty =
    let
        (* Create the "val X =" part. *)
        fun valPart (valOrCons, isColon) =
        let
            val (space, equOrColon) = if isColon then (0, ":") else (1, "=")
        in
            PrettyBlock (0, false, [],
                [
                    PrettyString valOrCons,
                    PrettyBreak (1, 0),
                    PrettyBlock(0, false, getLocation locations, [PrettyString name]),
                    PrettyBreak (space, 0),
                    PrettyString equOrColon
                ]
            )
        end
        val typeEnv = (* Environment to check for type constructors. *)
            { lookupType = #lookupType nameSpace, lookupStruct = #lookupStruct nameSpace}
    in
  
        if depth <= 0 
        then PrettyString "..."

        else case class of
            ValBound =>
            let
                (* In nearly all cases if we have Global code we will have a constant.
                   There was one case where "!" was actually a Lambda that hadn't been
                   code-generated. *)
                val value =
                    case access of Global code => evalue code | _ => NONE
                val start =
                    case value of
                        SOME v =>
                        [
                            valPart("val", false),
                            PrettyBreak (1, 0),
                            printValueForType (v, typeOf, depth),
                            PrettyString ":"
                        ]
                    |   _ => [ valPart("val", true) ]
            in
                PrettyBlock (3, false, [],
                    start @ [ PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ])
            end

        |    Exception => (* exceptions *)
             PrettyBlock (0, false, [],
                PrettyBlock (0, false, [],
                    [
                        PrettyString "exception",
                        PrettyBreak (1, 0),
                        PrettyBlock(0, false, getLocation locations, [PrettyString name])
                    ]
                )
                ::
                (
                    case getFnArgType typeOf of
                       NONE => []
                    |  SOME excType =>
                        [ PrettyBreak (1, 1), PrettyString "of", PrettyBreak (1, 3), displayWithMap (excType, depth, typeEnv, sigMap) ]
                )
            )

        | Constructor _ => (* This can only occur with #lookupVal *)
            PrettyBlock (3, false, [],
                [ valPart("constructor", true), PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ])
     
        | PattBound => (* Can this ever occur? *)
            PrettyBlock (3, false, [],
                [ valPart("val", true), PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ])
    end

    (* Print global values.  This is passed through the bootstrap and used in the debugger. *)
    fun printValues (Value{typeOf, class, access, ...}, depth) =
        case (class, access) of
            (ValBound, Global code) => printValueForType (valOf(evalue code), typeOf, depth)
        | _ => PrettyString "" (* Probably shouldn't occur. *)

    (* Prints "sig ... end" as a block, with no external formatting *)
    fun displaySig (Signatures{tab, typeIdMap, ...}, depth : int, _ : int,
                    { lookupType, lookupStruct, ...}, sigMap: (int-> typeId) option) : pretty =
    let
        (* Construct an environment for the types. *)

        val Env { lookupType = strType, lookupStruct = strStr, ...} = makeEnv tab

        (* Construct a map for types. *)
        val innerMap =
            case sigMap of
                NONE => SOME typeIdMap
            |   SOME outerMap => SOME(composeMaps(typeIdMap, outerMap))

        val compositeEnv =
        {
            lookupType   =
                fn s => case strType s of NONE => lookupType s | SOME t => SOME (t, innerMap),
            lookupStruct =
                fn s => case strStr s of NONE => lookupStruct s | SOME s => SOME (s, innerMap)
        }
        
        val typeEnv: printTypeEnv =
            { lookupType = #lookupType compositeEnv, lookupStruct = #lookupStruct compositeEnv }

        fun displaySpec (_, value) : pretty list =
        if (tagIs signatureVar value)
        then (* Not legal ML97 *)
            [ PrettyBreak(1,2), displaySignatures (tagProject signatureVar value, depth - 1, compositeEnv)]
           
        else if (tagIs structVar value)
        then
            [ PrettyBreak(1,2), displayStructures (tagProject structVar value, depth - 1, compositeEnv, innerMap)]
               
        else if (tagIs typeConstrVar value)
        then 
            [ PrettyBreak(1,2), displayTypeConstrsWithMap (tagProject typeConstrVar value, depth, typeEnv, innerMap) ]
      
        else if (tagIs valueVar value)
        then
        let
            (* Only print variables. Constructors are printed with their type. *)
            val value = tagProject valueVar value;
        in
            case value of
                Value{class = Constructor _, ...} => []
            |    _ =>
              [ PrettyBreak(1,2),
              (* We lookup the infix status and any exception in the global environment
                 only.  Infix status isn't a property of a structure and it's too
                 much trouble to look up exceptions in the structure. *)
                displayValues (value, depth, compositeEnv, innerMap)
              ]
        end
      
        else if (tagIs fixVar value)
        then  (* Not legal ML97 *)
            [ PrettyBreak(1,2), displayFixStatus (tagProject fixVar value) ]
 
        else []
       (* end displaySpec *)
    in
        PrettyBlock (0, true, [],
            PrettyString "sig" ::
            (
                (
                    if depth <= 1 (* If the depth is 1 each of the calls to displaySpec will
                                     print "..." so we replace them all by a single "..." here. *)
                    then [PrettyBreak (1, 0), PrettyString "..."]
                    else
                    let
                        val declist = ref nil : (string * universal) list ref
                        fun addToList nv = declist := nv :: !declist
                        (* For the moment order them by name.  We may change this to
                           order primarily by kind and secondarily by name. *)
                        fun order (s1: string, _) (s2: string, _) = s1 > s2
                    in
                        (* Put all the entries into a list. *)
                        UNIVERSALTABLE.app addToList tab;
                        (* Sort the list and print it. *)
                        List.foldl
                            (fn (a, l) => displaySpec a @ l)
                            [] (quickSort order (!declist))
                    end
                )
                @ [PrettyBreak (1, 0), PrettyString "end"]
            )
        )
        end (* displaySig *)

  (* Print: signature S = sig .... end *)
  and displaySignatures (str as Signatures{locations, name, ...}, depth : int, nameSpace) : pretty =
    if depth <= 0 then PrettyString "..."
    else
        PrettyBlock(0, false, [],
            [
                PrettyBlock(0, false, [],
                    [
                        PrettyString "signature",
                        PrettyBreak(1, 0),
                        PrettyBlock(0, false, getLocation locations, [PrettyString name]),
                        PrettyBreak(1, 0),
                        PrettyString "="
                    ]
                ),
            PrettyBreak (1, 2),
            displaySig (str, depth, 1, nameSpace, NONE)
            ])

  (* print structure in a block (no external spacing) *)
    and displayStructures (Struct{name, locations, signat, ...}, depth, nameSpace, sigMap): pretty =
    if depth <= 0 then PrettyString "..."
    else
        PrettyBlock (0, false, [],
        [
            PrettyBlock(0, false, [],
                [
                    PrettyString "structure",
                    PrettyBreak(1, 0),
                    PrettyBlock(0, false, getLocation locations, [PrettyString name]),
                    PrettyBreak(0, 0),
                    PrettyString ":"
                ]
            ),
            PrettyBreak(1, 2),
            displayNamedSig(signat, depth - 1, 1, nameSpace, sigMap)
        ])

    (* Internal function for printing structures and functors.  If a signature has a
       name print the name rather than the contents. *)
    and displayNamedSig(sign as Signatures{name = "", ...}, depth, space, nameSpace, sigMap) =
            displaySig (sign, depth, space, nameSpace, sigMap)
    |   displayNamedSig(Signatures{name, ...}, _, _, _, _) = PrettyString name

    fun displayFunctors (Functor{ name, locations, arg, result, ...}, depth, nameSpace) =
    if depth <= 0 then PrettyString "..."
    else
    let
        val arg as 
             Struct { name = argName, signat as Signatures { tab = argTab, ... }, ...} = arg
        val argEntries =
            (if argName <> ""
            then [ PrettyBlock(0, false, [], [PrettyString argName, PrettyBreak(0, 0), PrettyString ":"]), PrettyBreak(1, 2) ]
            else []) @
            [
                displayNamedSig (signat, depth - 1, 0, nameSpace, NONE),
                PrettyBreak(0, 0),
                PrettyString "):",
                PrettyBreak(1, 0)
            ]
        (* Include the argument structure name in the type environment. *)
        val argEnv =
            if argName = ""
            then
            let
                val Env { lookupType=lt, lookupStruct=ls, ...} = makeEnv argTab
            in
                {
                    lookupType =
                        fn s => case lt s of NONE => #lookupType nameSpace s | SOME t => SOME(t, NONE),
                    lookupStruct =
                        fn s => case ls s  of NONE => #lookupStruct nameSpace s | SOME s => SOME(s, NONE)
                }
            end
            else
            {
                lookupType   = #lookupType nameSpace,
                lookupStruct =
                    fn s => if s = argName then SOME(arg, NONE) else #lookupStruct nameSpace s
            }
    in
        PrettyBlock (0, false, [],
            [
                PrettyBlock(0, false, [],
                [
                    PrettyBlock(0, false, [],
                    [
                        PrettyString "functor",
                        PrettyBreak(1, 0),
                        PrettyBlock(0, false, getLocation locations, [PrettyString name]),
                        PrettyBreak(1, 0),
                        PrettyString "("
                    ]),
                    PrettyBreak(0, 2),
                    PrettyBlock(0, false, [], argEntries)
                ]),
                PrettyBreak(0, 2),
                displayNamedSig (result, depth - 1, 1, argEnv, NONE)
            ]
        )
    end

    (* Exported version. *)
    val displayValues = fn (value, depth, nameSpace) => displayValues (value, depth, nameSpace, NONE)
    and displayStructures = fn (str, depth, nameSpace) => displayStructures (str, depth, nameSpace, NONE)
   
  (* Code-generation. *)

    (* Code-generate the values. *) 
    fun codeStruct (Struct{access, ...}, level) =
        (* Global structures have no code value. Instead the
            values are held in the values of the signature. *)
        codeAccess (access, level)

    and codeAccess (Global code, _) = code
      
    |   codeAccess (Local{addr=ref locAddr, level=ref locLevel}, level) =
            mkLoad (locAddr, level, locLevel) (* Argument or local *)
     
    |   codeAccess (Selected{addr, base}, level) = (* Select from a structure. *)
            mkInd (addr, codeStruct (base, level))
     
    | codeAccess _ = raise InternalError "No access"


(*****************************************************************************)
(*                  datatype access functions                                *)
(*****************************************************************************)

    (* Get the appropriate instance of an overloaded function.  If the
       overloading has not resolved to a single type it finds the preferred
       type if possible (i.e. int for most overloadings, but possibly real,
       word, string or char for conversion functions.) *)
    fun getOverloadInstance(name, instance, isConv): codetree*string =
    let
        val constr = typeConstrFromOverload(instance, isConv)
    in
        (getOverload(name, constr, fn _ => raise InternalError "getOverloadInstance: Missing"), tcName constr)
    end

    (* This is only used in addPrettyPrint.  There's no point in
       producing a lot of detailed information. *)
    fun checkPPType (instanceType, matchType, fnName, lex, location, moreInfo) =
        case unifyTypes (instanceType, matchType) of
            NONE => ()
        |   SOME error =>
            let
                open DEBUG
                val parameters = LEX.debugParams lex
                val errorDepth = getParameter errorDepthTag parameters
            in
                reportError lex
                {
                    location = location,
                    hard = true,
                    message =
                        PrettyBlock(0, true, [],
                            [
                                PrettyString ("Argument for " ^ fnName),
                                PrettyBreak (1, 3),
                                PrettyBlock(0, false, [],
                                    [
                                        PrettyString "Required type:",
                                        PrettyBreak (1, 0),
                                        display (matchType, errorDepth, emptyTypeEnv)
                                    ]),
                                PrettyBreak (1, 3),
                                PrettyBlock(0, false, [],
                                    [
                                        PrettyString "Argument type:",
                                        PrettyBreak (1, 0),
                                        display (instanceType, errorDepth, emptyTypeEnv)
                                    ]),
                                PrettyBreak (1, 3),
                                unifyTypesErrorReport(lex, emptyTypeEnv, emptyTypeEnv, "unify") error
                            ]),
                    context = SOME (moreInfo ())
               }
            end;

    (* This is applied to the instance variables if it is polymorphic and bound by
       a val or fun binding or is a datatype constructor. *)
    fun applyToInstanceType(polyVars, ValBound, level, typeVarMap, code) =
            applyToInstance(polyVars, level, typeVarMap, code)
    |   applyToInstanceType(polyVars, Constructor _, level, typeVarMap, code) =
            applyToInstance(if justForEqualityTypes then [] else polyVars, level, typeVarMap, code)
    |   applyToInstanceType(_, PattBound, level, _, code) = code level
    |   applyToInstanceType(_, Exception, level, _, code) = code level

    val arg1     = mkLoadArgument 0 (* saves a lot of garbage *)

    fun addStatus typ = {value=typ, equality=false, printity=false}

 (* Code-generate an identifier matched to a value.  N.B. If the value is a
    constructor it returns the pair or triple representing the functions on the
    constructor. *)
 fun codeVal (Value{access = Global code, class, ...}, level: level, typeVarMap, instance, _, _) =
            applyToInstanceType(instance, class, level, typeVarMap, fn _ => code)

  |  codeVal (Value{access = Local{addr=ref locAddr, level=ref locLevel}, class, ...},
                    level, typeVarMap, instance, _, _) =
    let
        fun loadVar level = mkLoad (locAddr, level, locLevel) (* Argument or local *)
    in
        applyToInstanceType(instance, class, level, typeVarMap, loadVar)
    end

  |  codeVal (Value{access = Selected{addr, base}, class, ...}, level: level, typeVarMap, instance, _, _) =
       (* Select from a structure. *)
       applyToInstanceType(instance, class, level, typeVarMap, fn level => mkInd (addr, codeStruct (base, level)))

  |  codeVal (Value{access = Formal _, ...}, _, _, _, _, _) =
          raise InternalError "codeVal - Formal"

  |  codeVal (Value{access = Overloaded Print, ...}, _, _, [], lex, _) =
        (* If this appears in a structure return a null printer function.
           It has to have the polymorphic form with an extra lambda outside. *)
        let
            (* We should have a single entry for the type. *)
            open DEBUG
            (* The parameter is the reference used to control the print depth
               when the value is actually printed. *)
            val prettyOut = getPrintOutput (LEX.debugParams lex)
        in
            mkProc(
                mkProc(
                    CODETREE.mkEnv
                    (
                        [
                            mkNullDec
                            (mkEval(
                                mkConst(toMachineWord prettyOut),
                                [ mkConst(toMachineWord(PrettyString "?")) ])
                            )
                        ],
                        arg1 (* Returns its argument. *)
                    ),
                    1, "print()", [], 0),
                1, "print(P)", [], 0)
        end

  |  codeVal (Value{access = Overloaded Print, ...}, level: level, typeVarMap, [{value=argType, ...}], lex, _) =
        let 
            (* We should have a single entry for the type. *)
            open DEBUG
            (* The parameter is the reference used to control the print depth
               when the value is actually printed. *)
            val printDepthFun = getParameter printDepthFunTag (LEX.debugParams lex)
            and prettyOut = getPrintOutput (LEX.debugParams lex)
            val nLevel = newLevel level
        in
            (* Construct a function that gets the print code, prints it out and returns
               its argument. *)
            mkProc(
                CODETREE.mkEnv
                (
                    [
                        mkNullDec (
                            mkEval(
                                mkConst(toMachineWord prettyOut),
                                [
                                    mkEval(
                                        printerForType(argType, nLevel, typeVarMap),
                                        [
                                            mkTuple[arg1,
                                                mkEval(mkConst(toMachineWord printDepthFun), [CodeZero])]
                                        ])
                                ])
                        )
                    ],
                    arg1 (* Returns its argument. *)
                ),
                1, "print()", getClosure nLevel, 0)
        end

  |  codeVal (Value{access = Overloaded Print, ...}, _, _, _, _, _) =
        raise InternalError "Overloaded Print - wrong instance type"

  |  codeVal (Value{access = Overloaded MakeString, ...}, _, _, [], _, _) =
        (* If this appears in a structure produce a default version. *)
            mkInlproc(
                mkProc(mkConst(toMachineWord "?"), 1, "makestring()", [], 0),
                1, "makestring(P)", [], 0)

  |  codeVal (Value{access = Overloaded MakeString, ...}, level: level, typeVarMap, [{value=argType, ...}], _, _) =
        let
            val nLevel = newLevel level
        in
            (* Construct a function that gets the print code and prints it out using "uglyPrint". *)
            mkProc(
                mkEval(
                    mkConst(toMachineWord uglyPrint),
                    [
                        mkEval(
                            printerForType(argType, nLevel, typeVarMap),
                            [
                                mkTuple[arg1, mkConst(toMachineWord 10000)]
                            ])
                    ]),
                1, "makestring()", getClosure nLevel, 0)
        end

  |  codeVal (Value{access = Overloaded MakeString, ...}, _, _, _, _, _) =
        raise InternalError "Overloaded MakeString - wrong instance type"

  |  codeVal (Value{access = Overloaded GetPretty, ...}, level, typeVarMap, [], _, _) =
        let
            val nLevel = newLevel level
        in
            (* If this appears in a structure return a default function. *)
            mkProc(printerForType(badType, nLevel, typeVarMap), 1, "getPretty", getClosure nLevel, 0)
        end

  |  codeVal (Value{access = Overloaded GetPretty, ...}, level: level, typeVarMap, [{value=argType, ...}], _, _) =
       (* Get the pretty code for the specified argument. *)
            printerForType(argType, level, typeVarMap)

  |  codeVal (Value{access = Overloaded GetPretty, ...}, _, _, _, _, _) =
        raise InternalError "Overloaded GetPretty - wrong instance type"

  |  codeVal (Value{access = Overloaded AddPretty, ...}, _, _, [], _, _) =
        (* If this appears in a structure create a function that raises an exception if run. *)
        mkProc(
            mkConst (toMachineWord
                        (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction")),
            1, "AddPretty(P)", [], 0)

  |  codeVal (Value{access = Overloaded AddPretty, ...}, level: level, _, [{value=installType, ...}, {value=argPrints, ...}], lex, loc) =
        let 
         (* "instance" should be (int-> 'a -> 'b -> pretty) -> unit.
             We need to get the 'a and 'b.  This function installs a
             pretty printer against the type which matches 'b.
             The type 'a is related to type of 'b as follows:
             If 'b is a monotype t then 'a is ignored.
             If 'b is a unary type constructor 'c t then 'a must have
             type 'c * int -> pretty.
             If 'b is a binary or higher type constructor e.g. ('c, 'd, 'e) t
             then 'a must be a tuple of functions of the form
             ('c * int -> pretty, 'd * int -> pretty, 'e * int -> pretty).
             When the installed function is called it will be passed the
             appropriate argument functions which it can call to print the
             argument types.  *)
            val pretty = mkTypeVar (generalisable, false, false, false); (* Temporary hack. *)

            (* Find the last type constructor in the chain. We have to install
                 this against the last in the chain because type constructors in
                 different modules may be at different points in the chain. *)
              (* This does mean that it's not possible to install a
                 pretty printer for a type constructor rather than a datatype. *)
            fun followTypes (TypeConstruction{constr, args, ...}) =
                if not (tcIsAbbreviation constr)
                then SOME(tcIdentifier constr, constr, List.length args)
                else followTypes (makeEquivalent (constr, args))
            |   followTypes (TypeVar tv) =
                (
                    case tvValue tv of
                        EmptyType => NONE (* Unbound type variable *)
                    |   t => followTypes t
                )
            |   followTypes _ = NONE;

            val constrId = followTypes installType
            
            val () =
                case constrId of
                    NONE => ()
                |   SOME (_, constr, arity) =>
                    let
                        (* Check that the function tuple matches the arguments of the type
                           we're installing for. *)
                        (* Each entry should be a function of type 'a * int -> pretty *)
                        fun mkFn arg = mkFunctionType(mkProductType[arg, TYPESTRUCT.intType], pretty)
                        (* Create non-unifiable type vars to ensure this is properly polymorphic. *)
                        val typeVars = List.tabulate(arity, fn _ => mkTypeVar (0, false, true, false))
                        val tupleType =
                            case typeVars of
                                [] => (* No arg so must have unit. *)
				    unitType
                            |   [arg] => mkFn arg (* Just a single function. *)
                            |   args => mkProductType(List.map mkFn args)
                        val addPPType = mkFunctionType(argPrints, mkFunctionType(installType, pretty))
                        val testType = mkFunctionType(tupleType,
                            mkFunctionType(
                                mkTypeConstruction(tcName constr, constr, typeVars, [DeclaredAt loc]),
                                pretty))
                    in
                        checkPPType(addPPType, testType, "addPrettyPrint", lex, loc,
                            fn () =>
                                PrettyString "addPrettyPrint element functions must have type 'a * int -> pretty, 'b * int -> pretty, ... with one function for each type parameter")
                    end;

            (* Only report the error when the function is run.  Because addPrettyPrint is
               contained in the PolyML structure we may compile a reference to a polymorphic
               version of this for the structure record.  It's replaced in the final structure
               by this version. *)
        in
            case constrId of
                SOME (typeId, _, arity) =>
                    let
                        (* We need to transform the user-supplied function into the form required for
                           the reference.   The user function has type int -> 'b -> 'a -> pretty
                           where 'b is either "don't care" if this is a monotype, the print function
                           for the base type if it takes a single type argument or a tuple of base type
                           functions if it takes more than one.  The reference expects to contain a
                           function of type 'a * int -> pretty for a monotype or a function of the
                           form <'b1, 'b2...> -> 'a * int -> pretty if this is polytype where
                           <...> represents poly-style multiple arguments.  *)
                        val printFunction =
                            case arity of
                                0 => 
                                    mkProc(
                                        mkEval(
                                            mkEval(
                                                mkEval(
                                                    mkLoadClosure 0 (* The user-supplied fn *),
                                                    [mkInd(1, arg1)] (* The depth *)),
                                                [CodeZero] (* Ignored args. *)),
                                            [mkInd(0, arg1)] (* Value to print *)),
                                        1, "addPP-1", [arg1](* The user-supplied fn *), 0)

                            |   arity =>
                                let
                                    open TypeValue
                                    val args =
                                        if arity = 1
                                        then [extractPrinter(mkLoadClosure 1)]
                                        else [mkTuple(List.tabulate(arity, fn n => extractPrinter(mkLoadClosure(n+1))))]
                                in
                                    mkProc(
                                        mkProc(
                                            mkEval(
                                                mkEval(
                                                    mkEval(
                                                        mkLoadClosure 0 (* The user-supplied fn *),
                                                        [mkInd(1, arg1)] (* The depth *)),
                                                    args (* Base fns. *)),
                                                [mkInd(0, arg1)] (* Value to print *)),
                                            1, "addPP-2", mkLoadClosure 0 :: List.tabulate(arity, mkLoadArgument), 0),
                                        arity, "addPP-1", [arg1], 0)
                                end
                        val nLevel = newLevel level
                    in
                        (* Generate a function that will set the "print" ref for the type to
                           the argument function. *)
                        mkProc(
                            mkEval(
                                rtsFunction POLY_SYS_assign_word,
                                [TypeValue.extractPrinter(
                                    codeAccess(idAccess typeId, nLevel)), CodeZero, printFunction]
                                ), 1, "addPP", getClosure nLevel, 0)
                    end

            |   NONE =>
                    mkConst (toMachineWord
                        (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction"))
        end

  |  codeVal (Value{access = Overloaded AddPretty, ...}, _, _, _, _, _) =
        raise InternalError "Overloaded AddPretty - wrong instance type"

  |  codeVal (Value{access = Overloaded GetLocation, ...}, _, _, _, _, _) =
        (* This can't be used a value: It must be called immediately. *)
        let
            fun getLoc() =
                raise Fail "The special function PolyML.sourceLocation cannot be used as a value"
        in
            mkConst (toMachineWord getLoc)
        end

  |  codeVal (value as Value{access = Overloaded _, ...}, level: level, typeVarMap, instance, lex, lineno) =
        let
            val nLevel = newLevel level
        in
            (* AddOverload, Equal, NotEqual, TypeDep *)
            mkProc(applyFunction (value, arg1, nLevel, typeVarMap, instance, lex, lineno), 1, "", getClosure nLevel, 0)
        end

 (* Some of these have a more efficient way of calling them as functions. *)
 and applyFunction (value as Value{class=Exception, ...}, argument, level, typeVarMap, instance, lex, lineno) =
     let
       (* If we are applying it as a function we cannot be after the
          exception id, we must be constructing an exception packet. *)
       (* Get the exception id, put it in the packet with the exception name
          the argument and, currently, an empty location as the exception location. *)
         val exIden = codeVal (value, level, typeVarMap, instance, lex, lineno);
     in
         mkTuple (exIden :: mkStr (valName value) :: argument :: [mkConst(toMachineWord NoLocation)])
     end

  | applyFunction(value as Value{class=Constructor _, ...},
                    argument, level, typeVarMap, argVars, lex, lineno) =
    let
        (* If this is a value constructor we need to get the construction
           function and use that. *)
        fun getConstr level =
            ValueConstructor.extractInjection(codeVal (value, level, typeVarMap, [], lex, lineno))
        val polyConstr =
            applyToInstance(if justForEqualityTypes then [] else argVars, level, typeVarMap, getConstr)
    in
         (* Don't apply this "early".  It might be the ref constructor and that
           must not be applied until run-time.  The optimiser should take care
           of any other cases. *)
        mkEval (polyConstr, [argument])
    end

  | applyFunction (value as Value{access = Overloaded oper, name = valName, ...},
                     argument, level, typeVarMap, instance, lex, lineno) =
     (
       case oper of
            Equal => (* Get the equality function for the type. *)
            let
                (* We should have a single entry for the type. *)
                val argType =
                    case instance of
                        [{value, ...}] => value
                    |   _ => raise InternalError "Overload Equal"
                (* The instance type is a function so we have to get the first argument. *)
                val code = equalityForType(argType, level, typeVarMap)
            in
                mkEval (code, [argument])
            end
        
        | NotEqual =>
            let
                (* We should have a single entry for the type. *)
                val argType =
                    case instance of
                        [{value, ...}] => value
                    |   _ => raise InternalError "Overload NotEqual"
                (* Use the "=" function to provide inequality as well as equality. *)
                val code = equalityForType(argType, level, typeVarMap)
                val isEqual = mkEval (code, [argument])
            in
                mkNot isEqual
            end
       
        | TypeDep =>
           let
                val argType =
                    case instance of
                        [{value, ...}] => value
                    |   _ => raise InternalError "Overload TypeDep"
             val (code, _) = getOverloadInstance(valName, argType, false)
           in
             mkEval (code, [argument])
           end

       | AddOverload =>
            (* AddOverload is only intended for use by writers of library modules.
               It only does limited checking and should be regarded as "unsafe". *)
            let

            fun rmvars (TypeVar tv) = rmvars(tvValue tv)
            |   rmvars t = t
            (* instance should be ('a->'b) -> string -> unit.  For overloadings
               on most functions (e.g. abs and +) we are looking for the 'a, which
               may be a pair, but in the case of conversion functions we want the 'b. *)
            val (resultType, argType) =
                case instance of
                    [{value=alpha, ...}, {value=beta, ...}] => (rmvars alpha, rmvars beta)
                |   _ => (badType, badType)

            fun followTypes(TypeConstruction{constr as TypeConstrs {identifier = TypeId{idKind = Free _, ...},...}, ...}) = constr
 
            |   followTypes(TypeConstruction{constr as TypeConstrs {identifier = TypeId{idKind = TypeFn _, ...},...}, args, ...}) =
                    followTypes (makeEquivalent (constr, args))

            |   followTypes(TypeConstruction{constr = TypeConstrs {identifier = TypeId{idKind = Bound _, ...},...}, ...}) =
                   raise Fail "Cannot install an overload within a structure or functor"

            |   followTypes _ = raise Fail "Invalid type (not a type construction) (addOverload)"

            fun addOverloading (argCode: codetree) (name: string) =
                let
                    val typeToUse =
                        if size name > 4 andalso
                            String.substring(name, 0, 4) = "conv"
                        (* For conversion functions it's the result type we're interested in.
                           For everything else it's the argument type.  This will be a pair
                           for functions such as "+" and a single argument for "abs". *)
                        then resultType
                        else case argType of
                            LabelledType{recList=[{typeof, ...}, _], ...} => rmvars typeof
                        |   argType => argType
                            
                    val tcons = followTypes typeToUse
                in
                    addOverload(name, tcons, argCode)
                end

            (* This function is used if we can't get the codetree at
               compile time. *)
            fun addOverloadGeneral (arg: machineWord) =
                addOverloading(mkConst arg)
        in
        (* This is messy but necessary for efficiency.  If we simply treat
           addOverload as a function we would be able to pick up the
           additional overloading as a pointer to a function.  Most overloads
           are small functions or wrapped calls to RTS functions and so
           we need to get the inline code for them. *)
                (* evalue raises an exception if "argument" is not a constant,
                  or more usefully, a global value containing a constant and
                  possibly a piece of codetree to inline. *)
          case evalue(argument) of
            SOME _ => mkConst (toMachineWord (addOverloading argument))
          | NONE => mkEval (mkConst (toMachineWord addOverloadGeneral), [argument])
        end

      | GetLocation => (* Return the current location. *) mkConst(toMachineWord lineno)
        
      | _ => (* Print, MakeString, InstallPP *)
         (* Just call as functions. *) (* not early *)
            mkEval (codeVal (value, level, typeVarMap, instance, lex, lineno), [argument])
            
     ) (* overloaded *)
     
  | applyFunction (value, argument, level, typeVarMap, instance, lex, lineno) =
        mkEval (codeVal (value, level, typeVarMap, instance, lex, lineno), [argument])
    (* end applyFunction *)

  (* If the exception is being used as a value we want an exception packet
     or a function to make a packet. If it is a nullary constructor make
     an exception packet now, otherwise generate a function to construct
     an exception packet. *)
    fun codeExFunction (value, level, typeVarMap, instance, lex, lineno) =
    case getFnArgType(valTypeOf value) of (* N.B. Not "instance" *)
        NONE => applyFunction (value, CodeZero, level, typeVarMap, List.map addStatus instance, lex, lineno)
    |   SOME _ =>
            let
                val nLevel = newLevel level
            in
                mkProc 
                  (applyFunction (value, arg1, nLevel, typeVarMap, List.map addStatus instance, lex, lineno),
                    1, "", getClosure nLevel, 0)
            end

    (* Operations to compile code from the representation of a constructor. *)
    (* Code to test whether a value matches a constructor.
       This must be applied to any polymorphic variables in the instance but the
       result is always bool so we don't create a new function if the result is
       also polymorphic.
       It is just possible to have a resulting polytype here
       (N.B. that's different from having a parametric type) if we have a val binding.
        e.g. val SOME x = SOME nil.  In that case we can choose an arbitrary type
        for the test and have to parameterise the result.     *)
    fun makeGuard (value as Value{class=Constructor _, ...}, argVars, testing, level, typeVarMap) =
        let
            fun tester level =
                ValueConstructor.extractTest(codeVal (value, level, typeVarMap, [], nullLex, location nullLex))
            val testCode =
                applyToInstance(if justForEqualityTypes then [] else List.map addStatus argVars,
                                level, typeVarMap, tester)
        in
            mkEval(testCode, [testing])
        end

    |   makeGuard (value as Value{class=Exception, ...}, _, testing, level, typeVarMap) =
        (* Should only be an exception. Get the value of the exception identifier 
           and compare with the identifier in the exception packet. *)
        mkTestptreq 
            (mkInd (0, testing),
                codeVal (value, level, typeVarMap, [], nullLex, location nullLex))

    |   makeGuard _ = raise InternalError "makeGuard"

    (* Code to invert a constructor. i.e. return the value originally used as the argument.
       Apply to any polymorphic variables and construct a result. *)
    fun makeInverse(value as Value{class=Constructor{nullary=false, ...}, ...},
                    argVars, arg, level, typeVarMap): codetree =
        let
            fun getInverse level =
                ValueConstructor.extractProjection(codeVal (value, level, typeVarMap, [], nullLex, location nullLex))
            val loadCode =
                applyToInstance(if justForEqualityTypes then [] else List.map addStatus argVars,
                                level, typeVarMap, getInverse)
        in
            mkEval(loadCode, [arg])
        end

    |  makeInverse(Value{class=Constructor{nullary=true, ...}, ...}, _, _, _, _): codetree =
        (* makeInverse is called even on nullary constructors.  Return zero to keep the
           optimiser happy. *) CodeZero

    |   makeInverse (Value{class=Exception, ...}, _, arg, _, _) =
            (* Exceptions. - Get the parameter from third word *)
            (* We have to use a VarField here even though this field is present in
               every exception.  The format of the value that is returned depends
               on the exception id. *)
            mkVarField (2,arg)

    |   makeInverse _ = raise InternalError "makeInverse"

    (* Work out the polymorphism and the mapping between the formal
       type variables and the actual types.  Because flexible records
       may introduce extra polymorphism we can only do this once we've
       frozen them.  e.g. fun f x = #1 x + #2 x may be monomorphic or
       polymorphic depending on what it's subsequently applied to. *)
    (* Using unification here isn't ideal.  We have to put the equality attribute
       back on to abstypes in case the unification requires it.  There may be other
       situations where things don't work properly. *)
    fun getPolymorphism (Value{ typeOf, access, name, ...}, expType, typeVarMap) =
    let
        val (t, polyVars) =
            case access of
                Overloaded TypeDep =>
                let
                    val (t, polyVars) =
                        generaliseOverload(typeOf, List.map #1 (getOverloads name), false)
                in
                    (t, List.map (fn t => {value=t, equality=false, printity=false}) polyVars)
                end
            | _ => generaliseWithMap(typeOf, TypeVarMap.mapTypeVars typeVarMap)
        (* Ignore the result.  There are circumstances in which we can get a
           unification error as the result of failing to find a fixed record type
           where the possible records we could find have non-unifiable types.
           See Tests/Fail/Test072.ML *)
        val _ = unifyTypes(t, expType)
    in
        polyVars
    end

    (* Convert a literal constant. We can only do this once any overloading
       has been resolved. *)
    fun getLiteralValue(converter, literal, instance, error): machineWord option =
        let
            val (conv, name) =
                 getOverloadInstance(valName converter, instance, true)
        in
            SOME(RunCall.unsafeCast(valOf(evalue conv)) literal)
                handle Match => NONE (* Overload error *)
                  | Conversion s =>
                        (
                            error("Conversion exception ("^s^") raised while converting " ^
                                    literal ^ " to " ^ name);
                            NONE
                        )
                  | Overflow => 
                        (
                            error ("Overflow exception raised while converting " ^
                                    literal ^ " to " ^ name);
                            NONE
                        )
                  | Thread.Thread.Interrupt => raise Thread.Thread.Interrupt
                  | _ =>
                        (
                            error ("Exception raised while converting " ^
                                    literal ^ " to " ^ name);
                            NONE
                        )
        end

    (* Types that can be shared. *)
    structure Sharing =
    struct
        type lexan          = lexan
        type codetree       = codetree
        type types          = types
        type values         = values
        type structVals     = structVals
        type functors       = functors
        type valAccess      = valAccess
        type typeConstrs    = typeConstrs
        type typeConstrSet  = typeConstrSet
        type signatures     = signatures
        type fixStatus      = fixStatus
        type univTable      = univTable
        type pretty         = pretty
        type locationProp   = locationProp
        type typeId         = typeId
        type typeVarForm    = typeVarForm
        type typeVarMap     = typeVarMap
        type level          = level
        type machineWord    = machineWord
    end

end (* body of VALUEOPS *);