
<<MispLists.Mesa>>
<<Last Edited by: Spreitzer, July 30, 1985 2:08:27 pm PDT>>
    <<Pavel, June 20, 1985 1:34:09 pm PDT>>

    DIRECTORY Atom, IO, List, Misp, Real, Rope;

    MispLists: CEDAR PROGRAM
        IMPORTS Atom, IO, List, Misp, Rope
        EXPORTS Misp =

    BEGIN OPEN Misp;

    BoolSeq: TYPE = REF BoolSequence;
    BoolSequence: TYPE = RECORD [seq: SEQUENCE length: NAT OF BOOL];

    CXRCode: ARRAY BOOL OF ROPE = [FALSE: "a", TRUE: "d"];

    true: PUBLIC REF ANY _ $T;
    false: PUBLIC REF ANY _ NIL;

    ToBool: PUBLIC PROC [ra: REF ANY, e: Environment, s: Stack] RETURNS [BOOL] = {
        RETURN [ra # NIL]};

    BoolDecode: PUBLIC PROC [ra: REF ANY] RETURNS [isBool, value: BOOL] = {
        isBool _ TRUE;
        value _ ra # NIL;
        };

    DefineListStuff: PROC [environment: Environment] --EnvironmentProc-- =
        BEGIN
        DefineCXRs: PROC [n, i: NAT, pbs: BoolSeq] = {
            Work: PROC [b: BOOL] = {
                bs: BoolSeq _ NEW [BoolSequence[n]];
                name: ROPE _ Rope.Cat["c", CXRCode[b]];
                FOR j: NAT IN (i .. n] DO
                    name _ name.Cat[CXRCode[bs[j-1] _ pbs[j-1]]];
                    ENDLOOP;
                bs[i-1] _ b;
                SELECT i FROM
                    =1 => Defun[env: environment, name: Atom.MakeAtom[name.Cat["r"]], eval: EvalCXR, data: bs];
                    >1 => DefineCXRs[n, i-1, bs];
                    ENDCASE => ERROR;
                };
            Work[TRUE];
            Work[FALSE];
            };

        FOR n: NAT IN [1 .. 4] DO
            DefineCXRs[n, n, NIL]
            ENDLOOP;

        Defun[environment, $cons, EvalCons];
        <<Defun[environment, $car, EvalCar];    -- See DefineCXRs>>
        <<Defun[environment, $cdr, EvalCdr];>>
        Defun[environment, $and, EvalAnd, FALSE];
        Defun[environment, $or, EvalOr, FALSE];
        Defun[environment, $not, EvalNot];
        Defun[environment, $cond, EvalCond, FALSE];
        Defun[environment, $append, EvalAppend];
        Defun[environment, $mapcar, EvalMapCar];
        Defun[environment, $nth, EvalNth];
        Defun[environment, $length, EvalLength];
        Defun[environment, $rplaca, EvalRplaca];
        Defun[environment, $rplacd, EvalRplacd];
        Bind[$NIL, NIL, environment, FALSE];
        Bind[$T, $T, environment, FALSE];
        Bind[$nil, NIL, environment, FALSE];
        Bind[$t, $T, environment, FALSE];
        Bind[$true, true, environment, FALSE];
        Bind[$false, false, environment, FALSE];
        END;

    EvalCXR: EvalProc = {
        bs: BoolSeq _ NARROW[data];
        arg: REF ANY _ args.first;
        FOR i: NAT DECREASING IN [0 .. bs.length) DO
            lora: LORA _ NARROW[arg];
            arg _ SELECT bs[i] FROM
                FALSE => lora.first,
                TRUE => lora.rest,
                ENDCASE => ERROR;
            ENDLOOP;
        cooked _ arg;
        };

    EvalCons: EvalProc =
        BEGIN
        Tail: PROC [args: LORA] RETURNS [ans: LORA] =
            BEGIN
            IF args.rest = NIL THEN RETURN [NARROW[args.first]];
            ans _ CONS[args.first, Tail[args.rest]];
            END;
        cooked _ IF args = NIL THEN NIL ELSE Tail[args];
        END;

    <<EvalCar: EvalProc =>>
        <<BEGIN>>
        <<list: LORA _ NARROW[args.first];>>
        <<cooked _ list.first;>>
        <<END;>>
    <<>>
    <<EvalCdr: EvalProc =>>
        <<BEGIN>>
        <<list: LORA _ NARROW[args.first];>>
        <<cooked _ list.rest;>>
        <<END;>>

    EvalRplaca: EvalProc =
        BEGIN
        cons: LORA _ NARROW[args.first];
        elt: REF ANY _ args.rest.first;
        cons.first _ elt;
        cooked _ cons;
        END;

    EvalRplacd: EvalProc =
        BEGIN
        cons: LORA _ NARROW[args.first];
        elt: LORA _ NARROW[args.rest.first];
        cons.rest _ elt;
        cooked _ cons;
        END;

    EvalAnd: EvalProc =
        BEGIN
        cooked _ $T;
        FOR args _ args, args.rest WHILE args # NIL DO
            IF (cooked _ Eval[args.first, environment, stack]) = NIL THEN RETURN;
            ENDLOOP;
        END;

    EvalOr: EvalProc =
        BEGIN
        cooked _ NIL;
        FOR args _ args, args.rest WHILE args # NIL DO
            IF (cooked _ Eval[args.first, environment, stack]) # NIL THEN RETURN;
            ENDLOOP;
        END;

    EvalNot: EvalProc =
        BEGIN
        RETURN [IF args.first = NIL THEN $T ELSE NIL];
        END;

    EvalCond: EvalProc =
        BEGIN
        FOR args _ args, args.rest WHILE args # NIL DO
            arm: LORA _ NARROW[args.first];
            test: REF ANY _ Eval[arm.first, environment, stack];
            IF ToBool[test, environment, stack] THEN RETURN [IF arm.rest # NIL THEN Eval[arm.rest.first, environment, stack] ELSE test];
            ENDLOOP;
        cooked _ NIL;
        END;

    EvalAppend: EvalProc =
        BEGIN
        ans: LORA _ NIL;
        FOR args _ args, args.rest WHILE args # NIL DO
            next: LORA _ NARROW[args.first];
            ans _ List.Append[ans, next];
            ENDLOOP;
        cooked _ ans;
        END;

    EvalMapCar: EvalProc =
        BEGIN
        first, last: LORA _ NIL;
        fargs: LIST OF LORA _ NIL;
        fn: Closure _ NARROW[args.first];
        someNonEmpty, done: BOOLEAN _ FALSE;
        FOR args _ args.rest, args.rest WHILE args # NIL DO
            arg: LORA _ NARROW[args.first];
            fargs _ CONS[arg, fargs];
            IF arg # NIL THEN someNonEmpty _ TRUE;
            ENDLOOP;
        IF someNonEmpty THEN WHILE NOT done DO
            this: LORA;
            theseArgs: LORA _ NIL;
            done _ TRUE;
            FOR al: LIST OF LORA _ fargs, al.rest WHILE al # NIL DO
                theseArgs _ CONS[al.first.first, theseArgs];
                IF al.first.rest # NIL THEN {done _ FALSE; al.first _ al.first.rest};
                ENDLOOP;
            this _ LIST[ApplyFn[fn, theseArgs, environment, stack]];
            IF last = NIL THEN first _ this ELSE last.rest _ this;
            last _ this;
            ENDLOOP;
        cooked _ first;
        END;

    EvalNth: EvalProc =
        BEGIN
        nr: Int _ NARROW[args.first];
        lora: LORA _ NARROW[args.rest.first];
        n: CARDINAL _ nr^;
        FOR i: CARDINAL IN [1 .. n) DO
            IF (lora _ lora.rest) = NIL THEN ERROR Error[environment, stack, IO.PutFR["nth %g on list of length %g", IO.card[n], IO.card[i]]];
            ENDLOOP;
        cooked _ lora.first;
        END;

    EvalLength: EvalProc =
        BEGIN
        ans: INT _ 0;
        arg: LORA _ NARROW[args.first];
        FOR arg _ arg, arg.rest WHILE arg # NIL DO ans _ ans+1 ENDLOOP;
        cooked _ NEW [INT _ ans];
        END;

    Setup: PROC =
        BEGIN
        RegisterPrimitiveDefiner[DefineListStuff, front];
        END;

    Setup[];

    END.