
    <<IPMasterImpl.mesa>>
        <<Copyright © 1984, 1985, 1986 by Xerox Corporation.  All rights reserved.>>
        <<Michael Plass, October 31, 1985 4:35:14 pm PST>>
        <<Doug Wyatt, June 7, 1986 2:04:14 pm PDT>>

    DIRECTORY
        Basics USING [BYTE, CARD, HighHalf, LongNumber, LowHalf, NonNegative],
        Convert USING [IntFromRope],
        IO USING [EndOfStream, GetBlock, GetChar, GetIndex, PutBlock, PutChar, PutFR1, rope, SetIndex, STREAM],
        IPMaster USING [Block, BlockRep, Body, BodyRep, ByteCount, EncodingValue, ErrorDesc, ImagerVariable, LongSequenceLength, MaxLen, 
        MaxTextLen, Node, NodeRep, Op, PartActionType, SequenceType, ShortEncodingValue, ShortNumber, ShortSequenceLength, 
        Skeleton, SkeletonRep, Token, Version],
        IPReal USING [Rational, RationalFromReal],
        Real USING [NumberType, RealToPair, RoundLI],
        RefText USING [AppendChar, ObtainScratch, ReleaseScratch],
        Rope USING [ActionType, FromRefText, Length, Map, ROPE, Substr],
        SymTab USING [Create, Fetch, Ref, Store];

    IPMasterImpl: CEDAR PROGRAM
    IMPORTS Basics, Convert, IO, IPReal, Real, RefText, Rope, SymTab
    EXPORTS IPMaster
    ~ BEGIN OPEN IPMaster;

    BYTE: TYPE ~ Basics.BYTE;
    CARD: TYPE ~ Basics.CARD;
    ROPE: TYPE ~ Rope.ROPE;
    STREAM: TYPE ~ IO.STREAM;

    Error: PUBLIC ERROR [error: ErrorDesc] ~ CODE;

    EvFromOp: TYPE ~ REF READONLY EvFromOpArray;
    EvFromOpArray: TYPE ~ PACKED ARRAY Op OF EncodingValue;

    encodingValueFromOp: EvFromOp ~ NEW[EvFromOpArray = [
        nil: nil,
        get: get, makeveclu: makeveclu, makevec: makevec, shape: shape,
        getprop: getprop, getp: getp, mergeprop: mergeprop, 
        fget: fget, fset: fset, makesimpleco: makesimpleco, findoperator: findoperator, 
        do: do, dosave: dosave, dosaveall: dosaveall, dosavesimplebody: dosavesimplebody, 
        pop: pop, copy: copy, dup: dup, roll: roll, exch: exch,
        mark: mark, unmark: unmark, unmark0: unmark0,
        count: count, nop: nop, error: error,
        if: if, ifelse: ifelse, ifcopy: ifcopy, 
        eq: eq, gt: gt, ge: ge, and: and, or: or, not: not, type: type,
        add: add, sub: sub, neg: neg, abs: abs,
        floor: floor, ceiling: ceiling, trunc: trunc, round: round,
        mul: mul, div: div, mod: mod, rem: rem, 
        iget: iget, iset: iset, 
        maket: maket, translate: translate, rotate: rotate, scale: scale, scale2: scale2,
        concat: concat, concatt: concatt, move: move, trans: trans,
        setxy: setxy, setxyrel: setxyrel, setxrel: setxrel, setyrel: setyrel, getcp: getcp, 
        makepixelarray: makepixelarray, finddecompressor: finddecompressor,
        extractpixelarray: extractpixelarray, makegray: makegray, 
        findcolor: findcolor, findcoloroperator: findcoloroperator,
        findcolormodeloperator: findcolormodeloperator,
        makesampledcolor: makesampledcolor, makesampledblack: makesampledblack,
        setgray: setgray, setsampledcolor: setsampledcolor, setsampledblack: setsampledblack,
        moveto: moveto, lineto: lineto, linetox: linetox, linetoy: linetoy,
        curveto: curveto, conicto: conicto, arcto: arcto, makeoutline: makeoutline,
        makeoutlineodd: makeoutlineodd, maskfill: maskfill, 
        maskfillparity: maskfillparity, maskrectangle: maskrectangle,
        startunderline: startunderline, maskunderline: maskunderline,
        masktrapezoidx: masktrapezoidx, masktrapezoidy: masktrapezoidy,
        maskstroke: maskstroke, maskstrokeclosed: maskstrokeclosed, maskvector: maskvector, 
        maskdashedstroke: maskdashedstroke, maskpixel: maskpixel,
        clipoutline: clipoutline, cliprectangle: cliprectangle, 
        maskchar: maskchar, makefont: makefont, 
        findfont: findfont, modifyfont: modifyfont, setfont: setfont,
        show: show, showandxrel: showandxrel, showandfixedxrel: showandfixedxrel,
        correctmask: correctmask, correctspace: correctspace, correct: correct, space: space,
        setcorrectmeasure: setcorrectmeasure, setcorrecttolerance: setcorrecttolerance, 
        beginBody: beginBody, endBody: endBody, 
        beginBlock: beginBlock, endBlock: endBlock, contentInstructions: contentInstructions
        ]];

    OpFromEv: TYPE ~ REF READONLY OpFromEvArray;
    OpFromEvArray: TYPE ~ PACKED ARRAY EncodingValue OF Op;

    opFromEncodingValue: OpFromEv ~ InvertEvFromOp[encodingValueFromOp];

    InvertEvFromOp: PROC [encodingValueFromOp: EvFromOp] RETURNS [OpFromEv] ~ {
        opFromEncodingValue: REF OpFromEvArray ~ NEW[OpFromEvArray _ ALL[nil]];
        FOR op: Op IN Op DO opFromEncodingValue[encodingValueFromOp[op]] _ op ENDLOOP;
        RETURN[opFromEncodingValue];
        };

    EncodingValueFromOp: PUBLIC PROC [op: Op] RETURNS [EncodingValue] ~ {
        RETURN[encodingValueFromOp[op]];
        };

    OpFromEncodingValue: PUBLIC PROC [ev: EncodingValue] RETURNS [Op] ~ {
        RETURN[opFromEncodingValue[ev]];
        };


    NonDefaultingRope: TYPE ~ ROPE _;
    RopeFromOpArray: TYPE ~ ARRAY Op OF NonDefaultingRope;

    ropeFromOp: REF RopeFromOpArray ~ NEW[RopeFromOpArray _ [nil: NIL,
        get: "GET", makeveclu: "MAKEVECLU", makevec: "MAKEVEC", shape: "SHAPE",
        getprop: "GETPROP", getp: "GETP", mergeprop: "MERGEPROP",
        fget: "FGET", fset: "FSET", makesimpleco: "MAKESIMPLECO", findoperator: "FINDOPERATOR",
        do: "DO", dosave: "DOSAVE", dosaveall: "DOSAVEALL", 
        dosavesimplebody: "DOSAVESIMPLEBODY", 
        pop: "POP", copy: "COPY", dup: "DUP", roll: "ROLL", exch: "EXCH",
        mark: "MARK", unmark: "UNMARK", unmark0: "UNMARK0",
        count: "COUNT", nop: "NOP", error: "ERROR",
        if: "IF", ifelse: "IFELSE", ifcopy: "IFCOPY", 
        eq: "EQ", gt: "GT", ge: "GE",
        and: "AND", or: "OR", not: "NOT", type: "TYPE",
        add: "ADD", sub: "SUB", neg: "NEG", abs: "ABS",
        floor: "FLOOR", ceiling: "CEILING", trunc: "TRUNC", round: "ROUND",
        mul: "MUL", div: "DIV", mod: "MOD", rem: "REM", 
        iget: "IGET", iset: "ISET", maket: "MAKET", 
        translate: "TRANSLATE", rotate: "ROTATE", scale: "SCALE", scale2: "SCALE2",
        concat: "CONCAT", concatt: "CONCATT", move: "MOVE", trans: "TRANS",
        setxy: "SETXY", setxyrel: "SETXYREL", setxrel: "SETXREL", setyrel: "SETYREL",
        getcp: "GETCP", makepixelarray: "MAKEPIXELARRAY", 
        finddecompressor: "FINDDECOMPRESSOR", extractpixelarray: "EXTRACTPIXELARRAY", 
        makegray: "MAKEGRAY", setgray: "SETGRAY",
        findcolor: "FINDCOLOR", findcoloroperator: "FINDCOLOROPERATOR",
        findcolormodeloperator: "FINDCOLORMODELOPERATOR",
        makesampledcolor: "MAKESAMPLEDCOLOR", makesampledblack: "MAKESAMPLEDBLACK",
        setsampledcolor: "SETSAMPLEDCOLOR", setsampledblack: "SETSAMPLEDBLACK",
        moveto: "MOVETO", lineto: "LINETO", linetox: "LINETOX", linetoy: "LINETOY",
        curveto: "CURVETO", conicto: "CONICTO", arcto: "ARCTO", 
        makeoutline: "MAKEOUTLINE", makeoutlineodd: "MAKEOUTLINEODD", 
        maskfill: "MASKFILL", maskfillparity: "MASKFILLPARITY", 
        maskrectangle: "MASKRECTANGLE",
        startunderline: "STARTUNDERLINE", maskunderline: "MASKUNDERLINE",
        masktrapezoidx: "MASKTRAPEZOIDX", masktrapezoidy: "MASKTRAPEZOIDY",
        maskstroke: "MASKSTROKE", maskstrokeclosed: "MASKSTROKECLOSED",
        maskvector: "MASKVECTOR", maskdashedstroke: "MASKDASHEDSTROKE", 
        maskpixel: "MASKPIXEL",
        clipoutline: "CLIPOUTLINE", cliprectangle: "CLIPRECTANGLE", 
        maskchar: "MASKCHAR", makefont: "MAKEFONT", findfont: "FINDFONT", 
        modifyfont: "MODIFYFONT", setfont: "SETFONT",
        show: "SHOW", showandxrel: "SHOWANDXREL", showandfixedxrel: "SHOWANDFIXEDXREL",
        correctmask: "CORRECTMASK", correctspace: "CORRECTSPACE", space: "SPACE",
        setcorrectmeasure: "SETCORRECTMEASURE", setcorrecttolerance: "SETCORRECTTOLERANCE",
        correct: "CORRECT", 
        beginBody: "{", endBody: "}", beginBlock: "BEGIN", endBlock: "END",
        contentInstructions: "CONTENTINSTRUCTIONS"
        ]];

    opFromRope: SymTab.Ref ~ InvertRopeFromOp[ropeFromOp];

    OpFromRopeVal: TYPE ~ REF OpFromRopeValRep;
    OpFromRopeValRep: TYPE ~ RECORD[op: Op];

    InvertRopeFromOp: PROC [ropeFromOp: REF RopeFromOpArray] RETURNS [SymTab.Ref] ~ {
        opFromRope: SymTab.Ref ~ SymTab.Create[mod: ORD[Op.LAST], case: FALSE];
        FOR op: Op IN Op DO
            key: ROPE ~ ropeFromOp[op];
            val: OpFromRopeVal ~ NEW[OpFromRopeValRep _ [op: op]];
            IF NOT SymTab.Store[x: opFromRope, key: key, val: val] THEN ERROR; -- duplicate name
            ENDLOOP;
        RETURN[opFromRope];
        };

    RopeFromOp: PUBLIC PROC [op: Op] RETURNS [ROPE] ~ {
        RETURN[ropeFromOp[op]];
        };

    OpFromRope: PUBLIC PROC [rope: ROPE] RETURNS [Op] ~ {
        found: BOOL; val: REF;
        [found, val] _ SymTab.Fetch[x: opFromRope, key: rope];
        IF found THEN WITH val SELECT FROM
            val: OpFromRopeVal => RETURN[val.op];
            ENDCASE => ERROR; -- illegal value in symbol table
        RETURN[nil];
        };


    RopeFromImagerVarArray: TYPE ~ ARRAY ImagerVariable OF NonDefaultingRope;
    ropeFromImagerVar: REF RopeFromImagerVarArray ~ NEW[RopeFromImagerVarArray _ [
        DCScpx: "DCScpx", DCScpy: "DCScpy",
        correctMX: "correctMX", correctMY: "correctMY",
        T: "T", priorityImportant: "priorityImportant",
        mediumXSize: "mediumXSize", mediumYSize: "mediumYSize",
        fieldXMin: "fieldXMin", fieldYMin: "fieldYMin",
        fieldXMax: "fieldXMax", fieldYMax: "fieldYMax",
        font: "font", color: "color", noImage: "noImage",
        strokeWidth: "strokeWidth", strokeEnd: "strokeEnd",
        underlineStart: "underlineStart", amplifySpace: "amplifySpace",
        correctPass: "correctPass", correctShrink: "correctShrink",
        correctTX: "correctTX", correctTY: "correctTY",
        strokeJoint: "strokeJoint", clipper: "clipper"
        ]];

    RopeFromImagerVariable: PUBLIC PROC [var: ImagerVariable] RETURNS [ROPE] ~ {
        RETURN[ropeFromImagerVar[var]];
        };


    MapParts: PUBLIC PROC [base: ROPE, start: INT _ 0, len: INT _ MaxLen, 
    delimiter: CHAR, action: PartActionType] RETURNS [BOOL] ~ {
        next, pos: INT _ start; -- next = next char index, pos = start of part
        mapPartsAction: Rope.ActionType ~ {
            index: INT ~ next; next _ next+1;
            IF c=delimiter THEN { quit _ action[base: base, start: pos, len: index-pos]; pos _ next };
            };
        IF Rope.Map[base: base, start: start, len: len, action: mapPartsAction] THEN RETURN[TRUE];
        RETURN[action[base: base, start: pos, len: next-pos]]; -- don't forget the last one!
        };

    ValidateIdentifier: PUBLIC PROC [rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        state: {first, rest} _ first;
        pos: INT _ start;
        identifierChar: Rope.ActionType ~ {
            SELECT state FROM
                first => SELECT c FROM
                    IN['a..'z], IN['A..'Z] => state _ rest;
                    ENDCASE => RETURN[quit: TRUE]; -- illegal first char
                rest => SELECT c FROM
                    IN['a..'z], IN['A..'Z], IN['0..'9], '- => NULL;
                    ENDCASE => RETURN[quit: TRUE]; -- illegal char
                ENDCASE => ERROR;
            pos _ pos+1;
            };
        InvalidIdentifier: PROC [explanation: ROPE] ~ {
            ERROR Error[[code: $invalidIdentifier, explanation: explanation, index: pos]];
            };
        IF Rope.Map[base: rope, start: start, len: len, action: identifierChar] THEN SELECT state FROM
            first => InvalidIdentifier["Identifier begins with an illegal character."];
            rest => InvalidIdentifier["Identifier contains an illegal character."];
            ENDCASE => ERROR;
        IF state=first THEN InvalidIdentifier["Identifier is empty."];
        };

    ValidateName: PUBLIC PROC [rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        empty: BOOL _ TRUE;
        namePart: PartActionType ~ { empty _ FALSE; ValidateIdentifier[base, start, len] };
        [] _ MapParts[base: rope, start: start, len: len, delimiter: '/, action: namePart];
        IF empty THEN ERROR Error[[code: $invalidName, explanation: "Name is empty."]];
        };

    ValidateString: PUBLIC PROC [rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        state: {run, escape, escape2, extended, extended2} _ run;
        pos: INT _ start;
        stringChar: Rope.ActionType ~ {
            SELECT state FROM
                run => IF c='\377 THEN state _ escape;
                escape => IF c='\377 THEN state _ escape2 ELSE state _ run;
                escape2 => IF c='\000 THEN state _ extended ELSE quit _ TRUE;
                extended => IF c='\377 THEN state _ escape ELSE state _ extended2;
                extended2 => IF c='\377 THEN quit _ TRUE ELSE state _ extended;
                ENDCASE => ERROR;
            pos _ pos+1;
            };
        InvalidString: PROC [explanation: ROPE] ~ {
            ERROR Error[[code: $invalidString, explanation: explanation, index: pos]];
            };
        IF Rope.Map[base: rope, start: start, len: len, action: stringChar] THEN
            InvalidString["String contains an invalid character code."];
        IF NOT(state=run OR state=extended) THEN
            InvalidString["String ends in the middle of an escape sequence."];
        };

    ValidateNumber: PROC [rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        empty: BOOL _ TRUE;
        pos: INT _ start;
        InvalidVersion: PROC [explanation: ROPE] ~ {
            ERROR Error[[code: $invalidVersion, explanation: explanation, index: pos]];
            };
        numberChar: Rope.ActionType ~ {
            empty _ FALSE;
            IF c NOT IN['0..'9] THEN RETURN[quit: TRUE];
            pos _ pos+1;
            };
        IF Rope.Map[base: rope, start: start, len: len, action: numberChar] THEN
            InvalidVersion["Version number contains an illegal character."];
        IF empty THEN InvalidVersion["Version number part is empty."];
        };

    ValidateVersion: PUBLIC PROC [rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        count: NAT _ 0;
        pos: INT _ start;
        versionPart: PartActionType ~ {
        pos _ start;
        IF count>=2 THEN RETURN[quit: TRUE];
        ValidateNumber[base, start, len];
            count _ count+1;
            };
        InvalidVersion: PROC [explanation: ROPE] ~ {
            ERROR Error[[code: $invalidVersion, explanation: explanation, index: pos]];
            };
        IF MapParts[base: rope, start: start, len: len, delimiter: '., action: versionPart] THEN
            InvalidVersion["Version number has too many parts."];
        IF count=0 THEN InvalidVersion["Version number is empty."];
        IF count<2 THEN InvalidVersion["Version number has too few parts."];
        };

    VersionFromRope: PUBLIC PROC [rope: ROPE, start: INT _ 0, len: INT _ MaxLen] 
    RETURNS [version: Version] ~ {
        count: NAT _ 0;
        versionPart: PartActionType ~ {
            InvalidVersion: PROC [explanation: ROPE] ~ {
                ERROR Error[[code: $invalidVersion, explanation: explanation, index: start]];
                };
            val: INT ~ Convert.IntFromRope[Rope.Substr[base, start, len]];
            IF val NOT IN CARDINAL THEN InvalidVersion["Version number part is too big."];
            SELECT count FROM
                0 => version.major _ val;
                1 => version.minor _ val;
                ENDCASE => InvalidVersion["Version number has too many parts."];
            count _ count+1;
            };
        ValidateVersion[rope, start, len];
        [] _ MapParts[base: rope, start: start, len: len, delimiter: '., action: versionPart];
        };


    PutShortNumber: PUBLIC PROC [stream: STREAM, n: ShortNumber] ~ {
        x: [0..77777B] ~ n-ShortNumber.FIRST;
        IO.PutChar[stream, VAL[x/400B]];
        IO.PutChar[stream, VAL[x MOD 400B]];
        };

    PutShortOp: PUBLIC PROC [stream: STREAM, ev: ShortEncodingValue] ~ {
        x: [0..37B] ~ ORD[ev];
        IO.PutChar[stream, VAL[200B+x]];
        };

    PutLongOp: PUBLIC PROC [stream: STREAM, ev: EncodingValue] ~ {
        x: [0..17777B] ~ ORD[ev];
        IO.PutChar[stream, VAL[240B+x/400B]];
        IO.PutChar[stream, VAL[x MOD 400B]];
        };

    PutShortSequence: PUBLIC PROC [
    stream: STREAM, seq: SequenceType, len: ShortSequenceLength] ~ {
        x: [0..37B] ~ ORD[seq];
        IO.PutChar[stream, VAL[300B+x]];
        IO.PutChar[stream, VAL[len]];
        };

    PutLongSequence: PUBLIC PROC [
    stream: STREAM, seq: SequenceType, len: LongSequenceLength] ~ {
        x: [0..37B] ~ ORD[seq];
    lenH: [0..377B] ~ Basics.HighHalf[len]; -- bounds check
    lenL: CARDINAL ~ Basics.LowHalf[len];
        IO.PutChar[stream, VAL[340B+x]];
        IO.PutChar[stream, VAL[lenH]];
        IO.PutChar[stream, VAL[lenL/400B]];
        IO.PutChar[stream, VAL[lenL MOD 400B]];
        };
        <<>>
    BytesInInt: PUBLIC PROC [val: INT] RETURNS [ByteCount] ~ {
        x: CARD ~ IF val<0 THEN -(val+1) ELSE val;
        SELECT x FROM
            <00000080H => RETURN[1];
            <00008000H => RETURN[2];
            <00800000H => RETURN[3];
            ENDCASE => RETURN[4];
        };

    PutIntBytes: PUBLIC PROC [stream: STREAM, val: INT, len: ByteCount] ~ {
        bytes: Basics.LongNumber ~ [li[val]];
        IF len>3 THEN IO.PutChar[stream, VAL[bytes.hh]];
        IF len>2 THEN IO.PutChar[stream, VAL[bytes.hl]];
        IF len>1 THEN IO.PutChar[stream, VAL[bytes.lh]];
        IF len>0 THEN IO.PutChar[stream, VAL[bytes.ll]];
        };

    PutByte: PUBLIC PROC [stream: STREAM, byte: BYTE] ~ {
        IO.PutChar[stream, VAL[byte]];
        };


    PutOp: PUBLIC PROC [stream: STREAM, op: Op] ~ {
        ev: EncodingValue ~ encodingValueFromOp[op];
        IF ev IN ShortEncodingValue THEN PutShortOp[stream, ev]
        ELSE PutLongOp[stream, ev];
        };

    PutSequence: PUBLIC PROC [stream: STREAM, seq: SequenceType, len: INT] ~ {
        IF len IN ShortSequenceLength THEN PutShortSequence[stream, seq, len]
        ELSE PutLongSequence[stream, seq, len];
        };

    PutInt: PUBLIC PROC [stream: STREAM, n: INT] ~ {
        IF n IN ShortNumber THEN PutShortNumber[stream, n]
        ELSE {
            len: ByteCount ~ BytesInInt[n];
            PutShortSequence[stream, sequenceInteger, len];
            PutIntBytes[stream: stream, val: n, len: len];
            };
        };

    PutRational: PUBLIC PROC [stream: STREAM, n, d: INT] ~ {
        len: ByteCount ~ MAX[BytesInInt[n], BytesInInt[d]];
        PutShortSequence[stream, sequenceRational, len+len];
        PutIntBytes[stream: stream, val: n, len: len];
        PutIntBytes[stream: stream, val: d, len: len];
        };

    tryDecimal: BOOL _ FALSE;
    tryRational: BOOL _ TRUE;
    decimalPrecision: NAT _ 6;
    maxRelativeError: REAL _ 0.00001;

    PutReal: PUBLIC PROC [stream: STREAM, val: REAL] ~ {
        <<Appends a Number literal. Chooses a rational approximation if necessary.>>
        r: REAL _ val;
        n: INT _ 0; d: INT _ 1;
        IF ABS[r]>INT.LAST THEN {
            tail: NAT _ 0; -- number of trailing zero bytes
            WHILE ABS[r]>INT.LAST DO r _ r/256; tail _ tail+1 ENDLOOP;
            PutSequence[stream, sequenceInteger, 4+tail];
            PutIntBytes[stream: stream, val: Real.RoundLI[r], len: 4];
            THROUGH [0..tail) DO IO.PutChar[stream, VAL[0]] ENDLOOP;
            RETURN;
            };
        IF (n _ Real.RoundLI[r])=r THEN { PutInt[stream, n]; RETURN };
        IF tryDecimal THEN {
            type: Real.NumberType; exp10: INTEGER;
            [type: type, fr: n, exp10: exp10] _ Real.RealToPair[r: r, precision: decimalPrecision];
            IF type=$normal AND exp10 IN[-9..0) THEN {
                e: NAT _ -exp10;
                WHILE (n MOD 10)=0 AND e>0 DO n _ n/10; e _ e-1 ENDLOOP;
                THROUGH [0..e) DO d _ d*10 ENDLOOP;
                PutRational[stream, n, d]; RETURN;
                };
            };
        IF tryRational THEN {
            rat: IPReal.Rational _ IPReal.RationalFromReal[r];
            IF rat.denominator # 0 AND ABS[REAL[rat.numerator]/REAL[rat.denominator] - r] <= maxRelativeError * ABS[r] THEN {
                IF rat.denominator = 1 THEN PutInt[stream, rat.numerator]
                ELSE PutRational[stream, rat.numerator, rat.denominator];
                RETURN;
                };
            };
        THROUGH [0..30) DO
            r _ r*2; d _ d*2;
            IF (n _ Real.RoundLI[r])=r THEN EXIT;
            REPEAT FINISHED => { d _ INT.LAST; n _ Real.RoundLI[d*val] };
            ENDLOOP;
        PutRational[stream, n, d];
        };

    PutSequenceRope: PUBLIC PROC [stream: STREAM, seq: SequenceType, 
    rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        size: INT ~ Rope.Length[rope];
        rem: INT ~ Basics.NonNegative[size-Basics.NonNegative[start]];
        length: INT ~ MIN[MAX[0, len], rem];
        ropeChar: Rope.ActionType ~ { IO.PutChar[stream, c] };
        PutSequence[stream, seq, length];
        [] _ Rope.Map[base: rope, start: start, len: length, action: ropeChar];
        };

    PutSequenceText: PUBLIC PROC [stream: STREAM, seq: SequenceType, 
    text: REF READONLY TEXT, start: NAT _ 0, len: NAT _ MaxTextLen] ~ {
        size: NAT ~ text.length;
        rem: NAT ~ size-start;
        length: NAT ~ MIN[len, rem];
        PutSequence[stream, seq, length];
        IO.PutBlock[self: stream, block: text, startIndex: start, count: length];
        };

    PutIdentifier: PUBLIC PROC [stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        ValidateIdentifier[rope, start, len];
        PutSequenceRope[stream, sequenceIdentifier, rope, start, len];
        };

    PutString: PUBLIC PROC [stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        ValidateString[rope, start, len];
        PutSequenceRope[stream, sequenceString, rope, start, len];
        };

    PutName: PUBLIC PROC [stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ MaxLen] ~ {
        count: INT _ 0;
        namePart: PartActionType ~ {
            PutSequenceRope[stream, sequenceIdentifier, base, start, len];
            count _ count+1;
            };
        ValidateName[rope, start, len];
        [] _ MapParts[base: rope, start: start, len: len, delimiter: '/, action: namePart];
        PutInt[stream, count];
        PutOp[stream, makevec];
        };

    <<PutBits: PUBLIC PROC [stream: STREAM, 
    base: LONG POINTER, wordsPerLine: NAT, sMin, fMin, sSize, fSize: NAT] ~ {>>
        <<scanBytes: NAT ~ 4*((fSize+31)/32); -- bytes per output scan line>>
        <<block: REF TEXT ~ NEW[TEXT[scanBytes]]; -- scan line buffer>>
        <<length: INT ~ LONG[4]+LONG[scanBytes]*LONG[sSize]; -- length of token data>>
        <<bbspace: PrincOps.BBTableSpace;>>
        <<bb: PrincOps.BitBltTablePtr;>>
        <<PutDescriptor[stream, sequencePackedPixelVector, length];>>
        <<PutSigned[stream, 2, 1]; -- BitsPerSample>>
        <<PutSigned[stream, 2, fSize]; -- ScanLength>>
        <<TRUSTED {>>
            <<bb _ PrincOpsUtils.AlignedBBTable[@bbspace];>>
            <<bb^ _ [dst: [word: NIL, bit: 0], dstBpl: 0, src: [word: NIL, bit: 0], srcDesc: [srcBpl[0]], 
            width: 0, height: 0, flags: [disjoint: TRUE, gray: FALSE]];>>
            <<bb.dst.word _ LOOPHOLE[block, LONG POINTER]+SIZE[TEXT[0]];>>
            <<bb.dstBpl _ scanBytes*Basics.bitsPerByte;>>
            <<bb.src.word _ base+Basics.LongMult[sMin, wordsPerLine]+fMin/Basics.bitsPerWord;>>
            <<bb.src.bit _ fMin MOD Basics.bitsPerWord;>>
            <<bb.srcDesc.srcBpl _ wordsPerLine*Basics.bitsPerWord;>>
            <<bb.width _ fSize;>>
            <<bb.height _ 1;>>
            <<PrincOpsUtils.LongZero[where: bb.dst.word, nwords: scanBytes/2];>>
            <<};>>
        <<THROUGH [0..sSize) DO>>
            <<TRUSTED { PrincOpsUtils.BITBLT[bb] };>>
            <<IO.PutBlock[self: stream, block: block, startIndex: 0, count: scanBytes];>>
            <<TRUSTED { bb.src.word _ bb.src.word+wordsPerLine };>>
            <<ENDLOOP;>>
        <<};>>
        <<>>

    GetToken: PUBLIC PROC [stream: STREAM, flushComments: BOOL _ TRUE] RETURNS [Token] ~ {
        FOR first: BOOL _ TRUE, FALSE DO
            token: Token _ [];
            index: INT ~ IO.GetIndex[stream];
            b0: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
            SELECT b0 FROM
                <200B => {
                    b1: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
                    token.format _ shortNumber;
                    token.num _ ShortNumber.FIRST+(b0*400B+b1);
                    };
                <240B => {
                    token.format _ shortOp;
                    token.ev _ VAL[b0 MOD 40B];
                    };
                <300B => {
                    b1: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
                    token.format _ longOp;
                    token.ev _ VAL[(b0 MOD 40B)*400B+b1];
                    };
                <340B => {
                    b1: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
                    token.format _ shortSequence;
                    token.seq _ VAL[b0 MOD 40B];
                    token.len _ b1;
                    };
                ENDCASE => {
                    b1: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
                    b2: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
                    b3: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
                    long: Basics.LongNumber ~ [bytes[hh:0, hl: b1, lh: b2, ll: b3]];
                    token.format _ longSequence;
                    token.seq _ VAL[b0 MOD 40B];
                    token.len _ long.li;
                    };
            IF flushComments THEN {
                SELECT token.seq FROM
                    sequenceComment => GOTO Skip;
                    sequenceContinued => IF NOT first THEN GOTO Skip;
                    ENDCASE;
                EXITS Skip => { SkipBytes[stream, token.len]; LOOP };
                };
            token.index _ index;
            SELECT token.format FROM
                shortNumber => { token.type _ num };
                shortOp, longOp => { token.type _ op; token.op _ opFromEncodingValue[token.ev] };
                shortSequence, longSequence => { token.type _ seq };
                ENDCASE => ERROR;
            RETURN[token];
            ENDLOOP;
        };

    GetHeader: PUBLIC PROC [stream: STREAM, prefix: ROPE] RETURNS [rope: ROPE] ~ {
        prefixChar: Rope.ActionType ~ {
            index: INT ~ IO.GetIndex[stream];
            char: CHAR ~ IO.GetChar[stream];
            IF char#c THEN ERROR Error[[code: $invalidHeader, index: index, 
            explanation: IO.PutFR1["Header does not begin with \"%g\".", IO.rope[prefix]]]];
            };
        scratch: REF TEXT ~ RefText.ObtainScratch[100];
        text: REF TEXT _ scratch;
        [] _ Rope.Map[base: prefix, action: prefixChar];
        DO char: CHAR ~ IO.GetChar[stream];
            IF char='  THEN EXIT;
            text _ RefText.AppendChar[text, char];
            ENDLOOP;
        rope _ Rope.FromRefText[text];
        RefText.ReleaseScratch[scratch];
        };

    GetSkeleton: PUBLIC PROC [stream: STREAM] RETURNS [Skeleton] ~ {
        instructions: Body _ NIL;
        block: Block _ NIL;
        token: Token _ GetToken[stream];
        IF token.ev=$beginBody THEN {
            instructions _ GetBody[stream, token];
            token _ GetToken[stream];
            };
        block _ GetBlock[stream, token];
        RETURN[NEW[SkeletonRep _ [instructions: instructions, topBlock: block]]];
        };

    SkipToEndOfBody: PUBLIC PROC [stream: STREAM] ~ {
        DO token: Token ~ GetToken[stream];
            SELECT token.ev FROM
                beginBody => SkipToEndOfBody[stream];
                endBody => EXIT;
                ENDCASE => IF token.type=seq THEN SkipBytes[stream, token.len];
            ENDLOOP;
        };

    GetBody: PROC [stream: STREAM, first: Token] RETURNS [Body] ~ {
        IF first.ev=$beginBody THEN {
            SkipToEndOfBody[stream];
            RETURN[NEW[BodyRep _ [index: first.index, length: IO.GetIndex[stream]-first.index]]];
            };
        ERROR Error[[code: $invalidSkeleton, index: first.index, 
        explanation: "Missing { in skeleton."]];
        };

    GetBlock: PROC [stream: STREAM, first: Token] RETURNS [block: Block] = {
        IF first.ev=$beginBlock THEN {
            noPages: BOOL _ FALSE;
            preamble: Node _ NIL;
            list: LIST OF Node _ NIL;
            size: NAT _ 0;
            token: Token _ GetToken[stream];
            preamble _ GetNode[stream, token, TRUE];
            DO token _ GetToken[stream];
                IF token.ev=$endBlock THEN EXIT
                ELSE {
                    page: Node ~ GetNode[stream, token];
                    list _ CONS[page, list]; size _ size+1;
                    };
                ENDLOOP;
            block _ NEW[BlockRep[size] _ [
                index: first.index, length: IO.GetIndex[stream]-first.index,
                noPages: noPages, preamble: preamble, nodes: ]];
            WHILE size>0 DO block[size _ size-1] _ list.first; list _ list.rest ENDLOOP;
            RETURN[block];
            };
        ERROR Error[[code: $invalidSkeleton, index: first.index, 
        explanation: "Missing BEGIN in skeleton."]];
        };

    GetNode: PROC [stream: STREAM, first: Token, preamble: BOOL _ FALSE] RETURNS [Node] ~ {
        contentInstructions: Body _ NIL;
        token: Token _ first;
        IF token.ev=$contentInstructions THEN {
            IF preamble THEN ERROR Error[[code: $invalidSkeleton, index: token.index, 
            explanation: "Misplaced CONTENTINSTRUCTIONS in skeleton."]];
            token _ GetToken[stream];
            contentInstructions _ GetBody[stream, token];
            token _ GetToken[stream];
            };
        SELECT token.ev FROM
            $beginBody => {
                body: Body ~ GetBody[stream, token];
                RETURN[NEW[NodeRep.body _ [
                    index: first.index, length: IO.GetIndex[stream]-first.index,
                    contentInstructions: contentInstructions, content: body[body]]]];
                };
            $beginBlock => {
                block: Block ~ GetBlock[stream, token];
                RETURN[NEW[NodeRep.block _ [
                    index: first.index, length: IO.GetIndex[stream]-first.index,
                    contentInstructions: contentInstructions, content: block[block]]]];
                };
            ENDCASE;
        ERROR Error[[code: $invalidSkeleton, index: token.index, 
        explanation: "Missing { or BEGIN in skeleton."]];
        };


    SetIndex: PUBLIC PROC [stream: STREAM, index: INT] ~ {
        IO.SetIndex[stream, index];
        };

    CopyBytes: PUBLIC PROC [to: STREAM, from: STREAM, count: INT] RETURNS [copied: INT] ~ {
        rem: INT _ count;
        inner: PROC [buffer: REF TEXT] ~ {
            WHILE rem>0 DO
                request: NAT ~ MIN[rem, buffer.maxLength];
                length: NAT ~ IO.GetBlock[self: from, block: buffer, startIndex: 0, count: request];
                IO.PutBlock[self: to, block: buffer, startIndex: 0, count: length];
                rem _ rem-length;
                IF length<request THEN EXIT;
                ENDLOOP;
            };
        scratch: REF TEXT ~ RefText.ObtainScratch[512];
        inner[scratch ! UNWIND => RefText.ReleaseScratch[scratch]];
        RefText.ReleaseScratch[scratch];
        RETURN[count-rem];
        };

    CopySegment: PUBLIC PROC [to: STREAM, from: STREAM, start, length: INT] ~ {
        IO.SetIndex[from, start];
        IF CopyBytes[to: to, from: from, count: length]=length THEN RETURN;
        ERROR IO.EndOfStream[from];
        };


    SkipBytes: PUBLIC PROC [stream: STREAM, len: INT] ~ {
        IO.SetIndex[stream, IO.GetIndex[stream]+len];
        };

    <<GetUnsigned: PROC [stream: STREAM, length: [0..4]] RETURNS [LONG CARDINAL] ~ {>>
        <<x: LONG CARDINAL _ 0;>>
        <<FOR i: NAT IN [0..length) DO>>
            <<b: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];>>
            <<x _ x*400B+b;>>
            <<ENDLOOP;>>
        <<RETURN[x];>>
        <<};>>
        <<>>
    IntFromSequenceData: PUBLIC PROC [text: REF READONLY TEXT, 
    start: NAT _ 0, len: NAT _ NAT.LAST] RETURNS [val: INT _ 0] ~ {
        rem: NAT ~ text.length-start;
        neg: BOOL ~ ORD[text[start]]>=200B;
        FOR i: NAT IN[start..start+MIN[len, rem]) DO
            byte: BYTE _ ORD[text[i]];
            IF neg THEN byte _ 377B-byte;
            val _ val*400B+byte;
            ENDLOOP;
        IF neg THEN val _ -1-val;
        };
        <<>>
    RealFromSequenceData: PUBLIC PROC [text: REF READONLY TEXT, 
    start: NAT _ 0, len: NAT _ NAT.LAST] RETURNS [val: REAL _ 0] ~ {
        rem: NAT ~ text.length-start;
        neg: BOOL ~ ORD[text[start]]>=200B;
        FOR i: NAT IN[start..start+MIN[len, rem]) DO
            byte: BYTE _ ORD[text[i]];
            IF neg THEN byte _ 377B-byte;
            val _ val*400B+byte;
            ENDLOOP;
        IF neg THEN val _ -1-val;
        };
        <<>>

    END.