<<>>
    <<SchemePrimitivesImpl.mesa>>
        <<Copyright Ó 1987, 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Michael Plass, December 2, 1991 10:25 am PST>>
        <<Last changed by Pavel on March 20, 1989 6:16:08 pm PST>>
        <<>>
    DIRECTORY
        Ascii USING [CR, Digit, FF, Letter, LF, Lower, SP, TAB, Upper],
        Atom USING [GetPName, MakeAtom],
        Basics USING [BITXOR, CompareCard, Comparison, LongNumber],
        BigCardinals USING [BigToREAL],
        IO,
        List USING [Compare, CompareProc, Sort],
        Random USING [ChooseInt],
        Rope USING [AppendChars, Cat, Compare, Concat, Fetch, Flatten, FromChar, FromProc, Match, ROPE, Size, Substr, Text],
        SafeStorage USING [GetReferentType, Type],
        Scheme,
        SchemePrivate,
        SchemeSys USING [CheckForAbort];

    SchemePrimitivesImpl: CEDAR PROGRAM
    IMPORTS Ascii, Atom, Basics, BigCardinals, IO, List, Random, Rope, SafeStorage, Scheme, SchemeSys
    EXPORTS Scheme
    ~ BEGIN OPEN Scheme, SchemePrivate;

        ROPE: TYPE ~ Rope.ROPE;

        PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any Ź NIL];
<<Support for primitives>>
    MakeBoolean: PUBLIC PROC [b: BOOL] RETURNS [Any] ~ {
        RETURN [IF b THEN true ELSE false]
        };

    TheBOOL: PUBLIC PROC [any: Any] RETURNS [BOOL] ~ {
        RETURN [SELECT any FROM true => TRUE, false => FALSE ENDCASE => ERROR Complain[any, "neither #t or #f"]]
        };

    True: PUBLIC PROC [any: Any] RETURNS [BOOL] ~ {
        RETURN [SELECT any FROM false, NIL => FALSE ENDCASE => TRUE]
        };

    False: PUBLIC PROC [any: Any] RETURNS [BOOL] ~ {
        RETURN [SELECT any FROM false, NIL => TRUE ENDCASE => FALSE]
        };

    MakeChar: PUBLIC PROC [char: CHAR] RETURNS [Char] ~ {
        RETURN [charTable[char]]
        };

    TheChar: PUBLIC PROC [any: Any] RETURNS [Char] ~ {
        WITH any SELECT FROM
            c: Char => RETURN [c];
            ENDCASE => Complain[any, "not a character"];
        };

    TheROPE: PUBLIC PROC [a: Any] RETURNS [Rope.ROPE] ~ {
        WITH a SELECT FROM
            string: String => RETURN [RopeFromString[string]];
            rope: ROPE => RETURN [rope]; -- we're nice guys, but how did this happen?
            ENDCASE => Complain[a, "not a string"];
        };

    IsProcedure: PUBLIC PROC [a: Any] RETURNS [BOOL] ~ {
        WITH a SELECT FROM
            a: Primitive => RETURN [TRUE];
            a: TidbitProcedure => RETURN [TRUE];
            ENDCASE => RETURN [FALSE];
        };

    ProcedureDocumentation: PUBLIC PROC [a: Any] RETURNS [ROPE] ~ {
        WITH a SELECT FROM
            p: Primitive => RETURN [p.doc];
            p: TidbitProcedure => RETURN [p.code.doc];
            ENDCASE => Complain[a, "not a procedure"];
        };
