
    <<IPMasterImpl.mesa>>
    <<Copyright (C) 1984 Xerox Corporation.  All rights reserved.>>
        <<Doug Wyatt, December 18, 1984 5:45:03 pm PST>>

    DIRECTORY
        Basics USING [bitsPerByte, bitsPerWord, HighHalf, LongMult, LongNumber, LowHalf],
        IO USING [EndOfStream, GetBlock, GetChar, GetIndex, PutBlock, PutChar, RopeFromROS, ROS, SetIndex, STREAM],
        IPMaster,
        Real USING [NumberType, RealToPair, RoundLI],
        RefText USING [ObtainScratch, ReleaseScratch],
        Rope USING [Fetch, Index, Length, ROPE, Substr],
        PrincOps USING [BBTableSpace, BitBltTablePtr, zBNDCK, zLINI],
        PrincOpsUtils USING [AlignedBBTable, BITBLT, ZERO],
        ShortRational USING [FromReal, Rational],
        SymTab USING [Create, Fetch, Ref, Store];

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

NonNeg: PROC[x: INT] RETURNS[INT]
~ TRUSTED MACHINE CODE { PrincOps.zLINI; PrincOps.zBNDCK; };
<<Raises BoundsFault if x<0>>

    ROPE: TYPE ~ Rope.ROPE;
    STREAM: TYPE ~ IO.STREAM;

    Error: PUBLIC ERROR[code: ErrorCode, explanation: ROPE] ~ CODE;

    evFromOp: REF EvFromOpArray ~ NEW[EvFromOpArray _ [nil: nil,
        get: get, makeveclu: makeveclu, makevec: makevec, shape: shape,
        openvec: openvec, getprop: getprop, getp: getp, mergeprop: mergeprop,
        frame: frame, fget: fget, fset: fset,
        poolop: poolop, pool: pool, pget: pget, pset: pset,
        env: env, makepool: makepool, nopool: nopool,
        makeco: makeco, makesimpleco: makesimpleco,
        do: do, dosave: dosave, dosaveall: dosaveall,
        dobody: dobody, dosavebody: dosavebody, dosaveallbody: dosaveallbody,
        dosavesimplebody: dosavesimplebody, makecompiledimage: makecompiledimage,
        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, loop: loop,
        eq: eq, eqname: eqname, 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, max: max, min: min,
        sqrt: sqrt, exp: exp, log: log, sin: sin, cos: cos, atan: atan,
        iget: iget, iset: iset, dround: dround,
        maket: maket, opent: opent,
        translate: translate, rotate: rotate, scale: scale, scale2: scale2,
        concat: concat, invert: invert,
        transform: transform, transformvec: transformvec,
        roundxy: roundxy, roundxyvec: roundxyvec,
        concatt: concatt, move: move, trans: trans,
        show: show, showandxrel: showandxrel,
        setxy: setxy, setxyrel: setxyrel, setxrel: setxrel, setyrel: setyrel,
        getcp: getcp, getcprounded: getcprounded,
        makepixelarray: makepixelarray,
        extractpixelarray: extractpixelarray, joinpixelarrays: joinpixelarrays,
        finddecompressor: finddecompressor,
        makegray: makegray, setgray: setgray,
        findcolor: findcolor, findcoloroperator: findcoloroperator,
        findcolormodeloperator: findcolormodeloperator,
        makesampledcolor: makesampledcolor, makesampledblack: makesampledblack,
        moveto: moveto, lineto: lineto, linetox: linetox, linetoy: linetoy,
        curveto: curveto, conicto: conicto, arcto: arcto, makeoutline: makeoutline,
        maskfill: maskfill, maskfillparity: maskfillparity,
        maskstroke: maskstroke, maskstrokeclosed: maskstrokeclosed,
        maskvector: maskvector, maskrectangle: maskrectangle,
        startunderline: startunderline, maskunderline: maskunderline,
        masktrapezoidx: masktrapezoidx, masktrapezoidy: masktrapezoidy,
        maskpixel: maskpixel,
        clipoutline: clipoutline, excludeoutline: excludeoutline,
        cliprectangle: cliprectangle, excluderectangle: excluderectangle,
        findfont: findfont, findfontvec: findfontvec,
        modifyfont: modifyfont, setfont: setfont,
        correctmask: correctmask, correctspace: correctspace, space: space,
        setcorrectmeasure: setcorrectmeasure, setcorrecttolerance: setcorrecttolerance,
        correct: correct,
        beginBody: beginBody, endBody: endBody, beginBlock: beginBlock, endBlock: endBlock,
        pageInstructions: pageInstructions, noPages: noPages,
        metricMaster: metricMaster, environmentMaster: environmentMaster
        ]];

    opFromEv: REF OpFromEvArray ~ InvertEvFromOp[evFromOp];

    InvertEvFromOp: PROC[evFromOp: REF EvFromOpArray] RETURNS[REF OpFromEvArray] ~ {
        opFromEv: REF OpFromEvArray ~ NEW[OpFromEvArray _ ALL[nil]];
        FOR op: Op IN Op DO opFromEv[evFromOp[op]] _ op ENDLOOP;
        RETURN[opFromEv];
        };

    GetEvFromOp: PUBLIC PROC RETURNS[REF READONLY EvFromOpArray] ~ {
        RETURN[evFromOp];
        };
    GetOpFromEv: PUBLIC PROC RETURNS[REF READONLY OpFromEvArray] ~ {
        RETURN[opFromEv];
        };

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

    OpFromEncodingValue: PUBLIC PROC[ev: EncodingValue] RETURNS[Op] ~ {
        RETURN[opFromEv[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",
        openvec: "OPENVEC", getprop: "GETPROP", getp: "GETP", mergeprop: "MERGEPROP",
        frame: "FRAME", fget: "FGET", fset: "FSET",
        poolop: "POOLOP", pool: "POOL", pget: "PGET", pset: "PSET",
        env: "ENV", makepool: "MAKEPOOL", nopool: "NOPOOL",
        makeco: "MAKECO", makesimpleco: "MAKESIMPLECO",
        do: "DO", dosave: "DOSAVE", dosaveall: "DOSAVEALL",
        dobody: "DOBODY", dosavebody: "DOSAVEBODY", dosaveallbody: "DOSAVEALLBODY",
        dosavesimplebody: "DOSAVESIMPLEBODY", makecompiledimage: "MAKECOMPILEDIMAGE",
        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", loop: "LOOP",
        eq: "EQ", eqname: "EQNAME", 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", max: "MAX", min: "MIN",
        sqrt: "SQRT", exp: "EXP", log: "LOG", sin: "SIN", cos: "COS", atan: "ATAN",
        iget: "IGET", iset: "ISET", dround: "DROUND",
        maket: "MAKET", opent: "OPENT",
        translate: "TRANSLATE", rotate: "ROTATE", scale: "SCALE", scale2: "SCALE2",
        concat: "CONCAT", invert: "INVERT",
        transform: "TRANSFORM", transformvec: "TRANSFORMVEC",
        roundxy: "ROUNDXY", roundxyvec: "ROUNDXYVEC",
        concatt: "CONCATT", move: "MOVE", trans: "TRANS",
        show: "SHOW", showandxrel: "SHOWANDXREL",
        setxy: "SETXY", setxyrel: "SETXYREL", setxrel: "SETXREL", setyrel: "SETYREL",
        getcp: "GETCP", getcprounded: "GETCPROUNDED",
        makepixelarray: "MAKEPIXELARRAY",
        extractpixelarray: "EXTRACTPIXELARRAY", joinpixelarrays: "JOINPIXELARRAYS",
        finddecompressor: "FINDDECOMPRESSOR",
        makegray: "MAKEGRAY", setgray: "SETGRAY",
        findcolor: "FINDCOLOR", findcoloroperator: "FINDCOLOROPERATOR",
        findcolormodeloperator: "FINDCOLORMODELOPERATOR",
        makesampledcolor: "MAKESAMPLEDCOLOR", makesampledblack: "MAKESAMPLEDBLACK",
        moveto: "MOVETO", lineto: "LINETO", linetox: "LINETOX", linetoy: "LINETOY",
        curveto: "CURVETO", conicto: "CONICTO", arcto: "ARCTO", makeoutline: "MAKEOUTLINE",
        maskfill: "MASKFILL", maskfillparity: "MASKFILLPARITY",
        maskstroke: "MASKSTROKE", maskstrokeclosed: "MASKSTROKECLOSED",
        maskvector: "MASKVECTOR", maskrectangle: "MASKRECTANGLE",
        startunderline: "STARTUNDERLINE", maskunderline: "MASKUNDERLINE",
        masktrapezoidx: "MASKTRAPEZOIDX", masktrapezoidy: "MASKTRAPEZOIDY",
        maskpixel: "MASKPIXEL",
        clipoutline: "CLIPOUTLINE", excludeoutline: "EXCLUDEOUTLINE",
        cliprectangle: "CLIPRECTANGLE", excluderectangle: "EXCLUDERECTANGLE",
        findfont: "FINDFONT", findfontvec: "FINDFONTVEC",
        modifyfont: "MODIFYFONT", setfont: "SETFONT",
        correctmask: "CORRECTMASK", correctspace: "CORRECTSPACE", space: "SPACE",
        setcorrectmeasure: "SETCORRECTMEASURE", setcorrecttolerance: "SETCORRECTTOLERANCE",
        correct: "CORRECT",
        beginBody: "{", endBody: "}", beginBlock: "BEGIN", endBlock: "END",
        pageInstructions: "PAGEINSTRUCTIONS", noPages: "NOPAGES",
        metricMaster: "METRICMASTER", environmentMaster: "ENVIRONMENTMASTER"
        ]];

    opFromRope: SymTab.Ref ~ InvertRopeFromOp[ropeFromOp];

    OpVal: TYPE ~ REF Op;

    InvertRopeFromOp: PROC[ropeFromOp: REF RopeFromOpArray]
        RETURNS[opFromRope: SymTab.Ref] ~ {
        opFromRope _ SymTab.Create[mod: ORD[Op.LAST], case: FALSE];
        FOR op: Op IN Op DO
            key: ROPE ~ ropeFromOp[op];
            val: OpVal ~ NEW[Op _ op];
            IF SymTab.Store[x: opFromRope, key: key, val: val] THEN NULL
            ELSE ERROR Error[bug, "duplicate name in ropeFromOp"];
            ENDLOOP;
        };


    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: OpVal => RETURN[val^];
            ENDCASE => ERROR Error[bug, "illegal value in opFromRope"];
        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",
        showVec: "showVec", color: "color", noImage: "noImage",
        strokeWidth: "strokeWidth", strokeStyle: "strokeStyle",
        underlineStart: "underlineStart", amplifySpace: "amplifySpace",
        correctPass: "correctPass", correctShrink: "correctShrink",
        correctTX: "correctTX", correctTY: "correctTY",
        strokeDashes: "strokeDashes"
        ]];

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


    MapName: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST, 
    action: PROC[base: ROPE, start, len: INT] RETURNS[quit: BOOL _ FALSE]] 
    RETURNS[BOOL] ~ {
        size: INT ~ Rope.Length[rope];
        rem: INT ~ NonNeg[size-NonNeg[start]];
        stop: INT ~ start+MIN[len, rem];
        pos: INT _ start;
        WHILE pos<stop DO
            slash: INT ~ MIN[stop, Rope.Index[s1: rope, pos1: pos, s2: "/"]];
            IF action[base: rope, start: pos, len: slash-pos] THEN RETURN[TRUE];
            pos _ slash+1;
            ENDLOOP;
        RETURN[FALSE];
        };

    ListFromName: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] 
    RETURNS[list: LIST OF ROPE _ NIL] ~ {
        tail: LIST OF ROPE _ NIL;
        action: PROC[base: ROPE, start, len: INT] RETURNS[BOOL _ FALSE] ~ {
            component: ROPE ~ Rope.Substr[base: base, start: start, len: len];
            newTail: LIST OF ROPE ~ CONS[component, NIL];
            IF tail=NIL THEN list _ newTail ELSE tail.rest _ newTail;
            tail _ newTail;
            };
        [] _ MapName[rope, start, len, action];
        };

    ValidVersion: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] 
    RETURNS[BOOL] ~ {
        size: INT ~ Rope.Length[rope];
        rem: INT ~ NonNeg[size-NonNeg[start]];
        length: INT ~ MIN[len, rem];
    state: {begin, major, dot, minor} _ begin;
        FOR i: INT IN[start..start+length) DO
            char: CHAR ~ Rope.Fetch[rope, i];
            SELECT state FROM
                begin => SELECT char FROM
                    IN['0..'9] => state _ major;
                    ENDCASE => RETURN[FALSE];
                major => SELECT char FROM
                    IN['0..'9] => NULL;
                    '. => state _ dot;
                    ENDCASE => RETURN[FALSE];
                dot => SELECT char FROM
                    IN['0..'9] => state _ minor;
                    ENDCASE => RETURN[FALSE];
                minor => SELECT char FROM
                    IN['0..'9] => NULL;
                    ENDCASE => RETURN[FALSE];
                ENDCASE => ERROR;
            ENDLOOP;
    RETURN[state=minor];
        };

    VersionFromRope: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] RETURNS[version: Version _ [0, 0]] ~ {
        InvalidVersion: PROC ~ { ERROR Error[invalidVersion, "invalid version number"] };
        size: INT ~ Rope.Length[rope];
        rem: INT ~ NonNeg[size-NonNeg[start]];
        length: INT ~ MIN[len, rem];
    state: {begin, major, dot, minor} _ begin;
        FOR i: INT IN[start..start+length) DO
            char: CHAR ~ Rope.Fetch[rope, i];
            SELECT state FROM
                begin => SELECT char FROM
                    IN['0..'9] => { version.major _ (char-'0); state _ major };
                    ENDCASE => InvalidVersion[];
                major => SELECT char FROM
                    IN['0..'9] => version.major _ version.major*10+(char-'0);
                    '. => state _ dot;
                    ENDCASE => InvalidVersion[];
                dot => SELECT char FROM
                    IN['0..'9] => { version.minor _ (char-'0); state _ minor };
                    ENDCASE => InvalidVersion[];
                minor => SELECT char FROM
                    IN['0..'9] => version.minor _ version.minor*10+(char-'0);
                    ENDCASE => InvalidVersion[];
                ENDCASE => ERROR;
            ENDLOOP;
    IF state#minor THEN InvalidVersion[];
        };

    ValidIdentifier: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] 
    RETURNS[BOOL] ~ {
        size: INT ~ Rope.Length[rope];
        rem: INT ~ NonNeg[size-NonNeg[start]];
        length: INT ~ MIN[len, rem];
    state: {first, rest} _ first;
        FOR i: INT IN[start..start+length) DO
            char: CHAR ~ Rope.Fetch[rope, i];
            SELECT state FROM
                first => SELECT char FROM
                    IN['a..'z], IN['A..'Z] => state _ rest;
                    ENDCASE => RETURN[FALSE];
                rest => SELECT char FROM
                    IN['a..'z], IN['A..'Z], IN['0..'9], '- => NULL;
                    ENDCASE => RETURN[FALSE];
                ENDCASE => ERROR;
            ENDLOOP;
    RETURN[state=rest];
        };

    ValidName: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] 
    RETURNS[BOOL] ~ {
        action: PROC[base: ROPE, start, len: INT] RETURNS[quit: BOOL] ~ {
            RETURN[NOT ValidIdentifier[base, start, len]];
            };
        RETURN[NOT MapName[rope, start, len, action]];
        };

    ValidString: PUBLIC PROC[rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] 
    RETURNS[BOOL] ~ {
        size: INT ~ Rope.Length[rope];
        rem: INT ~ NonNeg[size-NonNeg[start]];
        length: INT ~ MIN[len, rem];
    state: {run, escape, escape2, extended, extended2} _ run;
        FOR i: INT IN[start..start+length) DO
            char: CHAR ~ Rope.Fetch[rope, i];
            SELECT state FROM
                run => IF char='\377 THEN state _ escape;
                escape => IF char='\377 THEN state _ escape2 ELSE state _ run;
                escape2 => IF char='\000 THEN state _ extended ELSE RETURN[FALSE];
                extended => IF char='\377 THEN state _ escape ELSE state _ extended2;
                extended2 => IF char='\377 THEN RETURN[FALSE] ELSE state _ extended;
                ENDCASE => ERROR;
            ENDLOOP;
    RETURN[state=run OR state=extended];
        };


    GetHeader: PUBLIC PROC[stream: STREAM, prefix: ROPE _ NIL, maxLength: INT _ 100] RETURNS[ROPE] ~ {
        InvalidHeader: PROC ~ { ERROR Error[invalidHeader, "invalid header"] };
        prefixLength: INT ~ Rope.Length[prefix];
        ros: IO.STREAM ~ IO.ROS[];
        FOR i: INT IN[0..MAX[prefixLength, maxLength]) DO
            char: CHAR ~ IO.GetChar[stream];
            IF i<prefixLength AND char#Rope.Fetch[prefix, i] THEN InvalidHeader[];
            IF char='  THEN EXIT ELSE IO.PutChar[ros, char];
            REPEAT FINISHED => InvalidHeader[]; -- too long
            ENDLOOP;
        RETURN[IO.RopeFromROS[ros]];
        };

    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]]];
            };
        IO.SetIndex[stream, first.index];
        ERROR Error[invalidSkeleton, "missing {"];
        };

    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];
            IF token.ev=$noPages THEN { noPages _ TRUE; 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];
            };
        IO.SetIndex[stream, first.index];
        ERROR Error[invalidSkeleton, "missing BEGIN"];
        };

    GetNode: PROC[stream: STREAM, first: Token, preamble: BOOL _ FALSE] RETURNS[Node] ~ {
        pageInstructions: Body _ NIL;
        token: Token _ first;
        IF token.ev=$pageInstructions THEN {
            IF preamble THEN {
                IO.SetIndex[stream, token.index];
                ERROR Error[invalidSkeleton, "misplaced PAGEINSTRUCTIONS"];
                };
            token _ GetToken[stream];
            pageInstructions _ 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,
                    pageInstructions: pageInstructions, content: body[body]]]];
                };
            $beginBlock => {
                block: Block ~ GetBlock[stream, token];
                RETURN[NEW[NodeRep.block _ [
                    index: first.index, length: IO.GetIndex[stream]-first.index,
                    pageInstructions: pageInstructions, content: block[block]]]];
                };
            ENDCASE;
        IO.SetIndex[stream, token.index];
        ERROR Error[invalidSkeleton, "missing { or BEGIN"];
        };


    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
                ENABLE UNWIND => RefText.ReleaseScratch[buffer];
                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];
        };


    GetToken: PUBLIC PROC[stream: STREAM, flushComments: BOOL _ TRUE] RETURNS[Token] ~ {
        FOR first: BOOL _ TRUE, FALSE DO
            token: Token _ [];
            state: {null, shortNum2, longOp2, shortSeq2, longSeq2, longSeq3, longSeq4} _ null;
            a: BYTE _ 0;
            token.index _ IO.GetIndex[stream];
            DO b: BYTE ~ ORD[CHAR[IO.GetChar[stream]]];
            SELECT state FROM
            null => SELECT b/40B FROM
            0, 1, 2, 3 => { a _ b; state _ shortNum2 };
            4 => { token.ev _ VAL[b MOD 40B]; token.type _ op; EXIT };
            5 => { a _ b MOD 40B; state _ longOp2 };
            6 => { token.seq _ VAL[b MOD 40B]; state _ shortSeq2 };
            7 => { token.seq _ VAL[b MOD 40B]; state _ longSeq2 };
            ENDCASE => ERROR;
            shortNum2 => { token.num _ VAL[a*400B+b]; token.type _ num; EXIT };
            longOp2 => { token.ev _ VAL[a*400B+b]; token.type _ op; EXIT };
            shortSeq2 => { token.len _ b; token.type _ seq; EXIT };
            longSeq2 => { token.len _ b; state _ longSeq3 };
            longSeq3 => { token.len _ token.len*400B+b; state _ longSeq4 };
            longSeq4 => { token.len _ token.len*400B+b; token.type _ seq; EXIT };
            ENDCASE => ERROR;
                ENDLOOP;
            IF flushComments AND token.type=seq THEN SELECT token.seq FROM
                sequenceComment => LOOP;
                sequenceContinued => IF NOT first THEN LOOP;
            ENDCASE;
            RETURN[token];
            ENDLOOP;
        };

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

    GetUnsigned: PUBLIC 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];
        };
        <<>>
    IntFromData: PUBLIC PROC[text: REF READONLY TEXT, 
    start: NAT _ 0, len: NAT _ NAT.LAST] RETURNS[int: 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;
            IF int<=INT.LAST/400B THEN int _ int*400B+byte
            ELSE ERROR Error[overflow, "overflow in IntFromData"];
            ENDLOOP;
        IF neg THEN int _ -1-int;
        };
        <<>>

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

    PutShortOp: PUBLIC PROC[stream: STREAM, ev: EncodingValue[VAL[0]..VAL[37B]]] ~ {
        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: [0..377B]] ~ {
        x: [0..37B] ~ ORD[seq];
        IO.PutChar[stream, VAL[300B+x]];
        IO.PutChar[stream, VAL[len]];
        };
    PutLongSequence: PUBLIC PROC[stream: STREAM, seq: SequenceType, len: INT] ~ {
        x: [0..37B] ~ ORD[seq];
    lenH: [0..377B] ~ Basics.HighHalf[len]; -- this does the 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: PROC[i: INT] RETURNS[[0..4]] ~ {
        SELECT i FROM
            IN[-LONG[200B]..LONG[200B]) => RETURN[1];
            IN[-LONG[100000B]..LONG[100000B]) => RETURN[2];
            IN[-40000000B..40000000B) => RETURN[3];
            ENDCASE => RETURN[4];
        };

    PutUnsigned: PUBLIC PROC[stream: STREAM, len: [0..4], val: CARD] ~ {
        IF len>3 THEN IO.PutChar[stream, VAL[LOOPHOLE[val, Basics.LongNumber].hh]];
        IF len>2 THEN IO.PutChar[stream, VAL[LOOPHOLE[val, Basics.LongNumber].hl]];
        IF len>1 THEN IO.PutChar[stream, VAL[LOOPHOLE[val, Basics.LongNumber].lh]];
        IF len>0 THEN IO.PutChar[stream, VAL[LOOPHOLE[val, Basics.LongNumber].ll]];
        };

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

    PutDescriptor: PUBLIC PROC[stream: STREAM, seq: SequenceType, len: INT] ~ {
        IF len IN[0..377B] THEN PutShortSequence[stream, seq, len]
        ELSE PutLongSequence[stream, seq, len];
        };


    PutOp: PUBLIC PROC[stream: STREAM, op: Op] ~ {
        ev: EncodingValue ~ evFromOp[op];
        IF ORD[ev] IN[0..37B] THEN PutShortOp[stream, ev]
        ELSE PutLongOp[stream, ev];
        };
        <<>>
    PutInt: PUBLIC PROC[stream: STREAM, n: INT] ~ {
        <<Appends a Number literal.>>
        IF n IN ShortNumber THEN PutShortNumber[stream, n]
        ELSE {
            len: [0..4] ~ BytesInInt[n];
            PutShortSequence[stream, sequenceInteger, len];
            PutSigned[stream, len, n];
            };
        };
        <<>>
    PutBool: PUBLIC PROC[stream: STREAM, bool: BOOL] ~ {
        PutShortNumber[stream, IF bool THEN 1 ELSE 0];
        };
        <<>>
    PutRational: PUBLIC PROC[stream: STREAM, n, d: INT] ~ {
        len: [0..4] ~ MAX[BytesInInt[n], BytesInInt[d]];
        PutShortSequence[stream, sequenceRational, 2*len];
        PutSigned[stream, len, n];
        PutSigned[stream, len, d];
        };

    tryDecimal: BOOL _ FALSE;
    tryShortRational: 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;
            PutDescriptor[stream, sequenceInteger, 4+tail];
            PutSigned[stream, 4, Real.RoundLI[r]];
            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 tryShortRational THEN {
            rat: ShortRational.Rational _ ShortRational.FromReal[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];
        };

    PutRope: PROC[stream: STREAM, seq: SequenceType, 
    rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] ~ {
        size: INT ~ Rope.Length[rope];
        rem: INT ~ NonNeg[size-NonNeg[start]];
        length: INT ~ MIN[len, rem];
        PutDescriptor[stream, seq, length];
        FOR i: INT IN[start..start+length) DO
            IO.PutChar[stream, Rope.Fetch[rope, i]];
            ENDLOOP;
        };

    PutIdentifier: PUBLIC PROC[stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] ~ {
        <<Appends an Identifier literal.>>
        <<! Error[invalidIdentifier] if the rope is not a legal identifier.>>
        IF ValidIdentifier[rope, start, len] THEN PutRope[stream, sequenceIdentifier, rope, start, len]
        ELSE ERROR Error[invalidIdentifier, "invalid identifier"];
        };

    PutString: PUBLIC PROC[stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] ~ {
        <<Appends the encoding notation for a string. Treats '\377 as an escape code.>>
        <<See the Character Code Standard, chapter 6, and Interpress, section 2.5.3.>>
        <<! Error[invalidString] if the rope is not a legal string.>>
        IF ValidString[rope, start, len] THEN PutRope[stream, sequenceString, rope, start, len]
        ELSE ERROR Error[invalidString, "invalid string"];
        };

    PutComment: PUBLIC PROC[stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] ~ {
        <<Appends a comment token.>>
        PutRope[stream, sequenceComment, rope, start, len];
        };

    PutInsertFile: PUBLIC PROC[stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] ~ {
        <<Appends a sequenceInsertFile.>>
        PutRope[stream, sequenceInsertFile, rope, start, len];
        };
        <<>>
    PutName: PUBLIC PROC[stream: STREAM, rope: ROPE, start: INT _ 0, len: INT _ INT.LAST] ~ {
        <<Parses a structured name and appends tokens to build a Vector of Identifiers.>>
        <<For example, "a/b/c" produces < a b c 3 MAKEVEC >; "foo" produces < foo 1 MAKEVEC >.>>
        <<See Interpress, section 3.2.1.>>
        <<! Error[invalidIdentifier] if the name contains an invalid identifier.>>
        depth: INT _ 0;
        action: PROC[base: ROPE, start, len: INT] RETURNS[BOOL _ FALSE] ~ {
            PutIdentifier[stream, base, start, len];
            depth _ depth+1;
            };
        [] _ MapName[rope, start, len, action];
        PutInt[stream, depth];
        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.ZERO[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;
        };


    END.