-- file [Indigo]<Cedar>BCD>TypeStringsImpl.mesa
-- Edited by Satterthwaite, May 21, 1982 1:29 pm
-- Edited by Maxwell, 19-Feb-82 11:33:15 (NOTE: we need better error reporting)
-- Last Modified On 16-Apr-82  9:43:31 By Paul Rovner

DIRECTORY
	Inline: TYPE USING [HighByte, HighHalf, LowByte, LowHalf],
	Strings: TYPE USING [SubStringDescriptor, AppendChar],
	Symbols: TYPE USING [codeANY, codeCHAR, codeINT, CSEIndex, CTXIndex, 
		       ISEIndex, HTIndex, HTNull, MDIndex, MDNull, OwnMdi, 
		       SEIndex, SENull, StandardContext, typeTYPE],
	SymbolTable: TYPE USING [Base],
	TypeStrings: TYPE USING [Code, TypeString];

TypeStringsImpl: PROGRAM 
		IMPORTS Inline, Strings
		EXPORTS TypeStrings =
BEGIN
OPEN Symbols, TypeStrings;


--*******************************************************************
--basic algorithm
--*******************************************************************

stb: SymbolTable.Base _ NIL;
zone: UNCOUNTED ZONE _ NIL;
ts: TypeString;

Create: PUBLIC PROC [base:SymbolTable.Base, sei:SEIndex, z:UNCOUNTED ZONE]
RETURNS[TypeString] = 
	{--n:Entry;
	 --IF base#stb THEN FlushCache[];
	 IF base=NIL THEN RETURN[NIL];
	 stb _ base;
	 zone _ z;
	 stackIndex _ defsIndex _ 0;
	 --IF (n_cache[sei]).type=sei THEN RETURN[n.string];
	 ts _ zone.NEW[StringBody[50]];
	 stack _ zone.NEW[StackVector];
	 defs _ zone.NEW[DefsVector];
	 lastName _ 000C;
	 stateLength _ 0;  
	 AppendTypeString[sei];
	 --n.type _ sei;
	 --n.recursive _ InsertDefinitions[];
	 IF InsertDefinitions[] THEN Canonicalize[sei];
	 --n.string _ ts;
	 zone.FREE[@defs];  zone.FREE[@stack];
	 IF ts.length # ts.maxlength THEN ts _ Adjust[ts,ts.length];
	 RETURN[ts]};

Adjust: PROC [s:TypeString, n:CARDINAL] RETURNS [new: TypeString] =
	{new _ zone.NEW[StringBody[n]];
	 FOR i:CARDINAL IN [0..MIN[n, s.length]) DO
	    Strings.AppendChar[new,s[i]] ENDLOOP;
	 zone.FREE[@s];
	 RETURN[new]};

Append: PROC [c: CHAR] =  
	{WHILE ts.length >= ts.maxlength DO
	   ts _ Adjust[ts,ts.length+20] ENDLOOP;
	 Strings.AppendChar[ts, c]};

AppendCode: PROC [code: Code] = LOOPHOLE[Append];

AppendCardinal: PROC [c: CARDINAL] = INLINE
	{Append[LOOPHOLE[Inline.HighByte[c]]];
	 Append[LOOPHOLE[Inline.LowByte[c]]]};

AppendLongCardinal: PROC [lc: LONG CARDINAL] =
	{AppendCardinal[Inline.HighHalf[lc]];
	 AppendCardinal[Inline.LowHalf[lc]]};

AppendString: PROC [s:TypeString] = INLINE
	{FOR i:CARDINAL IN [0..s.length) DO Append[s[i]] ENDLOOP};

Paint:TYPE = MACHINE DEPENDENT RECORD [
  version (0): ARRAY [0..3) OF CARDINAL,
  index (3): CARDINAL];

GetPaint: PROC [type: SEIndex] RETURNS [paint: Paint] =
     {SELECT stb.TypeForm[type] FROM
        enumerated, definition, record, union =>
	  {ctx: CTXIndex _ TypeContext[type];
	   mdi: MDIndex;
	   WITH c: stb.ctxb[ctx] SELECT FROM
	      simple => mdi _ OwnMdi;
	      included => {mdi _ c.module; ctx _ c.map};
	      ENDCASE => ERROR;
	    paint.index _ LOOPHOLE[ctx];
	    IF ctx IN StandardContext THEN paint.version _ ALL[0]
	    ELSE paint.version _ LOOPHOLE[stb.mdb[mdi].stamp]};
	opaque =>
	  paint _ [LOOPHOLE[stb.mdb[OwnMdi].stamp], LOOPHOLE[type]];
        ENDCASE => ERROR;
      };
       
