-- file StringCompactor.mesa
-- last edited by Satterthwaite, January 24, 1980  2:09 PM
  
DIRECTORY
  AltoDefs: FROM "altodefs" USING [CharsPerWord],
  CharIO: FROM "chario"
    USING [CR, NUL, NumberFormat, PutChar, PutNumber, PutString],
  PGScondefs: FROM "PGScondefs" USING [FixupBcdHeader],
  StreamDefs: FROM "streamdefs"
    USING [
      StreamHandle, StreamIndex, Read, Write, Append,
      GetIndex, ModifyIndex, NewByteStream, SetIndex],
  StringDefs: FROM "stringdefs" USING [WordsForString],
  SystemDefs: FROM "systemdefs" USING [AllocateHeapNode, FreeHeapNode],
  TableCommand: FROM "tablecommand" USING [CreateBCDStream];
  
StringCompactor: PROGRAM
    IMPORTS
      CharIO, PGScondefs, StreamDefs, StringDefs, SystemDefs, TableCommand
    EXPORTS TableCommand =
  BEGIN OPEN StreamDefs;
  
  CharsPerWord: CARDINAL = AltoDefs.CharsPerWord;

  CompStrDesc: TYPE = RECORD [offset, length: CARDINAL];
  
  nArrays: CARDINAL;
  nStrings: CARDINAL;
  nChars: CARDINAL;
  nWords: CARDINAL;
  
  in: StreamHandle;
  
  SLptr: TYPE = POINTER TO SL;
  
  SL: TYPE = RECORD [
    link: SLptr,
    startIndex: StreamIndex,
    length: CARDINAL];
  
  ALptr: TYPE = POINTER TO AL;
  
  AL: TYPE = RECORD [
    link: ALptr,
    name: NL,
    ARRAYindex: StreamIndex,
    needsIndexDef: BOOLEAN,
    headSL, tailSL: SLptr,
    nstrings: CARDINAL];
  
  NL: TYPE = RECORD [startIndex: StreamIndex, length: CARDINAL];
  
  BackUp: PROC [s: StreamHandle] =
    {SetIndex[s, ModifyIndex[GetIndex[s], -1]]};
  
  NextString: PROC [s: SLptr] RETURNS [BOOLEAN] =
    BEGIN
    c: CHARACTER;
    nc: CARDINAL _ 0;
    quoteFound, collectingChars: BOOLEAN _ FALSE;
      DO
      IF in.endof[in] THEN SIGNAL SyntaxError;
      c _ in.get[in];
      IF c = '; AND ~collectingChars THEN RETURN [FALSE];
      IF c = '" THEN
	IF quoteFound THEN
	  IF collectingChars THEN {quoteFound _ FALSE; nc _ nc+1} ELSE ERROR
	ELSE
	  IF collectingChars THEN quoteFound _ TRUE
	  ELSE {s.startIndex _ GetIndex[in]; collectingChars _ TRUE}
      ELSE
	IF quoteFound
	  THEN  {s.length _ nc; BackUp[in]; EXIT}
	  ELSE IF collectingChars THEN nc _ nc+1;
      ENDLOOP;
    nStrings _ nStrings+1;
    nChars _ nChars + nc;  nWords _ nWords + StringDefs.WordsForString[nc];
    RETURN [TRUE]
    END;
  
  lastCR: StreamIndex;
  
  AllDone: SIGNAL = CODE;
  SyntaxError: SIGNAL = CODE;
  
  NextItem: PROC [a: ALptr] =
    BEGIN
    c: CHARACTER;
    nc: CARDINAL;
    state: {start, aRray, arRay, arrAy, arraY,
	    sTring, stRing, strIng, striNg, strinG, Of, oF, end};
    array: BOOLEAN;
    state _ start;  nc _ 0;
  
    DO
    IF in.endof[in] THEN SIGNAL AllDone;
    c _ in.get[in];  nc _ nc+1;
    SELECT c FROM
      'A =>
	state _ SELECT state FROM
  		  start => aRray,
		  arrAy => arraY,
		  stRing => strIng,
		  ENDCASE => start;
      'R => 
	state _ SELECT state FROM
		  aRray => arRay,
		  arRay => arrAy,
		  stRing => strIng,
		  ENDCASE => start;
      'Y =>
	IF state = arraY
	  THEN {array _ TRUE; a.ARRAYindex _ GetIndex[in]; state _ end}
	  ELSE state _ start;
      'S =>
	IF state = start
	  THEN {a.name.length _ nc-1;  state _ sTring}
	  ELSE state _ start;
      'T =>  state _ IF state = sTring THEN stRing ELSE start;
      'I =>  state _ IF state = strIng THEN striNg ELSE start;
      'N =>  state _ IF state = striNg THEN strinG ELSE start;
      'G =>
	IF state = strinG
	  THEN {array _ FALSE; state _ end}
	  ELSE state _ start;
      CharIO.CR =>
	BEGIN
	IF state = end THEN EXIT;
	lastCR _ GetIndex[in];  nc _ 0;  state _ start;
	END;
      IN [0C..' ] => IF state = end THEN EXIT ELSE state _ start;
      ENDCASE => state _ start;
    ENDLOOP;

    a.name.startIndex _ lastCR;
    a.needsIndexDef _ array;
    IF array THEN
      BEGIN
      state _ Of;
        DO
        IF in.endof[in] THEN SIGNAL SyntaxError;
        c _ in.get[in];  nc _ nc+1;
        SELECT c FROM
          IN [0C..' ] =>
            SELECT state FROM
              start => state _ Of;
              Of => NULL;
              end => EXIT;
              ENDCASE => state _ start;
          'O =>  state _ IF state = Of THEN oF ELSE start;
          'F =>  state _ IF state = oF THEN end ELSE start;
          ENDCASE =>  {a.needsIndexDef _ FALSE; state _ start};
        ENDLOOP;
      a.name.length _ nc;
      END;
    CollectStrings[a];
    IF array THEN nArrays _ nArrays + 1;
    END;
  
  headAL, tailAL: ALptr;
  
  CollectStrings: PROC [a: ALptr] = 
    BEGIN
    s: SLptr;
    oldnStrings: CARDINAL = nStrings;
    a.headSL _ a.tailSL _ NIL;
    WHILE NextString[s _ AllocateSL[]] DO  AppendSL[a, s]  ENDLOOP;
    SystemDefs.FreeHeapNode[s];
    a.nstrings _ nStrings - oldnStrings;
    END;
  
  
  CollectArrays: PROC = 
    BEGIN
    a: ALptr;
    headAL _ tailAL _ NIL;
    nArrays _ nStrings _ nChars _ nWords _ 0;
    lastCR _ StreamIndex[0,0];
      DO
      NextItem[a _ AllocateAL[] !
        AllDone => {SystemDefs.FreeHeapNode[a]; EXIT}];
      AppendAL[a];
      ENDLOOP;
    END;
  
  
  AllocateSL: PROC RETURNS [s: SLptr] =
    {s _ SystemDefs.AllocateHeapNode[SIZE[SL]]; s.link _ NIL; RETURN};
  
  AppendSL: PROC [a: ALptr, s: SLptr] =
    BEGIN
    IF a.tailSL = NIL THEN a.headSL _ s ELSE a.tailSL.link _ s;
    a.tailSL _ s;
    END;
  
  
  AllocateAL: PROC RETURNS [a: ALptr] =
    {a _ SystemDefs.AllocateHeapNode[SIZE[AL]]; a.link _ NIL; RETURN};
  
  AppendAL: PROC [a: ALptr] =
    BEGIN
    IF tailAL = NIL THEN headAL _ a ELSE tailAL.link _ a;
    tailAL _ a;
    END;
  
  
  OutStrings: PROC [out: StreamHandle, compact: BOOLEAN] =
    BEGIN
    a: ALptr;
    s, nexts: SLptr;
    charpos: CARDINAL;
    i: CARDINAL;
    c: CHARACTER;

    buffer: PACKED ARRAY [0..CharsPerWord) OF CHARACTER;
    byte: [0 .. CharsPerWord];
  
    FlushBuffer: PROC = {UNTIL byte = 0 DO PutChar[CharIO.NUL] ENDLOOP};
  
    PutChar: PROC [c: CHARACTER] =
      BEGIN
      buffer[byte] _ c;
      IF (byte _ byte+1) = CharsPerWord THEN {out.put[out, buffer]; byte _ 0};
      END;
  
    IF compact
      THEN  {out.put[out, nStrings*SIZE[CompStrDesc]+1]; charpos _ 0}
      ELSE  {out.put[out, nStrings]; charpos _ (nStrings+1)*CharsPerWord};
    FOR a _ headAL, a.link UNTIL a = NIL
      DO
      FOR s _ a.headSL, s.link UNTIL s = NIL
	DO
        IF compact
	  THEN
	    BEGIN
	    out.put[out, charpos];   out.put[out, s.length];
	    charpos _ charpos + s.length;
	    END
	  ELSE
	    BEGIN
	    out.put[out, charpos/CharsPerWord];
	    charpos _
	      charpos + StringDefs.WordsForString[s.length]*CharsPerWord;
	    END;
        ENDLOOP;
      ENDLOOP;
    IF compact THEN {out.put[out, nChars]; out.put[out, nChars]};
    byte _ 0;
    FOR a _ headAL, a.link UNTIL a = NIL
      DO
      s _ a.headSL;
      FOR s _ a.headSL, nexts UNTIL s = NIL
	DO
	IF ~compact THEN {out.put[out, s.length]; out.put[out, s.length]};
        SetIndex[in, s.startIndex];
	FOR i IN [0 .. s.length)
	  DO
	  c _ in.get[in];  PutChar[IF c # '" THEN c ELSE in.get[in]];
	  ENDLOOP;
	IF ~compact THEN FlushBuffer[];
        nexts _ s.link;
        SystemDefs.FreeHeapNode[s];
        ENDLOOP;
      ENDLOOP;
    FlushBuffer[];
    END;
  
  OutRecordDecl: PROC [
      out: StreamHandle, formatId: STRING, compact: BOOLEAN] =
    BEGIN OPEN CharIO;
    a, nexta: ALptr;
    c: CHARACTER;
    nonBlank: BOOLEAN;
    i: CARDINAL;
  
    FOR i IN [0..formatId.length)
      DO
      IF formatId[i] = '. THEN EXIT; PutChar[out, formatId[i]];
      ENDLOOP;
    PutString[out, ": DEFINITIONS =
  BEGIN
  
  CSRptr: TYPE = BASE POINTER TO CompStrRecord;"L];
    PutString[out, IF compact THEN "
  CompStrDesc: TYPE = RECORD [offset, length: CARDINAL];
  
  CompStrRecord: TYPE = RECORD [
    stringOffset: CSRptr RELATIVE POINTER TO StringBody,
"L
    ELSE "
  StringOffset: TYPE = CSRptr RELATIVE POINTER TO StringBody;
  
  StringRecord: TYPE = RECORD [
    nStrings: CARDINAL,
"L];
    a _ headAL;
      DO
      SetIndex[in, a.name.startIndex];
      PutString[out, "    "L];  nonBlank _ FALSE;
      FOR i IN [0..a.name.length)
	DO
        IF a.needsIndexDef AND GetIndex[in] = a.ARRAYindex THEN
  	  BEGIN
  	  PutString[out, " [0.."L];
  	  PutNumber[out, a.nstrings, NumberFormat[10,FALSE,FALSE,0]];
  	  PutChar[out, ')];
  	  END;
        c _ in.get[in];
	IF nonBlank OR c # '  THEN {PutChar[out, c]; nonBlank _ TRUE};
        ENDLOOP;
      PutString[out, IF compact THEN "CompStrDesc"L ELSE "StringOffset"L];
      nexta _ a.link;
      SystemDefs.FreeHeapNode[a];
      IF (a _ nexta) = NIL THEN EXIT;
      PutChar[out, ',];  PutChar[out, CharIO.CR];
      ENDLOOP;
    PutString[out, "];

  END.
"L];
    END;
  
  
  CompileStrings: PUBLIC PROC [
	inputFile: STRING,		-- the source file
	interfaceId: STRING,		-- exported interface or "SELF"
	formatId: STRING,		-- ASCII record declaration
	moduleId: STRING,		-- output file
	compact, altoCode: BOOLEAN]
      RETURNS [CARDINAL, CARDINAL] =
    BEGIN
    sStream, rStream: StreamHandle;
    in _ NewByteStream[inputFile, Read];
    CollectArrays[];
    sStream _ TableCommand.CreateBCDStream[
	in: in, modId: moduleId,
	count: 1 + nStrings*(IF compact THEN SIZE[CompStrDesc] ELSE 1) +
	      (IF compact THEN StringDefs.WordsForString[nChars] ELSE nWords),
	interfaceId: interfaceId,
	altoCode: altoCode];
    OutStrings[sStream, compact];
    PGScondefs.FixupBcdHeader[]; sStream.destroy[sStream];
    rStream _ NewByteStream[formatId, Write+Append];
    OutRecordDecl[rStream, formatId, compact];  rStream.destroy[rStream];
    in.destroy[in];
    RETURN [nStrings, nChars];
    END;

  END.