
    <<StringCompactor.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Satterthwaite, November 2, 1982 11:51 am>>
        <<Maxwell, August 10, 1983 1:03 pm>>
        <<Doug Wyatt, April 2, 1984 2:30:44 pm PST>>
        <<Russ Atkinson (RRA) March 19, 1985 10:05:56 am PST>>

    DIRECTORY
        Basics USING [bytesPerWord, charsPerWord],
        FS USING [StreamOpen],
        IO USING [card, char, Close, EndOf, GetChar, GetIndex, Put, PutChar, PutRope, rope, SetIndex, STREAM, UnsafePutBlock],
        Rope USING [Fetch, Length, ROPE],
        TableCommand USING [CreateBCDStream, FinishBcdStream];

    StringCompactor: PROGRAM
        IMPORTS FS, IO, Rope, TableCommand
        EXPORTS TableCommand = {

        charsPerWord: CARDINAL = Basics.charsPerWord;
        StreamIndex: TYPE = INT; -- FileStream.FileByteIndex

        SyntaxError: ERROR = CODE;

        CompStrDesc: TYPE = RECORD [offset, length: CARDINAL];

        nArrays: CARDINAL;
        nStrings: CARDINAL;
        nChars: CARDINAL;
        nWords: CARDINAL;

        in: IO.STREAM;

        SLptr: TYPE = REF SL;

        SL: TYPE = RECORD [
            link: SLptr _ NIL,
            startIndex: StreamIndex _ 0,
            length: CARDINAL _ 0];

        ALptr: TYPE = REF AL;

        AL: TYPE = RECORD [
            link: ALptr _ NIL,
            name: NL _ [0, 0],
            ARRAYindex: StreamIndex _ 0,
            needsIndexDef: BOOL _ FALSE,
            headSL, tailSL: SLptr _ NIL,
            nstrings: CARDINAL _ 0];

        NL: TYPE = RECORD [startIndex: StreamIndex, length: CARDINAL];

        BackUp: PROC [s: IO.STREAM] = {
            IO.SetIndex[s, IO.GetIndex[s] - 1]};

        NextString: PROC [s: SLptr] RETURNS [found: BOOL _ TRUE] = {
            nc: CARDINAL _ 0;
            quoteFound, collectingChars: BOOL _ FALSE;
            DO
                c: CHAR;
                IF IO.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 _ IO.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 in.EndOf[] 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 _ IO.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 _ IO.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 IO.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 _ NEW[SL]] DO AppendSL[a, s] ENDLOOP;
            a.nstrings _ nStrings - oldnStrings};


        CollectArrays: PROC = {
            a: ALptr;
            headAL _ tailAL _ NIL;
            nArrays _ nStrings _ nChars _ nWords _ 0;
            lastCR _ 0;
            DO
                NextItem[a _ NEW[AL] ! AllDone => {EXIT}];
                AppendAL[a];
                ENDLOOP};


        AppendSL: PROC [a: ALptr, s: SLptr] = {
            IF a.tailSL = NIL THEN a.headSL _ s ELSE a.tailSL.link _ s;
            a.tailSL _ s};

        AppendAL: PROC [a: ALptr] = {
            IF tailAL = NIL THEN headAL _ a ELSE tailAL.link _ a;
            tailAL _ a};


        OutStrings: PROC [out: IO.STREAM, 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}};

            PutWord: PROC [stream: IO.STREAM, word: WORD] = {
                base: LONG POINTER ~ @word;
                stream.UnsafePutBlock[[base: base, count: Basics.bytesPerWord]]
                };

            IF compact THEN {PutWord[out, nStrings*CompStrDesc.SIZE+1]; charPos _ 0}
            ELSE {PutWord[out, 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 {
                        PutWord[out, charPos]; PutWord[out, s.length];
                        charPos _ charPos + s.length}
                    ELSE {
                        PutWord[out, charPos/charsPerWord];
                        charPos _ charPos + StringBody[s.length].SIZE*charsPerWord};
                    ENDLOOP;
                ENDLOOP;
            IF compact THEN {PutWord[out, nChars]; PutWord[out, 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 {PutWord[out, s.length]; PutWord[out, s.length]};
                    IO.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[];
                    s _ nextS;
                    ENDLOOP;
                ENDLOOP;
            FlushBuffer[]};

        OutRecordDecl: PROC [
            out: IO.STREAM, formatId: Rope.ROPE, compact, altoCode: BOOL] = {
            OPEN IO;
            a: ALptr _ headAL;
            FOR i: INT IN [0..formatId.Length[]) DO
                char: CHAR = formatId.Fetch[i];
                IF char = '. THEN EXIT; out.PutChar[char];
                ENDLOOP;
            out.PutRope[": DEFINITIONS = {

        CSRptr: TYPE = "];
            IF ~altoCode THEN out.PutRope["LONG "];
            out.PutRope["BASE POINTER TO CompStrRecord;"];
            out.PutRope[IF compact THEN "
        CompStrDesc: TYPE = RECORD [offset, length: CARDINAL];

        CompStrRecord: TYPE = RECORD [
            stringOffset: CSRptr RELATIVE POINTER TO StringBody,\n"
            ELSE "
        StringOffset: TYPE = CSRptr RELATIVE POINTER TO StringBody;

        StringRecord: TYPE = RECORD [
            nStrings: CARDINAL,\n"];
            a _ headAL;
            DO
                nextA: ALptr = a.link;
                nonBlank: BOOL _ FALSE;
                IO.SetIndex[in, a.name.startIndex];
                out.PutRope["    "];
                FOR i: CARDINAL IN [0..a.name.length) DO
                    c: CHAR;
                    IF a.needsIndexDef AND IO.GetIndex[in] = a.ARRAYindex 
                        THEN out.Put[IO.rope[" [0.."], IO.card[a.nstrings], IO.char[')]];
                    c _ in.GetChar[];
                    IF nonBlank OR c # '  THEN {out.PutChar[c]; nonBlank _ TRUE};
                    ENDLOOP;
                out.PutRope[IF compact THEN "CompStrDesc" ELSE "StringOffset"];
                IF (a _ nextA) = NIL THEN EXIT;
                out.PutChar[',];  out.PutChar['\n];
                ENDLOOP;
            out.PutRope["];\n\n  }.\n"]};


        CompileStrings: PUBLIC PROC [
            inputFile: Rope.ROPE,        -- the source file
            interfaceId: Rope.ROPE,        -- exported interface or "SELF"
            formatId: Rope.ROPE,        -- ASCII record declaration
            moduleId: Rope.ROPE,        -- output file
            compact, altoCode: BOOL]
            RETURNS [CARDINAL, CARDINAL] = {
            sStream, rStream: IO.STREAM;
            in _ FS.StreamOpen[inputFile, $read];
            CollectArrays[];
            sStream _ TableCommand.CreateBCDStream[
                in: in, modId: moduleId,
                interfaceId: interfaceId,
                altoCode: altoCode];
            OutStrings[sStream, compact];
            TableCommand.FinishBcdStream[]; IO.Close[sStream];
            rStream _ FS.StreamOpen[formatId, $create];
            OutRecordDecl[rStream, formatId, compact, altoCode]; IO.Close[rStream];
            IO.Close[in];
            RETURN [nStrings, nChars]
            };

        }.