AppendPaint: PROC [paint:Paint] = {
      AppendCardinal[paint.version[0]];
      AppendCardinal[paint.version[1]];
      AppendCardinal[paint.version[2]];
      AppendCardinal[paint.index]};

AppendName: PROC [hti: HTIndex] = {
    length, offset:CARDINAL;
    IF hti = HTNull THEN {length _ offset _ 0}
    ELSE length _ stb.ht[hti].ssIndex - (offset _ stb.ht[hti-1].ssIndex);
    IF length>200B THEN ERROR; -- avoid code for leftParen and rightParen
    Append[0c + length];
    FOR i:CARDINAL IN [offset..offset+length) DO Append[stb.ssb[i]] ENDLOOP;
    };

AppendField: PROC [iSei: ISEIndex] = INLINE {
    AppendName[stb.HashForSe[iSei]];
    AppendTypeString[stb.seb[iSei].idType]};

AppendTypeString: PROC [type: SEIndex] =
BEGIN
class:Code;
e:StackElement;
--strip off definitions
type _ UnderStar[type];
--substitute concrete type for opaque type
IF stb.TypeForm[type]=opaque 
   THEN type _ OpaqueValue[LOOPHOLE[type,CSEIndex],stb];
--replace type with its set representative
FOR i:CARDINAL IN [0..stateLength) DO
    IF state[i].type = type THEN
      {type _ state[i].current; EXIT};
    ENDLOOP;
--check to see if type is recursive
IF (e _ Find[type]) # NIL 
   THEN {IF e.name=000C THEN e.name_NewName[]; 
	 AppendCode[name]; Append[e.name]; RETURN};
-- general cases
Push[type];
SELECT (class _ TypeClass[type]) FROM
      definition =>  ERROR;
      enumerated =>
         {SELECT LOOPHOLE[TypeContext[type],CARDINAL] FROM
		4 => AppendCode[boolean];
		ENDCASE => {AppendCode[paint];
	  		    AppendPaint[GetPaint[type]]};
	  };
      record =>
         {SELECT LOOPHOLE[TypeContext[type],CARDINAL] FROM
		6 => AppendCode[text];
		8 => AppendCode[stringBody];
		--10 => AppendCode[condition];
		--12 => AppendCode[lock];
		ENDCASE => {AppendCode[paint];
	  		    AppendPaint[GetPaint[type]]};
	  };
      structure =>
         {ctx: CTXIndex = TypeContext[type];
	  WITH c: stb.ctxb[ctx] SELECT FROM
	      included => IF ~c.complete THEN ERROR;
	      ENDCASE;
	  AppendCode[leftParen];
          FOR iSei: ISEIndex _ stb.FirstCtxSe[ctx], stb.NextSe[iSei] 
	      WHILE iSei#SENull DO AppendField[iSei] ENDLOOP;
          AppendCode[rightParen]};
      union => 
         {AppendCode[union];
	  AppendPaint[GetPaint[type]]};
      array =>
         {IF Packed[type] THEN AppendCode[packed];
	  AppendCode[array];  
	  AppendTypeString[Domain[type]]; 
	  AppendTypeString[Range[type]]};
      sequence =>
         {IF Packed[type] THEN AppendCode[packed];
	  AppendCode[sequence];  
	  AppendField[Tag[type]]; 
	  AppendTypeString[Range[type]]};
      subrange => -- 10 bytes
         {AppendCode[subrange];
	  AppendTypeString[Ground[type]];
	  AppendLongCardinal[First[type]];
	  AppendLongCardinal[Last[type]]};
      opaque => 
         {csei:CSEIndex = LOOPHOLE[type];
	  WITH t: stb.seb[csei] SELECT FROM
	 	opaque => IF stb.seb[t.id].idCtx IN StandardContext 
			     THEN AppendCode[atomRec]
			     ELSE {AppendCode[opaque];
	  			   AppendPaint[GetPaint[type]]};
		ENDCASE => ERROR};
      countedZone, uncountedZone =>
         {IF Mds[type] THEN AppendCode[mds];
	  AppendCode[class]};
      list => -- list = REF RECORD[cdr]
         {IF Ordered[type] THEN AppendCode[ordered];
	  IF ReadOnly[type] THEN AppendCode[readOnly];
	  AppendCode[list];
	  AppendTypeString[Cdr[type]]};
      relativeRef => 
         {AppendCode[relativeRef];
	  AppendTypeString[Base[type]];
	  AppendTypeString[Range[type]]};
      ref =>
         {IF ReadOnly[type] THEN AppendCode[readOnly];
	  IF TypeClass[Range[type]] = any
           THEN AppendCode[refAny]
           ELSE {AppendCode[ref]; AppendTypeString[Range[type]]}};
      var =>
         {IF ReadOnly[type] THEN AppendCode[readOnly];
	  AppendCode[var]; AppendTypeString[Range[type]]};
      pointer, longPointer => 
         {IF Ordered[type] THEN AppendCode[ordered];
	  IF ReadOnly[type] THEN AppendCode[readOnly];
	  AppendCode[class]; AppendTypeString[Range[type]]}; 
      descriptor, longDescriptor =>
         {IF ReadOnly[type] THEN AppendCode[readOnly];
	  AppendCode[class]; AppendTypeString[Range[type]]};
      procedure, safeProc =>
         {AppendCode[class];
	  AppendTypeString[Domain[type]];
	  AppendTypeString[Range[type]]};
      port, program, signal, error =>
         {IF Safe[type] THEN AppendCode[safe];
	  AppendCode[class];
	  AppendTypeString[Domain[type]];
	  AppendTypeString[Range[type]]};
      process =>
         {IF Safe[type] THEN AppendCode[safe];
	  AppendCode[process]; AppendTypeString[Range[type]]};
      nil => {AppendCode[leftParen]; AppendCode[rightParen]};
      cardinal, integer, character, longInteger, longCardinal, real,
      type, any, unspecified  =>
         {AppendCode[class]};
      globalFrame, localFrame => ERROR;
     ENDCASE => ERROR;
