-- DIInterpret.mesa  last edit: Bruce  May 20, 1980  6:12 PM

DIRECTORY
  Actions, ComData,
  CompilerUtil USING [PrintTree],
  CoreSwapDefs, Debug, DebugOps, DebugFormat, DebugUsefulDefs, DI, DIActions,
  DOutput, Dump, Frames, Gf, Heap,
  Init, Inline, Lf, Literals, Lookup, MachineDefs,
  P1 USING [DParse],
  Pc, PrincOps,
  State USING [Get, GetGS, GSHandle, Handle, Stack],
  Storage, String, SymbolOps, SymbolPack, Symbols, SymbolSegment,
  SymbolTable USING [Base],
  Table USING [AddNotify, Base, DropNotify, Notifier],
  Tree, TreeOps, Types;

DIInterpret: PROGRAM
  IMPORTS Actions, com: ComData, CompilerUtil, Debug, DebugOps, DI, DIActions,
    DOutput, Dump, Frames, Gf, Heap, Init,
    Lf, Lookup, Pc, P1, State, Storage, 
    String, MyBase: SymbolPack, SymbolOps, Table, TreeOps, Types
  EXPORTS DebugOps, DebugUsefulDefs, DIActions 
  SHARES Debug =
  BEGIN OPEN DI, DIActions;

  Underflow: PUBLIC ERROR = CODE;
  StackNotEmptyAtStatement: PUBLIC ERROR = CODE;
  NotImplemented: PUBLIC SIGNAL [msg: STRING] = CODE;
  DIAbort: PUBLIC ERROR = CODE;

  DerefError: ERROR = CODE;
  BadTree: ERROR = CODE;
  WhosBeenScanningMyTree: ERROR = CODE;
  CantAssignInDebuggerImage: ERROR = CODE;

  seb: Table.Base;
  tb: Table.Base;
  data: State.GSHandle ← State.GetGS[];

  Interpreter: PUBLIC PROC [exp: STRING] = {Interpret[exp,NIL]};

  Interpret: PUBLIC PROC [
    exp: STRING, results: DebugOps.FooProc ← DebugOps.DisplayFoo] =
    BEGIN
    t: Tree.Link;
    copy: BOOLEAN = exp.length = exp.maxlength;
    temp: STRING ← IF copy THEN Storage.String[exp.length+1] ELSE NIL;
    CleanupString: PROC = 
      BEGIN
      IF copy THEN Storage.FreeString[temp] 
      ELSE exp.length ← exp.length - 1;
      END;
    Cleanup: PROC =
      BEGIN
      Table.DropNotify[Notify];
      [] ← TreeOps.FreeTree[t];
      ResetStack[];
      CleanupString[];
      END;
    IF copy THEN {String.AppendString[temp,exp]; exp ← temp};
    String.AppendChar[exp,'\];
    IF ~P1.DParse[exp !UNWIND => CleanupString[]] THEN
      BEGIN CleanupString[]; SIGNAL DebugOps.SyntaxError[0] END;
    t ← TreeOps.PopTree[];
    IF data.tree THEN CompilerUtil.PrintTree[t];
    Table.AddNotify[Notify];
    State.Get[].h.proc ← results;
    ProcessTree[t ! UNWIND => Cleanup[]];
    Cleanup[];
    END;

  StringExpToNum: PUBLIC PROC [s: STRING] RETURNS [u: UNSPECIFIED] =
    BEGIN OPEN DebugOps;
    Result: FooProc = BEGIN u ← ProcessNum[f, one].n.u END;
    Interpret[s,Result !
      ParseError, SyntaxError, InvalidCharacter => ERROR InvalidNumber[NIL]];
    END;

  StringExpToLNum: PUBLIC PROC [s: STRING] RETURNS [u: LONG UNSPECIFIED] =
    BEGIN OPEN DebugOps;
    Result: FooProc = BEGIN u ← ProcessNum[f, two].n.lu END;
    Interpret[s,Result !
      ParseError, SyntaxError, InvalidCharacter => ERROR InvalidNumber[NIL]];
    END;

  ProcessNum: PROC [f: DebugOps.Foo, size: DI.NumberType] RETURNS [n: Number]=
    BEGIN
    i: NumberType;
    p: LONG POINTER TO Words;
    IF f.bits # 0 OR f.addr.offset # 0 THEN GOTO invalid;
    n.type ← LOOPHOLE[f.words];
    SELECT n.type FROM
      size => NULL;
      one => IF size # two THEN GOTO invalid;
      two => {IF size = one THEN Error[sizeMismatch]; GOTO invalid};
      ENDCASE => GOTO invalid;
    GetValue[f];
    p ← f.addr.base;
    FOR i IN [nogood..n.type) DO
      n.w[i] ← p[i];
      ENDLOOP;
    IF n.type # size THEN n.w[one] ← 0;
    RETURN;
    EXITS
      invalid => SIGNAL DebugOps.InvalidNumber[f]
    END;

  ProcessTree: Tree.Scan =
    BEGIN OPEN TreeOps;
    IF t = Tree.Null THEN RETURN;
    t ← CheckNode[t,rowcons];
    t ← CheckNode[t,block];
    IF OpName[t] = list THEN ScanList[t,Exp] ELSE Exp[t];
    DOutput.EOL[];
    CheckForStackEmpty[];
    END;

  CheckNode: PROCEDURE [t: Tree.Link, name: Tree.NodeName]
    RETURNS [son1: Tree.Link] =
    BEGIN
    IF TreeOps.OpName[t] # name THEN ERROR BadTree;
    WITH t SELECT FROM
      subtree => son1 ← tb[index].son[1];
      ENDCASE => ERROR BadTree;
    END;

  CheckLink: PROC [t: Tree.Link, type: {subtree, hash, symbol, literal}]
      RETURNS [UNSPECIFIED] =
    BEGIN
    WITH t SELECT FROM
      subtree => IF type = subtree THEN RETURN[index];
      hash => IF type = hash THEN RETURN[index];
      symbol => IF type = symbol THEN RETURN[index];
      literal => IF type = literal THEN RETURN[info];
      ENDCASE => ERROR BadTree;
    ERROR WhosBeenScanningMyTree;
    END;

  Notify: Table.Notifier =
    BEGIN
    tb ← base[Tree.treeType];
    seb ← base[SymbolSegment.seType];
    END;

  Exp: Tree.Scan =
    BEGIN ENABLE DIAbort => GOTO cleanExit;
    son1: Foo;
    IF t = Tree.Null THEN RETURN;
    WITH t SELECT FROM
      subtree =>
	BEGIN OPEN TreeOps;
	SELECT tb[index].name FROM
	  exit =>
	    BEGIN
	    son1 ← FirstSon[index];
	    State.Get[].h.proc[son1];
	    END;
	  open =>
	    BEGIN
	    son1 ← FirstSon[index];
	    DumpMemory[son1];
	    END;
	  label =>
	    BEGIN
	    n: Number;
	    son1 ← FirstSon[index];
	    n ← GetNumber[son1];
	    SELECT n.type FROM
	      one => PutReps[n.u];
	      two => PutLongReps[n.lu];
	      ENDCASE;
	    END;
	  assign =>
	    BEGIN
	    son1 ← FirstSon[index];
	    TargetTypeWork[tb[index].son[2], son1.tsei];
	    Assign[son1]
	    END;
	  rowcons =>
	    {Exp[tb[index].son[1]]; DOutput.EOL[]; CheckForStackEmpty[]};
	  ENDCASE => ERROR WhosBeenScanningMyTree;
	END;
      ENDCASE => ERROR BadTree;
    EXITS
      cleanExit => {ResetStack[]; RETURN};
    END;

  FirstSon: PROC [index: Tree.Index, type: SEIndex ← Symbols.typeANY]
      RETURNS [f: Foo] =
    BEGIN
    Work[tb[index].son[1], type];
    f ← Pop[];
    END;

  Work: PROC [t: Tree.Link, type: Symbols.SEIndex ← Symbols.typeANY] =
    BEGIN
    IF t = Tree.Null THEN RETURN;
    WITH t SELECT FROM
      subtree => SubtreeWork[index,type];
      hash => Push[HashWork[index,type]];
      symbol => Push[SymbolWork[index]];
      literal => Push[FindLiteral[info]];
      ENDCASE => ERROR BadTree;
    END;

  LoopHoleWork: PROC [t: Tree.Link, type: Symbols.SEIndex] =
    BEGIN
    f: Foo ← NIL;
    IF t = Tree.Null THEN RETURN;
    WITH t SELECT FROM
      subtree => {SubtreeWork[index,type]; RETURN};
      hash => f ← HashWork[index,type];
      literal => f ← FindLiteral[info];
      ENDCASE => ERROR BadTree;
    LoopHole[f,type,TRUE];
    Push[f];
    END;

  TargetTypeWork: PROC [t: Tree.Link, type: Symbols.SEIndex] =
    BEGIN
    f: Foo ← NIL;
    IF t = Tree.Null THEN RETURN;
    WITH t SELECT FROM
      subtree => {SubtreeWork[index,type]; RETURN};
      hash => f ← HashWork[index,type];
      literal => f ← FindLiteral[info];
      ENDCASE => ERROR BadTree;
    Assignable[f,TypeForSe[type]];
    Push[f];
    END;

  SymbolWork: PROC [index: Symbols.SEIndex] RETURNS [f: Foo] = INLINE
    BEGIN
    f ← Heap.AllocFob[];
    f.tsei ← index;
    f.typeOnly ← TRUE;
    END;

  HashWork: PROC [index: Symbols.HTIndex, hint: Symbols.SEIndex] 
      RETURNS [f: Foo] =
    BEGIN
    f ← NIL;
    IF hint # Symbols.typeANY THEN
      BEGIN OPEN Symbols;
      WITH seb[TypeForSe[hint]] SELECT FROM
	enumerated => f ← Lookup.InCtx[index, valueCtx];
	ENDCASE;
      IF f # NIL THEN RETURN;
      END;
    f ← Lookup.OnStack[index];
    IF f = NIL THEN AbortWithError[notFound, index];
    END;

  SubtreeWork: PROC [index: Tree.Index, type: Symbols.SEIndex] =
    BEGIN OPEN TreeOps;
    SELECT tb[index].name FROM
      plus, minus, times, div, mod =>
	BEGIN
	f: Foo ← FirstSon[index];
	Work[tb[index].son[2]];
	Push[f];
	FoldExpr[tb[index].name];
	END;
      uminus =>
	BEGIN
	Work[tb[index].son[1]];
	FoldExpr[uminus];
	END;
      base => Base[FirstSon[index],type];
      length => Length[FirstSon[index], type];
      size => Size[FirstSon[index]];
      clit =>
	BEGIN
	f: Foo ← FindLiteral[CheckLink[tb[index].son[1], literal]];
	f.tsei ← com.typeCHAR;
	f.addr.offset ← 8;
	Push[f];
	END;
      mwconst => Push[FindLiteral[CheckLink[tb[index].son[1], literal]]];
      dollar =>
	BEGIN
	id: Symbols.HTIndex ← CheckLink[tb[index].son[2], hash];
	mod: Symbols.HTIndex ← CheckLink[tb[index].son[1], hash];
	f: Foo ← Lookup.InMod[id,mod];
	IF ~f.typeOnly THEN Error[notType, id];
	Push[f];
	END;
      addr => TakeAddress[Son[tb[index].son[1],type]];
      uparrow =>
	BEGIN
	f: Foo ← Son[tb[index].son[1],type];
	IF ~Deref[f] THEN AbortWithError[invalidPointer, f.hti];
	END;
      dot => Qualify[FirstSon[index],CheckLink[tb[index].son[2], hash]];
      apply => DoApply[tb[index].son[2], FirstSon[index]];
      loophole =>
	IF tb[index].son[2] = Tree.Null THEN
	  {Work[tb[index].son[1],type]; LoopHole[Tos[],Symbols.typeANY]}
	ELSE
	  BEGIN
	  f: Foo;
	  Work[tb[index].son[2],type];
	  f ← Pop[];
	  IF ~f.typeOnly THEN Error[notType, f.hti];
	  LoopHoleWork[tb[index].son[1],f.tsei];
	  END;
      cdot =>
	BEGIN
	id: Symbols.HTIndex ← CheckLink[tb[index].son[2], hash];
	mod: Symbols.HTIndex ← CheckLink[tb[index].son[1], hash];
	f: Foo ← Lookup.InMod[id,mod];
	Push[f];
	END;
      index =>
	BEGIN
	id: Symbols.HTIndex ← CheckLink[tb[index].son[2], hash];
	f: Foo ← FindLiteral[CheckLink[tb[index].son[1], literal]];
	Push[Lookup.InLF[id,f.addr.base↑]];
	END;
      openx => Memory[tb[index].son[1],type];
      longTC =>
	BEGIN
	f: Foo ← Tos[];
	f.tsei ← MakeLongType[f.tsei];
	END;
      pointerTC =>
	BEGIN
	f: Foo ← Tos[];
	f.tsei ← MakePointerType[f.tsei];
	END;
      discrimTC =>
	BEGIN
	f: Foo ← Son[tb[index].son[1],type];
	f.tsei ← SelectVariantType[f.tsei, CheckLink[tb[index].son[2],hash]];
	END;
      lengthen =>
	BEGIN
	f: Foo ← Son[tb[index].son[1],type];
	LengthenFob[f];
	END;
      abs => Abs[tb[index].son[1],type];
      min =>
	BEGIN
	size: NumberType;
	cnt: CARDINAL;
	signed: BOOLEAN;
	[size,cnt,signed] ← GetSize[index,type];
	Min[size,cnt,signed];
	END;
      max =>
	BEGIN
	size: NumberType;
	cnt: CARDINAL;
	signed: BOOLEAN;
	[size,cnt,signed] ← GetSize[index,type];
	Max[size,cnt,signed];
	END;
      intOO => Interval[
	t: tb[index].son[1], type: type, openLow: TRUE, openHigh: TRUE];
      intOC => Interval[t: tb[index].son[1], type: type, openLow: TRUE];
      intCO => Interval[t: tb[index].son[1], type: type, openHigh: TRUE];
      intCC => Interval[t: tb[index].son[1], type: type];
      cast => Interval[t: tb[index].son[1], type: type, cntOnly: TRUE];
      ENDCASE => NotImpl[tb[index].name];
    END;

  NotImpl: PROC [name: Tree.NodeName] =
    BEGIN
    Debug.LockStringTable[];
    Debug.WriteNodeName[name];
    Debug.UnlockStringTable[];
    SIGNAL NotImplemented[" "L];
    END;

  Interval: PROC [
      t: Tree.Link, type: Symbols.SEIndex,
      openLow, openHigh, cntOnly: BOOLEAN ← FALSE] =
    BEGIN
    index: Tree.Index ← CheckLink[t,subtree];
    f1, f2: Foo;
    size, size2: NumberType;
    signed, signed2: BOOLEAN;
    [f1,size,signed] ← MinimalRep[tb[index].son[1],type];
    [f2,size2,signed2] ← MinimalRep[tb[index].son[2],type];
    IF size # size2 THEN
      BEGIN
      SIGNAL NotImplemented["DoubleWord array indexes"L];
      size ← two;
      IF size = one THEN Long[f1,signed];
      IF size2 = one THEN Long[f2,signed2];
      END;
    IF cntOnly THEN RETURN;
    IF openLow THEN Inc[f1,size,signed];
    IF openHigh THEN Dec[f2,size,signed2];
    MakeCnt[f2,f1,size,signed OR signed2];
    END;

  Base: PROC [f: Foo, sei: SEIndex] =
    BEGIN
    WITH seb[TypeForSe[f.tsei]] SELECT FROM
      long => LongBase[f,sei];
      ENDCASE => ShortBase[f,sei];
    END;

  ShortBase: PROC [f: Foo, sei: SEIndex] =
    BEGIN
    asei: Symbols.ArraySEIndex;
    lp: LONG POINTER TO POINTER;
    d: Desc;
    [d,asei] ← GetDesc[f ! NotAnArray =>
	{AbortWithError[typeMismatch,f.hti]; ERROR}];
    lp ← Storage.Node[1];
    lp↑ ← d.base;
    f.addr.base ← lp; f.addr.offset ← f.bits ← 0;
    f.words ← 1; f.there ← FALSE; f.hti ← Symbols.HTNull;
    f.tsei ← MakePointerType[Symbols.typeANY];
    Push[f];
    END;

  LongBase: PROC [f: Foo, sei: SEIndex] =
    BEGIN
    asei: Symbols.ArraySEIndex;
    lp: LONG POINTER TO LONG POINTER;
    d: LongDesc;
    [d,asei] ← GetLongDesc[f ! NotAnArray =>
	{AbortWithError[typeMismatch,f.hti]; ERROR}];
    lp ← Storage.Node[2];
    lp↑ ← d.base;
    f.addr.base ← lp; f.addr.offset ← f.bits ← 0;
    f.words ← 2; f.bits ← 0; f.there ← FALSE; f.hti ← Symbols.HTNull;
    f.tsei ← MakeLongType[MakePointerType[Symbols.typeANY]];
    Push[f];
    END;

  Length: PROC [f: Foo, sei: SEIndex] =
    BEGIN
    long: BOOLEAN;
    asei: Symbols.ArraySEIndex;
    len: LONG POINTER TO CARDINAL;
    WITH seb[TypeForSe[f.tsei]] SELECT FROM
      long => long ← TRUE;
      ENDCASE => long ← FALSE;
    len ← Storage.Node[1];
    IF long THEN 
      BEGIN ld: LongDesc;
      [ld,asei] ← GetLongDesc[f ! NotAnArray =>
	{AbortWithError[typeMismatch,f.hti]; ERROR}];
      len↑ ← ld.length;
      END
    ELSE
      BEGIN
      d: Desc;
      [d,asei] ← GetDesc[f ! NotAnArray =>
	{AbortWithError[typeMismatch,f.hti]; ERROR}];
      len↑ ← d.length;
      END;
    f.addr.base ← len; f.addr.offset ← f.bits ← 0;
    f.words ← 1; f.there ← FALSE; f.hti ← Symbols.HTNull;
    f.tsei ← com.typeCARDINAL;
    Push[f];
    END;

  Deref: PUBLIC PROC [f: Foo] RETURNS [success: BOOLEAN] =
    BEGIN
    tsei: Symbols.CSEIndex ← TypeForSe[f.tsei];
    ref: SEIndex;
    n: Number;
    DO
      WITH seb[tsei] SELECT FROM
	ref =>
	  BEGIN
	  IF basing THEN RETURN[FALSE];
	  ref ← refType;
	  EXIT
	  END;
	long => tsei ← TypeForSe[rangeType];
      ENDCASE => RETURN[FALSE];
      ENDLOOP;
    n ← GetNumber[f, invalidPointer];
    Heap.FreeLong[f.addr.base];
    SELECT n.type FROM
      one => f.addr.base ← DebugOps.Lengthen[n.p];
      two => f.addr.base ← n.lp;
      ENDCASE;
    IF f.addr.base = NIL THEN AbortWithError[nilChk,f.hti];
    f.tsei ← ref; f.words ← SymbolOps.WordsForType[ref];
    f.hti ← Symbols.HTNull;
    f.typeOnly ← FALSE;
    f.addr.offset ← 0;
    f.bits ← 0;
    f.there ← TRUE;
    RETURN[TRUE];
    END;

  Qualify: PROC [f: Foo, hti: Symbols.HTIndex] =
    BEGIN OPEN Symbols;
    rsei: RecordSEIndex;
    WHILE Deref[f] DO NULL ENDLOOP;
    rsei ← CheckClass[record,f];
    IF SearchCtx[f, rsei, hti] THEN RETURN;
    IF seb[rsei].hints.variant AND
      SearchVariants[f,hti,rsei] THEN RETURN;
    AbortWithError[notValidField,hti];
    END;

  SearchCtx: PROC [f: Foo, rsei: RecordSEIndex, hti: HTIndex]
      RETURNS [BOOLEAN] =
    BEGIN OPEN Symbols;
    isei: ISEIndex ← SearchCtxList[hti,seb[rsei].fieldCtx];
    field: Foo;
    IF isei = ISENull THEN RETURN [FALSE];
    field ← FindField[f, DI.Pad[f,rsei], isei];
    IF field = NIL THEN RETURN [FALSE];
    Push[field];
    RETURN[TRUE];    
    END;

  SearchVariants: PROC [f: Foo, hti: HTIndex, rsei: RecordSEIndex]
      RETURNS [BOOLEAN] =
    BEGIN OPEN Symbols;
    usei: UnionSEIndex ← LOOPHOLE[VariantUnionType[rsei]];
    IF usei = typeANY THEN RETURN [FALSE];
    SELECT VariantType[usei] FROM
      controlled =>
	BEGIN
	isei: ISEIndex ← TagIsei[f,DI.Pad[f,rsei],usei];
	IF isei = ISENull THEN RETURN [FALSE];
	RETURN[SearchCtx[f,seb[isei].idInfo,hti]];
	END;
      overlaid =>
	BEGIN OPEN SymbolOps, seb[usei];
	isei: ISEIndex;
	Lookup.Complete[caseCtx];
	FOR isei ← FirstCtxSe[caseCtx], NextSe[isei] UNTIL isei = ISENull DO
	  IF SearchCtx[f,seb[isei].idInfo,hti] THEN RETURN[TRUE];
	  ENDLOOP;
	RETURN[FALSE];
	END;
      computed =>
	BEGIN OPEN SymbolOps, seb[usei];
	isei: ISEIndex;
	cnt: CARDINAL ← 0;
	Lookup.Complete[caseCtx];
	FOR isei ← FirstCtxSe[caseCtx], NextSe[isei] UNTIL isei = ISENull DO
	  IF SearchCtx[f,seb[isei].idInfo,hti] THEN cnt ← cnt + 1;
	  IF cnt > 1 THEN AbortWithError[notUniqueField,hti];
	  ENDLOOP;
	RETURN[cnt = 1];
	END;
      ENDCASE => ERROR;
    END;

  TakeAddress: PROC [f: Foo] =
    BEGIN
    p: LONG POINTER TO LONG POINTER;
    IF f.addr.offset # 0 THEN AbortWithError[invalidAddress,f.hti];
    IF ~f.there THEN ERROR WhosBeenScanningMyTree;
    f.tsei ← MakePointerType[f.tsei];
    f.hti ← Symbols.HTNull;
    f.there ← FALSE;
    p ← Storage.Node[(f.words ← SIZE[LONG POINTER])];
    p↑ ← f.addr.base;
    f.addr.base ← p;
    END;

  Memory: PROC [t: Tree.Link, type: Symbols.SEIndex] =
    BEGIN
    f: Foo ← Son[t,type];
    lp: LONG POINTER;
    n: Number ← GetNumber[f, invalidAddress];
    IF f.there THEN AbortWithError[invalidAddress];
    f.hti ← Symbols.HTNull;
    f.tsei ← Symbols.typeANY;
    lp ← Storage.Node[1];
    SELECT n.type FROM
      one => lp↑ ← DebugOps.ShortREAD[n.u];
      two => lp↑ ← DebugOps.LongREAD[n.u];
      ENDCASE;
    Heap.FreeLong[f.addr.base];
    f.addr.base ← lp;
    f.words ← 1;
    END;

  DoApply: PUBLIC PROC[t: Tree.Link, target: Foo] =
    BEGIN 
    uniOperand: BOOLEAN ← TreeOps.OpName[t] # list;
    long: BOOLEAN;
    targetType: CSEIndex;
    IF target = NIL THEN RETURN;
    WHILE DIActions.Deref[target] DO ENDLOOP;
    targetType ← TypeForSe[target.tsei];
    WITH seb[targetType] SELECT FROM
      long => {long ← TRUE; targetType ← TypeForSe[rangeType]};
      ENDCASE => long ← FALSE;
    WITH seb[targetType] SELECT FROM
      record => AbortWithError[constructor];
      array =>
	BEGIN
	start: CARDINAL;
	IF ~uniOperand THEN SIGNAL NotImplemented["Array intervals"L];
	start ← GetStart[t, indexType];
	DoArray[target,start,start];
	END;
      arraydesc =>
	BEGIN
	start: CARDINAL;
	asei: Symbols.ArraySEIndex;
	IF ~uniOperand THEN SIGNAL
	  NotImplemented["Array descriptor intervals"L];
	asei ← LOOPHOLE[SymbolOps.UnderType[describedType]];
	start ← GetStart[t, seb[asei].indexType];
	IF long THEN DoLongDesc[target,start,start]
	ELSE DoDesc[target,start,start];
	END;
      transfer =>
	BEGIN
	tm: Symbols.TransferMode = SymbolOps.XferMode[targetType];
	IF tm # proc THEN ApplyError[tm];
	ProcedureCall[t,target];
	END;
      ref =>
	BEGIN
	tos: Foo;
	IF ~basing THEN ERROR DerefError;
	Work[t];
	tos ← Tos[];
	IF ~uniOperand THEN AbortWithError[notRelative,tos.hti];
	Reloc[target,tos];
	END;
      ENDCASE;
    END;

  GetStart: PROC [t: Tree.Link, target: Symbols.SEIndex] RETURNS [CARDINAL] =
    BEGIN
    f: Foo;
    n: Number;
    TargetTypeWork[t,target];
    IF ~CheckLength[(f ← Pop[]),1] THEN AbortWithError[indexTooBig];
    n ← GetNumber[f];
    RETURN[n.c];
    END;

  DoLongDesc: PROC [f: Foo, start, stop: CARDINAL] =
    BEGIN
    sei: Symbols.ArraySEIndex;
    d: LongDesc;
    ai: Dump.ArrayInfo;
    [d,sei] ← GetLongDesc[f];
    IF d.base = NIL THEN AbortWithError[nilChk];
    ai ← [start: start, stop: stop, addr: [d.base,0], length: d.length,
      packing: SymbolOps.BitsPerElement[sei], type: seb[sei].componentType];
    IF start = stop THEN GetElement[@ai] ELSE Dump.Elements[@ai];
    END;

  DoDesc: PROC [f: Foo, start, stop: CARDINAL] =
    BEGIN
    sei: Symbols.ArraySEIndex;
    d: Desc;
    ai: Dump.ArrayInfo;
    [d,sei] ← GetDesc[f];
    IF d.base = NIL THEN AbortWithError[nilChk];
    ai ← [start: start, stop: stop, addr: [DebugOps.Lengthen[d.base],0],
      length: d.length,
      packing: SymbolOps.BitsPerElement[sei], type: seb[sei].componentType];
    IF start = stop THEN GetElement[@ai] ELSE Dump.Elements[@ai];
    END;

  DoArray: PROC [f: Foo, start, stop: CARDINAL] =
    BEGIN
    ai: Dump.ArrayInfo;
    d: Desc;
    sei: Symbols.ArraySEIndex;
    [d,sei] ← GetDesc[f];
    ai ← [
      start: start, stop: stop, length: d.length, addr: f.addr,
      packing: SymbolOps.BitsPerElement[sei], type: seb[sei].componentType];
    IF start = stop THEN GetElement[@ai] ELSE Dump.Elements[@ai];
    END;

  GetElement: PUBLIC PROCEDURE [ai: Dump.ArrayHandle] =
    BEGIN OPEN DOutput;
    f: Foo ← Heap.AllocFob[];
    f↑ ← [hti: Symbols.HTNull, indent:, xfer:, tsei: ai.type,
      typeOnly: FALSE, there: TRUE, addr:, words:, bits:];
    [f.words, f.bits] ← Normalize[ai.packing];
    f.addr ← Dump.CalculateAddr[ai, ai.start];
    Push[f];
    END;

  Reloc: PROC [base, rel: Foo] =
    BEGIN
    csei: CSEIndex ← TypeForSe[rel.tsei];
    lp: LONG POINTER TO LONG CARDINAL;
    WITH seb[csei] SELECT FROM
      relative =>
	BEGIN
	IF TypeForSe[baseType] # TypeForSe[base.tsei] THEN
	  AbortWithError[wrongBase, base.hti];
	rel.tsei ← resultType;
	GetValue[rel];		-- round to one word
	IF ~CheckLength[rel,1] THEN AbortWithError[notRelative,rel.hti];
	lp ← Add[base,rel];
	Heap.FreeLong[rel.addr.base];
	rel.addr.base ← lp; rel.addr.offset ← rel.bits ← 0;
	rel.words ← SymbolOps.WordsForType[resultType];
	rel.there ← FALSE; rel.hti ← Symbols.HTNull;
	IF ~Deref[rel] THEN AbortWithError[notRelative];
	END;
      ENDCASE => AbortWithError[notRelative,rel.hti];
    END;

  Add: PROC [f1,f2: Foo] RETURNS [lp: LONG POINTER TO LONG CARDINAL] =
    BEGIN
    n: Number;
    lc: LONG CARDINAL;
    n ← GetNumber[f1, invalidAddress];
    IF n.type = one THEN lc ← n.c ELSE lc ← n.lc;
    n ← GetNumber[f2, invalidAddress];
    IF n.type = one THEN lc ← lc + n.c ELSE lc ← lc + n.lc;
    lp ← Storage.Node[SIZE[LONG CARDINAL]]; lp↑ ← lc;
    END;

  ProcedureCall: PUBLIC PROCEDURE [args: Tree.Link, proc: Foo] =
    BEGIN OPEN SymbolOps;
    cnt: CARDINAL ← 0;
    in: Symbols.RecordSEIndex;
    isei: ISEIndex ← Symbols.ISENull;
    cl: PrincOps.ControlLink;
    state: PrincOps.StateVector;
    cbti: Symbols.CBTIndex;
    sv: PrincOps.SVPointer;

    Collect: Tree.Scan = 
      BEGIN
      f: Foo;
      words: CARDINAL;
      p: LONG POINTER TO ARRAY [0..0) OF UNSPECIFIED;
      isei ← IF cnt = 0 THEN FirstCtxSe[seb[in].fieldCtx] ELSE NextSe[isei];
      IF isei = Symbols.ISENull THEN AbortWithError[wrongNumberArgs,proc.hti];
      TargetTypeWork[t,isei];
      words ← TotalWords[(f←Pop[])];
      GetValue[f];
      cnt ← cnt + words;
      IF state.stkptr + words > PrincOps.MaxParamsInStack THEN
	AbortWithError[tooManyArgs,proc.hti];
      p ← LOOPHOLE[f.addr.base];
      FOR i: CARDINAL IN [0..words) DO
	state.stk[state.stkptr] ← p[state.stkptr];
	state.stkptr ← state.stkptr + 1;
	ENDLOOP;
      END;

    IF data.worryEntry THEN AbortWithError[worryCall];
    in ← TransferTypes[TypeForSe[proc.tsei]].typeIn;
    state.instbyte ← state.stkptr ← 0;
    TreeOps.ScanList[args,Collect];
    IF cnt#WordsForType[in] OR (cnt#0 AND NextSe[isei]#Symbols.ISENull) THEN 
      AbortWithError[wrongNumberArgs,proc.hti];
    cl ← DerefProcDesc[GetControlLink[proc ! NotAProcedure => GOTO inline] !
      NotAProcedure => GOTO inline];
    cbti ← Pc.LinkToCbti[cl];
    IF cbti = Symbols.CBTNull THEN AbortWithError[callingInline];
    state.source ← NIL;
    state.dest ← Gf.OldLink[cl];
    sv ← @LOOPHOLE[data.ESV.parameter, CoreSwapDefs.CallDP].sv;
    DebugOps.ShortCopyWRITE[
      to: sv, from: @state, nwords: SIZE[PrincOps.StateVector]];
    Init.CoreSwap[call];
    sv ← @LOOPHOLE[data.ESV.parameter, CoreSwapDefs.CallDP].sv;
    DebugOps.ShortCopyREAD[
      from: sv, to: @state, nwords: SIZE[PrincOps.StateVector]];
    Lf.DisplayResults[state.source];
    EXITS
      inline => AbortWithError[callingInline];
    END;

  ApplyError: PROC [tm: Symbols.TransferMode] =
    BEGIN OPEN DOutput;
    Text[" can't call a"L]; IF tm = error THEN Char['n];
    Blanks[1]; Dump.ModeName[tm]; Char['!]; EOL[];
    ERROR DIAbort;
    END;

  LoopHole: PROC [f: Foo, type: Symbols.SEIndex, lengthen: BOOLEAN ← FALSE] =
    BEGIN
    tSize: CARDINAL;
    SELECT TRUE FROM
      f = NIL => RETURN;
      f.tsei = type => RETURN;
      TotalWords[f] = (tSize ← SymbolOps.WordsForType[type]) => NULL;
      ~lengthen => AbortWithError[sizeMismatch];
      tSize # 2 => AbortWithError[sizeMismatch];
      ~CheckLength[f,1] => AbortWithError[sizeMismatch];
      ENDCASE => LengthenFob[f];
    f.tsei ← type;
    END;

  Size: PROC [f: Foo] =
    BEGIN
    f1: Foo ← Heap.AllocFob[];
    lp: LONG POINTER TO CARDINAL ← Storage.Node[SIZE[CARDINAL]];
    IF ~f.typeOnly THEN AbortWithError[notType];
    lp↑ ← SymbolOps.WordsForType[f.tsei];
    f1.addr.base ← lp;
    f1.words ← 1;
    f1.tsei ← com.typeCARDINAL;
    Push[f1];
    END;

  Assign: PUBLIC PROCEDURE [lhs: Foo] =
    BEGIN
    rhs: Foo = Pop[];
    Assignable[rhs, TypeForSe[lhs.tsei]];
    PutValue[lhs,rhs.addr.base]
    END;

  Assignable: PROCEDURE [f: Foo, csei: CSEIndex] =
    BEGIN
    left: Types.Handle ← [LOOPHOLE[MyBase],csei];
    right: Types.Handle ← [LOOPHOLE[MyBase],TypeForSe[f.tsei]];
    IF ~Types.Assignable[typeL: left, typeR: right] THEN
      AbortWithError[typeMismatch, f.hti];
    DI.GetValue[f];  -- so I can check sizes
    LoopHole[f,csei,TRUE];
    IF SymbolOps.WordsForType[csei] # TotalWords[f] THEN
      AbortWithError[sizeMismatch, f.hti];
    END;

  TotalWords: PROC [f: Foo] RETURNS [cnt: CARDINAL] =
    BEGIN
    cnt ← f.words;
    IF f.bits # 0 THEN cnt ← cnt + 1;
    END;

  DumpMemory: PROCEDURE [fcnt: Foo] =
    BEGIN
    fstart: Foo ← Pop[];
    start: LONG POINTER;
    cnt: CARDINAL;
    n: Number;
    n ← GetNumber[fstart];
    SELECT n.type FROM
      one => start ← DebugOps.Lengthen[n.p];
      two => start ← n.lp;
      ENDCASE => AbortWithError[invalidAddress];
    n ← GetNumber[fcnt];
    SELECT n.type FROM
      one => cnt ← n.c;
      two => AbortWithError[wontDump];
      ENDCASE => AbortWithError[invalidNumber];
    Actions.DoRead[start,cnt, Actions.ReadUser];
    RETURN
    END;
  
  GetSize: PROCEDURE [index: Tree.Index, type: Symbols.SEIndex]
      RETURNS [size: NumberType, cnt: CARDINAL, signed: BOOLEAN] =
    BEGIN
    Process: Tree.Scan =
      BEGIN
      tosSize: NumberType;
      int: BOOLEAN;
      IF t = Tree.Null THEN ERROR BadTree;
      cnt ← cnt + 1;
      [,tosSize,int] ← GetRep[t, type];
      IF int THEN signed ← TRUE;
      IF tosSize = size THEN RETURN;
      size ← two;
      END;
    cnt ← 0;  size ← one; signed ← FALSE;
    TreeOps.ScanList[tb[index].son[1],Process];
    END;

  MinimalRep: PROCEDURE [t: Tree.Link, type: Symbols.SEIndex]
      RETURNS [f: Foo, size: NumberType, signed: BOOLEAN] =
    BEGIN
    p: LONG POINTER TO Inline.LongNumber;
    [f,size,signed] ← GetRep[t,type];
    IF size = one THEN RETURN;
    p ← f.addr.base;
    IF p.highbits # 0 THEN RETURN;
    size ← one; f.words ← 1;
    END;

  GetRep: PROCEDURE [t: Tree.Link, type: Symbols.SEIndex]
      RETURNS [f: Foo, size: NumberType, signed: BOOLEAN] =
    BEGIN
    n: Number;
    f ← Son[t, type];
    n ← GetNumber[f];
    size ← n.type;
    WITH Format[f.tsei].vf SELECT FROM
      int => {signed ← TRUE; RETURN};
      ENDCASE;
    SELECT size FROM
      one => signed ← ~n.sign;
      two => signed ← ~n.lsign;
      ENDCASE => ERROR DebugOps.InvalidNumber[f];
    END;

  Son: PUBLIC PROC [t: Tree.Link, target: Symbols.SEIndex] RETURNS [Foo] =
    BEGIN
    IF t = Tree.Null THEN ERROR WhosBeenScanningMyTree;
    Work[t, target];
    RETURN[Tos[]];
    END;

  FindLiteral: PROCEDURE [info: Literals.LitRecord] RETURNS [f: Foo] =
    BEGIN
    f ← Heap.AllocFob[];
    [f.addr.base, f.words] ← Lookup.CopyLiteral[info];
    WITH info SELECT FROM
      string => f.tsei ← com.typeSTRING;
      ENDCASE => f.tsei ← Symbols.typeANY;
    END;

  CheckLength: PUBLIC PROC [f: Foo, size: CARDINAL] RETURNS [BOOLEAN] =
    BEGIN
    IF f.words # size OR f.bits # 0 OR f.addr.offset # 0 THEN 
      RETURN[FALSE]
    ELSE RETURN[TRUE];
    END;

  NumberLength: PUBLIC PROC [f: Foo] RETURNS [nt: NumberType] =
    BEGIN
    IF CheckLength[f,1] THEN RETURN[one];
    IF CheckLength[f,2] THEN RETURN[two]; 
    RETURN[nogood]
    END;

  GetNumber: PUBLIC PROC [f: Foo, code: Err ← invalidNumber] RETURNS [n: Number] =
    BEGIN
    i: NumberType;
    p: LONG POINTER TO Words;
    IF (n.type ← NumberLength[f]) = nogood THEN AbortWithError[code];
    GetValue[f];
    p ← f.addr.base;
    FOR i IN [nogood..n.type) DO
      n.w[i] ← p[i];
      ENDLOOP;
    END;

  LongRec: TYPE = RECORD [sei, lsei: Symbols.CSEIndex];
  longs: ARRAY [0..3) OF LongRec;

  SetUpLongs: PROCEDURE =
    BEGIN
    longs[0] ← [com.typeINT, Symbols.CSENull];
    longs[1] ← [com.typeCARDINAL, Symbols.CSENull];
    longs[2] ← [Symbols.typeANY, Symbols.CSENull];
    END;

  ResetLongs: PUBLIC PROC =
    BEGIN
    i: CARDINAL;
    FOR i IN [0..LENGTH[longs]) DO longs[i].lsei ← Symbols.CSENull ENDLOOP;
    END;

  MakeLongType: PROC[rType: Symbols.SEIndex] RETURNS[type: Symbols.CSEIndex] =
    BEGIN OPEN SymbolOps, Symbols;
    i: CARDINAL;
    sei: CSEIndex ← UnderType[rType];
    FOR i IN [0..LENGTH[longs]) DO
      IF longs[i].sei # sei THEN LOOP;
      IF longs[i].lsei # SENull THEN RETURN[longs[i].lsei];
      longs[i].lsei ← type ← MakeNonCtxSe[SIZE[long cons SERecord]];
      EXIT
      REPEAT
	FINISHED => type ← MakeNonCtxSe[SIZE[long cons SERecord]];
      ENDLOOP;
    seb[type] ← SERecord[mark3: TRUE, mark4: TRUE,
	body: cons[long[rangeType: rType]]];
    RETURN
    END;

  MakePointerType: PROC [cType: Symbols.SEIndex]
      RETURNS [type: Symbols.CSEIndex] =
    BEGIN OPEN SymbolOps, Symbols;
    type ← MakeNonCtxSe[SIZE[ref cons SERecord]];
    seb[type] ← SERecord[mark3: TRUE, mark4: TRUE,
	body: cons[ref[
	    list: FALSE,
	    counted: FALSE,
	    ordered: FALSE,
	    readOnly: FALSE,
	    basing: FALSE,
	    dereferenced: FALSE,
	    refType: cType]]];
    RETURN
    END;

  Stack: TYPE = State.Stack;

  Push: PUBLIC PROCEDURE [f: Foo] =
    BEGIN
    h: State.Handle ← State.Get[];
    new: POINTER TO Stack ← Storage.Node[SIZE[Stack]];
    new↑ ← [h.fooStack,f];
    h.fooStack ← new;
    END;

  Pop: PUBLIC PROCEDURE RETURNS [f: Foo] =
    BEGIN
    h: State.Handle ← State.Get[];
    old: POINTER TO Stack ← h.fooStack;
    IF old = NIL THEN ERROR Underflow;
    f ← old.foo;
    h.fooStack ← old.link;
    Storage.Free[old];
    END;

  ResetStack: PROCEDURE =
    BEGIN
    h: State.Handle ← State.Get[];
    top, next: POINTER TO Stack;
    FOR top ← h.fooStack, next UNTIL top = NIL DO
      next ← top.link;
      Storage.Free[top];
      ENDLOOP;
    h.fooStack ← NIL;
    END;

  Tos: PUBLIC PROCEDURE RETURNS [f: Foo] =
    BEGIN
    h: State.Handle ← State.Get[];
    old: POINTER TO Stack ← h.fooStack;
    IF old = NIL THEN ERROR Underflow;
    RETURN[old.foo];
    END;

  CheckForStackEmpty: PUBLIC PROCEDURE = 
    BEGIN
    IF State.Get[].h.fooStack # NIL THEN ERROR StackNotEmptyAtStatement;
    END;

  AbortWithError: PUBLIC PROC [
      code: Err, hti: Symbols.HTIndex ← Symbols.HTNull] =
    BEGIN Error[code, hti]; ERROR DIAbort END;

  Error: PUBLIC PROC [code: Err, hti: Symbols.HTIndex ← Symbols.HTNull] =
    BEGIN
    s: STRING ← [40];
    IF hti # Symbols.HTNull THEN {Lookup.HtiToString[hti,s]; DOutput.Text[s]};
    DOutput.Line[SELECT code FROM
      callingInline => " can't call an INLINE!"L,
      cantLengthen => " can't lengthen!"L,
      constructor => " can't make a constructor!"L,
      indexTooBig => " double word array index!"L,
      invalidAddress => " has an invalid address!"L,
      invalidNumber => " is an invalid number!"L,
      invalidPointer => " is an invalid pointer!"L,
      nilChk => " pointer fault!"L,
      notFound => " not found!"L,
      notRelative => " is not a relative pointer!"L,
      notType => " is not a type!"L,
      notUniqueField => " is not a unique field selector!"L,
      notValidField => " is not a valid field selector!"L,
      overflow => " overflow!"L,
      sizeMismatch => " size mismatch!"L,
      tooManyArgs => " too many arguments for stack!"L,
      typeMismatch => " has incorrect type!"L,
      unknownVariant => " unknown variant!"L,
      wontDump => " Won't dump that much memory!"L,
      worryCall => " not permitted in wory mode!"L,
      wrongBase => " is the wrong base!"L,
      wrongNumberArgs => " has the wrong number of arguments!"L,
      ENDCASE => ERROR];
    END;

  SetUpLongs[];

  END.