-- file SymLiteralPack.Mesa
-- last modified by Satterthwaite, February 24, 1983 3:11 pm

DIRECTORY
  Alloc: TYPE USING [Handle, Notifier, AddNotify, DropNotify, Top, Words],
  ComData: TYPE USING [
    idINTEGER, interface, mainCtx, ownSymbols, typeATOM, typeRefANY],
  Literals: TYPE USING [STIndex],
  LiteralOps: TYPE USING [Find],
  RTBcd: TYPE USING [RefLitIndex, TypeIndex],
  Strings: TYPE USING [String, SubStringDescriptor],
  Symbols: TYPE USING [
    Base, SERecord,
    Name, Type, ISEIndex, CSEIndex, CTXIndex, MDIndex, BitAddress,
    nullType, ISENull, CTXNull, StandardContext, lZ, OwnMdi, MDNull,
    typeANY, ctxType, seType],
  SymbolOps: TYPE USING [
    ClusterSe, EnterString, FirstCtxSe, MakeCtxSe, MakeNonCtxSe, NextSe, TypeForm,
    UnderType],
  SymbolSegment: TYPE USING [atType],
  SymLiteralOps: TYPE USING [RefLitItem],
  Table: TYPE USING [Base, Limit, Selector],
  Tree: TYPE USING [Link, NullIndex],
  TreeOps: TYPE USING [PopTree, PushLit, PushNode, PushSe, SetAttr, SetInfo],
  Types: TYPE USING [Equivalent];