Pop[];
END;

OpaqueValue: PROC [type:CSEIndex, base:SymbolTable.Base] RETURNS[val:SEIndex] = {
OPEN b1:stb;
val _ type;
WITH t1: b1.seb[type] SELECT FROM
  opaque => {
     mdi1:MDIndex = WITH c1: b1.ctxb[b1.seb[t1.id].idCtx] SELECT FROM
          included => c1.module,
	  imported => b1.ctxb[c1.includeLink].module,
	  ENDCASE => OwnMdi;
     mdi2: MDIndex = base.FindMdi[b1.mdb[mdi1].stamp];
     IF mdi2 # MDNull AND base.mdb[mdi2].exported THEN {
          ss: Strings.SubStringDescriptor;
	  sei2: ISEIndex;
	  b1.SubStringForHash[@ss,b1.seb[t1.id].hash];
	  sei2 _ base.SearchContext[base.FindString[@ss], base.mainCtx];
	  IF sei2#SENull AND base.seb[sei2].idType=typeTYPE 
	     AND base.seb[sei2].public THEN val _ base.UnderType[sei2]}};
  ENDCASE};
 
lastName: CHAR;

NewName: PROC RETURNS[CHAR] = 
	{RETURN[lastName _ lastName+1]};
	

--*******************************************************************
--canonicalization	
--*******************************************************************

Canonicalize: PROC [type:SEIndex] = {
    -- build an equivalence table for the type
    stateLength _ 0;
    state _ zone.NEW[StateTable];
    AddState[type]; -- gets them all recursively
    -- minimize the table
    UNTIL ~Split[] DO NULL ENDLOOP;
    -- generate a new string
    ts.length _ 0;
    AppendTypeString[type];  -- will make use of the equivalences
    [] _ InsertDefinitions[];
    zone.FREE[@state]};
    
Split: PROC RETURNS [split: BOOL_FALSE]= {
    -- iterate over all k-equivalent classes, 
    -- splitting them into k+1-equivalent classes
    FOR i:CARDINAL IN [0..stateLength) DO
        -- check to see if we have done this class already
    	found: BOOL _ FALSE;
	FOR j:CARDINAL IN [0..i) DO 
	    IF state[i].current=state[j].current THEN found _ TRUE;
	    ENDLOOP;
	IF found THEN LOOP;
	-- if not, process the class 
    	list _ zone.NEW[ListVector];
	list[0] _ state[i].type; listLength _ 1;
	state[i].next _ state[i].type;
	FOR j:CARDINAL IN (i..stateLength) DO
	    IF state[j].current#state[i].current THEN LOOP;  -- not in the class
	    found _ FALSE;
	    FOR k:CARDINAL IN [0..listLength) DO
	        IF kEQ[state[j].type,list[k]] 
		    THEN {state[j].next _ list[k]; found _ TRUE; EXIT};
		ENDLOOP;
	    IF found THEN LOOP;  
	    -- a new class is born
	    state[j].next _ state[j].type;
	    IF listLength >= maxStateLength THEN ERROR;
	    list[listLength]_state[j].type;
	    listLength _ listLength + 1;
	    split _ TRUE;
	    ENDLOOP;
	zone.FREE[@list];
	ENDLOOP;
    FOR i:CARDINAL IN [0..stateLength) DO
        state[i].current _ state[i].next;
	ENDLOOP;
    };

