let type void = unit;
let ArgStackSize = 12000;
let CtlStackSize = 12000;
let varstruct = [`Bind`];

% utility functions%

let type 'a opt = [|absent; present: 'a |];

% The following line is an apology for a proper type 'general' %
syntax nonfix forgettype 6 1; let rec forgettype(x: 'a): 'b = forgettype(x);
%AM: the next few lines provide (via hacks) an approximation to type 'general'%
syntax nonfix objectcasenum 116 1;
syntax nonfix objectcaseval 202 1;
syntax nonfix objectfield 136 2;
syntax nonfix variantobject 143 2;
syntax nonfix EqualObject 127 2;
let rec type object <=> object
with rec {mkobj(x: 'a) = absobject (forgettype x)
and castobj(x:object): 'a  = forgettype (repobject x)
and objectfield(x:object, n:int):object = objectfield(x,n)
and objectcasenum(x:object):int = objectcasenum(x)
and objectcaseval(x:object):object = objectcaseval(x)
and variantobject(x:int, y:object):object = variantobject(x,y)
and EqualObject(c:object,c':object):bool = EqualObject(c,c')
};

syntax nonfix Export 7 2;
let rec Export(fname:string, obj:'a): unit = Export(fname,obj);
syntax nonfix Import 8 1;
let rec Import(fname:string):'a = Import(fname);

let type UniqueStamp' <=> (| HostId:int; ProcessId: int; Time: int |);
syntax nonfix GetUniqueStamp 227 0; 
syntax nonfix StampOfFile 228 1;
let rec GetUniqueStamp(): UniqueStamp' = GetUniqueStamp();
let rec StampOfFile(x:string): UniqueStamp' = StampOfFile(x);

syntax nonfix share 127 2;
   let rec share(x: 'a ref, y: 'a ref): bool = share(x,y);
syntax nonfix EQPTR 127 2;     % keep this pretty quiet %
   let rec EQPTR(x: 'a, y: 'a): bool = EQPTR(x,y);

syntax nonfix bpt 128 1; let rec bpt(x:string):void = bpt(x);
  
let MaxInt = 999999;

let rec repeattok(n,t) = if n>0 then (outtok(t); repeattok(n-1,t)) else ();

%%
let type Print' = (|ParseTree     : bool ref; StackCode    : bool ref;
                    ObjectCode    : bool ref; Types        : bool ref;
                    VarNames      : bool ref; VarValues    : bool ref;
                    VarTypes      : bool ref;
                    Timings       : bool ref; Space        : bool ref;
                    TraceML       : bool ref; Use: [|none;some;all|] ref;
		    Depth	  : int ref
                  |);

let type Debug' = (|TypeVariables : bool ref;
                    TypeSharing   : bool ref; InlineCode   : int  ref;
                    ValEnv        : bool ref; TypeEnv      : bool ref;
                    InhibitUpdates: bool ref; Optimise     : bool ref;
                    NewRules      : bool ref; ExcEnv       : bool ref;
                    TimeStamps   : bool ref;
                    CheckMatchLimit: int ref; InhibitNewOverloadings: bool ref;
		    NativeCodeFns : bool ref
                  |);
%RJG CheckMatchLimit : max. number of recursive calls to pattern check fn.
 CheckMatchLimit <= 0 --> no pattern match checking%

let Print = (|ParseTree     = ref false; StackCode    = ref false;
              ObjectCode    = ref false; Types        = ref true;
              VarNames      = ref true;  VarValues    = ref true;
              VarTypes      = ref true;  
              Timings       = ref false; Space        = ref false;
              TraceML       = ref false; Use          = ref [|some|];
	      Depth	    = ref 1
            |): Print';

let Debug = (|TypeVariables = ref false;
              TypeSharing   = ref true;  InlineCode   = ref 10;
              ValEnv        = ref false; TypeEnv      = ref false;
              InhibitUpdates= ref false; Optimise     = ref true;
              NewRules      = ref false; ExcEnv       = ref false;
              TimeStamps   = ref false;
              CheckMatchLimit= ref 2000;  InhibitNewOverloadings = ref false;
	      NativeCodeFns = ref false
            |): Debug';

%%
%{--- Analyser Types }%

%AM: the next type is a list with modifyable tails - used for TypTagDList%
let rec type 'a dlist  <=>  'a # ('a dlist ref) + void
with dcons(x,y) = absdlist(inl(x,ref y))
and dnil = absdlist(inr())
and dhd x = fst(outl(repdlist x)) ? failwith `dhd`
and dtl x = !(snd(outl(repdlist x))) ? failwith `dtl`
and dtlset(x,y) = (snd(outl(repdlist x)) := y) ? failwith `dtlset`
and dnull x = isr(repdlist x);

let rec daplist(f:('a -> void),l) =
	if dnull(l) then () else (f(dhd l); daplist(f,dtl l));
let rec dexists(f,l) = if dnull(l) then false
                       else if f(dhd l) then true
                       else dexists(f,dtl l);
let rec dlistprint(Args:('a dlist), Print:('a -> void), Sep): void =
  if dnull(Args) then ()
  else ( Print(dhd Args);
         if dnull(dtl Args) then () else outtok(Sep);
         dlistprint(dtl Args, Print, Sep));

let rec dnth(n,l) = if n=1 then dhd(l) else dnth(n-1,dtl(l));
let rec dlength(l) = if dnull(l) then 0 else dlength(dtl l)+1;

%{AM: strictly, the next dozen or so types are SYN types, not ANAL types}%

% later use hash table for representation of Atom' %
let type Atom' <=> string
with HashAtom n x = tokhash(repAtom'(x),n)
and EqAtom(x,y) = (repAtom'(x) = repAtom'(y))
and LtAtom(x,y) = (repAtom'(x) #< repAtom'(y))
and PrintAtom(a: Atom') = outtok(repAtom'(a))
and WeakAtom(a) = (substring(repAtom'(a),1,2)=`'_`) ? false
and repAtom'=repAtom'
and absAtom'=absAtom'
enc [dummyAtom;AtomUnit;AtomBool;AtomInt;AtomFloat;AtomString;AtomPlus;
    AtomCross;AtomList;AtomArrow;
    AtomRef;AtomTrue;AtomFalse;AtomEqual;AtomNotEq;AtomArray;
    AtomPair;AtomCons;AtomComp;AtomPrint;AtomIt;
    AtomOldFail;AtomLambda;AtomTopLevel;AtomXn]
  = map absAtom' [`<anonymous>`; `unit`; `bool`; `int`; `real`; `string`; `+`;
                  `*`; `list`; `->`; `ref`; `true`;
                  `false`; `=`; `<>`; `array`; `,`; `::`; `o`; `print`; `it`;
                  `<fail>`;`<lambda>`;`<Top Level>`;`exn`];
%rjg numeric labels are held as null padded strings to allow normal
 string ordering to work - not nice%
let stringsize=5 %holds 65535%
enc chr n = implodeascii ([n])
enc asc ch = let l = explodeascii(ch) in if null(l) then ~1 else hd(l)
enc nullchar=chr(0)
enc ascZero = asc `0`
ins { intToAtom' (n:int,f:void -> Atom'):Atom' =
 let rec nTos (m,n,l) = 
       if m>0 then
              if n>0 then  nTos(m-1,n div 10,chr(ascZero +(n mod 10))::l)
                     else  nTos(m-1,0,nullchar::l)
       else l
 in
    if n<=0 Or n>65535 then f ()
    else absAtom'(implode (nTos (stringsize,n,[])))
and isNumLabel s = (asc (repAtom' s)) = 0
and Atom'toInt s = 
    let rec intify (n,l) = if null(l) then n 
                       else intify(n*10 
                                   + (let v=asc(hd(l)) in 
                                       if v=0 then v else v-ascZero),tl(l))
    in intify(0,explode (repAtom' s))};


let type Arity' = int;
let (Niladic,Monadic,Diadic) = (0,1,2);

let type SMorUser' =
  [| NonPrimitive;
     OverLoaded;
     PseudoOp: [| OpEqual;OpNotEq;OpWrite |]
  |];

let type Label'   = int;
let NullLabel = 0;

let rec type {
    TimeStamp' <=> [| Fixed: int; Var: StampVar' |]
and StampVar' = (| Stamp: int; Instance: (TimeStamp' opt) ref |) };

let rec type { literals' <=>
 (| LiteralForm: [| LiteralString: string;
                    LiteralText:     Atom' # int # int # (SMCode' list);
                    LiteralClosure:  Atom' # int # int # (SMCode' list);
                    LiteralInt:int;
                    LiteralFloat: real;
                    LiteralBool: bool;
                    LiteralTuple: literals' list;
                    LiteralVariant: int # literals';
                    GlobalObject: object |];
    LiteralValue: object opt ref
 |)
and SMCode' <=>
      [|OpThread: SMCode' list;
        OpLabel: (| Label: Label'; Address: int ref; 
                    NextOp: [|Unknown; Known: SMCode'|] |);
        OpNCBind: int;
        OpBCBind: int;
        OpNCDestTailApply: int;
        OpBCDestTailApply: int;
        OpGetLocal: int # bool;
        OpGetFree:  int;
        OpCurrClos;
        OpPrimitive:int;
        OpRecord: int;
        OpVariant: int;
        OpRef;
        OpEqual: [|Bool;Int;String;Real;Ref|];
        OpPrint: [|Bool;Int;String;Real|];
        OpQuaDot: int;
        OpDestTuple:  (|Displ: int; Size: int|);
        OpQuaIs: int;
        OpQuaAs: int;
        OpDestVariant:(|DVarCaseIndex: int; DVarArgDispl: int|);
        OpDestBigVar: int;
        OpCase:       SMCode' list;
        OpJump:       (|JumpType: [|Always; IfTrue; IfFalse|]; 
                        Target: SMCode'|); 
        OpClosure: int;
        OpDumClosure: int;
        OpRecClosure: (|RecFreeVarNum: int; RecClosDispl: int|);
        OpDestNil: int;
        OpDestPointer: int;
        OpDestConst: int # [|Bool;Int;String;Real|];
        OpReturn: int;
        OpSaveFrame;
        OpNCApplFrame;
        OpBCApplFrame;
        OpRestFrame;
        OpNCTailApply: (|NumArgs: int; NumJunk: int |);
        OpBCTailApply: (|NumArgs: int; NumJunk: int |);
        OpSlide:     (|NumArgs: int; NumJunk: int |);
        OpFunId;
        OpFunComp;
        OpRaise;
        OpHandle:    SMCode' list;
        OpPopTrap;
        OpUnTrap:    SMCode';
        OpGetLiteral:(|LiteralType: literals'; LiteralsNeeded: int|)
      |]
};

let type InlineCode' = [|absent; usedasclosure;
                         present: (int # int # SMCode' list)|];

let type SynBindIde' = 
  (| Ide: Atom'; References: int ref;
     StkPosn: [|Local:int; Global:object |] ref;
     Constructor: [| no; yes:([|variant;pointer;zero;ref;xcon:int ref|] # int # int # bool) ref |]; %RJG xcon is Extensible in TypTerm'%
     Inline: InlineCode' ref;  NativeCoded: bool ref;
     MinFunArity: int ref; SMorUser: SMorUser'; UserArity: int ref |);

let type SynConst' = [| int: int; real: real; string: string |];

% A path is a list of atomic identifiers. %
let type Path' = Atom' list;

let rec type {

  SynTypTerm' <=>
     [| SynTypVar:  (| VarIde: Atom' |);
        SynTypAppl: (| OperIde: Atom'; 
                       Args: SynTypArgs' |);
        SynTypTagAppl: (| TagSort: [|Record; Variant|];
                          Args: (|Tag:Atom';Arg:SynTypTerm'|) list |)
     |]

and SynTypArgs' = SynTypTerm' list

};

let type SynTypParams' = Atom' list;



let type Handle' <=> (| Stamp: TimeStamp'; AtomicName: Atom' ref |);

let rec type {
  SynTerm' <=>
     [| SynIde:    (| Ide: Atom'; LastUse: bool ref;
		      Binder: (void -> SynBindIde') ref;

                      MonoType: TypTerm' ref |);
        SynConst:  SynConst';
        SynTuple:  SynTerm' list;
        SynList:   SynTerm' list;
        SynRecord: SynTermRecord' list;
        SynVariant:(| VarKey: Atom'; VarField: SynTerm';
                      VarPos: (Atom' -> int#int) ref |);
        SynCond:   (| CondIf:SynTerm';
                      CondThen:SynTerm'; CondElse: SynTerm' |);
        SynWhile:  (| WhileCond:SynTerm';
                      WhileBody:SynTerm' |);
        SynLamb:   (| Match: SynRule' list;
                      LastUseFreeVar: SynBindIde' list ref |);
        SynNewCase:   (| Match: SynRule' list;
                         Select: SynTerm' |);
        SynAppl:   (| Fun: SynTerm'; Arg: SynTerm'; HowRead: Arity' |);
        SynCase:   (| Select: SynTerm'; Cases: SynTermCase' list |);
        SynJumpcase: (| Select: SynTerm'; Cases: SynTermCase' list |);
        SynLet:    (| Decl: SynDecl'; Scope: SynTerm' |);
        SynQuaOp:  (| QuaOp: [| SynQuaDot; SynQuaIs; SynQuaAs |];
                      QuaIde: Atom'; QuaArg: SynTerm';
                      QuaPos: (Atom' -> int#int) ref |);
        SynForce:  (| ForceTerm: SynTerm'; ForceType: SynTypTerm' |);
        SynTagType:(| Arg: SynTerm'; Type: TypTerm' ref; 
                      Purpose: [|Print; Dynamic; Cast|] |);
        SynTrap:   (| TrapLft: SynTerm'; TrapRht: SynTerm';
                      TrapClass:                     
                        [| SynTrapAll:  void;
                           SynTrapList: (| TrapList: SynTerm' |);
                           SynTrapLamb: (| TrapBind: SynBind' |)
		        |]
		   |);
        SynHandle: (| HandLft: SynTerm';
                      Match: SynRule' list
		   |);
        SynRaise:  (| ExcIde: Atom';
		      ExcBinder: SynBindIde' ref;
                      ExcArg: SynTerm' |);
%AM: get rid of the next into an operator%
        SynSequence:(| SeqLft: SynTerm'; SeqRht: SynTerm' |)
    |]

and SynDecl' <=>
  [| SynDeclDefVal: (| Bind: SynBind'; BindType: TypTerm' ref;
                       Term: SynTerm' |);
     SynDeclDefTyp:
      (| Bind: Atom';
         Params: SynTypParams';
         TypParams: TypArgs' ref;
         TypVarEnv: TypVarEnv' ref;
         DefSort:
          [| ShortHand:
	            (| SynBinding: SynTypTerm';
		       TypBinding: TypTerm' ref
		    |);
             Isomorphism:
		    (| Constrs: SynDataDef' list;
                       Extending: bool;  %old type to be extended%
                       Extensible: bool  %allow extensions to this type%
                    |)
          |]
      |);
     SynDeclDefExcon:
      (| AbsBinder: SynBindIde'; 
         Binder: (void -> SynBindIde') ref; 
         ConstrArgType: TypTerm' ref;
         CopyIde: Atom' |);
     SynDeclAnd: (| Lft: SynDecl'; Rht: SynDecl' |);
     SynDeclEnc: (| Ext: SynDecl'; Int: SynDecl' |);
     SynDeclIns: (| Outs: SynDecl'; Ins: SynDecl' |);
     SynDeclWith:(| WithExt: SynDecl'; WithInt: SynDecl' |);
     SynDeclRec: (| Rec: SynDecl' |)

  |]

and SynBind' <=>
  [| SynBindIde:   (| Ide: Atom'; 
                      Binder: SynBindIde'; PreBinder: (SynBindIde' opt ref) |);
     SynBindAny:     void;
     SynBindBoth:    SynBind' # SynBind';
     SynBindTuple:   SynBind' list;
     SynBindConst:   SynConst';
     SynBindAppl:  (| Ide: Atom'; 
                      Binder: SynBindIde' ref;
                      Arg: SynBind';
                      HowRead: Arity' |);
     SynBindRecord:  SynBindRecord' list #
			[| solid; 
			   flexi: (unit -> SynBindRecord' list) ref
			|];
     SynBindVariant: (| VarKey: Atom'; VarField: SynBind';
                        VarPos: (Atom' -> int#int) ref |);
     SynBindForce:   (| ForceBind: SynBind'; ForceType: SynTypTerm' |)
  |]

%{AM: the real ANAL stuff starts here}%

and LoopCheck' = [| Unknown; Yes; No |] 

and TypTerm' <=>
     [| TypVar:
	  %RH: here are what the fields are for:			%
	  % VarStamp: timestamp, used to test equality.			%
	  % Instance: binding of this type variable (if any).		%
	  % Generic: make a new copy when taking generic instance.	%
	  % Weak: not generic unless OccurLevel > AnalysisLevel.	%
	  % OccurLevel: minimum binding depth of lambda--bound variables%
	  % whose type involves this variable; used to determine when a %
	  % weak type variable can become generic; has no meaning for	%
	  % generic type variables; if infinite, then is not in type of %
	  % any lambda--bound variable (and hence can be made generic). %
	  % Instantiable: has meaning only for non--generics; determines%
	  % whether or not a type variable may be instantiated; set to	%
	  % false when explicit type variable is encountered, and is	%
	  % effectively true for generics.				%
          % Ety: true if the variable is used in a context where an     %
          %      equality function is assumed.                          %
	  % TopLevel:							%
	  % TypVarCopy:							%
	  % CopyCounter:						%
          (| VarStamp: int; Instance: [| None:void; Yes:TypTerm' |] ref;
             Generic: bool ref; Weak: bool ref; OccurLevel: int ref;
	     Instantiable: bool ref; Ety: bool ref;
             Toplevel: bool;
             TypVarCopy: TypTerm' ref; CopyCounter: int ref |);
	TypConVar:
	  (| ConVarHandle: Handle';
	     ConVarArgs: TypArgs';
	     Instance: TypTerm' opt ref |);
        TypDefOper:
          (| Guarded: LoopCheck' ref;
             DefHandle: Handle';
	     DefBody: TypTerm';
             DefArgs: TypArgs' |);
        TypAbsOper:
          (| AbsArgs: TypArgs';
             AbsInfo: AbsInfo' |);
        TypTagOper:
          (| TagSort: [|Record; Variant|];
             TagList:
                [| TagInstance:  TypTerm';
		   Solid:  TagTypTerm' list;
		   Flexi:  TagTypTerm' dlist |] ref
          |)
    |]

and TypArgs' = TypTerm' list

and AbsInfo' = (|  AbsHandle: Handle';
		   %AbsCons: AbsCons' list ref;%
		   AbsCons: (| VarName: SynBindIde'; VarType: TypTerm' |) list ref;
		   AbsEqFn: (SMCode' list list -> SMCode' list) ref;
		   AbsPrintFn: ((object # (object->void) list) -> void) ref;
                   EqDefined: LoopCheck' ref;
		   Extensible: int ref|)

and AbsCons' = (| VarName: SynBindIde'; VarType: TypTerm' |)

and TagTypTerm' = (| Tag: Atom'; Typ: TypTerm' |)

and SynDataDef' = (| Term: SynTypTerm'; ConstrArgType: TypTerm' ref;
                     AbsBinder: SynBindIde' |)
and SynBindRecord' = (| RecKey: Atom'; RecField: SynBind' |)
and SynTermRecord' = (| RecKey: Atom'; RecField: SynTerm' |)
and SynTermCase' = (| Tag: Atom'; Bind: SynBind'; Body: SynTerm' |)
and SynRule' =  (SynBind' # SynTerm')
and SynHandRule' =
  [| WildCard: (| HandAction: SynTerm'; HandExcName: SynBind' opt |);
     Proper:   (| HandIde: Atom';
		  HandBinder: SynBindIde' ref;
                  HandAction: (SynBind' # SynTerm') list |) |]

% Value environments %
and LocEnvCell' =
    (| VarName: SynBindIde'; Hidden: bool ref; LambdaBound: bool ref;
       VarType: TypTerm' ref |)
and LocValEnv' = %LocEnvCell' list%
    (| VarName: SynBindIde'; Hidden: bool ref; LambdaBound: bool ref;
       VarType: TypTerm' ref |) list

% Type variable environments %
and TypVarEnv' = (| VarIde: Atom'; TypVar: TypTerm' |) list

% Type environments %
and LocTypEnvCell' =
    (| TypNam: Atom'; Multiadic: bool; TypIde: TypTerm' ref; Hidden: bool ref |)
and LocTypEnv' = %LocTypEnvCell' list%
    (| TypNam: Atom'; Multiadic: bool; TypIde: TypTerm' ref; Hidden: bool ref |) list

% Exception environments %
%RJGDELand LocExcEnvCell' =%
%RJGDEL    (| ExcIde: SynBindIde'; ExcTyp: TypTerm'; Hidden: bool ref |)%
%RJGDELand LocExcEnv' = LocExcEnvCell' list%
%RJGDEL    (| ExcIde: SynBindIde'; ExcTyp: TypTerm'; Hidden: bool ref |) list%

};

% Some useful abbreviations %
let type SynHandler' = SynHandRule' list
and	 SynMatch' = SynRule' list;

let type LocEnv' = LocValEnv';

let type TypTagList' = TagTypTerm' list
and	 TypTagDList' = TagTypTerm' dlist;

% Local environments %
let type LocAllEnv' =
    (| Val: LocValEnv'; Typ: LocTypEnv'; %RJGDEL Exc: LocExcEnv';%
       LastUse: ((SynBindIde' # (SynTerm' list ref)) list) ref
    |);


let type OverLoad' = [| None; Some: (TypTerm' # SynBindIde') list |];

let NilEnv = [];

% Assembler like types %

syntax nonfix tupleoflist 180 1;
let rec type tuple <=> tuple
with rec tupleoflist(x: 'a list): tuple = tupleoflist(x);

let rec type literalpool <=> literalpool
with makeliteral(x: object list): literalpool =
  forgettype(tupleoflist(x));

syntax nonfix maketext 117 4;
syntax nonfix StoreByte 118 3;
syntax nonfix StoreWord 119 3;
syntax nonfix StoreLong 120 3;
let rec type text <=> text
with rec
  { maketext(ObjCodeLength:int, literals: literalpool, 
             ArgSiz: int, CtlSiz: int):text =
      maketext(ObjCodeLength, literals, ArgSiz, CtlSiz)
and StoreByte(x:int,y:text,z:int):void = StoreByte(x,y,z)
and StoreWord(x:int,y:text,z:int):void = StoreWord(x,y,z)
and StoreLong(x:int,y:text,z:int):void = StoreLong(x,y,z)
};

let type closure <=> tuple
with closureFV1(x:closure): object =
  (forgettype(x): (|a: text; b: object; c: object %...% |)).b
and  makeclosure0(x:text):closure = absclosure(tupleoflist[x]);

let FatalCrash() = failwith `FatalCrash`;
let ReEnter() = failwith `Reenter`;
let Crash() =
( outtok(`Internal consistency error`); newline(1); ReEnter());
let NoModules() =
( outtok(`Modules not yet supported`); newline(1); ReEnter());
let PrintLn() = newline(1);


% new exception things %
%smallest number for an extensible datatype constructor %
let StartExtensibleFrom = 200; 
let XnTypTerm : TypTerm' opt ref = ref [| absent |];