SymLiteralPack: PROGRAM
    IMPORTS
      Alloc, LiteralOps, SymbolOps, TreeOps, Types,
      dataPtr: ComData
    EXPORTS SymLiteralOps = {
  OPEN Symbols;
  
  RefLitItem: TYPE = SymLiteralOps.RefLitItem;

 -- types

  SymLitRecord: TYPE = RECORD [
    SELECT tag: * FROM
      type => [canonical: BOOL, typeCode: Type],
      lit => [info: RefLitItem]
      ENDCASE];

  SymLitIndex: TYPE = Table.Base RELATIVE ORDERED POINTER[0..Table.Limit) TO SymLitRecord;

 -- bases

  table: Alloc.Handle;
  
  atType: Table.Selector = SymbolSegment.atType;
  slb: Table.Base;
  seb: Symbols.Base;
  ctxb: Symbols.Base;

  UpdateBases: Alloc.Notifier = {
   seb _ base[seType]; ctxb _ base[ctxType];
   slb _ base[atType]; seb _ base[seType]};


 -- auxiliary type predicates

  Matched: SIGNAL [m1, m2: Type] RETURNS [BOOL] = CODE;

  NameEqual: PROC [key, entry: Type] RETURNS [BOOL] = {
    RETURN [(key = entry) OR Isomorphic[key, entry ! Matched => {RESUME [FALSE]}]]};

  Isomorphic: PROC [key, entry: Type] RETURNS [BOOL] = {
    RETURN [WITH type1: seb[key] SELECT FROM
      id => (SymbolOps.ClusterSe[key] = SymbolOps.ClusterSe[entry]),
      cons =>
	WITH type2: seb[entry] SELECT FROM
	  cons =>
	    WITH t1: type1 SELECT FROM
	      record =>
		WITH t2: type2 SELECT FROM
		  record =>
		    (t1.fieldCtx = t2.fieldCtx) OR
		     (~t1.painted AND ~t2.painted AND (
			(SIGNAL Matched[key, entry])
			   OR
			 IsoFields[t1.fieldCtx, t2.fieldCtx
			  ! Matched => {IF m1=key AND m2=entry THEN RESUME [TRUE]}])),
		  ENDCASE => FALSE,
	      ref =>
		WITH t2: type2 SELECT FROM
		  ref =>
		    (t1.counted = t2.counted) AND (t1.ordered = t2.ordered) AND
		     (t1.readOnly = t2.readOnly) AND Isomorphic[t1.refType, t2.refType],
		  ENDCASE => FALSE,
	      long =>
		WITH t2: type2 SELECT FROM
		  long => Isomorphic[t1.rangeType, t2.rangeType],
		  ENDCASE => FALSE,
	      any => WITH t2: type2 SELECT FROM any => TRUE, ENDCASE => FALSE,
	      ENDCASE => (key = entry),
	  ENDCASE => FALSE,
      ENDCASE => ERROR]};

  IsoFields: PROC [ctx1, ctx2: CTXIndex] RETURNS [BOOL] = {
    sei1: ISEIndex _ SymbolOps.FirstCtxSe[ctx1];
    sei2: ISEIndex _ SymbolOps.FirstCtxSe[ctx2];
    UNTIL sei1 = sei2 DO
      IF seb[sei1].hash # seb[sei2].hash OR ~Isomorphic[seb[sei1].idType, seb[sei2].idType] THEN
	RETURN [FALSE];
      sei1 _ SymbolOps.NextSe[sei1];  sei2 _ SymbolOps.NextSe[sei2];
      ENDLOOP;
    RETURN [sei1 = sei2]};

      
  Equivalent: PROC [key, entry: Type] RETURNS [BOOL] = {
    RETURN [(key = entry) OR (
	Types.Equivalent[
	  [dataPtr.ownSymbols, SymbolOps.UnderType[key]],
	  [dataPtr.ownSymbols, SymbolOps.UnderType[entry]]]
	 AND ~Fuzzy[key, entry])]};

  Fuzzy: PROC [sei1, sei2: Type] RETURNS [BOOL] = INLINE {
    RETURN [SymbolOps.TypeForm[sei1] = array AND (~seb[sei1].mark4 OR ~seb[sei2].mark4)]};


 -- universal type fingers

  UTypeId: PUBLIC PROC [type: Type] RETURNS [mdi: MDIndex, index: Type] = {
    sei: Type = SymbolOps.ClusterSe[type];
    WITH se: seb[sei] SELECT FROM
      id => {
	ctx: CTXIndex = se.idCtx;
	WITH c: ctxb[ctx] SELECT FROM
	  included =>
	    IF c.level = lZ THEN {index _ sei; mdi _ OwnMdi}
	    ELSE {index _ se.idValue; mdi _ c.module};
	  ENDCASE => {
	    index _ sei;
	    mdi _ IF Predeclared[sei] THEN MDNull ELSE OwnMdi}};
      cons => {
        index _ sei;
	mdi _ WITH t: se SELECT FROM
	    basic => MDNull,
	    enumerated => IF t.valueCtx IN StandardContext THEN MDNull ELSE OwnMdi,
	    record => IF t.fieldCtx IN StandardContext THEN MDNull ELSE OwnMdi,
	    opaque => IF Predeclared[t.id] THEN MDNull ELSE OwnMdi,
	    ENDCASE => OwnMdi};
      ENDCASE;
    RETURN};
    
  Predeclared: PROC [type: Type] RETURNS [BOOL] = {
    RETURN [type = nullType OR (
      WITH se: seb[type] SELECT FROM
        id => se.idCtx IN (CTXNull .. StandardContext.LAST],
	ENDCASE => FALSE)]};
	  
     
 -- typeIds

  minTypes: CARDINAL = 2;	-- type fragment, if any, at least this big (avoid global 0)

  nTypes: CARDINAL;
  nTypeRefs: CARDINAL;
  typeMapId: ISEIndex;

  EnterType: PUBLIC PROC [type: Type, canonical: BOOL] = {
    sei: Type = SymbolOps.ClusterSe[type];
    slLimit: SymLitIndex = table.Top[SymbolSegment.atType];
    nTypeRefs _ nTypeRefs + 1;
    FOR sli: SymLitIndex _ FIRST[SymLitIndex], sli+SIZE[SymLitRecord] UNTIL sli = slLimit DO
      WITH s: slb[sli] SELECT FROM
	type =>
	  IF canonical = s.canonical AND
	   (IF canonical THEN Equivalent ELSE NameEqual)[sei, s.typeCode] THEN EXIT;
	ENDCASE;
      REPEAT
	FINISHED => InsertType[sei, canonical];
      ENDLOOP};

  TypeIndex: PUBLIC PROC [type: Type, canonical: BOOL] RETURNS [RTBcd.TypeIndex] = {
    sei: Type = SymbolOps.ClusterSe[type];
    i: CARDINAL _ 0;
    FOR sli: SymLitIndex _ FIRST[SymLitIndex], sli+SIZE[SymLitRecord] WHILE i < nTypes DO
      WITH s: slb[sli] SELECT FROM
	type =>
	  IF canonical = s.canonical AND
	   (IF canonical THEN Equivalent ELSE NameEqual)[sei, s.typeCode] THEN EXIT;
	ENDCASE;
      i _ i+1;
      REPEAT
	FINISHED => ERROR;
      ENDLOOP;
    RETURN [[i]]};

  TypeRef: PUBLIC PROC [type: Type, canonical: BOOL] RETURNS [Tree.Link] = {
    RETURN [IndexedRef[typeMapId, TypeIndex[type, canonical], typeANY]]};

  DescribeTypes: PUBLIC PROC RETURNS [offset, length: CARDINAL] = {
    RETURN [offset: WordOffset[typeMapId], length: nTypes]};

  EnumerateTypes: PUBLIC PROC [scan: PROC [canonical: BOOL, type: Type]] = {
    i: CARDINAL _ 0;
    FOR sli: SymLitIndex _ FIRST[SymLitIndex], sli+SIZE[SymLitRecord] WHILE i < nTypes DO
      WITH s: slb[sli] SELECT FROM
	type => scan[s.canonical, s.typeCode];
	ENDCASE;
      i _ i + 1;
      ENDLOOP};


  InsertType: PROC [type: Type, canonical: BOOL] = {
    sli: SymLitIndex = table.Words[atType, SIZE[SymLitRecord]];
    slb[sli] _ [type[canonical: canonical, typeCode: type]];
    nTypes _ nTypes + 1};
    
  PadTypes: PROC = INLINE {
    IF nTypes # 0 THEN {
      FOR i: NAT IN [nTypes .. minTypes) DO
        InsertType[Symbols.nullType, FALSE] ENDLOOP}};
	
	
 -- atoms and REFs to literals

  minLitRefs: CARDINAL = 1;	-- ref lit fragment, if any, at least this big (avoid global 0)

  nLits: CARDINAL;
  nLitRefs: CARDINAL;
  firstLit: SymLitIndex;	-- only after Reset
  litMapId: ISEIndex;

  EnterLit: PROC [item: RefLitItem] = {
    key: SymLitRecord = [lit[item]];
    slLimit: SymLitIndex = table.Top[SymbolSegment.atType];
    nLitRefs _ nLitRefs + 1;
    FOR sli: SymLitIndex _ FIRST[SymLitIndex], sli+SIZE[SymLitRecord] UNTIL sli = slLimit DO
      IF slb[sli] = key THEN EXIT;
      REPEAT
	FINISHED => InsertLit[item];
      ENDLOOP};

  LitIndex: PROC [item: RefLitItem] RETURNS [RTBcd.RefLitIndex] = {
    key: SymLitRecord = [lit[item]];
    i: CARDINAL _ 0;
    FOR sli: SymLitIndex _ firstLit, sli+SIZE[SymLitRecord] WHILE i < nLits DO
      IF slb[sli] = key THEN EXIT;  i _ i+1;
      REPEAT
	FINISHED => ERROR;
      ENDLOOP;
    RETURN [[i]]};

  InsertLit: PROC [item: RefLitItem] = {
    sli: SymLitIndex = table.Words[atType, SIZE[SymLitRecord]];
    slb[sli] _ [lit[item]];
    nLits _ nLits + 1};
    

  EnterAtom: PUBLIC PROC [name: Name] = {EnterLit[[atom[pName: name]]]};

  AtomIndex: PUBLIC PROC [name: Name] RETURNS [RTBcd.RefLitIndex] = {
    RETURN [LitIndex[[atom[pName: name]]]]};

  AtomRef: PUBLIC PROC [name: Name] RETURNS [Tree.Link] = {
    RETURN [IndexedRef[litMapId, AtomIndex[name], dataPtr.typeATOM]]};


  EnterText: PUBLIC PROC [sti: Literals.STIndex] = {EnterLit[[text[value: sti]]]};

  TextIndex: PUBLIC PROC [sti: Literals.STIndex] RETURNS [RTBcd.RefLitIndex] = {
    RETURN [LitIndex[[text[value: sti]]]]};

  TextRef: PUBLIC PROC [sti: Literals.STIndex] RETURNS [Tree.Link] = {
    RETURN [IndexedRef[litMapId, TextIndex[sti], dataPtr.typeRefANY]]};


  DescribeRefLits: PUBLIC PROC RETURNS [offset, length: CARDINAL] = {
    RETURN [offset: WordOffset[litMapId], length: nLits]};

  EnumerateRefLits: PUBLIC PROC [scan: PROC [RefLitItem]] = {
    i: CARDINAL _ 0;
    FOR sli: SymLitIndex _ firstLit, sli+SIZE[SymLitRecord] WHILE i < nLits DO
      WITH s: slb[sli] SELECT FROM
	lit => scan[s.info];
	ENDCASE;
      i _ i + 1;
      ENDLOOP};


  PadRefLits: PROC = INLINE {NULL};	-- for now
	
  
 -- state transitions

  Initialize: PUBLIC PROC [ownTable: Alloc.Handle] = {
    table _ ownTable; table.AddNotify[UpdateBases];
    nLits _ nLitRefs _ 0;  nTypes _ nTypeRefs _ 0;
    typeMapId _ litMapId _ ISENull};

  Reset: PUBLIC PROC = {
    PadTypes[];  PadRefLits[];
    IF nLits # 0 AND ~dataPtr.interface THEN
      litMapId _ CreateMap["&refs"L, dataPtr.typeRefANY, nLits, nLitRefs];
    firstLit _ FIRST[SymLitIndex];
    IF nTypes # 0 THEN {
      slLimit: SymLitIndex = table.Top[atType];
      lastType: SymLitIndex;
      t: SymLitRecord;
      lastType _ slLimit - SIZE[SymLitRecord];
      DO
	UNTIL firstLit = slLimit OR slb[firstLit].tag = lit DO
	  firstLit _ firstLit + SIZE[SymLitRecord] ENDLOOP;
	UNTIL slb[lastType].tag = type DO
	  lastType _ lastType - SIZE[SymLitRecord] ENDLOOP;
	IF lastType < firstLit THEN EXIT;
	t _ slb[firstLit];  slb[firstLit] _ slb[lastType];  slb[lastType] _ t;
	ENDLOOP;
      IF ~dataPtr.interface
        THEN typeMapId _ CreateMap["&types"L, typeANY, nTypes, nTypeRefs]}};

  Finalize: PUBLIC PROC = {table.DropNotify[UpdateBases]; table _ NIL};


 -- utility routines

  CreateMap: PROC [id: Strings.String, cType: Type, nEntries, nRefs: CARDINAL]
      RETURNS [sei: ISEIndex] = {
    desc: Strings.SubStringDescriptor _ [base:id, offset:0, length:id.length];
    mapType, iType: CSEIndex;
    sei _ SymbolOps.MakeCtxSe[SymbolOps.EnterString[@desc], dataPtr.mainCtx];
    iType _ SymbolOps.MakeNonCtxSe[SIZE[subrange cons SERecord]];
    seb[iType].typeInfo _ subrange[
		filled: TRUE, empty: FALSE,
		rangeType: dataPtr.idINTEGER,
		origin: 0, range: nEntries-1];
    seb[iType].mark3 _ seb[iType].mark4 _ TRUE;
    mapType _ SymbolOps.MakeNonCtxSe[SIZE[array cons SERecord]];
    seb[mapType].typeInfo _ array[packed: FALSE, indexType: iType, componentType: cType];
    seb[mapType].mark3 _ seb[mapType].mark4 _ TRUE;
    seb[sei].idType _ mapType;
    seb[sei].public _ seb[sei].extended _ seb[sei].constant _ seb[sei].linkSpace _ FALSE;
    seb[sei].immutable _ TRUE;
    seb[sei].idValue _ Tree.NullIndex;  seb[sei].idInfo _ nRefs;
    seb[sei].mark3 _ seb[sei].mark4 _ TRUE;
    RETURN};

  WordOffset: PROC [sei: ISEIndex] RETURNS [offset: CARDINAL] = {
    IF sei = ISENull THEN offset _ 0
    ELSE {
      addr: BitAddress = seb[sei].idValue;
      offset _ addr.wd};
    RETURN};
    
  IndexedRef: PROC [array: ISEIndex, item: CARDINAL, type: CSEIndex] RETURNS [Tree.Link] = {
    OPEN TreeOps;
    PushSe[array];  PushLit[LiteralOps.Find[item]];  PushNode[index, 2];
    SetAttr[2, FALSE];  SetInfo[type];
    RETURN [PopTree[]]};

  }.