AddState: PROC [type:SEIndex] = {
class:Code;
-- strip off unnecessary definitions
type _ UnderStar[type];
--ground:SEIndex _ type;
--WHILE TypeClass[ground]=definition DO
--     type _ ground; 
--     ground _ stb.UnderType[type];
--     ENDLOOP;
--type _ ground;
FOR i:CARDINAL IN [0..stateLength) DO
     IF state[i].type = type THEN RETURN;
     ENDLOOP;
IF stateLength >= maxStateLength THEN ERROR;
state[stateLength] _ [type,SENull,SENull];
stateLength _ stateLength + 1;
class _ TypeClass[type];
SELECT class FROM
      definition => ERROR;
      record, enumerated => NULL;
      structure =>
         {FOR iSei:ISEIndex _ stb.FirstCtxSe[TypeContext[type]], stb.NextSe[iSei] 
	      WHILE iSei#SENull DO
	       	  AddState[stb.seb[iSei].idType];
           	  ENDLOOP;
          };
      union => NULL;
      array => {AddState[Domain[type]]; AddState[Range[type]]};
      sequence =>
         {AddState[stb.seb[Tag[type]].idType]; AddState[Range[type]]};
      subrange => AddState[Ground[type]];
      opaque => NULL;
      countedZone, uncountedZone => NULL;
      list => AddState[Cdr[type]];
      relativeRef => {AddState[Base[type]]; AddState[Range[type]]};
      ref => AddState[Range[type]];
      var => AddState[Range[type]];
      pointer, longPointer, descriptor, longDescriptor => AddState[Range[type]];
      procedure, safeProc, port, program, signal, error =>
         {AddState[Domain[type]]; AddState[Range[type]]};
      process => AddState[Range[type]];
      nil => NULL;
      globalFrame, localFrame => ERROR;
      cardinal, integer, character, longInteger, longCardinal, real,
      type, any, unspecified => NULL;
     ENDCASE => ERROR;
   };
   
kEQ: PROC [t1,t2:SEIndex] RETURNS[BOOL] = {
class1:Code = TypeClass[t1];
class2:Code = TypeClass[t2];
IF class1#class2 THEN RETURN[FALSE];
SELECT class1 FROM
      definition => ERROR;
      record, enumerated, union => RETURN[t1=t2];
      structure =>
         {iSei1:ISEIndex _ stb.FirstCtxSe[TypeContext[t1]];
	  iSei2:ISEIndex _ stb.FirstCtxSe[TypeContext[t2]];
	  DO IF iSei1=SENull OR iSei2=SENull THEN RETURN[iSei1=iSei2];
	     IF stb.HashForSe[iSei1] # stb.HashForSe[iSei2] THEN RETURN[FALSE];
	     IF Current[stb.seb[iSei1].idType]#Current[stb.seb[iSei2].idType] THEN RETURN[FALSE]; 
	     iSei1 _ stb.NextSe[iSei1];
	     iSei2 _ stb.NextSe[iSei2];
	     ENDLOOP;
	  };
      array => {RETURN[Current[Domain[t1]]=Current[Domain[t2]]
      	           AND Current[Range[t1]]=Current[Range[t2]]]};
      sequence =>
         {iSei1: ISEIndex = Tag[t1];
	  iSei2: ISEIndex = Tag[t2];
	  RETURN[stb.HashForSe[iSei1] = stb.HashForSe[iSei2]
	  	   AND Current[stb.seb[iSei1].idType]=Current[stb.seb[iSei2].idType]
      	           AND Current[Range[t1]]=Current[Range[t2]]]};
      subrange => RETURN[Current[Ground[t1]]=Current[Ground[t2]]];
      opaque => RETURN[t1=t2];
      countedZone, uncountedZone => RETURN[t1=t2];
      list => RETURN[Current[Cdr[t1]]=Current[Cdr[t2]]];
      relativeRef => {RETURN[Current[Base[t1]]=Current[Base[t2]]
      		         AND Current[Range[t1]]=Current[Range[t2]]]};
      ref => RETURN[Current[Range[t1]]=Current[Range[t2]]];
      var => RETURN[Current[Range[t1]]=Current[Range[t2]]];
      pointer, longPointer, descriptor, longDescriptor => 
      	RETURN[Current[Range[t1]]=Current[Range[t2]]];
      procedure, safeProc, port, program, signal, error => {
      	RETURN[Current[Domain[t1]]=Current[Domain[t2]] 
	   AND Current[Range[t1]]=Current[Range[t2]]]};
      process => RETURN[Current[Range[t1]]=Current[Range[t2]]];
      type => RETURN[t1=t2];  --***PDR--
      nil => RETURN[t1=t2];
      any => RETURN[t1=t2];   --***PDR--
      unspecified => RETURN[t1=t2];
      globalFrame, localFrame => ERROR;
      cardinal, integer, character, longInteger, longCardinal, real,
      type, any, unspecified =>
        RETURN[t1=t2];
     ENDCASE => ERROR;
   };
   