<<Primitives>>
    HashPrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $eqHash => result Ź MakeFixnum[LOOPHOLE[a]];
            $eqvHash => {
                XOR: PROC [a, b: INT] RETURNS [INT] ~ INLINE {
                    RETURN[LOOPHOLE[DoubleXor[LOOPHOLE[a], LOOPHOLE[b]]]];
                    };
                DoubleXor: PROC [a,b: Basics.LongNumber] RETURNS [Basics.LongNumber] ~ INLINE {
                    RETURN [[pair[lo: Basics.BITXOR[a.lo, b.lo], hi: Basics.BITXOR[a.hi, b.hi]]]]
                    };
                EqvHash: PROC [a: Any] RETURNS [result: INT] ~ {
                    WITH a SELECT FROM
                        a: Fixnum =>
                            result Ź a­;
                        a: Flonum =>
                            result Ź LOOPHOLE[a.real];
                        a: Bignum =>
                            result Ź LOOPHOLE[BigCardinals.BigToREAL[a.magnitude]];
                        a: Ratnum =>
                            result Ź XOR[EqvHash[a.numerator], EqvHash[a.denominator]];
                        a: Complex =>
                            result Ź XOR[EqvHash[a.x], EqvHash[a.y]];
                        a: Char =>
                            result Ź ORD[a­] + 1000;
                        a: PrimitiveSyntax =>
                            result Ź ORD[a­] + 2000;
                        ENDCASE =>
                            result Ź LOOPHOLE[a];
                    };

                result Ź MakeFixnum[EqvHash[a]];
                };
            ENDCASE => ERROR;
        };

    RandomPrim: PrimitiveProc ~ {
        result Ź MakeFixnum[Random.ChooseInt[max: KCheck[a] - 1]];
        };

    EqPredPrim: PrimitiveProc ~ {
        result Ź IF a = b THEN true ELSE false;
        };

    EqvPredPrim: PrimitiveProc ~ {
        IF a = b THEN RETURN [true];
        WITH a SELECT FROM
            a: Fixnum => {
                WITH b SELECT FROM
                    b: Fixnum => {
                        RETURN [IF a­ = b­ THEN true ELSE false];
                        };
                    b: Number => {
                        RETURN [IF b.exact AND Arith[equality, a, b] # false THEN true ELSE false];
                        };
                    ENDCASE => RETURN [false];
                };
            a: Number => {
                WITH b SELECT FROM
                    b: Fixnum => {
                        RETURN [IF a.exact AND Arith[equality, a, b] # false THEN true ELSE false];
                        };
                    b: Number => {
                        RETURN [IF a.exact=b.exact AND Arith[equality, a, b] # false THEN true ELSE false];
                        };
                    ENDCASE => RETURN [false];
                };
            a: Char => {
                WITH b SELECT FROM
                    b: Char => RETURN [IF a­ = b­ THEN true ELSE false];
                    ENDCASE => RETURN [false];
                };
            a: PrimitiveSyntax => {
                WITH b SELECT FROM
                    b: PrimitiveSyntax => RETURN [IF a­ = b­ THEN true ELSE false];
                    ENDCASE => RETURN [false];
                };
            ENDCASE => RETURN [false];
        };

    ConsPrim: PrimitiveProc ~ { result Ź Cons[a, b] };

    ListPrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $list => RETURN [rest];
            $length => RETURN[MakeFixnum[ListLength[a]]];
            $reverse => RETURN[Reverse[a]];
            $sort => {
                predicate: Any ~ b;
                key: Any ~ c;
                zPair: Pair ~ Cons[NIL, NIL];
                yPair: Pair ~ Cons[NIL, zPair];
                List1: PROC [s: Any] RETURNS [Pair] ~ INLINE { zPair.car Ź s; RETURN [zPair] };
                List2: PROC [s, t: Any] RETURNS [Pair] ~ INLINE { yPair.car Ź s; zPair.car Ź t; RETURN [yPair] };
                Compare: List.CompareProc = {
                    <<[ref1: REF ANY, ref2: REF ANY] RETURNS [Basics.Comparison]>>
                    arg1: Any ~ IF key # undefined THEN Apply[proc: key, arguments: List1[ref1]] ELSE ref1;
                    arg2: Any ~ IF key # undefined THEN Apply[proc: key, arguments: List1[ref2]] ELSE ref2;
                    test: Any ~ Apply[proc: predicate, arguments: List2[arg1, arg2]];
                    RETURN [IF test = NIL OR test = false THEN less ELSE greater] -- sense is to sort list in reverse order
                    };
                lora: LIST OF REF ANY Ź NIL;
                result Ź NIL;
                FOR tail: Any Ź a, Cdr[tail] UNTIL tail = NIL DO
                    lora Ź CONS[Car[tail], lora];
                    ENDLOOP;
                RETURN [Reverse[List.Sort[list: lora, compareProc: Compare]]]
                };
            ENDCASE => ERROR;
        };


    CXRName: PROC [code: NAT] RETURNS [ROPE] ~ {
        <<Makes names like car, cdr, caar, ...>>
        <<code should be greater than 1>>
        rope: ROPE Ź "r";
        FOR s: NAT Ź code, s/2 UNTIL s = 1 DO
            rope Ź Rope.Concat[IF s MOD 2 = 0 THEN "a" ELSE "d", rope];
            ENDLOOP;
        RETURN [Rope.Concat["c", rope]];
        };

    CXRPrim: PrimitiveProc ~ {
        result Ź a;
        FOR s: NAT Ź NARROW[self.data, REF NAT]­, s/2 UNTIL s = 1 DO
            result Ź IF s MOD 2 = 0 THEN Car[result] ELSE Cdr[result];
            ENDLOOP;
        };

    SetPrim: PrimitiveProc ~ {
        result Ź unspecified;
        WITH a SELECT FROM
            p: Pair => {IF self.data = $car THEN p.car Ź b ELSE p.cdr Ź b};
            ENDCASE => Complain[a, "not a pair"];
        };

    TypePredPrim: PrimitiveProc ~ {
        <<The primitive's data field should be a LIST OF REF; returns true if the argument's type matches the type of any of the elements 
        of this LIST.>>
        prototypes: LIST OF REF ANY ~ NARROW[self.data];
        type: SafeStorage.Type ~ SafeStorage.GetReferentType[a];
        FOR each: LIST OF REF ANY Ź prototypes, each.rest UNTIL each = NIL DO
            IF type = SafeStorage.GetReferentType[each.first] THEN RETURN [true]
            ENDLOOP;
        RETURN [false]
        };

    MemberPrim: PrimitiveProc ~ {
        obj: Any ~ a;
        test: Primitive ~ NARROW[self.data];
        FOR list: Any Ź b, Cdr[list] UNTIL list = NIL DO
            first: Any ~ Car[list];
            IF first = obj OR (test#NIL AND test.proc[test, obj, first, NIL, NIL]#false) THEN RETURN [list];
            SchemeSys.CheckForAbort[];
            ENDLOOP;
        RETURN [false]
        };

    AssocPrim: PrimitiveProc ~ {
        obj: Any ~ a;
        test: Primitive ~ NARROW[self.data];
        FOR list: Any Ź b, Cdr[list] UNTIL list = NIL DO
            first: Any ~ Car[list];
            key: Any ~ Car[first];
            IF key = obj OR (test#NIL AND test.proc[test, obj, key, NIL, NIL]#false) THEN RETURN [first];
            SchemeSys.CheckForAbort[];
            ENDLOOP;
        RETURN [false]
        };

    VectorPrim: PrimitiveProc ~ {
        WITH a SELECT FROM
            v: SimpleVector => {
                SELECT self.data FROM
                    $length => RETURN [MakeFixnum[v.length]];
                    $ref => {i: INT ~ KCheck[b, v.length-1]; RETURN [v[i]]};
                    $set => {i: INT ~ KCheck[b, v.length-1]; v[i] Ź c; RETURN [unspecified]};
                    ENDCASE => ERROR;
                };
            v: Vector => {
                SELECT self.data FROM
                    $length => RETURN [MakeFixnum[v.length]];
                    $ref => {i: INT ~ KCheck[b, v.length-1]; RETURN [v.ref[v, i]]};
                    $set => {i: INT ~ KCheck[b, v.length-1]; v.set[v, i, c]; RETURN [unspecified]};
                    ENDCASE => ERROR;
                };
            ENDCASE => Complain[a, "not a vector"];
        };

    MakePrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $string => {
                fill: CHAR ~ IF b = undefined THEN '\040 ELSE TheChar[b]­;
                RETURN [StringFromRope[FillRope[fill: fill, length: KCheck[a]]]];
                };
            $vector => {
                length: NAT ~ KCheck[a, NAT.LAST-8];
                fill: Any ~ IF b = undefined THEN NIL ELSE b;
                v: SimpleVector ~ NEW[SimpleVectorRep[length]];
                FOR i: NAT IN [0..length) DO v[i] Ź fill ENDLOOP;
                RETURN [v]
                };
            ENDCASE => ERROR;
        };

    ConvertPrim: PrimitiveProc ~ {
        types: LIST OF REF ~ NARROW[self.data];
        target: REF ~ types.rest.first;
        SELECT types.first FROM
            $symbol => {
                WITH a SELECT FROM
                    a: Symbol => {
                        SELECT target FROM
                            $string => {RETURN [StringFromRope[RopeFromSymbol[a]]]};
                            ENDCASE => ERROR;
                        };
                    ENDCASE => Complain[a, "not a symbol"];
                };
            $string => {
                WITH a SELECT FROM
                    a: String => {
                        SELECT target FROM
                            $symbol => {RETURN [SymbolFromRope[RopeFromString[a]]]};
                            $list => {
                                list: Any Ź NIL;
                                FOR i: INT DECREASING IN [0..StringLength[a]) DO
                                    list Ź Cons[MakeChar[StringRef[a, i]], list];
                                    ENDLOOP;
                                RETURN [list]
                                };
                            ENDCASE => ERROR;
                        };
                    ENDCASE => Complain[a, "not a string"];
                };
            $list => {
                length: INT Ź 0;
                FOR each: Any Ź a, Cdr[each] UNTIL each = NIL DO
                    length Ź length + 1;
                    ENDLOOP;
                SELECT target FROM
                    $vector => {
                        IF length <= NAT.LAST-8
                            THEN {
                                v: SimpleVector ~ NEW[SimpleVectorRep[length]];
                                i: NAT Ź 0;
                                FOR each: Any Ź a, Cdr[each] UNTIL each = NIL DO
                                    v[i] Ź Car[each];
                                    i Ź i + 1;
                                    ENDLOOP;
                                RETURN [v];
                                }
                            ELSE Complain[a, "too long to convert to a vector"];
                        };
                    $string => {
                        rest: Any Ź a;
                        P: PROC RETURNS [CHAR] ~ {
                            c: Any Ź Car[rest];
                            rest Ź Cdr[rest];
                            RETURN [TheChar[c]­]
                            };
                        rope: ROPE ~ Rope.FromProc[len: length, p: P];
                        RETURN [StringFromRope[rope]]
                        };
                    ENDCASE => ERROR;
                };
            $char => {
                WITH a SELECT FROM
                    c: Char => {
                        SELECT target FROM
                            $integer => RETURN [MakeFixnum[ORD[c­]]];
                            ENDCASE => ERROR;
                        };
                    ENDCASE => Complain[a, "not a character"];
                };
            $integer => {
                SELECT target FROM
                    $char => RETURN [MakeChar[VAL[BYTE[KCheck[a]]]]];
                    ENDCASE => ERROR;
                };
            ENDCASE => ERROR;
        };

    gensymCounter: CARD Ź 0;

    GensymPrim: PrimitiveProc ~ {
        prefix: ROPE ~ IF a = undefined THEN "t" ELSE RopeFromString[TheString[a]];
        THROUGH [0..10000) DO
            trial: Rope.Text ~ Rope.Flatten[IO.PutFR["%g%g", [rope[prefix]], [cardinal[gensymCounter]]]];
            atom: ATOM ~ Atom.MakeAtom[trial];
            gensymCounter Ź gensymCounter + 1;
            IF Atom.GetPName[atom] = trial THEN RETURN [atom];
                <<Note this relies on MakeAtom and GetPName to not copy a flat rope.>>
            ENDLOOP;
        ERROR; -- somebody probably changed AtomImpl.
        };
    RecordPrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $make => result Ź NEW[RecordRep[KCheck[a]]];
            $test => 
                WITH a SELECT FROM
                    r: Record => result Ź true;
                    ENDCASE => result Ź false;
            $length => 
                WITH a SELECT FROM
                    r: Record => result Ź MakeFixnum[r.length];
                    ENDCASE => Complain[a, "not a structure"];
            $ref => 
                WITH a SELECT FROM
                    r: Record => result Ź r[KCheck[b, r.length - 1]];
                    ENDCASE => Complain[a, "not a structure"];
            $set => 
                WITH a SELECT FROM
                    r: Record => {
                        r[KCheck[b, r.length - 1]] Ź c;
                        result Ź unspecified;
                        };
                    ENDCASE => Complain[a, "not a structure"];
            ENDCASE => ERROR;
        };
<<Comparison Primitives>>
    CompareDataRep: TYPE ~ RECORD [type: ATOM, case: BOOL, min: Basics.Comparison, max: Basics.Comparison];
    ComparePrim: PrimitiveProc ~ {
        data: REF CompareDataRep ~ NARROW[self.data];
        comparison: Basics.Comparison Ź equal;
        SELECT data.type FROM
            $string => { comparison Ź Rope.Compare[s1: RopeFromString[TheString[a]], s2: RopeFromString[TheString[b]], case: data.case] };
            $char => {
                IF data.case
                    THEN comparison Ź Basics.CompareCard[ORD[TheChar[a]­], ORD[TheChar[b]­]]
                    ELSE {
                        c1: CHAR Ź TheChar[a]­;
                        c2: CHAR Ź TheChar[b]­;
                        IF c1 <= 'Z AND c1 >= 'A THEN c1 Ź c1 + ('a-'A);
                        IF c2 <= 'Z AND c2 >= 'A THEN c2 Ź c2 + ('a-'A);
                        comparison Ź Basics.CompareCard[ORD[c1], ORD[c2]];
                        };
                };
            $numeric => {
                rc: REF Basics.Comparison ~ NARROW[Arith[compare, a, b]];
                comparison Ź rc­;
                };
            ENDCASE => ERROR;
        RETURN [IF comparison IN [data.min..data.max] THEN true ELSE false]
        };

    NAryComparePrim: PrimitiveProc ~ {
        prev: Any Ź b;
        result Ź ComparePrim[self, a, b, undefined, NIL];
        WHILE result = true AND rest # NIL DO
            result Ź ComparePrim[self, prev, rest.car, undefined, NIL];
            prev Ź rest.car;
            rest Ź NARROW[rest.cdr];
            ENDLOOP;
        };

    DefineComparisons: PROC [type: ATOM, env: Environment, case: BOOL Ź TRUE, nAry: BOOL Ź FALSE] ~ {
        t: ARRAY [0..5) OF ROPE ~ ["<", "<=", "=", ">=", ">"];
        r: ARRAY [0..5) OF RECORD [min, max: Basics.Comparison] ~ [[less, less], [less, equal], [equal, equal], [equal, greater], [greater, 
        greater]];
        stem: ROPE ~ SELECT type FROM $string => "string", $char => "char", $numeric => NIL, ENDCASE => ERROR; 
        doc: ROPE Ź SELECT type FROM
            $string => (IF case THEN "case-sensitive string " ELSE "case-insensitive string "),
            $char => (IF case THEN "case-sensitive character " ELSE "case-insensitive character "),
            $numeric => ("numerical "),
            ENDCASE => ERROR; 
        prim: PrimitiveProc ~ IF nAry THEN NAryComparePrim ELSE ComparePrim;
        IF nAry THEN 
            doc Ź Rope.Concat["n-ary ", doc];
        FOR i: NAT IN [0..5) DO
            name: ROPE ~ IF stem = NIL THEN t[i] ELSE Rope.Cat[stem, IF case THEN NIL ELSE "-ci", t[i], "?"];
            DefinePrimitive[name: name, nArgs: 2, dotted: nAry, proc: prim, env: env,
            doc: Rope.Cat[doc, t[i], " test"], data: NEW[CompareDataRep Ź [type: type, case: case, min: r[i].min, max: r[i].max]]];
            ENDLOOP;
        };
<<String/Character Primitives>>
    charTable: REF ARRAY CHAR OF Char ~ InitCharTable[];
        InitCharTable: PROC RETURNS [a: REF ARRAY CHAR OF Char] ~ {
            a Ź NEW[ARRAY CHAR OF Char];
            FOR i: CHAR IN CHAR DO
                a[i] Ź NEW[CHAR Ź i];
                ENDLOOP;
            };


    CharPrim: PrimitiveProc ~ {
        c1: CHAR Ź TheChar[a]­;
        SELECT self.data FROM
            $alphaPred => {RETURN [IF Ascii.Letter[c1] THEN true ELSE false]};
            $upperPred => {
                RETURN [
                    SELECT c1 FROM
                        IN ['a..'z] => false,
                        IN ['A..'Z] => true
                        ENDCASE => Complain[a, "not a letter"]
                    ]
                };
            $lowerPred => {
                RETURN [
                    SELECT c1 FROM
                        IN ['a..'z] => true,
                        IN ['A..'Z] => false
                        ENDCASE => Complain[a, "not a letter"]
                    ]
                };
            $numericPred => {RETURN [IF Ascii.Digit[c1] THEN true ELSE false]};
            $whitespacePred => {
                RETURN [
                    SELECT c1 FROM
                        Ascii.SP, Ascii.CR, Ascii.TAB, Ascii.LF, Ascii.FF => true
                        ENDCASE => false
                    ]
                };
            $upcase => {RETURN [MakeChar[Ascii.Upper[c1]]]};
            $downcase => {RETURN [MakeChar[Ascii.Lower[c1]]]};
            ENDCASE => ERROR;
        };

    StringLength: PUBLIC PROC [string: String] RETURNS [INT] ~ {
        RETURN [MAX[Rope.Size[string.base], (IF string.buffer = NIL THEN 0 ELSE string.where+string.buffer.length)]]
        };

    StringRef: PUBLIC PROC [string: String, i: INT] RETURNS [CHAR] ~ {
        RETURN [IF string.buffer # NIL AND i IN [string.where..string.where+string.buffer.length) THEN string.buffer[i-string.where] ELSE 
        Rope.Fetch[string.base, i]]
        };

    maxStringBufferSize: NAT Ź 60;
    StringSet: PUBLIC PROC [string: String, i: INT, c: CHAR] ~ {
        length: INT ~ StringLength[string];
        IF string.buffer = NIL THEN string.buffer Ź NEW[TEXT[MIN[length, maxStringBufferSize]]];
        IF i NOT IN [string.where..string.where + string.buffer.length) THEN {
            [] Ź RopeFromString[string];
            string.where Ź IF i < string.where THEN MAX[0, i-string.buffer.maxLength/2] ELSE i;
            [] Ź Rope.AppendChars[buffer: string.buffer, rope: string.base, start: string.where];
            };
        string.buffer[i-string.where] Ź c;
        };

    TheString: PUBLIC PROC [any: Any] RETURNS [String] ~ {
        WITH any SELECT FROM
            s: String => RETURN [s];
            ENDCASE => Complain[any, "not a string"];
        };

    StringPrim: PrimitiveProc ~ {
        string: String Ź TheString[a];
        SELECT self.data FROM
            $length => RETURN [MakeFixnum[StringLength[string]]];
            $ref => RETURN [MakeChar[StringRef[string, KCheck[b, StringLength[string]-1]]]];
            $set => {StringSet[string, KCheck[b, StringLength[string]-1], TheChar[c]­]; RETURN [unspecified]};
            $substring => {
                length: INT ~ StringLength[string];
                start: INT ~ KCheck[b, length];
                end: INT ~ KCheck[c, length];
                IF NOT (0 <= start) AND (start <= end) AND (end <= length) THEN
                    Complain[Cons[a, Cons[b, NIL]], "invalid substring"];
                RETURN [StringFromRope[Rope.Substr[base: RopeFromString[string], start: start, len: end-start]]]};
            $append => {
                RETURN [
                    StringFromRope[Rope.Concat[RopeFromString[string],
                              RopeFromString[TheString[b]]]]]
                };
            $copy => { RETURN [StringFromRope[RopeFromString[string]]] };
            $fill => {
                fill: CHAR ~ TheChar[b]­;
                [] Ź RopeFromString[string];
                string.base Ź FillRope[fill, Rope.Size[string.base]];
                RETURN [unspecified]
                };
            $stringmatch, $stringcimatch => {
                pattern: ROPE ~ RopeFromString[string];
                target: ROPE ~ WITH b SELECT FROM b: Symbol => RopeFromSymbol[b] ENDCASE => RopeFromString[TheString[b]];
                RETURN [IF Rope.Match[pattern: pattern, object: target, case: self.data=$stringmatch] THEN true ELSE false];
                };
            ENDCASE => ERROR;
        };

    FillRope: PROC [fill: CHAR, length: INT] RETURNS [ROPE] ~ {
        r: ROPE Ź Rope.FromChar[fill];
        UNTIL Rope.Size[r] = length DO
            r Ź Rope.Concat[r, Rope.Substr[r, 0, length-Rope.Size[r]]];
            ENDLOOP;
        RETURN [r]
        };

<<Syntax Primitives>>
    symbolForPrimitiveSyntaxRep: PUBLIC REF ARRAY PrimitiveSyntaxRep OF Symbol ~ NEW[ARRAY PrimitiveSyntaxRep OF Symbol Ź [quote: 
    $quote, define: $define, setBang: SymbolFromRope["set!"], lambda: $lambda, begin: $begin, if: $if]];

    primitiveSyntaxForPrimitiveSyntaxRep: PUBLIC REF ARRAY PrimitiveSyntaxRep OF PrimitiveSyntax ~ InitRefForPrimitiveSyntax[];
        InitRefForPrimitiveSyntax: PROC RETURNS [a: REF ARRAY PrimitiveSyntaxRep OF PrimitiveSyntax] ~ {
            a Ź NEW[ARRAY PrimitiveSyntaxRep OF PrimitiveSyntax];
            FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
                a[p] Ź NEW[PrimitiveSyntaxRep Ź p];
                ENDLOOP;
            };

    ExpandPrimitiveSyntaxPrim: PrimitiveProc ~ {
        IF self.maxArgs >= 3 THEN rest Ź Cons[c, rest];
        IF self.maxArgs >= 2 THEN rest Ź Cons[b, rest];
        IF self.maxArgs >= 1 THEN rest Ź Cons[a, rest];
        RETURN [Cons[self.data, rest]]
        };

    SyntaxPrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $make => {
                syntax: Syntax ~ NEW[SyntaxRep];
                IF IsProcedure[a] THEN 
                    syntax.expander Ź a
                ELSE
                    Complain[a, "not a procedure"];
                result Ź syntax;
                };
            $syntaxP => {
                WITH a SELECT FROM
                    s: Syntax => RETURN [true];
                    ENDCASE => RETURN [false];
                };
            $expander => {
                WITH a SELECT FROM
                    s: Syntax => RETURN [s.expander];
                    ENDCASE => Complain[a, "not a syntax object"];
                };
            $toSymbol => {
                WITH a SELECT FROM
                    p: PrimitiveSyntax => RETURN [symbolForPrimitiveSyntaxRep[p­]];
                    ENDCASE => Complain[a, "not a primitive-syntax-marker"];
                };
            $toMarker => {
                FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
                    IF symbolForPrimitiveSyntaxRep[p] = a THEN RETURN [primitiveSyntaxForPrimitiveSyntaxRep[p]]
                    ENDLOOP;
                Complain[a, "not the name of a primitive-syntax-marker"];
                };
            $primitiveSyntaxP => {
                WITH a SELECT FROM
                    p: PrimitiveSyntax => RETURN [true];
                    ENDCASE => RETURN [false];
                };
            ENDCASE => ERROR;
        };
<<Registration of Primitives>>
    RegisterEssentials: PROC [env: Environment] ~ {
        nArgsPS: ARRAY PrimitiveSyntaxRep OF NAT ~ [quote: 1, define: 2, setBang: 2, lambda: 1, begin: 0, if: 3];
        dottedPS: ARRAY PrimitiveSyntaxRep OF BOOL ~ [quote: FALSE, define: FALSE, setBang: FALSE, lambda: TRUE, begin: TRUE, if: FALSE];
        FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
            symbol: Symbol ~ symbolForPrimitiveSyntaxRep[p];
            expander: Primitive ~ NEW[PrimitiveRep Ź [minArgs: nArgsPS[p], maxArgs: nArgsPS[p], dotted: dottedPS[p], proc: 
            ExpandPrimitiveSyntaxPrim, doc: Rope.Concat[RopeFromSymbol[symbol], " primitive syntax"], data: NEW[PrimitiveSyntaxRep 
            Ź p], symbol: symbol]];
            value: Syntax ~ NEW[SyntaxRep Ź [expander: expander]];
            DefineVariable[variable: symbol, value: value, env: env];
            ENDLOOP;
        DefineComparisons[type: $numeric, env: env];
        DefineComparisons[type: $string, env: env, case: TRUE];
        DefineComparisons[type: $char, env: env, case: TRUE];
        DefinePrimitive[name: "eq?", nArgs: 2, dotted: FALSE, proc: EqPredPrim, env: env,
        doc: "Pointer equality"];
        DefinePrimitive[name: "eqv?", nArgs: 2, dotted: FALSE, proc: EqvPredPrim, env: env,
        doc: "operational equivalence"];
        DefinePrimitive[name: "cons", nArgs: 2, dotted: FALSE, proc: ConsPrim, env: env,
        doc: "New pair"];
        FOR i: NAT IN [2..32) DO
            name: ROPE ~ CXRName[i];
            DefinePrimitive[name: name, nArgs: 1, dotted: FALSE, proc: CXRPrim, env: env, data: NEW[NAT Ź i], doc: name];
            ENDLOOP;
        DefinePrimitive[name: "list", nArgs: 0, dotted: TRUE, proc: ListPrim, env: env, data: $list, doc: "Construct a list of the 
        arguments"];
        DefinePrimitive[name: "length", nArgs: 1, dotted: FALSE, proc: ListPrim, env: env, data: $length, doc: "length of a list"];
        DefinePrimitive[name: "boolean?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env, data: LIST[false], doc: "test for boolean 
        type"];
        DefinePrimitive[name: "char?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env, data: LIST[MakeChar['a]], doc: "test for 
        character type"];
        DefinePrimitive[name: "pair?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
        data: LIST[Cons[NIL, NIL], LIST[NIL]], doc: "test for pair type"];
        DefinePrimitive[name: "symbol?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
        data: LIST[$a], doc: "test for symbol type"];
        DefinePrimitive[name: "vector?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
        data: LIST[NEW[SimpleVectorRep[0]], NEW[VectorRep Ź [0, NIL, NIL, NIL]]], doc: "test for vector type"];
        DefinePrimitive[name: "string?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
        data: LIST[emptyString], doc: "test for string type"];
        DefinePrimitive[name: "procedure?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
        data: LIST[NEW[PrimitiveRep], NEW[TidbitProcedureRep]], doc: "test for procedure type"];
        DefinePrimitive[name: "number?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env, data: LIST[MakeFixnum[0], NEW[NumberRep Ź 
        [TRUE, flonum[0.0]]]], doc: "test for number type"];
        DefinePrimitive[name: "memv", nArgs: 2, dotted: FALSE, proc: MemberPrim, env: env, data: 
        LookupVariableValue[SymbolFromRope["eqv?"], env], doc: "membership test using eqv?"];
        DefinePrimitive[name: "memq", nArgs: 2, dotted: FALSE, proc: MemberPrim, env: env, data: NIL, doc: "membership test using eq?"];
        DefinePrimitive[name: "assv", nArgs: 2, dotted: FALSE, proc: AssocPrim, env: env, data: LookupVariableValue[SymbolFromRope["eqv?"], 
        env], doc: "association list lookup using eqv?"];
        DefinePrimitive[name: "assq", nArgs: 2, dotted: FALSE, proc: AssocPrim, env: env, data: NIL, doc: "association list lookup using 
        eq?"];
        DefinePrimitive[name: "set-car!", nArgs: 2, dotted: FALSE, proc: SetPrim, env: env, data: $car, doc: "Store object in car field"];
        DefinePrimitive[name: "set-cdr!", nArgs: 2, dotted: FALSE, proc: SetPrim, env: env, data: $cdr, doc: "Store object in cdr field"];
        DefinePrimitive[name: "symbol->string", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$symbol, $string], doc: 
        "convert a symbol to a string"];
        DefinePrimitive[name: "string->symbol", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$string, $symbol], doc: 
        "convert a string to a symbol"];
        DefinePrimitive[name: "string->list", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$string, $list], doc: 
        "convert a string to a list"];
        DefinePrimitive[name: "list->string", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$list, $string], doc: 
        "convert a list to a string"];
        DefinePrimitive[name: "list->vector", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$list, $vector], doc: 
        "convert a list to a vector"];
        DefinePrimitive[name: "char->integer", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$char, $integer], doc: 
        "convert a char to an integer"];
        DefinePrimitive[name: "integer->char", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$integer, $char], doc: 
        "convert an integer to a char"];
        DefinePrimitive[name: "make-string", nArgs: 2, optional: 1, dotted: FALSE, proc: MakePrim, env: env, data: $string, doc: "make a 
        new string"];
        DefinePrimitive[name: "string-length", nArgs: 1, dotted: FALSE, proc: StringPrim, env: env, data: $length, doc: "length of a 
        string"];
        DefinePrimitive[name: "string-ref", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $ref, doc: "element b in string a"];
        DefinePrimitive[name: "string-set!", nArgs: 3, dotted: FALSE, proc: StringPrim, env: env, data: $set, doc: "set element b in string 
        a to c"];
        DefinePrimitive[name: "substring", nArgs: 3, dotted: FALSE, proc: StringPrim, env: env, data: $substring, doc: "substring of a 
        starting at b and ending before c"];
        DefinePrimitive[name: "string-copy", nArgs: 1, dotted: FALSE, proc: StringPrim, env: env, data: $copy, doc: "copy the string"];
        DefinePrimitive[name: "essential-string-append", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $append, doc: "append 
        two strings"];
        DefinePrimitive[name: "string-fill!", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $fill, doc: "fill string a with 
        character b"];
        DefinePrimitive[name: "make-vector", nArgs: 2, optional: 1, dotted: FALSE, proc: MakePrim, env: env, data: $vector, doc: "make a 
        new vector"];
        DefinePrimitive[name: "vector-length", nArgs: 1, dotted: FALSE, proc: VectorPrim, env: env, data: $length, doc: "length of a 
        vector"];
        DefinePrimitive[name: "vector-ref", nArgs: 2, dotted: FALSE, proc: VectorPrim, env: env, data: $ref, doc: "element b in vector a"];
        DefinePrimitive[name: "vector-set!", nArgs: 3, dotted: FALSE, proc: VectorPrim, env: env, data: $set, doc: "set element b in vector 
        a to c"];
        };

    RegisterOptionals: PROC [env: Environment] ~ {
        DefineComparisons[type: $numeric, env: env, nAry: TRUE];
        DefineComparisons[type: $string, env: env, case: TRUE, nAry: TRUE];
        DefineComparisons[type: $char, env: env, case: TRUE, nAry: TRUE];
        DefineComparisons[type: $string, env: env, case: FALSE, nAry: TRUE];
        DefineComparisons[type: $char, env: env, case: FALSE, nAry: TRUE];
        DefinePrimitive[name: "reverse", nArgs: 1, dotted: FALSE, proc: ListPrim, env: env, data: $reverse, doc: "reverse a list"];
        DefinePrimitive[name: "char-alphabetic?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $alphaPred,
        doc: "test for an alphabetic character"];
        DefinePrimitive[name: "char-upper-case?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $upperPred,
        doc: "test for an upper-case letter"];
        DefinePrimitive[name: "char-lower-case?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $lowerPred,
        doc: "test for a lower-case letter"];
        DefinePrimitive[name: "char-numeric?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $numericPred,
        doc: "test for a digit"];
        DefinePrimitive[name: "char-whitespace?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $whitespacePred,
        doc: "test for whitespace"];
        DefinePrimitive[name: "char-upcase", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $upcase,
        doc: "convert char to upper case"];
        DefinePrimitive[name: "char-downcase", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $downcase,
        doc: "convert char to lower case"];
        };

    RegisterExtensions: PROC [env: Environment] ~ {
        DefinePrimitive[name: "make-syntax", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
        doc: "Make a syntax object", data: $make];
        DefinePrimitive[name: "syntax?", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
        doc: "Is this a syntax expander?", data: $syntaxP];
        DefinePrimitive[name: "syntax-expander", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
        doc: "Extract the expansion function from a syntax object", data: $expander];
        DefinePrimitive[name: "primitive-syntax-marker->symbol", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
        doc: "Convert a primitive syntax marker to a symbol", data: $toSymbol];
        DefinePrimitive[name: "symbol->primitive-syntax-marker", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
        doc: "Convert a symbol to a primitive syntax marker", data: $toMarker];
        DefinePrimitive[name: "primitive-syntax-marker?", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
        doc: "test for a primitive syntax marker", data: $primitiveSyntaxP];
        DefinePrimitive[name: "gensym", nArgs: 1, optional: 1, dotted: FALSE, proc: GensymPrim, env: env, data: NIL, doc: "generate a new 
        symbol [with prefix a]"];
        DefinePrimitive[name: "sort", nArgs: 3, optional: 1, dotted: FALSE, proc: ListPrim, env: env, data: $sort, doc: "(list predicate [ 
        key ]) sort a list"];
        DefinePrimitive[name: "eq-hash", nArgs: 1, dotted: FALSE, proc: HashPrim, env: env, data: $eqHash, doc: "Hash function respecting 
        the EQ? predicate"];
        DefinePrimitive[name: "eqv-hash", nArgs: 1, dotted: FALSE, proc: HashPrim, env: env, data: $eqvHash, doc: "Hash function respecting 
        the EQV? predicate"];
        DefinePrimitive[name: "random", nArgs: 1, dotted: FALSE, proc: RandomPrim, env: env, doc: "Returns a random integer in the range 
        [0..a)"];
        DefinePrimitive[name: "string-match?", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $stringmatch, doc: 
        "(pattern-string target) Does pattern-string match target? Use \"*\" as a wildcard."];
        DefinePrimitive[name: "string-ci-match?", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $stringcimatch, doc: 
        "(pattern-string target) Does pattern-string match target, ignoring case?  Use \"*\" as a wildcard."];

        DefinePrimitive[name: "%make-record", nArgs: 1, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $make, doc: "(length) 
        PRIVATE: make a new structure object of the given length"];
        DefinePrimitive[name: "%record-ref", nArgs: 2, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $ref, doc: "(structure 
        index) PRIVATE: get a field of a structure"];
        DefinePrimitive[name: "%record-set!", nArgs: 3, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $set, doc: 
        "(structure index value) PRIVATE: set a field of a structure"];
        DefinePrimitive[name: "%record-length", nArgs: 1, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $length, doc: 
        "(structure) PRIVATE: return length of a structure object"];
        DefinePrimitive[name: "%record?", nArgs: 1, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $test, doc: "(value) 
        PRIVATE: is this a structure?"];
        };
<<Initalization>>
    RegisterInit[RegisterEssentials];
    RegisterInit[RegisterOptionals];
    RegisterInit[RegisterExtensions];

    END.