-- file StringCompactor.mesa
-- last edited by Satterthwaite, November 2, 1982 11:51 am
  
DIRECTORY
  CharIO: TYPE USING [NumberFormat, PutChar, PutNumber, PutString],
  Environment: TYPE USING [charsPerWord],
  FileStream: TYPE USING [FileByteIndex, Create, EndOf, GetIndex, SetIndex],
  LongStorage: TYPE USING [Node, Free],
  OSMiscOps: TYPE USING [FindFile],
  Stream: TYPE USING [Handle, Delete, GetChar, PutChar, PutWord],
  Strings: TYPE USING [String, AppendString],
  TableCommand: TYPE USING [CreateBCDStream, FinishBcdStream];
  
StringCompactor: PROGRAM
    IMPORTS
      CharIO, FileStream, OSMiscOps, Storage: LongStorage,
      Stream, Strings, TableCommand
    EXPORTS TableCommand = {
  
  charsPerWord: CARDINAL = Environment.charsPerWord;
  StreamIndex: TYPE = FileStream.FileByteIndex;

  SyntaxError: ERROR = CODE;

  CompStrDesc: TYPE = RECORD [offset, length: CARDINAL];
  
  nArrays: CARDINAL;
  nStrings: CARDINAL;
  nChars: CARDINAL;
  nWords: CARDINAL;
  
  in: Stream.Handle;
  
  SLptr: TYPE = LONG POINTER TO SL;
  
  SL: TYPE = RECORD [
    link: SLptr,
    startIndex: StreamIndex,
    length: CARDINAL];
  
  ALptr: TYPE = LONG POINTER TO AL;
  
  AL: TYPE = RECORD [
    link: ALptr,
    name: NL,
    ARRAYindex: StreamIndex,
    needsIndexDef: BOOL,
    headSL, tailSL: SLptr,
    nstrings: CARDINAL];
  
  NL: TYPE = RECORD [startIndex: StreamIndex, length: CARDINAL];
  
  BackUp: PROC [s: Stream.Handle] = {
    FileStream.SetIndex[s, FileStream.GetIndex[s] - 1]};
  
  NextString: PROC [s: SLptr] RETURNS [found: BOOL _ TRUE] = {
    nc: CARDINAL _ 0;
    quoteFound, collectingChars: BOOL _ FALSE;
    DO
      c: CHAR;
      IF FileStream.EndOf[in] THEN ERROR SyntaxError;
      c _ in.GetChar[];
      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 _ FileStream.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 + StringBody[nc].SIZE};
  
  lastCR: StreamIndex;
  
  AllDone: ERROR = CODE;
  
  NextItem: PROC [a: ALptr] = {
    nc: CARDINAL _ 0;
    state: {
      start, aRray, arRay, arrAy, arraY,
      sTring, stRing, strIng, striNg, strinG, Of, oF, end} _ $start;
    array: BOOL;
  
    DO
      c: CHAR;
      IF FileStream.EndOf[in] THEN ERROR AllDone;
      c _ in.GetChar[];  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 _ FileStream.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;
	'\n => {
	  IF state = $end THEN EXIT;
	  lastCR _ FileStream.GetIndex[in];  nc _ 0;  state _ $start};
	IN ['\000..' ] => IF state = $end THEN EXIT ELSE state _ $start;
	ENDCASE => state _ $start;
      ENDLOOP;
    a.name.startIndex _ lastCR;  a.needsIndexDef _ array;
    IF array THEN {
      state _ $Of;
      DO
	c: CHAR;
	IF FileStream.EndOf[in] THEN ERROR SyntaxError;
	c _ in.GetChar[];  nc _ nc+1;
	SELECT c FROM
	  IN ['\000..' ] =>
	    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};
    CollectStrings[a];
    IF array THEN nArrays _ nArrays + 1};
  
  headAL, tailAL: ALptr;
  
  CollectStrings: PROC [a: ALptr] = { 
    s: SLptr;
    oldnStrings: CARDINAL = nStrings;
    a.headSL _ a.tailSL _ NIL;
    WHILE NextString[s _ AllocateSL[]] DO AppendSL[a, s] ENDLOOP;
    Storage.Free[s];
    a.nstrings _ nStrings - oldnStrings};
  
  
  CollectArrays: PROC = {
    a: ALptr;
    headAL _ tailAL _ NIL;
    nArrays _ nStrings _ nChars _ nWords _ 0;
    lastCR _ 0;
    DO
      NextItem[a _ AllocateAL[] ! AllDone => {Storage.Free[a]; EXIT}];
      AppendAL[a];
      ENDLOOP};
  
  
  AllocateSL: PROC RETURNS [s: SLptr] = {
    s _ Storage.Node[SL.SIZE]; s.link _ NIL; RETURN};
  
  AppendSL: PROC [a: ALptr, s: SLptr] = {
    IF a.tailSL = NIL THEN a.headSL _ s ELSE a.tailSL.link _ s;
    a.tailSL _ s};
  
  
  AllocateAL: PROC RETURNS [a: ALptr] = {
    a _ Storage.Node[AL.SIZE]; a.link _ NIL; RETURN};
  
  AppendAL: PROC [a: ALptr] = {
    IF tailAL = NIL THEN headAL _ a ELSE tailAL.link _ a;
    tailAL _ a};
  
  
  OutStrings: PROC [out: Stream.Handle, compact: BOOL] = {
    charPos: CARDINAL;
    buffer: PACKED ARRAY [0..charsPerWord) OF CHAR;
    byte: [0 .. charsPerWord] _ 0;
  
    FlushBuffer: PROC = {UNTIL byte = 0 DO PutChar['\000] ENDLOOP};
  
    PutChar: PROC [c: CHAR] = {
      buffer[byte] _ c;
      IF (byte _ byte+1) = charsPerWord THEN {
	FOR i: [0..charsPerWord) IN [0..charsPerWord) DO
	  out.PutChar[buffer[i]] ENDLOOP;
	byte _ 0}};
  
    IF compact THEN {out.PutWord[nStrings*CompStrDesc.SIZE+1]; charPos _ 0}
    ELSE {out.PutWord[nStrings]; charPos _ (nStrings+1)*charsPerWord};
    FOR a: ALptr _ headAL, a.link UNTIL a = NIL DO
      FOR s: SLptr _ a.headSL, s.link UNTIL s = NIL DO
        IF compact THEN {
	  out.PutWord[charPos]; out.PutWord[s.length];
	  charPos _ charPos + s.length}
	ELSE {
	  out.PutWord[charPos/charsPerWord];
	  charPos _ charPos + StringBody[s.length].SIZE*charsPerWord};
        ENDLOOP;
      ENDLOOP;
    IF compact THEN {out.PutWord[nChars]; out.PutWord[nChars]};
    FOR a: ALptr _ headAL, a.link UNTIL a = NIL DO
      s: SLptr _ a.headSL;
      UNTIL s = NIL
	DO
	nextS: SLptr = s.link;
	IF ~compact THEN {out.PutWord[s.length]; out.PutWord[s.length]};
        FileStream.SetIndex[in, s.startIndex];
	FOR i: CARDINAL IN [0 .. s.length) DO
	  c: CHAR = in.GetChar[];
	  PutChar[IF c # '" THEN c ELSE in.GetChar[]];
	  ENDLOOP;
	IF ~compact THEN FlushBuffer[];
        Storage.Free[s];  s _ nextS;
        ENDLOOP;
      ENDLOOP;
    FlushBuffer[]};
  
  OutRecordDecl: PROC [
      out: Stream.Handle, formatId: Strings.String, compact, altoCode: BOOL] = {
    OPEN CharIO;
    a: ALptr _ headAL;
    FOR i: CARDINAL IN [0..formatId.length) DO
      IF formatId[i] = '. THEN EXIT; PutChar[out, formatId[i]];
      ENDLOOP;
    PutString[out, ": DEFINITIONS = {
  
  CSRptr: TYPE = "L];
    IF ~altoCode THEN PutString[out, "LONG "L];
    PutString[out, "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,\n"L
    ELSE "
  StringOffset: TYPE = CSRptr RELATIVE POINTER TO StringBody;
  
  StringRecord: TYPE = RECORD [
    nStrings: CARDINAL,\n"L];
    a _ headAL;
    DO
      nextA: ALptr = a.link;
      nonBlank: BOOL _ FALSE;
      FileStream.SetIndex[in, a.name.startIndex];
      PutString[out, "    "L];
      FOR i: CARDINAL IN [0..a.name.length) DO
        c: CHAR;
        IF a.needsIndexDef AND FileStream.GetIndex[in] = a.ARRAYindex THEN {
	  PutString[out, " [0.."L];
	  PutNumber[out, a.nstrings, NumberFormat[10,FALSE,FALSE,0]];
	  PutChar[out, ')]};
        c _ in.GetChar[];
	IF nonBlank OR c # '  THEN {PutChar[out, c]; nonBlank _ TRUE};
        ENDLOOP;
      PutString[out, IF compact THEN "CompStrDesc"L ELSE "StringOffset"L];
      Storage.Free[a];
      IF (a _ nextA) = NIL THEN EXIT;
      PutChar[out, ',];  PutChar[out, '\n];
      ENDLOOP;
    PutString[out, "];\n\n  }.\n"L]};
  
  
  CompileStrings: PUBLIC PROC [
	inputFile: Strings.String,		-- the source file
	interfaceId: Strings.String,		-- exported interface or "SELF"
	formatId: Strings.String,		-- ASCII record declaration
	moduleId: Strings.String,		-- output file
	compact, altoCode: BOOL]
      RETURNS [CARDINAL, CARDINAL] = {
    t: STRING = [40];
    sStream, rStream: Stream.Handle;
    t.length _ 0;  Strings.AppendString[t, inputFile];
    in _ FileStream.Create[OSMiscOps.FindFile[t, read]];
    CollectArrays[];
    sStream _ TableCommand.CreateBCDStream[
	in: in, modId: moduleId,
	interfaceId: interfaceId,
	altoCode: altoCode];
    OutStrings[sStream, compact];
    TableCommand.FinishBcdStream[]; Stream.Delete[sStream];
    t.length _ 0;  Strings.AppendString[t, formatId];
    rStream _ FileStream.Create[OSMiscOps.FindFile[t, write]];
    OutRecordDecl[rStream, formatId, compact, altoCode];  Stream.Delete[rStream];
    Stream.Delete[in];
    RETURN [nStrings, nChars]};

  }.