Current: PROC [type:SEIndex] RETURNS[SEIndex] = {
    type _ UnderStar[type];
    FOR i:CARDINAL IN [0..stateLength) DO
        IF state[i].type=type THEN RETURN[state[i].current];
	ENDLOOP;
    ERROR};
       
StateTable: TYPE = ARRAY [0..maxStateLength) OF RECORD [type,current,next: SEIndex];
state: LONG POINTER TO StateTable _ NIL;
stateLength: CARDINAL;
maxStateLength:CARDINAL = 100;

ListVector: TYPE = ARRAY [0..maxStateLength) OF SEIndex;
list: LONG POINTER TO ListVector _ NIL;
listLength: CARDINAL;


--*******************************************************************
--stack management
--*******************************************************************

StackElementRecord:TYPE = RECORD[name:CHAR,type:SEIndex,index:CARDINAL];
StackElement:TYPE = LONG POINTER TO StackElementRecord;

StackVector: TYPE = ARRAY [0..stackLength) OF StackElementRecord;
stack: LONG POINTER TO StackVector _ NIL;
stackLength: CARDINAL = 100;
stackIndex: CARDINAL _ 0;

DefsVector: TYPE = ARRAY [0..defsLength) OF StackElementRecord;
defs: LONG POINTER TO DefsVector _ NIL;
defsLength: CARDINAL = 30;
defsIndex: CARDINAL _ 0;

Push: PROC [type:SEIndex] = {
    IF stackIndex=stackLength THEN ERROR;
    stack[stackIndex] _ [000C,type,ts.length];
    stackIndex _ stackIndex + 1};

Pop: PROC = {
    IF stackIndex=0 THEN ERROR;
    stackIndex _ stackIndex - 1;
    IF stack[stackIndex].name=000C THEN RETURN;
    IF defsIndex=defsLength THEN ERROR;
    defs[defsIndex] _ stack[stackIndex];
    defsIndex _ defsIndex+1};
    
Find: PROC [type:SEIndex] RETURNS[StackElement_NIL] = {
    FOR i:CARDINAL IN [0..stackIndex) DO
        IF stack[i].type=type THEN RETURN[@stack[i]];
	ENDLOOP};
	
InsertDefinitions: PROC RETURNS [recursive:BOOL _ FALSE] = {
    WHILE TRUE DO
	index, j: CARDINAL _ 0;
	found: BOOL _ FALSE;
	FOR i:CARDINAL IN [0..defsIndex) DO
	    IF defs[i].name=000C THEN LOOP;
	    IF defs[i].index<index THEN LOOP;
	    index _ defs[i].index; j _ i;
	    found _ recursive _ TRUE;
	    ENDLOOP;
	IF ~found THEN EXIT;
	IF ts.length+2 > ts.maxlength THEN ts _ Adjust[ts,ts.length+4];
	ts.length _ ts.length + 2;
	FOR i:CARDINAL DECREASING IN [index+2..ts.length) DO ts[i] _ ts[i-2] ENDLOOP;
	LOOPHOLE[ts[index],Code] _ definition;
	ts[index+1] _ defs[j].name;
	defs[j].name _ 000C;
	ENDLOOP;
    lastName _ 000C;
    defsIndex _ 0};

--*******************************************************************
--hash table management
--*******************************************************************

--Entry:TYPE = LONG POINTER TO EntryRec;

--EntryRec:TYPE = RECORD [type:SEIndex,
--			recursive:BOOL,
--			string:TypeString];
			
--nullEntry:EntryRec = [SENull, FALSE, NIL];

--array: ARRAY [0..arrayLength) OF EntryRec;
--arrayLength:CARDINAL = 47;

--FlushCache: PROC = {array _ ALL[nullEntry]};

--cache: PROC [sei:SEIndex] RETURNS[Entry] ={
--	p:CARDINAL _ LOOPHOLE[sei,CARDINAL] MOD arrayLength;
--	FOR i:CARDINAL IN [p..arrayLength) DO
--		IF array[i].type=SENull THEN RETURN[@array[i]];
--		IF array[i].type=sei THEN RETURN[@array[i]];
--		ENDLOOP;
--	FOR i:CARDINAL IN [0..p) DO
--		IF array[i].type=SENull THEN RETURN[@array[i]];
--		IF array[i].type=sei THEN RETURN[@array[i]];
--		ENDLOOP;
--	ERROR}; ++ too many types!!!

--*******************************************************************
--procedures that work with the symbol table
--*******************************************************************

TypeContext: PROC [type: SEIndex] RETURNS [CTXIndex] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
      enumerated => t.valueCtx,
      record => t.fieldCtx,
      definition => t.defCtx,
      union => t.caseCtx,
      ENDCASE => ERROR]};
      
Cdr: PROC [type: SEIndex] RETURNS [SEIndex] = {
    ctx:CTXIndex = TypeContext[Range[type]];
    iSei:ISEIndex _ stb.FirstCtxSe[ctx];
    WITH c:stb.ctxb[ctx] SELECT FROM
         included => IF ~c.complete THEN ERROR;
	 ENDCASE;
    RETURN [stb.seb[iSei].idType]};
 
Base: PROC [type: SEIndex] RETURNS [SEIndex] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
        relative => t.baseType,
        ENDCASE => ERROR]};

Range: PROC [type: SEIndex] RETURNS [SEIndex] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
	array => t.componentType,
	sequence => t.componentType,
	transfer => t.typeOut,
	ref => t.refType,
	relative => t.offsetType,
	arraydesc => t.describedType,
        long => Range[t.rangeType],
        ENDCASE => ERROR]};

Domain: PROC [type: SEIndex] RETURNS [SEIndex] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
	array => t.indexType,
	sequence => stb.seb[t.tagSei].idType,
	union => stb.seb[t.tagSei].idType,
	transfer => t.typeIn,
	ENDCASE => ERROR]};

Tag: PROC [type: SEIndex] RETURNS [ISEIndex] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
	sequence => t.tagSei,
	union => t.tagSei,
	ENDCASE => ERROR]};

First: PROC [type: SEIndex] RETURNS [LONG CARDINAL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [SELECT TypeClass[csei] FROM
	enumerated => 0,
	subrange => WITH t: stb.seb[csei] SELECT FROM
                     subrange => LONG[t.origin],
                     ENDCASE => ERROR,
	cardinal => FIRST[CARDINAL],
	integer => LONG[LOOPHOLE[FIRST[INTEGER], CARDINAL]],
	character => LONG[LOOPHOLE[FIRST[CHAR], CARDINAL]],
	longInteger => LOOPHOLE[FIRST[LONG INTEGER]],
	longCardinal => FIRST[LONG CARDINAL],
	ENDCASE => ERROR]
    };

Last: PROC [type: SEIndex] RETURNS [LONG CARDINAL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [SELECT TypeClass[csei] FROM
       enumerated =>
          WITH t: stb.seb[csei] SELECT FROM
             enumerated => LOOPHOLE[LONG[t.nValues - 1]],
             ENDCASE => ERROR,
       subrange =>
          WITH t: stb.seb[csei] SELECT FROM
             subrange => LOOPHOLE[LONG[t.origin + t.range]],
             ENDCASE => ERROR,
       cardinal => LAST[CARDINAL],
       integer => LONG[LOOPHOLE[LAST[INTEGER], CARDINAL]],
       character => LONG[LOOPHOLE[LAST[CHAR], CARDINAL]],
       longInteger => LOOPHOLE[LAST[LONG INTEGER]],
       longCardinal => LAST[LONG CARDINAL],
       ENDCASE => ERROR]
    };
   
Safe: PROC [type: SEIndex] RETURNS [BOOL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
	transfer => t.safe,
	ENDCASE => ERROR]
    };

ReadOnly: PROC [type: SEIndex] RETURNS [BOOL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
        long => ReadOnly[t.rangeType],
	ref => t.readOnly,
	arraydesc => t.readOnly,
	ENDCASE => ERROR]
    };

Ordered: PROC [type: SEIndex] RETURNS [BOOL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
        long => Ordered[t.rangeType],
	ref => t.ordered,
	ENDCASE => ERROR]
    };

Packed: PROC [type: SEIndex] RETURNS [BOOL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
        array => t.packed,
        sequence => t.packed,
	ENDCASE => ERROR]
    };
    
Mds: PROC [type: SEIndex] RETURNS[BOOL] = {
    csei: CSEIndex = stb.UnderType[type];
    RETURN [WITH t: stb.seb[csei] SELECT FROM
        zone => t.mds,
	ENDCASE => ERROR]
    };

Ground: PROC [type: SEIndex] RETURNS [SEIndex] = {
    RETURN [WITH se: stb.seb[type] SELECT FROM
       id => se.idInfo,  -- a definition
       cons =>
         WITH cse: se SELECT FROM
           subrange => cse.rangeType,
           ENDCASE => ERROR,  -- NOTE relativeRef not yet
       ENDCASE => ERROR]};
       
UnderStar: PROC [type: SEIndex] RETURNS [SEIndex] = {
    WHILE TypeClass[type]=definition DO
        type _ stb.UnderType[type];
	ENDLOOP;
    RETURN[type]};
       
TypeClass: PROC [sei: SEIndex] RETURNS[ans: Code] =
  BEGIN
    csei:CSEIndex;
    --IF type = fhType THEN RETURN[localFrame];
    --IF type = nullType THEN RETURN[nil];
    --IF type = gfhType THEN RETURN[globalFrame];
    --IF type = unspecType THEN RETURN[unspecified];
    IF sei=SENull THEN RETURN[nil];
    IF stb.seb[sei].seTag = id THEN RETURN[definition];
    csei _ stb.UnderType[sei];
    ans _ 
        (WITH ser: stb.seb[csei] SELECT FROM
          basic => SelectBasicClass[ser.code],
          record => (IF ser.painted THEN record ELSE structure),
          definition => record,
          real => real,
          union => union,
          array => array,
          opaque => opaque,
          sequence => sequence,
          ref => (IF ser.counted THEN ERROR ELSE pointer),
          arraydesc => descriptor,
          long => (WITH rse: stb.seb[stb.UnderType[ser.rangeType]] SELECT FROM
                      ref => (SELECT TRUE FROM
		        rse.var => var,
			rse.counted => IF rse.list THEN list ELSE ref,
			ENDCASE => longPointer),
                      basic => (IF rse.code = codeINT THEN longInteger ELSE ERROR),
                      arraydesc => longDescriptor,
                      ENDCASE => IF IsCardinal[ser.rangeType] THEN longCardinal ELSE ERROR),
          relative => relativeRef,
          enumerated => enumerated,
          subrange => IF IsCardinal[csei] THEN cardinal ELSE subrange,
          transfer => (SELECT ser.mode FROM
                          proc => IF ser.safe THEN safeProc ELSE procedure,
                          port => port,
                          signal => signal,
                          error => error,
                          process => process,
                          program => program,
                         ENDCASE => ERROR),
          zone => (IF ser.counted THEN countedZone ELSE uncountedZone),
          mode => type,
          any => any,
         ENDCASE => ERROR);
  END;

SelectBasicClass: PROC [code: [0..16)] RETURNS[Code] = INLINE {
    RETURN [SELECT code FROM
        codeINT => integer,
        codeANY => unspecified,
        codeCHAR => character,
        ENDCASE => ERROR]};
	
IsCardinal: PROC [type: SEIndex] RETURNS [BOOL] = {
  csei: CSEIndex = stb.UnderType[type];
  RETURN [WITH t: stb.seb[csei] SELECT FROM
    subrange => (WITH tt: stb.seb[stb.UnderType[t.rangeType]] SELECT FROM
                   basic => (tt.code = codeINT AND t.origin = 0
                                      AND t.range = LAST[CARDINAL]),
		   ENDCASE => FALSE),
    ENDCASE => FALSE]};


--*******************************************************************
--substitution	
--*******************************************************************

Substitute: PUBLIC PROC [concrete,opaque,type:TypeString,z:UNCOUNTED ZONE] = {
    maxDef:CHAR _ MaxDefinition[concrete];
    IF type.length<opaque.length THEN RETURN;
    IF HasCode[concrete,opaque] THEN ERROR; -- potentially recursive
    IF maxDef#000C THEN ERROR; -- potentially recursive
    zone _ z; 
    FOR i:CARDINAL DECREASING IN [0..type.length-opaque.length] DO
        IF ~Match[opaque,type,i] THEN LOOP;
	IF maxDef#000C THEN Rename[concrete,MaxDefinition[type]]; 
	--delete opaque
	type.length _ type.length - opaque.length; 
	FOR j:CARDINAL IN [i..type.length) DO 
	    type[j] _ type[j+opaque.length]; ENDLOOP;
	--insert concrete
	IF type.length+concrete.length > type.maxlength 
	   THEN type _ Adjust[type,type.length+concrete.length];
	type.length _ type.length + concrete.length; 
	FOR j:CARDINAL DECREASING IN [i+concrete.length..type.length) DO 
	    type[j] _ type[j-concrete.length]; ENDLOOP;
	FOR j:CARDINAL IN [0..concrete.length) DO type[i+j] _ concrete[j]; ENDLOOP;
	ENDLOOP;
    IF maxDef#000C THEN ReorderDefinitions[type,MaxDefinition[type]];
    };
     
Match: PROC [s1,s2:TypeString,index:CARDINAL] RETURNS[BOOL] = INLINE {
    FOR i:CARDINAL IN [0..s1.length) DO
        IF s1[i]#s2[i+index] THEN RETURN[FALSE];
	ENDLOOP;
    RETURN[TRUE]};
    
ReorderDefinitions: PROC [s:TypeString,last:CHAR] = {
    a:ARRAY CHAR [001C..020C] OF RECORD[i:CARDINAL,n:CHAR];
    skip:CARDINAL _ 0;
    min,max:CARDINAL _ 0;
    IF last>020C THEN ERROR;
    a _ ALL[[0,000C]];
    -- build the array of name => index associations
    FOR i:CARDINAL IN [0..s.length) DO
        IF skip>0 THEN {skip_skip-1; LOOP};
        IF LOOPHOLE[s[i],Code]=opaque THEN skip _ 8; -- skip paint
	IF LOOPHOLE[s[i],Code]=paint  THEN skip _ 8;
        IF LOOPHOLE[s[i],Code]#name THEN LOOP;
	IF a[s[i+1]].i=0 THEN a[s[i+1]].i _ i;
	ENDLOOP;
    -- sort names by their position in the string
    FOR i:CHAR IN [001C..last] DO
        max _ min;
	min _ s.length;
	FOR j:CHAR IN [001C..last] DO
	    IF a[j].i >= min THEN LOOP;
	    IF a[j].i <= max THEN LOOP;
	    min _ a[j].i;
	    a[j].n _ i;
	    ENDLOOP;
	ENDLOOP;
    -- replace definitions and names with their new names;
    FOR i:CARDINAL IN [0..s.length) DO
        IF skip>0 THEN {skip_skip-1; LOOP};
        IF LOOPHOLE[s[i],Code]=opaque THEN skip _ 8; -- skip paint
	IF LOOPHOLE[s[i],Code]=paint  THEN skip _ 8;
        IF ~(LOOPHOLE[s[i],Code] IN [definition..name]) THEN LOOP;
	s[i+1] _ a[s[i+1]].n;
	ENDLOOP;    
    };
    
MaxDefinition: PROC [s:TypeString] RETURNS[max:CHAR] = {
    skip:CARDINAL_0;
    max _ 000C;
    FOR i:CARDINAL IN [0..s.length) DO
        IF skip>0 THEN {skip_skip-1; LOOP};
        IF LOOPHOLE[s[i],Code]=opaque THEN skip _ 8; -- skip paint
	IF LOOPHOLE[s[i],Code]=paint  THEN skip _ 8;
        IF LOOPHOLE[s[i],Code]#definition THEN LOOP;
	max _ MAX[max,s[i+1]];
	ENDLOOP;
    };
    
Rename: PROC [s:TypeString,offset:CHAR] = {
    skip:CARDINAL_0;
    FOR i:CARDINAL IN [0..s.length) DO
       IF skip>0 THEN {skip_skip-1; LOOP};
       IF LOOPHOLE[s[i],Code]=opaque THEN skip _ 8; -- skip paint
       IF LOOPHOLE[s[i],Code]=paint  THEN skip _ 8;
       IF ~(LOOPHOLE[s[i],Code] IN [definition..name]) THEN LOOP;
       s[i+1] _ s[i+1]+LOOPHOLE[offset];
       ENDLOOP;
   };
   
HasCode: PROC [s:TypeString,code:Code] RETURNS[BOOL]= {
    skip:CARDINAL_0;
    FOR i:CARDINAL IN [0..s.length) DO
       IF skip>0 THEN {skip_skip-1; LOOP};
       IF LOOPHOLE[s[i],Code]=opaque THEN skip _ 8; -- skip paint
       IF LOOPHOLE[s[i],Code]=paint  THEN skip _ 8;
       IF LOOPHOLE[s[i],Code]=code  THEN RETURN[TRUE];
       ENDLOOP;
    RETURN[FALSE]};
   
END..