reduce-historical/r36/cslbase/compiler.red

%
% Compiler from Lisp into byte-codes for use with CSL.
%       Copyright (C) Codemist Ltd, 1990-1996
%

% Pretty-well all internal functions defined here and all fluid and
% global variables have been written with names of the form s!:xxx. This
% might keep them away from most users.  In Common Lisp I may want to put
% them all in a package called "s".

global '(s!:opcodelist);

% The following list of opcodes must be kept in step with the corresponding
% C header file "bytes.h" in the CSL kernel code, and the source file
% "opnames.c".

in "$cslbase/opcodes.red"$

begin
  scalar n;
  n := 0;
  for each v in s!:opcodelist do <<
     put(v, 's!:opcode, n);
     n := n + 1 >>;
  return list(n, 'opcodes, 'allocated)
end;

s!:opcodelist := nil;

symbolic procedure s!:vecof l;
  begin
    scalar v, n;
    v := mkvect sub1 length l;
    n := 0;
    for each x in l do <<
       putv(v, n, x);
       n := n+1 >>;
    return v
  end;

<< put('batchp,                   's!:builtin0, 0);
   put('date,                     's!:builtin0, 1);
   put('eject,                    's!:builtin0, 2);
   put('error1,                   's!:builtin0, 3);
   put('gctime,                   's!:builtin0, 4);
%  put('gensym,                   's!:builtin0, 5);
   put('lposn,                    's!:builtin0, 6);
%  put('next!-random,             's!:builtin0, 7);
   put('posn,                     's!:builtin0, 8);
   put('read,                     's!:builtin0, 9);
!#endif
   put('readch,                   's!:builtin0, 10);
   put('terpri,                   's!:builtin0, 11);
!#if (not common!-lisp!-mode)
   put('time,                     's!:builtin0, 12);
!#endif
   put('tyi,                      's!:builtin0, 13);
% load!-spid is not for use by an ordinary programmer - it is used in the
% compilation of unwind!-protect.
   put('load!-spid,               's!:builtin0, 14);

   put('abs,                      's!:builtin1, 0);
   put('add1,                     's!:builtin1, 1);
!#if common!-lisp!-mode
   put('!1!+,                     's!:builtin1, 1);
!#endif
!#if (not common!-lisp!-mode)
   put('atan,                     's!:builtin1, 2);
!#endif
   put('apply0,                   's!:builtin1, 3);
   put('atom,                     's!:builtin1, 4);
   put('boundp,                   's!:builtin1, 5);
   put('char!-code,               's!:builtin1, 6);
   put('close,                    's!:builtin1, 7);
   put('codep,                    's!:builtin1, 8);
!#if (not common!-lisp!-mode)
   put('compress,                 's!:builtin1, 9);
!#endif
   put('constantp,                's!:builtin1, 10);
   put('digit,                    's!:builtin1, 11);
   put('endp,                     's!:builtin1, 12);
   put('eval,                     's!:builtin1, 13);
   put('evenp,                    's!:builtin1, 14);
   put('evlis,                    's!:builtin1, 15);
   put('explode,                  's!:builtin1, 16);
   put('explode2lc,               's!:builtin1, 17);
   put('explode2,                 's!:builtin1, 18);
   put('explodec,                 's!:builtin1, 18);
   put('fixp,                     's!:builtin1, 19);
!#if (not common!-lisp!-mode)
   put('float,                    's!:builtin1, 20);
!#endif
   put('floatp,                   's!:builtin1, 21);
   put('symbol!-specialp,         's!:builtin1, 22);
   put('gc,                       's!:builtin1, 23);
   put('gensym1,                  's!:builtin1, 24);
   put('getenv,                   's!:builtin1, 25);
   put('symbol!-globalp,          's!:builtin1, 26);
   put('iadd1,                    's!:builtin1, 27);
   put('symbolp,                  's!:builtin1, 28);
   put('iminus,                   's!:builtin1, 29);
   put('iminusp,                  's!:builtin1, 30);
   put('indirect,                 's!:builtin1, 31);
   put('integerp,                 's!:builtin1, 32);
!#if (not common!-lisp!-mode)
   put('intern,                   's!:builtin1, 33);
!#endif
   put('isub1,                    's!:builtin1, 34);
   put('length,                   's!:builtin1, 35);
   put('lengthc,                  's!:builtin1, 36);
   put('linelength,               's!:builtin1, 37);
   put('liter,                    's!:builtin1, 38);
   put('load!-module,             's!:builtin1, 39);
   put('lognot,                   's!:builtin1, 40);
!#if (not common!-lisp!-mode)
   put('macroexpand,              's!:builtin1, 41);
   put('macroexpand!-1,           's!:builtin1, 42);
!#endif
   put('macro!-function,          's!:builtin1, 43);
   put('make!-bps,                's!:builtin1, 44);
   put('make!-global,             's!:builtin1, 45);
   put('make!-simple!-string,     's!:builtin1, 46);
   put('make!-special,            's!:builtin1, 47);
   put('minus,                    's!:builtin1, 48);
   put('minusp,                   's!:builtin1, 49);
   put('mkvect,                   's!:builtin1, 50);
   put('modular!-minus,           's!:builtin1, 51);
   put('modular!-number,          's!:builtin1, 52);
   put('modular!-reciprocal,      's!:builtin1, 53);
   put('null,                     's!:builtin1, 54);
   put('oddp,                     's!:builtin1, 55);
   put('onep,                     's!:builtin1, 56);
   put('pagelength,               's!:builtin1, 57);
   put('pairp,                    's!:builtin1, 58);
   put('plist,                    's!:builtin1, 59);
   put('plusp,                    's!:builtin1, 60);
!#if (not common!-lisp!-mode)
   put('prin,                     's!:builtin1, 61);
   put('princ,                    's!:builtin1, 62);
   put('print,                    's!:builtin1, 63);
   put('printc,                   's!:builtin1, 64);
!#endif
%  put('random,                   's!:builtin1, 65);
   put('rational,                 's!:builtin1, 66);
%  put('load,                     's!:builtin1, 67);
   put('rds,                      's!:builtin1, 68);
   put('remd,                     's!:builtin1, 69);
!#if (not common!-lisp!-mode)
   put('reverse,                  's!:builtin1, 70);
!#endif
   put('reversip,                 's!:builtin1, 71);
   put('seprp,                    's!:builtin1, 72);
   put('set!-small!-modulus,      's!:builtin1, 73);
   put('spaces,                   's!:builtin1, 74);
   put('xtab,                     's!:builtin1, 74);   % = spaces?
   put('special!-char,            's!:builtin1, 75);
   put('special!-form!-p,         's!:builtin1, 76);
   put('spool,                    's!:builtin1, 77);
   put('stop,                     's!:builtin1, 78);
!#if (not common!-lisp!-mode)
   put('stringp,                  's!:builtin1, 79);
!#endif
   put('sub1,                     's!:builtin1, 80);
!#if common!-lisp!-mode
   put('!1!-,                     's!:builtin1, 80);
!#endif
   put('symbol!-env,              's!:builtin1, 81);
   put('symbol!-function,         's!:builtin1, 82);
   put('symbol!-name,             's!:builtin1, 83);
   put('symbol!-value,            's!:builtin1, 84);
   put('system,                   's!:builtin1, 85);
!#if (not common!-lisp!-mode)
   put('fix,                      's!:builtin1, 86);
!#endif
   put('ttab,                     's!:builtin1, 87);
   put('tyo,                      's!:builtin1, 88);
!#if (not common!-lisp!-mode)
   put('remob,                    's!:builtin1, 89);
!#endif
   put('unmake!-global,           's!:builtin1, 90);
   put('unmake!-special,          's!:builtin1, 91);
   put('upbv,                     's!:builtin1, 92);
!#if (not common!-lisp!-mode)
   put('vectorp,                  's!:builtin1, 93);
!#else
   put('simple!-vectorp,          's!:builtin1, 93);
!#endif
   put('verbos,                   's!:builtin1, 94);
   put('wrs,                      's!:builtin1, 95);
   put('zerop,                    's!:builtin1, 96);
% car, cdr etc will pretty-well always turn into single byte operations
% rather than the builtin calls listed here. So the next few lines are
% probably redundant.
   put('car,                      's!:builtin1, 97);
   put('cdr,                      's!:builtin1, 98);
   put('caar,                     's!:builtin1, 99);
   put('cadr,                     's!:builtin1, 100);
   put('cdar,                     's!:builtin1, 101);
   put('cddr,                     's!:builtin1, 102);
   put('qcar,                     's!:builtin1, 103);
   put('qcdr,                     's!:builtin1, 104);
   put('qcaar,                    's!:builtin1, 105);
   put('qcadr,                    's!:builtin1, 106);
   put('qcdar,                    's!:builtin1, 107);
   put('qcddr,                    's!:builtin1, 108);
   put('ncons,                    's!:builtin1, 109);
   put('numberp,                  's!:builtin1, 110);
% is!-spid and spid!-to!-nil are NOT for direct use by ordinary programmers.
% They are part of the support for &optional arguments.
   put('is!-spid,                 's!:builtin1, 111);
   put('spid!-to!-nil,            's!:builtin1, 112);
!#if common!-lisp!-mode
   put('mv!-list!*,               's!:builtin1, 113);
!#endif
   put('append,                   's!:builtin2, 0);
   put('ash,                      's!:builtin2, 1);
!#if (not common!-lisp!-mode)
   put('assoc,                    's!:builtin2, 2);
!#endif
   put('assoc!*!*,                's!:builtin2, 2);
   put('atsoc,                    's!:builtin2, 3);
   put('deleq,                    's!:builtin2, 4);
!#if (not common!-lisp!-mode)
   put('delete,                   's!:builtin2, 5);
   put('divide,                   's!:builtin2, 6);
!#endif
   put('eqcar,                    's!:builtin2, 7);
   put('eql,                      's!:builtin2, 8);
!#if (not common!-lisp!-mode)
   put('eqn,                      's!:builtin2, 9);
!#endif
   put('expt,                     's!:builtin2, 10);
   put('flag,                     's!:builtin2, 11);
   put('flagpcar,                 's!:builtin2, 12);
!#if (not common!-lisp!-mode)
   put('gcdn,                     's!:builtin2, 13);
!#endif
   put('geq,                      's!:builtin2, 14);
   put('getv,                     's!:builtin2, 15);
   put('greaterp,                 's!:builtin2, 16);
   put('idifference,              's!:builtin2, 17);
   put('igreaterp,                's!:builtin2, 18);
   put('ilessp,                   's!:builtin2, 19);
   put('imax,                     's!:builtin2, 20);
   put('imin,                     's!:builtin2, 21);
   put('iplus2,                   's!:builtin2, 22);
   put('iquotient,                's!:builtin2, 23);
   put('iremainder,               's!:builtin2, 24);
   put('irightshift,              's!:builtin2, 25);
   put('itimes2,                  's!:builtin2, 26);
!#if (not common!-lisp!-mode)
%  put('lcm,                      's!:builtin2, 27);
!#endif
   put('leq,                      's!:builtin2, 28);
   put('lessp,                    's!:builtin2, 29);
%  put('make!-random!-state,      's!:builtin2, 30);
   put('max2,                     's!:builtin2, 31);
!#if (not common!-lisp!-mode)
   put('member,                   's!:builtin2, 32);
!#endif
   put('member!*!*,               's!:builtin2, 32);
   put('memq,                     's!:builtin2, 33);
   put('min2,                     's!:builtin2, 34);
   put('mod,                      's!:builtin2, 35);
   put('modular!-difference,      's!:builtin2, 36);
   put('modular!-expt,            's!:builtin2, 37);
   put('modular!-plus,            's!:builtin2, 38);
   put('modular!-quotient,        's!:builtin2, 39);
   put('modular!-times,           's!:builtin2, 40);
   put('nconc,                    's!:builtin2, 41);
   put('neq,                      's!:builtin2, 42);
   put('orderp,                   's!:builtin2, 43);
%  put('ordp,                     's!:builtin2, 43); % alternative name
!#if (not common!-lisp!-mode)
   put('quotient,                 's!:builtin2, 44);
!#endif
   put('remainder,                's!:builtin2, 45);
   put('remflag,                  's!:builtin2, 46);
   put('remprop,                  's!:builtin2, 47);
   put('rplaca,                   's!:builtin2, 48);
   put('rplacd,                   's!:builtin2, 49);
   put('schar,                    's!:builtin2, 50);
   put('set,                      's!:builtin2, 51);
   put('smemq,                    's!:builtin2, 52);
   put('subla,                    's!:builtin2, 53);
   put('sublis,                   's!:builtin2, 54);
   put('symbol!-set!-definition,  's!:builtin2, 55);
   put('symbol!-set!-env,         's!:builtin2, 56);
   put('times2,                   's!:builtin2, 57);
   put('xcons,                    's!:builtin2, 58);
   put('equal,                    's!:builtin2, 59);
   put('eq,                       's!:builtin2, 60);
   put('cons,                     's!:builtin2, 61);
   put('list2,                    's!:builtin2, 62);
!#if (not common!-lisp!-mode)
   put('get,                      's!:builtin2, 63);
!#endif
   put('qgetv,                    's!:builtin2, 64);
   put('flagp,                    's!:builtin2, 65);
   put('apply1,                   's!:builtin2, 66);
   put('difference,               's!:builtin2, 67);
   put('plus2,                    's!:builtin2, 68);
   put('times2,                   's!:builtin2, 69);
   put('equalcar,                 's!:builtin2, 70);
   put('iequal,                   's!:builtin2, 71);

   put('bps!-putv,                's!:builtin3, 0);
   put('errorset,                 's!:builtin3, 1);
   put('list2!*,                  's!:builtin3, 2);
   put('list3,                    's!:builtin3, 3);
   put('putprop,                  's!:builtin3, 4);
   put('putv,                     's!:builtin3, 5);
   put('putv!-char,               's!:builtin3, 6);
   put('subst,                    's!:builtin3, 7);
   put('apply2,                   's!:builtin3, 8);
   put('acons,                    's!:builtin3, 9);
   nil >>;


% Hex printing, for use when displaying assembly code

symbolic procedure s!:prinhex1 n;
  princ schar("0123456789abcdef", logand(n, 15));

symbolic procedure s!:prinhex2 n;
 << s!:prinhex1 truncate(n, 16);
    s!:prinhex1 n >>;

symbolic procedure s!:prinhex4 n;
 << s!:prinhex2 truncate(n, 256);
    s!:prinhex2 n >>;

%
% The rather elaborate scheme here is to allow for the possibility that the
% horrid user may have defined one of these variables before loading in
% the compiler - I do not want to clobber the user's settings.
%

flag('(comp plap pgwd pwrds notailcall ord nocompile
       carcheckflag savedef carefuleq), 'switch); % for RLISP

if not boundp '!*comp then <<      % compile automatically on "de"
   fluid '(!*comp);
   !*comp := t >>;

if not boundp '!*nocompile then << % do not compile when fasling
   fluid '(!*nocompile);
   !*nocompile := nil >>;

if not boundp '!*plap then <<      % print generated bytecodes
   fluid '(!*plap);
   !*plap := nil >>;

if not boundp '!*pgwd then <<      % equivalent to *plap here
   fluid '(!*pgwd);
   !*pgwd := nil >>;

if not boundp '!*pwrds then <<     % display size of generated code
   fluid '(!*pwrds);
   !*pwrds := t >>;

if not boundp '!*notailcall then << % disable an optimisation
   fluid '(!*notailcall);
   !*notailcall := nil >>;

if not boundp '!*ord then << % disable an optimisation
   fluid '(!*ord);
   !*ord := nil >>;

if not boundp '!*savedef then <<   % keep interpretable definition on p-list
   fluid '(!*savedef);
   !*savedef := nil >>;

if not boundp '!*carcheckflag then << % safety/speed control
   fluid '(!*carcheckflag);
   !*carcheckflag := t >>;

if not boundp '!*carefuleq then << % force EQ to be function call
   fluid '(!*carefuleq);           % to permit checking of (EQ number number)
   !*carefuleq := not null member('jlisp, lispsystem!*) >>;

fluid '(s!:current_function s!:current_label s!:current_block s!:current_size
        s!:current_procedure s!:other_defs s!:lexical_env s!:has_closure
        s!:recent_literals s!:used_lexicals s!:a_reg_values s!:current_count);

%
% s!:current_procedure is a list of basic blocks, with the entry-point
% implicit at the first block (that is to say at the END of the list
% while I am building it).. Each block is represented as a list
%  (label exit-condn size . byte-list)
% where the exit-condn can (at various stages during compilation) be
%    nil                            drop through
%    (exit)                         one-byte exit opcodes
%    (jump <label>)                 unconditional jump
%    (jumpcond <L1> <L2>)           two exits from this block
%    ((jumparg ...) <L1> <L2>)      two exits, extra data
%    (icase <L0> <L1> ... <Ln>)     multi-way branch
% furthermore <label> can be either an atom (for a regular label)
% or a list of the form (exit) for an exit condition.
%
% The byte-list is a list of atoms (for genuine bytes in the code
% stream) interleaved with lists that denote comments that appear in
% any assembly listing.

symbolic procedure s!:start_procedure(nargs, nopts, restarg);
 << s!:current_procedure := nil;
    s!:current_label := gensym();
    s!:a_reg_values := nil;
    if not zerop nopts or restarg then <<
       s!:current_block := list(list('OPTARGS, nopts), nopts,
                             list('ARGCOUNT, nargs), nargs);
       s!:current_size := 2 >>
    else if nargs > 3 then <<
       s!:current_block := list(list('ARGCOUNT, nargs), nargs);
       s!:current_size := 1 >>
    else <<
       s!:current_block := nil;
       s!:current_size := 0 >>
 >>;

symbolic procedure s!:set_label x;
 << if s!:current_label then begin scalar w;
       w := s!:current_size . s!:current_block;
       for each x in s!:recent_literals do rplaca(x, w);
       s!:recent_literals := nil;
       s!:current_procedure :=
          (s!:current_label . list('JUMP, x) . w) . s!:current_procedure;
       s!:current_block := nil;
       s!:current_size := 0 end;
    s!:current_label := x;
    s!:a_reg_values := nil
 >>;

symbolic procedure s!:outjump(op, lab);
 begin
    scalar g, w;
    if not flagp(op, 's!:preserves_a) then s!:a_reg_values := nil;
    if null s!:current_label then return nil;
% unconditional jumps set s!:current_label to nil, which denotes
% a state where control can not reach.
    if op = 'JUMP then op := list(op, lab)
    else if op = 'ICASE then op := op . lab
    else op := list(op, lab, g := gensym());
    w := s!:current_size . s!:current_block;
    for each x in s!:recent_literals do rplaca(x, w);
    s!:recent_literals := nil;
    s!:current_procedure :=
       (s!:current_label . op . w) . s!:current_procedure;
    s!:current_block := nil;
    s!:current_size := 0;
    s!:current_label := g;
    return op
 end;

symbolic procedure s!:outexit();
  begin
    scalar w, op;
    op := '(EXIT);
    if null s!:current_label then return nil;
    w := s!:current_size . s!:current_block;
    for each x in s!:recent_literals do rplaca(x, w);
    s!:recent_literals := nil;
    s!:current_procedure := 
       (s!:current_label . op . w) . s!:current_procedure;
    s!:current_block := nil;
    s!:current_size := 0;
    s!:current_label := nil
 end;

flag('(PUSH PUSHNIL PUSHNIL2 PUSHNIL3 LOSE LOSE2 LOSE3 LOSES
       STORELOC STORELOC0 STORELOC1 STORELOC2 STORELOC3
       STORELOC4 STORELOC5 STORELOC6 STORELOC7
       JUMP JUMPT JUMPNIL 
       JUMPEQ JUMPEQUAL JUMPNE JUMPNEQUAL
       JUMPATOM JUMPNATOM),
     's!:preserves_a);

symbolic procedure s!:outopcode0(op, doc);
  begin
    if not flagp(op, 's!:preserves_a) then s!:a_reg_values := nil;
    if null s!:current_label then return nil;
    s!:current_block := op . s!:current_block;
    s!:current_size := s!:current_size + 1;
    if !*plap or !*pgwd then s!:current_block := doc . s!:current_block;
  end;

symbolic procedure s!:outopcode1(op, arg, doc);
% doc is just a single item here.
  begin
    if not flagp(op, 's!:preserves_a) then s!:a_reg_values := nil;
    if null s!:current_label then return nil;
    s!:current_block := arg . op . s!:current_block;
    s!:current_size := s!:current_size + 2;
    if !*plap or !*pgwd then s!:current_block := list(op, doc) . s!:current_block
  end;

% Whenever compiled code needs to refer to any Lisp object it does so
% via a literal table - this procedure manages the table. I common up
% literals if they are EQL.  In the table that I build here I associate
% each literal with a pair (n . l) where n is the number of times the
% literal is referenced (or some other measure of its importance) and l is
% a list of all the places in the codestream where it is referenced.

deflist(
  '((LOADLIT 1)
    (LOADFREE 2)
    (CALL0 2)
    (CALL1 2)
    (LITGET 2)
    (JUMPLITEQ 2)
    (JUMPLITNE 2)
    (JUMPLITEQ!* 2)
    (JUMPLITNE!* 2)
    (JUMPFREET 2)
    (JUMPFREENIL 2)),
   's!:short_form_bonus);

% s!:record_literal is called when a literal reference has just been
% pushed onto s!:current_block. It inserts a reference to the literal
% into a hash table so that it can be resolved into an offset into a literal
% vector later on.

symbolic procedure s!:record_literal env;
  begin
    scalar w, extra;
    w := gethash(car s!:current_block, car env);
    if null w then w := 0 . nil;
    extra := get(cadr s!:current_block, 's!:short_form_bonus);
    if null extra then extra := 10 else extra := extra + 10;
    s!:recent_literals := (nil . s!:current_block) . s!:recent_literals;
    puthash(car s!:current_block, car env,
       (car w+extra) . car s!:recent_literals . cdr w);
  end;

% record_literal_for_jump is used with x of the form (eg)
%    (JUMPLITEQ literal-value <comment>)
% where this list will be used in a jump instruction.

symbolic procedure s!:record_literal_for_jump(x, env, lab);
  begin
    scalar w, extra;
    if null s!:current_label then return nil;
    w := gethash(cadr x, car env);
    if null w then w := 0 . nil;
    extra := get(car x, 's!:short_form_bonus);
    if null extra then extra := 10 else extra := extra + 10;
    x := s!:outjump(x, lab);
    puthash(cadar x, car env, (car w+extra) . (nil . x) . cdr w)
  end;

symbolic procedure s!:outopcode1lit(op, arg, env);
  begin
    if not flagp(op, 's!:preserves_a) then s!:a_reg_values := nil;
    if null s!:current_label then return nil;
    s!:current_block := arg . op . s!:current_block;
    s!:record_literal env;
    s!:current_size := s!:current_size + 2;
    if !*plap or !*pgwd then s!:current_block := list(op, arg) . s!:current_block
  end;

symbolic procedure s!:outopcode2(op, arg1, arg2, doc);
% This is only used for BIGSTACK
  begin
    if not flagp(op, 's!:preserves_a) then s!:a_reg_values := nil;
    if null s!:current_label then return nil;
    s!:current_block := arg2 . arg1 . op . s!:current_block;
    s!:current_size := s!:current_size + 3;
    if !*plap or !*pgwd then s!:current_block := (op . doc) . s!:current_block
  end;

symbolic procedure s!:outopcode2lit(op, arg1, arg2, doc, env);
% This is only used for CALLN
  begin
    if not flagp(op, 's!:preserves_a) then s!:a_reg_values := nil;
    if null s!:current_label then return nil;
    s!:current_block := arg1 . op . s!:current_block;
    s!:record_literal env;
    s!:current_block := arg2 . s!:current_block;
    s!:current_size := s!:current_size + 3;
    if !*plap or !*pgwd then s!:current_block := (op . doc) . s!:current_block
  end;

symbolic procedure s!:outlexref(op, arg1, arg2, arg3, doc);
% Only used for LOADLEX and STORELEX
  begin
    scalar arg4;
    if null s!:current_label then return nil;
    if arg1 > 255 or arg2 > 255 or arg3 > 255 then <<
       if arg1 > 2047 or arg2 > 31 or arg3 > 2047 then
          error "stack frame > 2047 or > 31 deep nesting";
       doc := list(op, doc);
       arg4 := logand(arg3, 255);
       arg3 := truncate(arg3,256) + 16*logand(arg1, 15);
       if op = 'LOADLEX then op := 192 + arg2
       else op := 224 + arg2;
       arg2 := truncate(arg1,16);
       arg1 := op;
       op := 'BIGSTACK >>
    else doc := list doc;
    s!:current_block := arg3 . arg2 . arg1 . op . s!:current_block;
    s!:current_size := s!:current_size + 4;
    if arg4 then <<
       s!:current_block := arg4 . s!:current_block;
       s!:current_size := s!:current_size + 1 >>;
    if !*plap or !*pgwd then s!:current_block := (op . doc) . s!:current_block
  end;

% Some opcodes that take a byte offset following them have special forms
% that cope with a few very small values of that offset. Here are tables
% that document what is available, and code that optimises the general case
% into the special opcodes when it can.

put('LOADLIT,    's!:shortform, '(1 . 7) .
        s!:vecof '(!- LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4
                      LOADLIT5 LOADLIT6 LOADLIT7));
put('LOADFREE,   's!:shortform, '(1 . 4) .
        s!:vecof '(!- LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4));
put('STOREFREE,  's!:shortform, '(1 . 3) .
        s!:vecof '(!- STOREFREE1 STOREFREE2 STOREFREE3));
put('CALL0,      's!:shortform, '(0 . 3) .
        s!:vecof '(CALL0_0 CALL0_1 CALL0_2 CALL0_3));
put('CALL1,      's!:shortform, '(0 . 5) .
        s!:vecof '(CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5));
put('CALL2,      's!:shortform, '(0 . 4) .
        s!:vecof '(CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4));

put('JUMPFREET,  's!:shortform, '(1 . 4) .
        s!:vecof '(!- JUMPFREE1T JUMPFREE2T JUMPFREE3T JUMPFREE4T));
put('JUMPFREENIL, 's!:shortform, '(1 . 4) .
        s!:vecof '(!- JUMPFREE1NIL JUMPFREE2NIL JUMPFREE3NIL JUMPFREE4NIL));
put('JUMPLITEQ ,  's!:shortform, '(1 . 4) .
        s!:vecof '(!- JUMPLIT1EQ JUMPLIT2EQ JUMPLIT3EQ JUMPLIT4EQ));
put('JUMPLITNE ,  's!:shortform, '(1 . 4) .
        s!:vecof '(!- JUMPLIT1NE JUMPLIT2NE JUMPLIT3NE JUMPLIT4NE));
put('JUMPLITEQ!*, 's!:shortform, get('JUMPLITEQ, 's!:shortform));
put('JUMPLITNE!*, 's!:shortform, get('JUMPLITNE, 's!:shortform));

% These are sub opcodes used with BIGCALL
% The format used with the opcode is as follows:
%    BIGCALL (op:4/high:4) (low:8) ?(nargs:8)
% so the upper four bits of the byte after the BIGCALL opcode select what
% operation is actually performed (from the following list). There is a
% 12-bit literal-vector offset with its 4 high bits packed into that byte
% and the next 8 in the byte "low". Then just in the cases CALLN and JCALLN
% a further byte indicates how many arguments are actually being passed.

put('CALL0,     's!:longform,   0);     % 0
put('CALL1,     's!:longform,   16);    % 1
put('CALL2,     's!:longform,   32);    % 2
put('CALL3,     's!:longform,   48);    % 3
put('CALLN,     's!:longform,   64);    % 4
put('CALL2R,    's!:longform,   80);    % 5 (no JCALL version)
put('LOADFREE,  's!:longform,   96);
put('STOREFREE, 's!:longform,   112);
put('JCALL0,    's!:longform,   128);
put('JCALL1,    's!:longform,   144);
put('JCALL2,    's!:longform,   160);
put('JCALL3,    's!:longform,   176);
put('JCALLN,    's!:longform,   192);
put('FREEBIND,  's!:longform,   208);
put('LITGET,    's!:longform,   224);
put('LOADLIT,   's!:longform,   240);

symbolic procedure s!:literal_order(a, b);
    if cadr a = cadr b then orderp(car a, car b)
    else cadr a > cadr b;

symbolic procedure s!:resolve_literals env;
  begin
    scalar w, op, opspec, n, litbytes;
    w := hashcontents car env;
% I sort the literals used in this function so that the ones that are
% used most often come first, and hence get allocated the smaller
% offsets within the table. Here I need to do something magic if there
% are over 256 literals since the regular opcodes only have that much
% addressability.
    w := sort(w, function s!:literal_order);
    n := length w;
    litbytes := 4*n;
    if n > 4096 then w := s!:too_many_literals(w, n);
    n := 0;
    for each x in w do <<
        rplaca(cdr x, n);    % Turn priorities into offsets
        n := n + 1 >>;
    for each x in w do <<
       n := cadr x;
       for each y in cddr x do <<
          if null car y then <<  % JUMP operation
% If I have a jump that refers to a literal (eg JUMPEQCAR) then I am
% entitled at this stage to leave a 12-bit value in the data structure,
% because as necessary s!:expand_jump will unwind it later to fit in with
% the bytecode restrictions.
             op := caadr y;
             opspec := get(op, 's!:shortform);
             if opspec and caar opspec <= n and n <= cdar opspec then
                 rplaca(cdr y, getv(cdr opspec, n))
             else rplaca(cdadr y, n) >>
          else <<
             op := caddr y;
             if n > 255 then <<
                 rplaca(car y, caar y + 1);          % block is now longer
                 op := get(op, 's!:longform) + truncate(n,256);
                 rplaca(cdr y, ilogand(n, 255));     % low byte offset
                 rplaca(cddr y, 'BIGCALL);           % splice in byte and...
                 rplacd(cdr y, op . cddr y) >>       % make a BIGCALL
             else if (opspec := get(op, 's!:shortform)) and
                     caar opspec <= n and 
                     n <= cdar opspec then <<        % short form available
                 rplaca(car y, caar y - 1);          % block is now shorter
                 rplaca(cdr y, getv(cdr opspec, n)); % replace opcode
                 rplacd(cdr y, cdddr y) >>           % splice out a byte
             else rplaca(cdr y, n) >> >> >>;  % OR just fill in offset
    for each x in w do rplacd(x, cadr x);
    rplaca(env, reversip w . litbytes)
  end;

% s!:too_many_literals is called when there are over 4096 literals called for.
% The simple bytecode instruction set can only cope with 256.
% There are two ways I get around this. To consider these it is useful to
% document the opcodes that reference literals:
%
% operations:  CALL0, CALL1, CALL2, CALL2R, CALL3, CALLN,
%              LOADLIT, LOADFREE, STOREFREE, FREEBIND, LITGET
% and jumps:   JUMPLITEQ, JUMPLITNE, JUMPFREENIL, JUMPFREET,
%              JUMPEQCAR, JUMPNEQCAR, JUMPFLAGP, JUMPNFLAGP
%
% The jumps involved are all versions that can only support short
% branch offsets, and which s!:expand_jump will elaborate into
% code that uses LOADLIT or LOADFREE as necessary. Eg
%
%   JUMPFREENIL var lab  =>  LOADFREE var; JUMPNIL lab
%   JUMPEQCAR lit lab    =>  LOADLIT lit; EQCAR; JUMPT lab
%
% Thus I do not have to worry too much about jumps if I can deal with the
% other operations.  The bytecode interpreter provides an operation
% called BIGCALL that is followed by two bytes. The first contains a 4-bit
% sub-opcode, while the remaining twelve bits provide for access within the
% first 2048 literals for all the above operations and for the JCALL
% operations corresponding to the CALL ones shown (except CALL2R which does
% not have a coresponding JCALL version). So normally I can just map
% references that need to address literals beyong the 256th onto these
% extended opcodes.
%
% Just to be super-careful I will make at least some allowance for things
% with over 2048 literals. In such cases I will identify excess literals
% that are ONLY referenced using the LOADLIT operation (and that directly,
% not via one of the JUMP combinations shown above). For a suitable number
% of these I migrate the literal values into one or more secondary vectors 
% (called v<i> here). These secondary vectors will be stored in the main
% literal vector, and I turn a reference
%           LOADLIT x
% into      LOADLIT v<i>
%           QGETVN  n
% for the offset n of the value x in the secondary vector v<i>.  Note that
% because v<i> will then probably be referenced very often it will stand
% a good chance of ending up within the first 8 slots in the main
% vector so "LOADLIT v<i>" will end turn into just one byte so the effect
% is as if I have a three byte opcode to load a literal from the extended
% pool.  With luck in truly huge procedures there will be a significant
% proportion of literals used in this way and the ones used in more general
% ways will then end up fitting within the first 2048.
%
% In reality the nastiest case I have seen so far has had around 800 literals,
% and that only because of some unduly clumsy compilation and (lack of)
% macro expansion.

symbolic procedure s!:only_loadlit l;
   if null l then t
   else if null caar l then nil
   else if not eqcar(cddar l, 'LOADLIT) then nil
   else s!:only_loadlit cdr l;

symbolic procedure s!:too_many_literals(w, n);
  begin
    scalar k, xvecs, l, r, newrefs, uses, z1;
    k := 0;             % Number of things in current overflow vector
    n := n + 1;
% I must not move the function name down into a sub-vector since it is
% essential (for debugging messages etc) that it ends up in position 0
% in the final literal vector. Hence the test for 10000000 here.
    while n > 4096 and not null w do <<
       if not (cadar w = 10000000) and s!:only_loadlit cddar w then <<
           l := car w . l;
           n := n-1;
           k := k + 1;
           if k = 256 then <<
              xvecs := l . xvecs;
              l := nil;
              k := 0;
              n := n+1 >> >>
       else r := car w . r;
       w := cdr w >>;
% Complain if migrating LOADLIT literals into sub-vectors does not bring me
% down to 12-bit addressability.
    if n > 4096 then error "function uses too many literals (4096 is limit)";
    xvecs := l . xvecs;
    while r do <<
       w := car r . w;
       r := cdr r >>;
    for each v in xvecs do <<
       newrefs := nil;
       uses := 0;
       r := nil;
       k := 0;
       for each q in v do <<
          for each z in cddr q do <<
% Now z is (hdrp . [litval LOADLIT ...]) and I need to rewrite it to
% be +2 in the length and  (offset . QGETVN . [<vector> LOADLIT ...])
             if car z then rplaca(car z, caar z + 2);
             z1 := 'QGETVN . nil . cddr z;
             rplaca(cdr z, k);
             rplacd(cdr z, z1);
             rplacd(z, cdr z1);
             newrefs := z . newrefs;
             uses := uses + 11 >>;
          r := car q . r;
          k := k + 1 >>;
       newrefs := uses . newrefs;
       newrefs := (s!:vecof reversip r) . newrefs;
       w := newrefs . w >>;
    return sort(w, function s!:literal_order)
  end;

% The following variable is a hook that the Lisp to C compiler
% might like to use.

fluid '(s!:into_c);

symbolic procedure s!:endprocedure(name, env);
  begin
    scalar pc, labelvals, w, vec;
% First I finish off the final basic block by appending an EXIT operation
    s!:outexit();

    if s!:into_c then return (s!:current_procedure . env);

% Literals have just been collected in an unordered pool so far - now I
% should decide which ones go where in the literal vectors, and insert
% optimised forms of opcodes that can rely on them.
    s!:resolve_literals env;

% Tidy up blocks by re-ordering them so as to try to remove chains of
% jumps and similar ugliness.
    s!:current_procedure := s!:tidy_flowgraph s!:current_procedure;

% Look for possible tail calls AFTER resolving literals so that I know the
% exact location in the literal vector of the names of the procedures
% chained to. This means that there can be BIGCALL operations present
% as well as regular CALL opcodes. It also means that come calls that
% address the first few items in the literal vector will have been collapsed
% onto one-byte opcodes.
    if not !*notailcall and not s!:has_closure then
       s!:current_procedure := s!:try_tailcall s!:current_procedure;

% In all cases I can now turn things like (NIL;EXIT) and (LOADLOC 1;EXIT)
% into single-byte instructions, and discard the LOSE from (LOSE;EXIT).
    s!:current_procedure := s!:tidy_exits s!:current_procedure;

% JUMP instructions are span-dependent, so I need to iterate to
% cope with that as well as with forward references.
    labelvals := s!:resolve_labels();
    pc := car labelvals; labelvals := cdr labelvals;

% Allocate space for the compiled code -  this is done in
% a separate heap.  Maybe soon I will put environment vectors
% in that heap too.  The code heap is not subject to garbage
% colection (at present).
    vec := make!-bps pc;
    pc := 0;
    if !*plap or !*pgwd then <<
       terpri(); ttab 23; princ "+++ "; prin name; princ " +++"; terpri() >>;

% The final pass assembles all the basic blocks and prints a
% listing (if desired)
    for each b in s!:current_procedure do <<
       if car b and flagp(car b, 'used_label) and (!*plap or !*pgwd) then <<
          ttab 20;
          prin car b;
          princ ":";
          terpri() >>;
       pc := s!:plant_basic_block(vec, pc, reverse cdddr b);
       b := cadr b;   % documentation
       if b and
          not car b = 'ICASE and 
          cdr b and
          cddr b then b := list(car b, cadr b);  % Trim unwanted second label
       pc := s!:plant_exit_code(vec, pc, b, labelvals) >>;

% At the end of a procedure I may display a message to record the fact
% that I have compiled it and to show how many bytes were generated
    if !*pwrds then <<
        if posn() neq 0 then terpri();
        princ "+++ "; prin name; princ " compiled, ";
        princ pc; princ " + "; princ (cdar env);
        princ " bytes"; terpri() >>;

% finally I manufacture a literal vector for use with this code segment
    env := caar env;
    if null env then w := nil
    else <<
       w := mkvect cdar env;
       while env do <<
          putv(w, cdar env, caar env);
          env := cdr env >> >>;
    return (vec . w);
  end;

symbolic procedure s!:add_pending(lab, pend, blocks);
  begin
    scalar w;
    if not atom lab then return
       list(gensym(), lab, 0) . pend;
    w := atsoc(lab, pend);
    if w then return w . deleq(w, pend)
    else return atsoc(lab, blocks) . pend
  end;

symbolic procedure s!:invent_exit(x, blocks);
  begin
    scalar w;
    w := blocks;
scan:
    if null w then go to not_found
    else if eqcar(cadar w, x) and caddar w = 0 then return caar w . blocks
    else w := cdr w;
    go to scan;
not_found:
    w := gensym();
    return w . list(w, list x, 0) . blocks
  end;

symbolic procedure s!:destination_label(lab, blocks);
% lab is a label - first find the associated block. If it is empty
% of executable code and it control leaves it unconditionally (either via
% an unconditional jump or an EXIT) then return a value that reflects
% going directly to that destination. Either an atom for a label or a
% non-atomic EXIT marker. In the case of chains of blocks that end up in
% and EXIT I want to ignore LOSE operations, while in all other cases LOSE
% operations are significant.
  begin
    scalar n, w, x;
    w := atsoc(lab, blocks);
    if s!:is_lose_and_exit(w, blocks) then return '(EXIT);
    x := cadr w;
    n := caddr w;
    w := cdddr w;
    if n neq 0 then return lab;  % is there any code?
    if null x or null cdr x then return x  % an exit block
    else if cadr x = lab then return lab   % Very direct loop
    else if null cddr x then return s!:destination_label(cadr x, blocks)
    else return lab
  end;

symbolic procedure s!:remlose b;
% If the instruction stream b has some LOSE opcodes at its tail return
% (q . b') where q is the number of bytes of instructions involved,
% and b' is the instruction sequence with the LOSE opcodes removed.
  begin
    scalar w;
    w := b;
    while w and not atom car w do w := cdr w;
    if null w then return (0 . b);
    if numberp car w and eqcar(cdr w, 'LOSES) then w := (2 . cddr w)
    else if car w = 'LOSE or car w = 'LOSE2 or car w = 'LOSE3 then
       w := (1 . cdr w)
    else return (0 . b);
    b := s!:remlose cdr w;
    return ((car w + car b) . cdr b);
  end;

put('CALL0_0,  's!:shortcall, '(0 . 0));
put('CALL0_1,  's!:shortcall, '(0 . 1));
put('CALL0_2,  's!:shortcall, '(0 . 2));
put('CALL0_3,  's!:shortcall, '(0 . 3));
put('CALL1_0,  's!:shortcall, '(1 . 0));
put('CALL1_1,  's!:shortcall, '(1 . 1));
put('CALL1_2,  's!:shortcall, '(1 . 2));
put('CALL1_3,  's!:shortcall, '(1 . 3));
put('CALL1_4,  's!:shortcall, '(1 . 4));
put('CALL1_5,  's!:shortcall, '(1 . 5));
put('CALL2_0,  's!:shortcall, '(2 . 0));
put('CALL2_1,  's!:shortcall, '(2 . 1));
put('CALL2_2,  's!:shortcall, '(2 . 2));
put('CALL2_3,  's!:shortcall, '(2 . 3));
put('CALL2_4,  's!:shortcall, '(2 . 4));

symbolic procedure s!:remcall b;
% If the instruction stream b has a CALL opcode at its head then
% return (p . q . r . s . b') where p is any comment assocated with
% the call, q is the number of arguments the called function expects,
% r is the literal-vector offset involved, s is the number of bytes
% in the codestream used up and b' is the code stream with the CALL deleted.
% Return NIL if no CALL is found.
  begin
    scalar w, p, q, r, s;
    while b and not atom car b do <<
       p := car b;    % Strip comments, leaves p=nil if none
       b := cdr b >>;
    if null b then return nil  % Nothing left
% The possible interesting cases here are:
%     CALL0_0 .... JCALL2_4   (1 byte opcodes)
%     CALL0 n .... CALL3 n    (2 bytes)
%     CALL2R n                (2 bytes, treat as (SWOP;CALL2 n))
%     CALLN m n               (3 bytes)
%     BIGCALL [CALL0..3] n    (3 bytes)
%     BIGCALL [CALL2R] n      (3 bytes, treat as (SWOP;BIGCALL [CALL2] n))
%     BIGCALL [CALLN] n m     (4 bytes)
    else if numberp car b then <<
       r := car b;
       s := 2;
       b := cdr b;
       if null b then return nil
       else if numberp car b then <<
          q := r;
          r := car b;
          s := 3;
          b := cdr b;
          if b and numberp (w := car b) and eqcar(cdr b, 'BIGCALL) and
             truncate(w, 16) = 4 then <<
              r := 256*logand(w, 15) + r;
              s := 4;
              b := cdr b >>
          else if eqcar(b, 'BIGCALL) then <<
              w := truncate(r,16);
              r := 256*logand(r, 15) + q;
              q := w;
              if q = 5 then <<   % BIGCALL [CALL2R]
                 q := 2;
                 s := s-1; % fudge for the inserted byte
                 b := 'BIGCALL . 'SWOP . cdr b >>;
              if q > 4 then return nil >>
          else if not eqcar(b, 'CALLN) then return nil >>
       else if car b = 'CALL0 then q := 0
       else if car b = 'CALL1 then q := 1
       else if car b = 'CALL2 then q := 2
       else if car b = 'CALL2R then <<
           q := 2;
           s := s-1; % fudge for the inserted byte
           b := 'CALL2 . 'SWOP . cdr b >>
       else if car b = 'CALL3 then q := 3
       else return nil;
       b := cdr b >>
    else if (q := get(car b, 's!:shortcall)) then <<
       r := cdr q;
       q := car q;
       s := 1;
       b := cdr b >>
    else return nil;
    return (p . q . r . s . b);
  end;


symbolic procedure s!:is_lose_and_exit(b, blocks);
% If the block b amounts to just a sequence of LOSE
% operations and then a real exit then return TRUE. Otherwise return NIL.
  begin
    scalar lab, exit;
    lab := car b;
    exit := cadr b;
    b := cdddr b;
    if null exit then return nil;
    b := s!:remlose b;
    b := cdr b;
    while b and not atom car b do b := cdr b;
    if b then return nil      % something in addition to the LOSEs
    else if car exit = 'EXIT then return t
    else if car exit = 'JUMP then <<
       if cadr exit = lab then nil              % very direct loop
       else return s!:is_lose_and_exit(atsoc(cadr exit, blocks), blocks) >>
    else return nil;
  end;

symbolic procedure s!:try_tail_1(b, blocks);
  begin
    scalar exit, size, body, w, w0, w1, w2, op;
    exit := cadr b;
    if null exit then return b
    else if not (car exit = 'EXIT) then <<
       if car exit = 'JUMP then <<
           if not s!:is_lose_and_exit(atsoc(cadr exit, blocks), blocks) then
               return b >>
       else return b >>;
% Here the relevant block either ended with an EXIT, or it ended in an
% unconditional jump to a block that contained no more than LOSE opcodes
% before an EXIT.
    size := caddr b;
    body := cdddr b;
    body := s!:remlose body;
    size := size - car body; body := cdr body;
    w := s!:remcall body;
    if null w then return b;
% w = (comment . nargs . target . bytes . other_bytes)
    w0 := cadr w;       % nargs
    w1 := caddr w;      % target
    body := cddddr w;   % byte-stream tail
    if w0 <= 7 and w1 <= 31 then <<
% Here I can use a version of JCALL that packs both operands into
% a single post-byte
       body := 'JCALL . body;
       body := (32*w0 + w1) . body;
       size := size-1 >>
% For reasonably short calls I can use a generic JCALL where both nargs
% and the target address use one byte each
    else if w1 < 256 then body := w0 . w1 . 'JCALLN . body
% When the offset required is over-large I use variants on BIGCALL.
    else <<
        body := 'BIGCALL . body;
        w2 := logand(w1, 255); w1 := truncate(w1,256);
        if w0 < 4 then body := w2 . (w1 + 16*w0 + 128) . body
        else <<
            body := w0 . w2 . (w1 + (16*4 + 128)) . body;
            size := size + 1 >> >>;
    if car w then body := append(car w, list('TAIL)) . body;
    rplaca(cdr b, nil);
    rplaca(cddr b, size-cadddr w+3);
    rplacd(cddr b, body);
    return b
  end;

symbolic procedure s!:try_tailcall b;
   for each v in b collect s!:try_tail_1(v, b);

symbolic procedure s!:tidy_exits_1(b, blocks);
  begin
    scalar exit, size, body, comm, w, w0, w1, w2, op;
    exit := cadr b;
    if null exit then return b
    else if not (car exit = 'EXIT) then <<
       if car exit = 'JUMP then <<
           if not s!:is_lose_and_exit(atsoc(cadr exit, blocks), blocks) then
               return b >>
       else return b >>;
% Here the relevant block either ended with an EXIT, or it ended in an
% unconditional jump to a block that contained no more than LOSE opcodes
% before an EXIT.
    size := caddr b;
    body := cdddr b;
    body := s!:remlose body;  % chucks away any LOSEs just before the EXIT
    size := size - car body; body := cdr body;
    while body and not atom car body do <<
        comm := car body;
        body := cdr body >>;
    if      eqcar(body, 'VNIL)     then w := 'NILEXIT
    else if eqcar(body, 'LOADLOC0) then w := 'LOC0EXIT
    else if eqcar(body, 'LOADLOC1) then w := 'LOC1EXIT
    else if eqcar(body, 'LOADLOC2) then w := 'LOC2EXIT
    else w := nil;
    if w then <<
        rplaca(cdr b, list w);
        body := cdr body;
        size := size - 1 >>
    else if comm then body := comm . body;
    rplaca(cddr b, size);
    rplacd(cddr b, body);
    return b
  end;

symbolic procedure s!:tidy_exits b;
   for each v in b collect s!:tidy_exits_1(v, b);

symbolic procedure s!:tidy_flowgraph b;
  begin
    scalar r, pending;
% The blocks are initially built up in reverse order - correct that here
    b := reverse b;
% The first block is where we enter the procedure, and so it always has to
% be the first thing emitted.
    pending := list car b;
    while pending do begin
      scalar c, x, l1, l2, done1, done2;
      c := car pending;             % next block to emit
      pending := cdr pending;
      flag(list car c, 'coded);     % this label has now been set
      x := cadr c;                  % exit status of current block
      if null x or null cdr x then
        r := c . r
      else if car x = 'ICASE then <<
% I reverse the list of case labels here so that I add pending blocks in
% and order that will typically arrange that the cases come out in the
% generated code in the "natural" order.
        rplacd(x, reversip cdr x);
        for each ll on cdr x do <<
          l1 := s!:destination_label(car ll, b);
          if not atom l1 then <<
             l1 := s!:invent_exit(car l1, b);
             b := cdr l1;
             l1 := cadr l1 >>;
          rplaca(ll, l1);
          done1 := flagp(l1, 'coded);
          flag(list l1, 'used_label);
          if not done1 then pending := s!:add_pending(l1, pending, b) >>;
        rplacd(x, reversip cdr x);
        r := c . r >>
      else if null cddr x then <<   % unconditional jump
        l1 := s!:destination_label(cadr x, b);
        if not atom l1 then         % goto exit turns into exit block
           c := car c . l1 . cddr c
        else if flagp(l1, 'coded) then <<
           flag(list l1, 'used_label);
           c := car c . list(car x, l1) . cddr c >>
        else <<
           c := car c . nil . cddr c;
           pending := s!:add_pending(l1, pending, b) >>;
        r := c . r >>
      else <<                       % conditional jump
        l1 := s!:destination_label(cadr x, b);
        l2 := s!:destination_label(caddr x, b);
        done1 := atom l1 and flagp(l1, 'coded);
        done2 := atom l2 and flagp(l2, 'coded);
        if done1 then <<
           if done2 then <<
              flag(list l1, 'used_label);
              rplaca(cdadr c, l1);
% Here I synthesize a block to carry the unconditional jump to L2 that I need
              pending := list(gensym(), list('JUMP, l2), 0) . pending >>
           else <<
              flag(list l1, 'used_label);
              rplaca(cdadr c, l1);
              pending := s!:add_pending(l2, pending, b) >> >>
        else <<
           if done2 then <<
              flag(list l2, 'used_label);
              rplaca(cadr c, s!:negate_jump car x);
              rplaca(cdadr c, l2);
              pending := s!:add_pending(l1, pending, b) >>
           else <<
% neither l1 nor l2 have been done - I make a somewhat random selection
% as to which I will emit first
              if not atom l1 then <<    % invent block for exit case
                 l1 := s!:invent_exit(car l1, b);
                 b := cdr l1;
                 l1 := car l1 >>;
              flag(list l1, 'used_label);
              rplaca(cdadr c, l1);
% it is possible here that l1 was an exit case and s!:invent_exit discovers a
% previously emitted suitable exit block, in which case l1 is now a reference
% to an already-set label, so it should not be pushed onto the list of
% pending blocks
              if not flagp(l1, 'coded) then
                  pending := s!:add_pending(l1, pending, b);
              pending := s!:add_pending(l2, pending, b) >> >>;
        r := c . r >>
      end;
    return reverse r
  end;

deflist('((JUMPNIL      JUMPT)
          (JUMPT        JUMPNIL)
          (JUMPATOM     JUMPNATOM)
          (JUMPNATOM    JUMPATOM)
          (JUMPEQ       JUMPNE)
          (JUMPNE       JUMPEQ)
          (JUMPEQUAL    JUMPNEQUAL)
          (JUMPNEQUAL   JUMPEQUAL)
          (JUMPL0NIL    JUMPL0T)
          (JUMPL0T      JUMPL0NIL)
          (JUMPL1NIL    JUMPL1T)
          (JUMPL1T      JUMPL1NIL)
          (JUMPL2NIL    JUMPL2T)
          (JUMPL2T      JUMPL2NIL)
          (JUMPL3NIL    JUMPL3T)
          (JUMPL3T      JUMPL3NIL)
          (JUMPL4NIL    JUMPL4T)
          (JUMPL4T      JUMPL4NIL)
          (JUMPL0ATOM   JUMPL0NATOM)
          (JUMPL0NATOM  JUMPL0ATOM)
          (JUMPL1ATOM   JUMPL1NATOM)
          (JUMPL1NATOM  JUMPL1ATOM)
          (JUMPL2ATOM   JUMPL2NATOM)
          (JUMPL2NATOM  JUMPL2ATOM)
          (JUMPL3ATOM   JUMPL3NATOM)
          (JUMPL3NATOM  JUMPL3ATOM)
          (JUMPST0NIL   JUMPST0T)
          (JUMPST0T     JUMPST0NIL)
          (JUMPST1NIL   JUMPST1T)
          (JUMPST1T     JUMPST1NIL)
          (JUMPST2NIL   JUMPST2T)
          (JUMPST2T     JUMPST2NIL)
          (JUMPFREE1NIL JUMPFREE1T)
          (JUMPFREE1T   JUMPFREE1NIL)
          (JUMPFREE2NIL JUMPFREE2T)
          (JUMPFREE2T   JUMPFREE2NIL)
          (JUMPFREE3NIL JUMPFREE3T)
          (JUMPFREE3T   JUMPFREE3NIL)
          (JUMPFREE4NIL JUMPFREE4T)
          (JUMPFREE4T   JUMPFREE4NIL)
          (JUMPFREENIL  JUMPFREET)
          (JUMPFREET    JUMPFREENIL)
          (JUMPLIT1EQ   JUMPLIT1NE)
          (JUMPLIT1NE   JUMPLIT1EQ)
          (JUMPLIT2EQ   JUMPLIT2NE)
          (JUMPLIT2NE   JUMPLIT2EQ)
          (JUMPLIT3EQ   JUMPLIT3NE)
          (JUMPLIT3NE   JUMPLIT3EQ)
          (JUMPLIT4EQ   JUMPLIT4NE)
          (JUMPLIT4NE   JUMPLIT4EQ)
          (JUMPLITEQ    JUMPLITNE)
          (JUMPLITNE    JUMPLITEQ)
          (JUMPLITEQ!*  JUMPLITNE!*)
          (JUMPLITNE!*  JUMPLITEQ!*)
          (JUMPB1NIL    JUMPB1T)
          (JUMPB1T      JUMPB1NIL)
          (JUMPB2NIL    JUMPB2T)
          (JUMPB2T      JUMPB2NIL)
          (JUMPFLAGP    JUMPNFLAGP)
          (JUMPNFLAGP   JUMPFLAGP)
          (JUMPEQCAR    JUMPNEQCAR)
          (JUMPNEQCAR   JUMPEQCAR)
                                    ), 'negjump);

symbolic procedure s!:negate_jump x;
   if atom x then get(x, 'negjump)
   else rplaca(x, get(car x, 'negjump));

symbolic procedure s!:resolve_labels();
  begin
    scalar w, labelvals, converged, pc, x;
    repeat <<
       converged := t;
       pc := 0;
       for each b in s!:current_procedure do <<
% Each block has a label at its head - set the label, or
% on subsequent passes check to see if its value has changed -
% if anything has happened clear the converged flag so that another
% pass will be taken
          w := assoc!*!*(car b, labelvals);
          if null w then <<
             converged := nil;
             w := car b . pc;
             labelvals := w . labelvals >>
          else if cdr w neq pc then <<
             rplacd(w, pc);
             converged := nil >>;

% move on pc by the length of the block excluding any exit code
          pc := pc + caddr b;

          x := cadr b;
          if null x then nil                      % no EXIT needed
          else if null cdr x then pc := pc + 1    % EXIT operation
          else if car x = 'ICASE then pc := pc + 2*length x
          else <<
% by this stage I demand that (a) the labels in jump instructions
% are simple atomic labels (and never (EXIT) psuedo-labels) and (b)
% there are no longer any 2-way jumps - everything is just (JUMPcond l)
% where the alternative case is handled by just dropping through.
% But note that the JUMPcond will sometimes be composite (eg in effect
% <LOADLOC 2/JUMPT>, eg)
             w := assoc!*!*(cadr x, labelvals);
             if null w then <<
                w := 128;           % will be a "short" offset
                converged := nil >>
             else w := cdr w - pc;  % the offset
             w := s!:expand_jump(car x, w);  % list of bytes to plant
             pc := pc + length w >> >>
       >> until converged;
    return (pc . labelvals)
  end;

symbolic procedure s!:plant_basic_block(vec, pc, b);
% For this to give a sensible display the list of bytes must have
% a comment/annotation after every operation in it.  This is ensured by
% s!:outop.
  begin
    scalar tagged;
    for each i in b do <<
       if atom i then <<
          if symbolp i then i := get(i, 's!:opcode);
          if not tagged and (!*plap or !*pgwd) then <<
             s!:prinhex4 pc; princ ":"; ttab 8; tagged := t >>;
          if not fixp i or i < 0 or i > 255 then error("bad byte to put", i);
          bps!-putv(vec, pc, i);
          if !*plap or !*pgwd then << s!:prinhex2 i; princ " " >>;
          pc := pc + 1 >>
       else if !*plap or !*pgwd then <<
          ttab 23;
          princ car i;
          for each w in cdr i do << princ " "; prin w >>;
          terpri(); tagged := nil >> >>;
    return pc
 end;

symbolic procedure s!:plant_bytes(vec, pc, bytelist, doc);
  begin
    if !*plap or !*pgwd then << s!:prinhex4 pc; princ ":"; ttab 8 >>;
    for each v in bytelist do <<
       if symbolp v then v := get(v, 's!:opcode);
       if not fixp v or v < 0 or v > 255 then error("bad byte to put", v);
       bps!-putv(vec, pc, v);
       if !*plap or !*pgwd then <<
           if posn() > 50 then << terpri(); ttab 8 >>;
           s!:prinhex2 v; princ " " >>;
       pc := pc + 1 >>;
    if !*plap or !*pgwd then <<
       if posn() > 23 then terpri();
       ttab 23;
       princ car doc;
       for each w in cdr doc do <<
           if posn() > 65 then << terpri(); ttab 23 >>;
           princ " "; prin w >>;
       terpri() >>;
    return pc
  end;

symbolic procedure s!:plant_exit_code(vec, pc, b, labelvals);
  begin
    scalar w, loc, low, high, r;
    if null b then return pc
    else if null cdr b then     % Simple EXIT
       return s!:plant_bytes(vec, pc, list get(car b, 's!:opcode), b)
    else if car b = 'ICASE then <<
       loc := pc + 3;
       for each ll in cdr b do <<
          w := cdr assoc!*!*(ll, labelvals) - loc;
          loc := loc + 2;
          if w < 0 then <<
             w := -w;
             low := ilogand(w, 255);
             high := 128 + truncate(w - low, 256) >>
          else <<
             low := ilogand(w, 255);
             high := truncate(w - low, 256) >>;
          r := low . high . r >>;
       r := get('ICASE, 's!:opcode) . length cddr b . reversip r;
       return s!:plant_bytes(vec, pc, r, b) >>;
    w := cdr assoc!*!*(cadr b, labelvals) - pc;
    w := s!:expand_jump(car b, w);  % list of bytes to plant
    return s!:plant_bytes(vec, pc, w, b)
  end;

deflist('(
          (JUMPL0NIL    ((LOADLOC0) JUMPNIL))
          (JUMPL0T      ((LOADLOC0) JUMPT))
          (JUMPL1NIL    ((LOADLOC1) JUMPNIL))
          (JUMPL1T      ((LOADLOC1) JUMPT))
          (JUMPL2NIL    ((LOADLOC2) JUMPNIL))
          (JUMPL2T      ((LOADLOC2) JUMPT))
          (JUMPL3NIL    ((LOADLOC3) JUMPNIL))
          (JUMPL3T      ((LOADLOC3) JUMPT))
          (JUMPL4NIL    ((LOADLOC4) JUMPNIL))
          (JUMPL4T      ((LOADLOC4) JUMPT))
          (JUMPL0ATOM   ((LOADLOC0) JUMPATOM))
          (JUMPL0NATOM  ((LOADLOC0) JUMPNATOM))
          (JUMPL1ATOM   ((LOADLOC1) JUMPATOM))
          (JUMPL1NATOM  ((LOADLOC1) JUMPNATOM))
          (JUMPL2ATOM   ((LOADLOC2) JUMPATOM))
          (JUMPL2NATOM  ((LOADLOC2) JUMPNATOM))
          (JUMPL3ATOM   ((LOADLOC3) JUMPATOM))
          (JUMPL3NATOM  ((LOADLOC3) JUMPNATOM))
          (JUMPST0NIL   ((STORELOC0) JUMPNIL))
          (JUMPST0T     ((STORELOC0) JUMPT))
          (JUMPST1NIL   ((STORELOC1) JUMPNIL))
          (JUMPST1T     ((STORELOC1) JUMPT))
          (JUMPST2NIL   ((STORELOC2) JUMPNIL))
          (JUMPST2T     ((STORELOC2) JUMPT))
          (JUMPFREE1NIL ((LOADFREE1) JUMPNIL))
          (JUMPFREE1T   ((LOADFREE1) JUMPT))
          (JUMPFREE2NIL ((LOADFREE2) JUMPNIL))
          (JUMPFREE2T   ((LOADFREE2) JUMPT))
          (JUMPFREE3NIL ((LOADFREE3) JUMPNIL))
          (JUMPFREE3T   ((LOADFREE3) JUMPT))
          (JUMPFREE4NIL ((LOADFREE4) JUMPNIL))
          (JUMPFREE4T   ((LOADFREE4) JUMPT))
          (JUMPFREENIL  ((LOADFREE !*) JUMPNIL))
          (JUMPFREET    ((LOADFREE !*) JUMPT))
          (JUMPLIT1EQ   ((LOADLIT1) JUMPEQ))
          (JUMPLIT1NE   ((LOADLIT1) JUMPNE))
          (JUMPLIT2EQ   ((LOADLIT2) JUMPEQ))
          (JUMPLIT2NE   ((LOADLIT2) JUMPNE))
          (JUMPLIT3EQ   ((LOADLIT3) JUMPEQ))
          (JUMPLIT3NE   ((LOADLIT3) JUMPNE))
          (JUMPLIT4EQ   ((LOADLIT4) JUMPEQ))
          (JUMPLIT4NE   ((LOADLIT4) JUMPNE))
          (JUMPLITEQ    ((LOADLIT !*) JUMPEQ))
          (JUMPLITNE    ((LOADLIT !*) JUMPNE))
          (JUMPLITEQ!*  ((LOADLIT !* SWOP) JUMPEQ))
          (JUMPLITNE!*  ((LOADLIT !* SWOP) JUMPNE))
          (JUMPB1NIL    ((BUILTIN1 !*) JUMPNIL))
          (JUMPB1T      ((BUILTIN1 !*) JUMPT))
          (JUMPB2NIL    ((BUILTIN2 !*) JUMPNIL))
          (JUMPB2T      ((BUILTIN2 !*) JUMPT))
          (JUMPFLAGP    ((LOADLIT !* FLAGP) JUMPT))
          (JUMPNFLAGP   ((LOADLIT !* FLAGP) JUMPNIL))
          (JUMPEQCAR    ((LOADLIT !* EQCAR) JUMPT))
          (JUMPNEQCAR   ((LOADLIT !* EQCAR) JUMPNIL))
          ), 's!:expand_jump);

fluid '(s!:backwards_jump s!:longer_jump);

<< s!:backwards_jump := make!-simple!-string 256;
   s!:longer_jump    := make!-simple!-string 256;
   nil >>;


for each op in '(
   (JUMP         JUMP_B       JUMP_L       JUMP_BL)
   (JUMPNIL      JUMPNIL_B    JUMPNIL_L    JUMPNIL_BL)
   (JUMPT        JUMPT_B      JUMPT_L      JUMPT_BL)
   (JUMPATOM     JUMPATOM_B   JUMPATOM_L   JUMPATOM_BL)
   (JUMPNATOM    JUMPNATOM_B  JUMPNATOM_L  JUMPNATOM_BL)
   (JUMPEQ       JUMPEQ_B     JUMPEQ_L     JUMPEQ_BL)
   (JUMPNE       JUMPNE_B     JUMPNE_L     JUMPNE_BL)
   (JUMPEQUAL    JUMPEQUAL_B  JUMPEQUAL_L  JUMPEQUAL_BL)
   (JUMPNEQUAL   JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL)
   (CATCH        CATCH_B      CATCH_L      CATCH_BL)) do <<
   putv!-char(s!:backwards_jump,
         get(car op, 's!:opcode), get(cadr op, 's!:opcode));
   putv!-char(s!:backwards_jump,
         get(caddr op, 's!:opcode), get(cadddr op, 's!:opcode));
   putv!-char(s!:longer_jump,
         get(car op, 's!:opcode), get(caddr op, 's!:opcode));
   putv!-char(s!:longer_jump,
         get(cadr op, 's!:opcode), get(cadddr op, 's!:opcode)) >>;


symbolic procedure s!:expand_jump(op, offset);
  begin
    scalar arg, low, high, opcode, expanded;
    if not atom op then <<
       arg := cadr op;
       op := car op;
       offset := offset - 1 >>;
    expanded := get(op, 's!:expand_jump);
% The special compact jumps only support forward jumps by up to 255 bytes -
% they do not allow for backwards or long jumps. I also expand the jumps
% to a longer form if the argument is 256 or higher (in which case I must
% have an expansion that uses LOADLIT or LOADFREE and I turn it into one
% of the longer sequences that can access up to position 2047 in the literal
% vector.
    if expanded and
       not (2 <= offset and offset < 256+2 and
            (null arg or arg < 256)) then <<
       % Here I need to expand the branch
       op := cadr expanded;
       expanded := car expanded;
       if arg then <<
          if arg > 2047 then
              error("function uses too many literals (2048 limit)")
          else if arg > 255 then begin
             scalar high, low;
             low := ilogand(expanded, 255);
             high := truncate(expanded - low, 256);
% LOADLIT and LOADFREE are encoded here as sub-types of the BIGCALL opcode.
             expanded := 'BIGCALL .
               get(car expanded, 's!:longform) + high .
               low . cddr expanded end
          else expanded := subst(arg, '!*, expanded);
          offset := offset + 1 >>;
       offset := offset - length expanded;
       arg := nil >>
    else expanded := nil;
    opcode := get(op, 's!:opcode);
    if null opcode then error(0, list(op, offset, "invalid block exit"));
    if -256+2 < offset and offset < 256+2 then offset := offset - 2
    else << high := t; offset := offset - 3 >>;
    if offset < 0 then <<
       opcode := byte!-getv(s!:backwards_jump, opcode);
       offset := -offset >>;
    if high then <<
       low := logand(offset, 255);
       high := truncate(offset - low,256) >>
    else if (low := offset) > 255 then error(0, "Bad offset in expand_jump");
    if arg then return list(opcode, arg, low)
    else if not high then return append(expanded, list(opcode, low))
    else return append(expanded,
         list(byte!-getv(s!:longer_jump, opcode), high, low))
  end;

%
% Each expression processed occurs in a context - for CSL we have
% a strict interpretation of 'program' context - and to allow
% some optimisations we also distinguish 'top level', 'normal'
% and 'void'.  Contexts are coded numerically, which is a long
% established hack, but pretty inscrutable - here are the codes..
%      0    a top-level expression, value is value of current fn
%      1    an expression whose value is needed, but not at top level
%      2    an expression whose value is not needed (e.g. in PROGN)
%      4    value not needed because in PROG context: top level PROG
%      5    in prog context, PROGs value was needed
%      6    in prog context, PROG was in void context
%
% Note that to support REDUCE I seem to have to allow GO and RETURN
% to appear anywhere within a progn that is itself in prog context,
% and not just in the final position.  For COMMON Lisp GO and
% RETURN-FROM statements can appear pretty-well anywhere.

symbolic procedure s!:comval(x, env, context);
% s!:comval is the central dispatch procedure in the compiler - calling
% it will generate code to load the value of x into the A register,
% pushing down previous value through B.
  begin
    scalar helper;
    x := s!:improve x;
    if atom x then return s!:comatom(x, env, context)
    else if eqcar(car x, 'lambda) then
        return s!:comlambda(cadar x, cddar x, cdr x, env, context)
    else if car x eq s!:current_function then s!:comcall(x, env, context)
!#if common!-lisp!-mode
    else if helper := s!:local_macro car x then <<
       if atom cdr helper then
          s!:comval('funcall . cdr helper . cdr x, env, context)
       else s!:comval(funcall('lambda . cdr helper, x), env, context) >>
!#endif
    else if (helper := get(car x, 's!:compilermacro)) and
            (helper := funcall(helper, x, env, context)) then
        return s!:comval(helper, env, context)
    else if (helper := get(car x, 's!:newname)) then
        return s!:comval(helper . cdr x, env, context)
    else if helper := get(car x, 's!:compfn) then
        return funcall(helper, x, env, context)
    else if helper := macro!-function car x then
       return s!:comval(funcall(helper, x), env, context)
    else return s!:comcall(x, env, context)
  end;

symbolic procedure s!:comspecform(x, env, context);
   error(0, list("special form", x));

% This establishes a default handler for each special form so that
% any that I forget to treat more directly will cause a tidy error
% if found in compiled code.  The conditional definition here is to
% allow me to re-load this file on top of itself during bootstrapping.
% The list here can be a reminder of ways that this compiler is
% incomplete.

if null get('and, 's!:compfn) then <<
    put('compiler!-let,          's!:compfn, function s!:comspecform);
    put('de,                     's!:compfn, function s!:comspecform);
    put('defun,                  's!:compfn, function s!:comspecform);
    put('eval!-when,             's!:compfn, function s!:comspecform);
    put('flet,                   's!:compfn, function s!:comspecform);
    put('labels,                 's!:compfn, function s!:comspecform);
    put('macrolet,               's!:compfn, function s!:comspecform);
!#if (not common!-lisp!-mode)
% In Common Lisp Mode I support there. In Standard Lisp mode they
% are not very meaningful so I do not, but I still reserve the names.
    put('multiple!-value!-call,  's!:compfn, function s!:comspecform);
    put('multiple!-value!-prog1, 's!:compfn, function s!:comspecform);
    put('prog!*,                 's!:compfn, function s!:comspecform);
    put('progv,                  's!:compfn, function s!:comspecform);
!#endif
    nil >>;

symbolic procedure s!:improve u;
  begin
    scalar w;
    if atom u then return u
    else if (w := get(car u, 's!:tidy_fn)) then 
       return funcall(w, u)
    else if (w := get(car u, 's!:newname)) then
       return s!:improve (w . cdr u)
    else return u
  end;

symbolic procedure s!:imp_minus u;
  begin
    scalar a;
    a := s!:improve cadr u;
    return if numberp a then -a
      else if eqcar(a, 'minus) or eqcar(a, 'iminus) then cadr a
      else if eqcar(a, 'difference) then
         s!:improve list('difference, caddr a, cadr a)
      else if eqcar(a, 'idifference) then
         s!:improve list('idifference, caddr a, cadr a)
      else list(car u, a)
  end;

put('minus, 's!:tidy_fn, 's!:imp_minus);
put('iminus, 's!:tidy_fn, 's!:imp_minus);

!#if common!-lisp!-mode

symbolic procedure s!:imp_1!+ u;
  s!:improve ('add1 . cdr u);

put('!1!+, 's!:tidy_fn, 's!:imp_1!+);

symbolic procedure s!:imp_1!- u;
  s!:improve ('sub1 . cdr u);

put('!1!-, 's!:tidy_fn, 's!:imp_1!-);

!#endif

symbolic procedure s!:imp_times u;
  begin
    scalar a, b;
    if not (length u = 3) then
       return car u . for each v in cdr u collect s!:improve v;
    a := s!:improve cadr u;
    b := s!:improve caddr u;
    return if a = 1 then b
      else if b = 1 then a
      else if a = -1 then s!:imp_minus list('minus, b)
      else if b = -1 then s!:imp_minus list('minus, a)
      else list(car u, a, b)
  end;

put('times, 's!:tidy_fn, 's!:imp_times);

symbolic procedure s!:imp_itimes u;
  begin
    scalar a, b;
    if not (length u = 3) then
       return car u . for each v in cdr u collect s!:improve v;
    a := s!:improve cadr u;
    b := s!:improve caddr u;
    return if a = 1 then b
      else if b = 1 then a
      else if a = -1 then s!:imp_minus list('iminus, b)
      else if b = -1 then s!:imp_minus list('iminus, a)
      else list(car u, a, b)
  end;

put('itimes, 's!:tidy_fn, 's!:imp_itimes);

symbolic procedure s!:imp_difference u;
  begin
    scalar a, b;
    a := s!:improve cadr u;
    b := s!:improve caddr u;
    return if a = 0 then s!:imp_minus list('minus, b)
      else if b = 0 then a
      else list(car u, a, b)
  end;

put('difference, 's!:tidy_fn, 's!:imp_difference);

symbolic procedure s!:imp_idifference u;
  begin
    scalar a, b;
    a := s!:improve cadr u;
    b := s!:improve caddr u;
    return if a = 0 then s!:imp_minus list('iminus, b)
      else if b = 0 then a
      else list(car u, a, b)
  end;

put('idifference, 's!:tidy_fn, 's!:imp_idifference);

% s!:iseasy yields true if the given expression can be loaded without
% disturbing registers.

symbolic procedure s!:alwayseasy x;
   t;

put('quote, 's!:helpeasy, function s!:alwayseasy);
put('function, 's!:helpeasy, function s!:alwayseasy);

symbolic procedure s!:easyifarg x;
    null cdr x or (null cddr x and s!:iseasy cadr x);

put('ncons, 's!:helpeasy, function s!:easyifarg);

put('car, 's!:helpeasy, function s!:easyifarg);
put('cdr, 's!:helpeasy, function s!:easyifarg);
put('caar, 's!:helpeasy, function s!:easyifarg);
put('cadr, 's!:helpeasy, function s!:easyifarg);
put('cdar, 's!:helpeasy, function s!:easyifarg);
put('cddr, 's!:helpeasy, function s!:easyifarg);
put('caaar, 's!:helpeasy, function s!:easyifarg);
put('caadr, 's!:helpeasy, function s!:easyifarg);
put('cadar, 's!:helpeasy, function s!:easyifarg);
put('caddr, 's!:helpeasy, function s!:easyifarg);
put('cdaar, 's!:helpeasy, function s!:easyifarg);
put('cdadr, 's!:helpeasy, function s!:easyifarg);
put('cddar, 's!:helpeasy, function s!:easyifarg);
put('cdddr, 's!:helpeasy, function s!:easyifarg);
put('caaaar, 's!:helpeasy, function s!:easyifarg);
put('caaadr, 's!:helpeasy, function s!:easyifarg);
put('caadar, 's!:helpeasy, function s!:easyifarg);
put('caaddr, 's!:helpeasy, function s!:easyifarg);
put('cadaar, 's!:helpeasy, function s!:easyifarg);
put('cadadr, 's!:helpeasy, function s!:easyifarg);
put('caddar, 's!:helpeasy, function s!:easyifarg);
put('cadddr, 's!:helpeasy, function s!:easyifarg);
put('cdaaar, 's!:helpeasy, function s!:easyifarg);
put('cdaadr, 's!:helpeasy, function s!:easyifarg);
put('cdadar, 's!:helpeasy, function s!:easyifarg);
put('cdaddr, 's!:helpeasy, function s!:easyifarg);
put('cddaar, 's!:helpeasy, function s!:easyifarg);
put('cddadr, 's!:helpeasy, function s!:easyifarg);
put('cdddar, 's!:helpeasy, function s!:easyifarg);
put('cddddr, 's!:helpeasy, function s!:easyifarg);

%put('ncons, 's!:helpeasy, function s!:easyifarg);
%put('list, 's!:helpeasy, function s!:easyifarg);
%put('list!*, 's!:helpeasy, function s!:easyifarg);
%put('minus, 's!:helpeasy, function s!:easyifarg);
%put('minusp, 's!:helpeasy, function s!:easyifarg);

symbolic procedure s!:easygetv x;
  begin
    scalar a2;
    a2 := caddr x;
    if null !*carcheckflag and
       fixp a2 and a2 >= 0 and a2 < 256 then return s!:iseasy cadr x
    else return nil
  end;

put('getv, 's!:helpeasy, function s!:easygetv);
!#if common!-lisp!-mode
put('svref, 's!:heapeasy, function s!:easygetv);
!#endif

symbolic procedure s!:easyqgetv x;
  begin
    scalar a2;
    a2 := caddr x;
    if fixp a2 and a2 >= 0 and a2 < 256 then return s!:iseasy cadr x
    else return nil
  end;

put('qgetv, 's!:helpeasy, function s!:easyqgetv);
!#if common!-lisp!-mode
put('qsvref, 's!:heapeasy, function s!:easyqgetv);
!#endif

symbolic procedure s!:iseasy x;
  begin
    scalar h;
    if atom x then return t;
    if not atom car x then return nil;
    if h := get(car x, 's!:helpeasy) then return funcall(h, x)
    else return nil
  end;

symbolic procedure s!:instate_local_decs(v, d, w);
  begin
    scalar fg;
    if fluidp v then return w;
    for each z in d do
       if eqcar(z, 'special) and memq(v, cdr z) then fg := t;
    if fg then << 
        make!-special v;
        w := v . w >>;
    return w
  end;

symbolic procedure s!:residual_local_decs(d, w);
  begin
    for each z in d do
      if eqcar(z, 'special) then for each v in cdr z do
         if not fluidp v and not globalp v then <<
            make!-special v;
            w := v . w >>;
    return w
  end;

symbolic procedure s!:cancel_local_decs w;
   unfluid w;

symbolic procedure s!:find_local_decs body;
  begin
    scalar w, local_decs;
    while body and (eqcar(car body, 'declare) or stringp car body) do <<
       if stringp car body then w := car body . w
       else local_decs := append(local_decs, cdar body);
       body := cdr body >>;
% I put back any strings since although MAYBE they are documentation also
% it could be that one was a result.
    while w do << body := car w . body; w := cdr w >>;
    return local_decs . body
  end;

symbolic procedure s!:comlambda(bvl, body, args, env, context);
% Handle embedded lambda expressions, which may well be serving as
% the construct that Common Lisp would write as (let ((x v)) ...)
% NOTE: I do not support &optional or &rest keywords with embedded
% lambda expressions. This is maybe just because I think that they would
% be a gross frivolity!  If I find an important piece of code that
% happens (say because of some macro-expansion) to use them I can
% process out the keywords here.
  begin
    scalar s, nbvl, fluids, fl1, w, local_decs;
    nbvl := s := cdr env;
    body := s!:find_local_decs body;
    local_decs := car body; body := cdr body;
    if atom body then body := nil
    else if atom cdr body then body := car body
    else body := 'progn . body;
    w := nil;
    for each v in bvl do w := s!:instate_local_decs(v, local_decs, w);
    for each v in bvl do <<
       if fluidp v or globalp v then begin
          scalar g;
          g := gensym();
          nbvl := g . nbvl;
          fl1 := v . fl1;
          fluids := (v . g) . fluids end
       else nbvl := v . nbvl;
% It would be even better to collect up NILs here and use s!:outstack with
% larger args (where possible), but at least this is a slight improvement!
       if car args = nil then s!:outstack 1
       else <<
          s!:comval(car args, env, 1);
          s!:outopcode0('PUSH, '(PUSH)) >>;
       rplacd(env, 0 . cdr env);
       args := cdr args >>;
    rplacd(env, nbvl);
    if fluids then <<
       fl1 := s!:vecof fl1;
       s!:outopcode1lit('FREEBIND, fl1, env);
       for each v in nil . fluids do rplacd(env, 0 . cdr env);
% The number in the environment map where a variable name would more
% normally be wanted marks a place where free variables are saved. It
% indicates how many stack locations are used by the free variable save block.
       rplacd(env, (2 + length fluids) . cdr env);
       for each v in fluids do
          s!:comval(list('setq, car v, cdr v), env, 2) >>;
    w := s!:residual_local_decs(local_decs, w);
% I use a context of 1 here (value needed) regardless of where I am. It avoids
% program context filtering down into embedded lambdas.
    s!:comval(body, env, 1);
    s!:cancel_local_decs w;
    if fluids then s!:outopcode0('FREERSTR, '(FREERSTR));
    s!:outlose length bvl;
    rplacd(env, s)
  end;

symbolic procedure s!:loadliteral(x, env);
  if member!*!*(list('quote, x), s!:a_reg_values) then nil
  else <<
    if x = nil then s!:outopcode0('VNIL, '(loadlit nil))
    else s!:outopcode1lit('LOADLIT, x, env);
    s!:a_reg_values := list list('quote, x) >>;

symbolic procedure s!:comquote(x, env, context);
  if context <= 1 then s!:loadliteral(cadr x, env);

put('quote, 's!:compfn, function s!:comquote);

fluid '(s!:current_exitlab s!:current_proglabels s!:local_macros);

!#if common!-lisp!-mode

symbolic procedure s!:comval_m(x, env, context, s!:local_macros);
    s!:comval(x, env, context);

symbolic procedure s!:comflet(x, env, context);
  begin
    scalar w, r, g, save;
    save := cdr env;
    for each d in cadr x do <<
       g := gensym();
       s!:comval(list('function, 'lambda . cdr d), env, context);
       s!:outopcode0('PUSH, '(PUSH));
       rplacd(env, g . cdr env);
       r := (car d . g) . r >>;
    s!:comval_m('progn . cddr x, env, context, append(r, s!:local_macros));
    s!:outlose length cadr x;
    rplacd(env, save)
  end;

put('flet, 's!:compfn, function s!:comflet);

symbolic procedure s!:comlabels(x, env, context);
  begin
    scalar w, w1, r, g;
    for each d in cadr x do <<
       g := gensym();
       w := list('setq, g, list('function, 'lambda . cdr d)) . w;
       w1 := list g . w1;
       r := (car d . g) . r >>;
    x := 'let . reverse w1 . append(w, cddr x);
    return s!:comval_m(x, env, context, append(r, s!:local_macros))
  end;

put('labels, 's!:compfn, function s!:comlabels);

symbolic procedure s!:commacrolet(x, env, context);
   s!:comval_m('progn . cddr x, env, context,
               append(cadr x, s!:local_macros));

put('macrolet, 's!:compfn, function s!:commacrolet);

symbolic procedure s!:local_macro fn;
  begin
    scalar w, y;
    w := list(nil, nil, nil, s!:local_macros) . s!:lexical_env;
    while w do <<
       y := atsoc(fn, cadddr car w);
       if y then w := nil else w := cdr w >>;
    return y
  end;

!#endif

symbolic procedure s!:comfunction(x, env, context);
  if context <= 1 then
  << x := cadr x;
     if eqcar(x, 'lambda) then begin
        scalar g, w, s!:used_lexicals;
        s!:has_closure := t;
% I base the name used on the current date, which probably makes
% it hard to have clashes.
        g := hashtagged!-name('lambda, cdr x);
% If I find an expression (FUNCTION (LAMBDA ...)) I will create a lexical
% closure.  In other cases FUNCTION behaves just like QUOTE.
        w := s!:compile1(g, cadr x, cddr x,
                         list(cdr env, s!:current_exitlab,
                              s!:current_proglabels, s!:local_macros) .
                           s!:lexical_env);
        if s!:used_lexicals then
            w := s!:compile1(g, gensym() . cadr x, cddr x,
                         list(cdr env, s!:current_exitlab,
                              s!:current_proglabels, s!:local_macros) .
                           s!:lexical_env);
        s!:other_defs := append(w, s!:other_defs);
        s!:loadliteral(g, env);
        w := length cdr env;
        if s!:used_lexicals then <<
% If the lambda expression did not use any non-local lexical references
% then it does not need a closure, so I can load its value slightly more
% efficiently and also permit tal=il-call optimisation in the function
% that loads it.
            s!:has_closure := t;
            if w > 4095 then error "stack frame > 4095"
            else if w > 255 then
               s!:outopcode2('BIGSTACK, 128+truncate(w,256), logand(w, 255),
                             list('CLOSURE, w))
            else s!:outopcode1('CLOSURE, w, x) >> end
!#if common!-lisp!-mode
     else if context := s!:local_macro x then <<
        if atom cdr context then s!:comatom(cdr context, env, 1)
        else error(0, "(function <local macro>) is illegal") >>
!#endif
     else s!:loadliteral(x, env) >>;

put('function, 's!:compfn, function s!:comfunction);

symbolic procedure s!:should_be_fluid x;
   if not (fluidp x or globalp x) then <<
       if !*pwrds then <<  % The !*pwrds flag controls this verbosity too
          if posn() neq 0 then terpri();
          princ "+++ ";
          prin x;
!#if common!-lisp!-mode
          princ " treated as if locally SPECIAL";
!#else
          princ " declared fluid";
!#endif
          terpri() >>;
!#if (not common!-lisp!-mode)
       fluid list x;
!#endif
       nil >>;

symbolic procedure s!:find_lexical(x, lex, n);
  begin
    scalar p;
    if null lex then return nil;
    p := memq(x, caar lex);
    if p then <<
        if not memq(x, s!:used_lexicals) then
            s!:used_lexicals := x . s!:used_lexicals;
        return list(n, length p) >>
    else return s!:find_lexical(x, cdr lex, n+1)
  end;

global '(s!:loadlocs);

s!:loadlocs := s!:vecof '(LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3
                          LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7
                          LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11);

symbolic procedure s!:comatom(x, env, context);
  begin
    scalar n, w;
    if context > 1 then return nil
    else if null x or not symbolp x then return s!:loadliteral(x, env);
!#if common!-lisp!-mode
    if keywordp x then return s!:loadliteral(x, env);
!#endif
    n := 0;
    w := cdr env;
    while w and not eqcar(w, x) do << n := add1 n; w := cdr w >>;
    if w then <<
       w := 'loc . w;
       if member!*!*(w, s!:a_reg_values) then return nil
       else <<
          if n < 12 then s!:outopcode0(getv(s!:loadlocs, n),
                                       list('LOADLOC, x))
          else if n > 4095 then error "stack frame > 4095"
          else if n > 255 then
             s!:outopcode2('BIGSTACK, truncate(n,256),
                           logand(n, 255), list('LOADLOC, x))
          else s!:outopcode1('LOADLOC, n, x);
          s!:a_reg_values := list w;
          return nil >> >>;
    if w := s!:find_lexical(x, s!:lexical_env, 0) then <<
        if member!*!*('lex . w, s!:a_reg_values) then return nil;
        s!:outlexref('LOADLEX, length cdr env, car w, cadr w, x);
        s!:a_reg_values := list('lex . w);
        return nil >>;
    s!:should_be_fluid x;
    if flagp(x, 'constant!?) then return s!:loadliteral(eval x, env);
    w := 'free . x;
    if member!*!*(w, s!:a_reg_values) then return nil;
    s!:outopcode1lit('LOADFREE, x, env);
    s!:a_reg_values := list w
  end;

flag('(t !$EOL!$ !$EOF!$), 'constant!?);

symbolic procedure s!:islocal(x, env);
% Returns a small integer if x is a local variable in the current environment.
% return 99999 otherwise. Yes I know that 99999 is a silly value to use.
  begin
    scalar n, w;
    if null x or not symbolp x or x eq t then return 99999;
    n := 0;
    w := cdr env;
    while w and not eqcar(w, x) do << n := add1 n; w := cdr w >>;
    if w then return n
    else return 99999
  end;

symbolic procedure s!:load2(a, b, env);
% s!:load2(a,b,env) calls s!:comval on a and then on b, so that
% a end up in the B register and b ends up in the A register(!).
% If processing b would corrupt the pre-loaded value of a it is
% necessary to issue PUSH and POP operations.
% If a final SWOP is needed then this returns T, otherwise NIL
 <<
    if s!:iseasy b then begin
       scalar wa, wb, w;
       wa := s!:islocal(a, env);
       wb := s!:islocal(b, env);
       if wa < 4 and wb < 4 then <<
          if wa = 0 and wb = 1 then w := 'LOC0LOC1
          else if wa = 1 and wb = 2 then w := 'LOC1LOC2   
          else if wa = 2 and wb = 3 then w := 'LOC2LOC3
          else if wa = 1 and wb = 0 then w := 'LOC1LOC0
          else if wa = 2 and wb = 1 then w := 'LOC2LOC1
          else if wa = 3 and wb = 2 then w := 'LOC3LOC2;
          if w then <<
             s!:outopcode0(w, list('LOCLOC, a, b));
             return nil >> >>;
       s!:comval(a, env, 1);
       s!:a_reg_values := nil;
       s!:comval(b, env, 1);
       return nil end
!#if common!-lisp!-mode
% For Common Lisp it seems that I *must* evaluate args strictly left-to-right.
% I can violate this rule if the item I move in evaluation order is something
% which has an utterly constant value.
    else if numberp a or 
            stringp a or 
            keywordp a or
            eqcar(a, 'quote) then <<
       s!:comval(b, env, 1);
       s!:a_reg_values := nil;
       s!:comval(a, env, 1);
       t >>
    else <<
       s!:comval(a, env, 1);
       s!:outopcode0('PUSH, '(PUSH));
       rplacd(env, 0 . cdr env);
       s!:a_reg_values := nil;
       s!:comval(b, env, 1);
       s!:outopcode0('POP, '(POP));
       rplacd(env, cddr env);
       t >>
!#else
% Here, in Standard Lisp mode, I will compile the arguments left to right
% if !*ord is set. Otherwise in the cases that get down here I can save
% some generated code (and hence bot time and space) by working right
% to left.
    else if !*ord then <<
       s!:comval(a, env, 1);
       s!:outopcode0('PUSH, '(PUSH));
       rplacd(env, 0 . cdr env);
       s!:a_reg_values := nil;
       s!:comval(b, env, 1);
       s!:outopcode0('POP, '(POP));
       rplacd(env, cddr env);
       t >>
    else if s!:iseasy a then <<
       s!:comval(b, env, 1);
       s!:a_reg_values := nil;
       s!:comval(a, env, 1);
       t >>
    else <<
       s!:comval(b, env, 1);         % b is a complicated expression here
       s!:outopcode0('PUSH, '(PUSH));
       rplacd(env, 0 . cdr env);
       s!:a_reg_values := nil;
       s!:comval(a, env, 1);
       s!:outopcode0('POP, '(POP));
       rplacd(env, cddr env);        % this case saves a SWAP afterwards
       nil >>
!#endif
 >>;

global '(s!:carlocs s!:cdrlocs s!:caarlocs);

s!:carlocs  := s!:vecof '(CARLOC0  CARLOC1  CARLOC2  CARLOC3
                          CARLOC4  CARLOC5  CARLOC6  CARLOC7
                          CARLOC8  CARLOC9  CARLOC10 CARLOC11);
s!:cdrlocs  := s!:vecof '(CDRLOC0  CDRLOC1  CDRLOC2  CDRLOC3
                          CDRLOC4  CDRLOC5);
s!:caarlocs := s!:vecof '(CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3);

flag('(plus2 times2 eq equal), 's!:symmetric);

flag('(car cdr caar cadr cdar cddr
       ncons add1 sub1 numberp length), 's!:onearg);

flag('(cons xcons list2 get flagp plus2 difference times2
       greaterp lessp apply1 eq equal getv qgetv eqcar), 's!:twoarg);

flag('(apply2 list2!* list3 acons), 's!:threearg);

% The case of APPLY3 is handled by in-line code rather than a general flag,
% but I leave the flag statement here as a reminder that it is present as a
% special case. There is a byte-code allocated for APPLY4, but at present
% the compiler never generates it and the bytecode interpreter does not
% implement it. It is reserved in case that sort of use of APPLY/FUNCALL
% proves sufficiently important.
% flag('(apply3), 's!:fourarg);
% flag('(apply4), 's!:fivearg);

symbolic procedure s!:comcall(x, env, context);
% generate a procedure call - different CALL instructions
% and formats are used for different numbers of arguments.
  begin
    scalar fn, args, nargs, op, s, w1, w2, w3, sw;
    fn := car x;
    args := for each v in cdr x collect s!:improve v;
    nargs := length args;
% Standard Lisp only allows 15 arguments.  CSL supports 20 just
% to be on the safe side, but it tells the programmer when the lower
% limit is violated. Common Lisp can cope with rather more args, but I
% will still let people know if I think they have gone over the top.
    if nargs > 15 and !*pwrds then <<
        if posn() neq 0 then terpri();
        princ "+++ ";
        prin fn;
        princ " called with ";
        prin nargs;
        princ " from function ";
        prin s!:current_function;
        terpri() >>;
    s := cdr env;
    if nargs = 0 then
       if (w2 := get(fn, 's!:builtin0)) then s!:outopcode1('BUILTIN0, w2, fn)
       else s!:outopcode1lit('CALL0, fn, env)
    else if nargs = 1 then <<
       if fn = 'car and
          (w2 := s!:islocal(car args, env)) < 12 then
          s!:outopcode0(getv(s!:carlocs, w2), list('carloc, car args))
       else if fn = 'cdr and
          (w2 := s!:islocal(car args, env)) < 6 then
          s!:outopcode0(getv(s!:cdrlocs, w2), list('cdrloc, car args))
       else if fn = 'caar and
          (w2 := s!:islocal(car args, env)) < 4 then
          s!:outopcode0(getv(s!:caarlocs, w2), list('caarloc, car args))
       else <<
          s!:comval(car args, env, 1);
          if flagp(fn, 's!:onearg) then s!:outopcode0(fn, list fn)
          else if (w2 := get(fn, 's!:builtin1)) then
            s!:outopcode1('BUILTIN1, w2, fn)
          else s!:outopcode1lit('CALL1, fn, env) >> >>
    else if nargs = 2 then <<
        sw := s!:load2(car args, cadr args, env);
        if flagp(fn, 's!:symmetric) then sw := nil;
        if flagp(fn, 's!:twoarg) then <<
           if sw then s!:outopcode0('SWOP, '(SWOP));
           s!:outopcode0(fn, list fn) >>
        else <<
          w3 := get(fn, 's!:builtin2);
          if sw then <<
              if w3 then s!:outopcode1('BUILTIN2R, w3, fn)
              else s!:outopcode1lit('CALL2R, fn, env) >>
          else if w3 then s!:outopcode1('BUILTIN2, w3, fn)
          else s!:outopcode1lit('CALL2, fn, env) >> >>
    else if nargs = 3 then <<
        if car args = nil then s!:outstack 1
        else <<
           s!:comval(car args, env, 1);
           s!:outopcode0('PUSH, '(PUSHA3)) >>;
        rplacd(env, 0 . cdr env);
        s!:a_reg_values := nil;
        if s!:load2(cadr args, caddr args, env) then
           s!:outopcode0('SWOP, '(SWOP));
        if flagp(fn, 's!:threearg) then
           s!:outopcode0(if fn = 'list2!* then 'list2star else fn, list fn)
        else if w2 := get(fn, 's!:builtin3) then
           s!:outopcode1('BUILTIN3, w2, fn)
        else s!:outopcode1lit('CALL3, fn, env);
        rplacd(env, cddr env) >>
    else begin
% Functions with 4 or more arguments are called by pushing all their
% arguments onto the stack.  I expect that this will not be a common case.
      scalar largs;
      largs := reverse args;
      for each a in reverse cddr largs do <<
        if null a then s!:outstack 1
        else <<
           s!:comval(a, env, 1);
           if nargs = 4 then s!:outopcode0('PUSH, '(PUSHA4))
           else s!:outopcode0('PUSH, '(PUSHARG)) >>;
        rplacd(env, 0 . cdr env);
        s!:a_reg_values := nil >>;
      if s!:load2(cadr largs, car largs, env) then
         s!:outopcode0('SWOP, '(SWOP));
      if fn = 'apply3 and nargs = 4 then s!:outopcode0('APPLY3, '(APPLY3))
%     else if fn = 'apply4 and nargs = 5 then   % Not yet implemented.
%        s!:outopcode0('APPLY4, '(APPLY4));
      else if nargs > 255 then error("Over 255 args in a function call")
      else s!:outopcode2lit('CALLN, fn, nargs, list(nargs, fn), env);
      rplacd(env, s) end
  end;

% caaar to cddddr get expanded into compositions of
% car, cdr, caar, cadr, cdar and cddr - which in turn get
% compiled into direct bytecodes

symbolic procedure s!:ad_name l;
  if car l = 'a then
    if cadr l = 'a then 'caar else 'cadr
  else if cadr l = 'a then 'cdar else 'cddr;

symbolic procedure s!:comcarcdr3(x, env, context);
  begin
    scalar name, outer, c1, c2;
    name := cdr explode2 car x;
% Turns (eg) (caddr x) into (cadr (cdr x))
    x := list(s!:ad_name name,
            list(if caddr name = 'a then 'car else 'cdr, cadr x));
    return s!:comval(x, env, context)
  end;

put('caaar, 's!:compfn, function s!:comcarcdr3);
put('caadr, 's!:compfn, function s!:comcarcdr3);
put('cadar, 's!:compfn, function s!:comcarcdr3);
put('caddr, 's!:compfn, function s!:comcarcdr3);
put('cdaar, 's!:compfn, function s!:comcarcdr3);
put('cdadr, 's!:compfn, function s!:comcarcdr3);
put('cddar, 's!:compfn, function s!:comcarcdr3);
put('cdddr, 's!:compfn, function s!:comcarcdr3);

symbolic procedure s!:comcarcdr4(x, env, context);
  begin
    scalar name, outer, c1, c2;
    name := cdr explode2 car x;
    x := list(s!:ad_name name, list(s!:ad_name cddr name, cadr x));
    return s!:comval(x, env, context)
  end;

put('caaaar, 's!:compfn, function s!:comcarcdr4);
put('caaadr, 's!:compfn, function s!:comcarcdr4);
put('caadar, 's!:compfn, function s!:comcarcdr4);
put('caaddr, 's!:compfn, function s!:comcarcdr4);
put('cadaar, 's!:compfn, function s!:comcarcdr4);
put('cadadr, 's!:compfn, function s!:comcarcdr4);
put('caddar, 's!:compfn, function s!:comcarcdr4);
put('cadddr, 's!:compfn, function s!:comcarcdr4);
put('cdaaar, 's!:compfn, function s!:comcarcdr4);
put('cdaadr, 's!:compfn, function s!:comcarcdr4);
put('cdadar, 's!:compfn, function s!:comcarcdr4);
put('cdaddr, 's!:compfn, function s!:comcarcdr4);
put('cddaar, 's!:compfn, function s!:comcarcdr4);
put('cddadr, 's!:compfn, function s!:comcarcdr4);
put('cdddar, 's!:compfn, function s!:comcarcdr4);
put('cddddr, 's!:compfn, function s!:comcarcdr4);

% The next chunk is commented out - the "carcheck" flag was at one stage
% there so that *carcheckflag = nil would cause compilation to give
% unchecked car/cdr access, which ought to be faster.  However with the
% bytecode interpreter model I dedicate plenty of opcodes to regular car and
% cdr combinations, while unchecked car is supported in a rather simpler
% way, so the small savings in missing out the check are outweighed by the
% extra overheads of invoking the unchecked operation!

% I leave the flag there and cause it to map vector access (getv in Standard
% lisp and svref in Common Lisp) into a cheaper version that omits checking.
% This is more profitable becase (a) I do less in the bytecode model to make
% getv special, and (b) the overheads on array bound checking are greater
% than those for car/cdr chaining.

% symbolic procedure s!:comcar(x, env, context);
%   if !*carcheckflag then s!:comcall(x, env, context)
%   else s!:comval('qcar . cdr x, env, context);
% 
% put('car, 's!:compfn, function s!:comcar);
% 
% symbolic procedure s!:comcdr(x, env, context);
%   if !*carcheckflag then s!:comcall(x, env, context)
%   else s!:comval('qcdr . cdr x, env, context);
% 
% put('cdr, 's!:compfn, function s!:comcdr);
% 
% symbolic procedure s!:comcaar(x, env, context);
%   if !*carcheckflag then s!:comcall(x, env, context)
%   else s!:comval('qcaar . cdr x, env, context);
% 
% put('caar, 's!:compfn, function s!:comcaar);
% 
% symbolic procedure s!:comcadr(x, env, context);
%   if !*carcheckflag then s!:comcall(x, env, context)
%   else s!:comval('qcadr . cdr x, env, context);
% 
% put('cadr, 's!:compfn, function s!:comcadr);
% 
% symbolic procedure s!:comcdar(x, env, context);
%   if !*carcheckflag then s!:comcall(x, env, context)
%   else s!:comval('qcdar . cdr x, env, context);
% 
% put('cdar, 's!:compfn, function s!:comcdar);
% 
% symbolic procedure s!:comcddr(x, env, context);
%   if !*carcheckflag then s!:comcall(x, env, context)
%   else s!:comval('qcddr . cdr x, env, context);
% 
% put('cddr, 's!:compfn, function s!:comcddr);

symbolic procedure s!:comgetv(x, env, context);
  if !*carcheckflag then s!:comcall(x, env, context)
  else s!:comval('qgetv . cdr x, env, context);

put('getv, 's!:compfn, function s!:comgetv);

symbolic procedure s!:comqgetv(x, env, context);
  if fixp caddr x and caddr x >= 0 and caddr x < 256 then <<
    s!:comval(cadr x, env, 1);
    s!:outopcode1('QGETVN, caddr x, caddr x) >>
  else s!:comcall(x, env, context);

put('qgetv, 's!:compfn, function s!:comqgetv);

symbolic procedure s!:comget(x, env, context);
  begin
    scalar a, b, c, w;
    a := cadr x;
    b := caddr x;
    c := cdddr x;
    if eqcar(b, 'quote) then <<
       b := cadr b;
       w := symbol!-make!-fastget(b, nil);
       if c then <<
          if w then <<
             if s!:load2(a, b, env) then
                s!:outopcode0('SWOP, '(SWOP));
             s!:outopcode1('FASTGET, logor(w, 64), b) >>
          else s!:comcall(x, env, context) >>
       else <<
          s!:comval(a, env, 1);
          if w then s!:outopcode1('FASTGET, w, b)
          else s!:outopcode1lit('LITGET, b, env) >> >>
    else s!:comcall(x, env, context)
  end;

put('get, 's!:compfn, function s!:comget);

symbolic procedure s!:comflagp(x, env, context);
  begin
    scalar a, b;
    a := cadr x;
    b := caddr x;
    if eqcar(b, 'quote) then <<
       b := cadr b;
       s!:comval(a, env, 1);
       a := symbol!-make!-fastget(b, nil);
       if a then s!:outopcode1('FASTGET, logor(a, 128), b)
       else s!:comcall(x, env, context) >>
    else s!:comcall(x, env, context)
  end;

put('flagp, 's!:compfn, function s!:comflagp);

% plus and times (and later on, I guess, logand, logor and a few more)
% get macroexpanded into calls to two-argument versions of the same
% operators.

symbolic procedure s!:complus(x, env, context);
   s!:comval(expand(cdr x, 'plus2), env, context);

put('plus, 's!:compfn, function s!:complus);

!#if common!-lisp!-mode
put('!+, 's!:compfn, function s!:complus);
!#endif

symbolic procedure s!:comtimes(x, env, context);
   s!:comval(expand(cdr x, 'times2), env, context);

put('times, 's!:compfn, function s!:comtimes);

!#if common!-lisp!-mode
put('!*, 's!:compfn, function s!:comtimes);
!#endif


symbolic procedure s!:comiplus(x, env, context);
   s!:comval(expand(cdr x, 'iplus2), env, context);

put('iplus, 's!:compfn, function s!:comiplus);

symbolic procedure s!:comitimes(x, env, context);
   s!:comval(expand(cdr x, 'itimes2), env, context);

put('itimes, 's!:compfn, function s!:comitimes);

symbolic procedure s!:complus2(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    return if numberp a and numberp b then s!:comval(a+b, env, context)
       else if a = 0 then s!:comval(b, env, context)
       else if a = 1 then s!:comval(list('add1, b), env, context)
       else if b = 0 then s!:comval(a, env, context)
       else if b = 1 then s!:comval(list('add1, a), env, context)
       else if b = -1 then s!:comval(list('sub1, a), env, context)
       else s!:comcall(x, env, context)
  end;

put('plus2, 's!:compfn, function s!:complus2);

symbolic procedure s!:comdifference(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    return if numberp a and numberp b then s!:comval(a-b, env, context)
       else if a = 0 then s!:comval(list('minus, b), env, context)
       else if b = 0 then s!:comval(a, env, context)
       else if b = 1 then s!:comval(list('sub1, a), env, context)
       else if b = -1 then s!:comval(list('add1, a), env, context)
       else s!:comcall(x, env, context)
  end;

put('difference, 's!:compfn, function s!:comdifference);

symbolic procedure s!:comiplus2(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    return if numberp a and numberp b then s!:comval(a+b, env, context)
       else if a = 1 then s!:comval(list('iadd1, b), env, context)
       else if b = 1 then s!:comval(list('iadd1, a), env, context)
       else if b = -1 then s!:comval(list('isub1, a), env, context)
       else s!:comcall(x, env, context)
  end;

put('iplus2, 's!:compfn, function s!:comiplus2);

symbolic procedure s!:comidifference(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    return if numberp a and numberp b then s!:comval(a-b, env, context)
       else if b = 1 then s!:comval(list('isub1, a), env, context)
       else if b = -1 then s!:comval(list('iadd1, a), env, context)
       else s!:comcall(x, env, context)
  end;

put('idifference, 's!:compfn, function s!:comidifference);

symbolic procedure s!:comtimes2(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    return if numberp a and numberp b then s!:comval(a*b, env, context)
       else if a = 1 then s!:comval(b, env, context)
       else if a = -1 then s!:comval(list('minus, b), env, context)
       else if b = 1 then s!:comval(a, env, context)
       else if b = -1 then s!:comval(list('minus, a), env, context)
       else s!:comcall(x, env, context)
  end;

put('times2, 's!:compfn, function s!:comtimes2);
put('itimes2, 's!:compfn, function s!:comtimes2);

symbolic procedure s!:comminus(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    return if numberp a then s!:comval(-a, env, context)
       else if eqcar(a, 'minus) then s!:comval(cadr a, env, context)
       else s!:comcall(x, env, context)
  end;

put('minus, 's!:compfn, function s!:comminus);

symbolic procedure s!:comminusp(x, env, context);
  begin
    scalar a;
    a := s!:improve cadr x;
    if eqcar(a, 'difference) then return
       s!:comval('lessp . cdr a, env, context)
    else return s!:comcall(x, env, context)
  end;

put('minusp, 's!:compfn, function s!:comminusp);

symbolic procedure s!:comlessp(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    if b = 0 then return
       s!:comval(list('minusp, a), env, context)
    else return s!:comcall(x, env, context)
  end;

put('lessp, 's!:compfn, function s!:comlessp);

symbolic procedure s!:comiminusp(x, env, context);
  begin
    scalar a;
    a := s!:improve cadr x;
    if eqcar(a, 'difference) then return
       s!:comval('ilessp . cdr a, env, context)
    else return s!:comcall(x, env, context)
  end;

put('iminusp, 's!:compfn, function s!:comiminusp);

symbolic procedure s!:comilessp(x, env, context);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    if b = 0 then return
       s!:comval(list('iminusp, a), env, context)
    else return s!:comcall(x, env, context)
  end;

put('ilessp, 's!:compfn, function s!:comilessp);

% s!:comprogn is used not only when I see an explicit progn in the
% code, but to handle the implicit ones in cond and after lambda.
% it switches evaluation mode to a void context for all but the
% last expression

symbolic procedure s!:comprogn(x, env, context);
 << x := cdr x;
    if null x then s!:comval(nil, env, context)
    else begin
      scalar a;
      a := car x;
      while x := cdr x do <<
         s!:comval(a, env, if context >= 4 then context else 2);
         a := car x >>;
      s!:comval(a, env, context)
    end
 >>;

put('progn, 's!:compfn, function s!:comprogn);

symbolic procedure s!:comprog1(x, env, context);
  begin
    x := cdr x;
    if null x then return s!:comval(nil, env, context);
    s!:comval(car x, env, context);
    if null (x := cdr x) then return nil;
    s!:outopcode0('PUSH, '(PUSH));
    rplacd(env, 0 . cdr env);
    for each a in x do
        s!:comval(a, env, if context >= 4 then context else 2);
    s!:outopcode0('POP, '(POP));
    rplacd(env, cddr env)
  end;

put('prog1, 's!:compfn, function s!:comprog1);

symbolic procedure s!:comprog2(x, env, context);
  begin
    scalar a;
    x := cdr x;
    if null x then return s!:comval(nil, env, context);
    a := car x;
    s!:comval(a, env, if context >= 4 then context else 2);
    s!:comprog1(x, env, context)
  end;

put('prog2, 's!:compfn, function s!:comprog2);

!#if common!-lisp!-mode

% REDUCE seems to introduce a function called IDENTITY that is not quite this
% one. Shame! hence only do this in Common mode.

symbolic procedure s!:comidentity(x, env, context);
   s!:comval(cadr x, env, context);

put('identity, 's!:compfn, function s!:comidentity);

!#endif

symbolic procedure s!:outstack n;
  begin
    scalar w, a;
    w := s!:current_block;
    while w and not atom car w do w := cdr w;
    if eqcar(w, 'PUSHNIL) then a := 1
    else if eqcar(w, 'PUSHNIL2) then a := 2
    else if eqcar(w, 'PUSHNIL3) then a := 3
% If I has a "PUSHNILS 255" already issued it would do no good at all
% to pick it off here and attempt to consolidate it with a further PUSH.
% Indeed that would probably lead to disaster.
    else if w and numberp (a := car w) and not (a = 255) and
            eqcar(cdr w, 'PUSHNILS) then <<
       w := cdr w;
       s!:current_size := s!:current_size - 1 >>
    else a := nil;
    if a then <<
       s!:current_block := cdr w;
       s!:current_size := s!:current_size - 1;
       n := n + a >>;
    if n = 1 then s!:outopcode0('PUSHNIL, '(PUSHNIL))
    else if n = 2 then s!:outopcode0('PUSHNIL2, '(PUSHNIL2))
    else if n = 3 then s!:outopcode0('PUSHNIL3, '(PUSHNIL3))
    else if n > 255 then <<
       s!:outopcode1('PUSHNILS, 255, 255);
       s!:outstack(n-255) >>
    else if n > 3 then s!:outopcode1('PUSHNILS, n, n)
  end;

symbolic procedure s!:outlose n;
  begin
    scalar w, a;
    w := s!:current_block;
    while w and not atom car w do w := cdr w;
    if eqcar(w, 'LOSE) then a := 1
    else if eqcar(w, 'LOSE2) then a := 2
    else if eqcar(w, 'LOSE3) then a := 3
    else if w and numberp (a := car w) and not (a = 255) and
            eqcar(cdr w, 'LOSES) then <<
       w := cdr w;
       s!:current_size := s!:current_size - 1 >>
    else a := nil;
    if a then <<
       s!:current_block := cdr w;
       s!:current_size := s!:current_size - 1;
       n := n + a >>;
    if n = 1 then s!:outopcode0('LOSE, '(LOSE))
    else if n = 2 then s!:outopcode0('LOSE2, '(LOSE2))
    else if n = 3 then s!:outopcode0('LOSE3, '(LOSE3))
    else if n > 255 then <<
       s!:outopcode1('LOSES, 255, 255);
       s!:outlose(n-255) >>
    else if n > 3 then s!:outopcode1('LOSES, n, n)
  end;

!#if (not common!-lisp!-mode)

% s!:comprog displays how much fun prog blocks are, in that it has to
% prepare support for go statements and returns, and it needs to
% handle fluid bindings.  The version here does not handle initialising forms
% (as required by Common Lisp) but in that case a macro that turns
% prog into a combination of BLOCK, LET and TAGBODY is used, so there is
% no serious loss.  Similarly PROG* is handled by macroexpansion rather
% than a variant on this direct support.

symbolic procedure s!:comprog(x, env, context);
  begin
    scalar labs, s, bvl, fluids, n, body, local_decs, w;
    body := s!:find_local_decs cddr x;
    local_decs := car body; body := cdr body;
    n := 0;
    for each v in cadr x do w := s!:instate_local_decs(v, local_decs, w);
    for each v in cadr x do <<
       if globalp v then <<
          if !*pwrds then <<
             if posn() neq 0 then terpri();
             princ "+++++ global ";
             prin v;
             princ " converted to fluid";
             terpri() >>;
 % convert from global to fluid so that I can proceed
          unglobal list v;
          fluid list v >>;
       if fluidp v then fluids := v . fluids
       else << n := n + 1; bvl := v . bvl >> >>;
% save the environment that existed outside the prog so I can restore it later
    s := cdr env;
    s!:current_exitlab := (nil . (gensym() . s)) . s!:current_exitlab;
    s!:outstack n;
    rplacd(env, append(bvl, cdr env));
% bind the fluids
    if fluids then begin
       scalar fl1;
       fl1 := s!:vecof fluids;
       s!:outopcode1lit('FREEBIND, fl1, env);
       for each v in nil . fluids do rplacd(env, 0 . cdr env);
       rplacd(env, (2 + length fluids) . cdr env);
       if context = 0 then context := 1 end;
% use gensyms as internal names for the labels in this block
    for each a in cddr x do
       if atom a then <<
          if atsoc(a, labs) then <<
             if not null a then <<
% I do not generate a message if NIL appears several times as a label,
% since in some generated PROG blocks people may have stuck in NIL thinking
% of it as a null expression rather than as a label.
                if posn() neq 0 then terpri();
                princ "+++++ label "; prin a;
                princ " multiply defined"; terpri() >> >>
          else labs := (a . ((gensym() . cdr env) . nil)) . labs >>; 
    s!:current_proglabels := labs . s!:current_proglabels;
    w := s!:residual_local_decs(local_decs, w);
% handle the body of the prog
    for each a in cddr x do
       if not atom a then s!:comval(a, env, context+4)
       else begin
          scalar d;
          d := atsoc(a, labs);
          if null cddr d then <<
             rplacd(cdr d, t);
             s!:set_label caadr d >> end;
    s!:cancel_local_decs w;
% if I drop off the end of a prog block I must return nil, so
% load it up here
    s!:comval(nil, env, context);
    if fluids then s!:outopcode0('FREERSTR, '(FREERSTR));
    s!:outlose n;
    rplacd(env, s);
    s!:set_label cadar s!:current_exitlab;
    s!:current_exitlab := cdr s!:current_exitlab;
    s!:current_proglabels := cdr s!:current_proglabels
  end;

put('prog, 's!:compfn, function s!:comprog);

!#endif

% s!:comtagbody is put here next to s!:comprog since it is really a subset.

symbolic procedure s!:comtagbody(x, env, context);
  begin
    scalar labs;
% use gensyms as internal names for the labels in this block
    for each a in cdr x do
       if atom a then <<
          if atsoc(a, labs) then <<
             if not null a then <<
% I do not generate a message if NIL appears several times as a label,
% since in some generated PROG blocks people may have stuck in NIL thinking
% of it as a null expression rather than as a label.
                if posn() neq 0 then terpri();
                princ "+++++ label "; prin a;
                princ " multiply defined"; terpri() >> >>
          else labs := (a . ((gensym() . cdr env) . nil)) . labs >>;
    s!:current_proglabels := labs . s!:current_proglabels;
    for each a in cdr x do
       if not atom a then s!:comval(a, env, context+4)
       else begin
          scalar d;
          d := atsoc(a, labs);
          if null cddr d then <<
             rplacd(cdr d, t);
             s!:set_label caadr d >> end;
% if I drop off the end of a prog block I must return nil, so
% load it up here
    s!:comval(nil, env, context);
    s!:current_proglabels := cdr s!:current_proglabels
  end;

put('tagbody, 's!:compfn, function s!:comtagbody);

!#if common!-lisp!-mode

symbolic procedure s!:comprogv(x, env, context);
  begin
    x := cdr x;
    if s!:load2(car x, cadr x, env) then s!:outopcode0('SWOP, '(SWOP));
    s!:outopcode0('PVBIND, '(PVBIND));
    rplacd(env, '(pvbind) . 0 . cdr env);
    s!:comval('progn . cddr x, env, 1);
    s!:outopcode0('PVRESTORE, '(PVRESTORE));
    rplacd(env, cdddr env)
  end;

put('progv, 's!:compfn, function s!:comprogv);

symbolic procedure s!:comprog!*(x, env, context);
  begin
    scalar local_decs;
    local_decs := s!:find_local_decs cddr x;
% Macroexpand as per CLTL trying to migrate declarations to the right place
    x := list('block, nil,
           list('let!*, cadr x,
              'declare . car local_decs,
              'tagbody . cdr local_decs));
    return s!:comval(x, env, context)
  end;

put('prog!*, 's!:compfn, function s!:comprog!*);

!#endif

% s!:comblock is just for RETURN to work with.

symbolic procedure s!:comblock(x, env, context);
  begin
    s!:current_exitlab := (cadr x . (gensym() . cdr env)) . s!:current_exitlab;
    s!:comval('progn . cddr x, env, context);
    s!:set_label cadar s!:current_exitlab;
    s!:current_exitlab := cdr s!:current_exitlab
  end;

!#if common!-lisp!-mode
put('block, 's!:compfn, function s!:comblock);
!#else
put('!~block, 's!:compfn, function s!:comblock);
!#endif

symbolic procedure s!:comcatch(x, env, context);
  begin
    scalar g;
    g := gensym();
    s!:comval(cadr x, env, 1);      % The catch tag
    s!:outjump('CATCH, g);          % Jumps to label if a THROW happens
    rplacd(env, '(catch) . 0 . 0 . cdr env);
    s!:comval('progn . cddr x, env, context);
    s!:outopcode0('UNCATCH, '(UNCATCH));
    rplacd(env, cddddr env);
    s!:set_label g
  end;

put('catch, 's!:compfn, 's!:comcatch);

symbolic procedure s!:comthrow(x, env, context);
  begin
    s!:comval(cadr x, env, 1);          % The tag
    s!:outopcode0('PUSH, '(PUSH));
    rplacd(env, 0 . cdr env);
    s!:comval(caddr x, env, 1);         % value to be returned
    s!:outopcode0('THROW, '(THROW));    % tag is on the stack
    rplacd(env, cddr env)
  end;

put('throw, 's!:compfn, 's!:comthrow);

symbolic procedure s!:comunwind!-protect(x, env, context);
  begin
    scalar g;
    g := gensym();
% UNWIND-PROTECT shares an opcode with CATCH by using an otherwise
% invalid value as a tag.  The function LOAD-SPID is not available
% in interpreted code but in compiled code it just loads such a value.
    s!:comval('(load!-spid), env, 1);  % The unwind!-protect tag
    s!:outjump('CATCH, g);             % Jumps to label if ANY unwind happens
    rplacd(env, list('unwind!-protect, cddr x) . 0 . 0 . cdr env);
    s!:comval(cadr x, env, context);
% PROTECT may use the top three stack locations, and must use them to
% store the current set of values and exit status.  It is implicitly done
% by the forced jump that is taken on a failure...
    s!:outopcode0('PROTECT, '(PROTECT));
    s!:set_label g;
    rplaca(cdr env, 0);
% A lexical exit here will just pop the stack, discarding the saved
% information that PROTECT had left behind.
    s!:comval('progn . cddr x, env, context);
    s!:outopcode0('UNPROTECT, '(UNPROTECT));
    rplacd(env, cddddr env)
  end;

put('unwind!-protect, 's!:compfn, 's!:comunwind!-protect);

symbolic procedure s!:comdeclare(x, env, context);
% I print a message if I find DECLARE where I am compiling things.
% I am supposed to have picked off all valid uses of DECLARE
% elsewhere, so this is probably an error - but I will make it just
% a gentle warning message for now.
  begin
    if !*pwrds then <<
       princ "+++ ";
       prin x;
       princ " ignored";
       terpri() >>
  end;

put('declare, 's!:compfn, function s!:comdeclare);

symbolic procedure s!:expand_let(vl, b);
%  if null vl then b
%  else if null cdr vl then s!:expand_let!*(vl, b)
%  else
  begin scalar vars, vals;
    for each v in vl do
      if atom v then << vars := v . vars; vals := nil . vals >>
      else if atom cdr v then << vars := car v . vars; vals := nil . vals >>
      else << vars := car v . vars; vals := cadr v . vals >>;
    return list(('lambda . vars . b) . vals)
  end;

symbolic procedure s!:comlet(x, env, context);
   s!:comval('progn . s!:expand_let(cadr x, cddr x), env, context);

!#if common!-lisp!-mode
put('let, 's!:compfn, function s!:comlet);
!#else
put('!~let, 's!:compfn, function s!:comlet);
!#endif

symbolic procedure s!:expand_let!*(vl, local_decs, b);
% This has loads of fun because although it basically wants to expand
%        (LET* ((v1 e1) (v2 e2)) b1 b1 b2)
% into   ((LAMBDA (v1)               |              ) e1)
%                                    v
%                      ((LAMBDA (v2) b1 b2 b3) e2)
% it also needs to migrate special declarations to the proper levels.
% I also want the degenerate case (LET* () (DECLARE ...) ...) to arrange to
% spot and process the DECLARE, so I expand it into a vacuuous LAMBDA.
  begin
    scalar r, var, val;
    r := ('declare . local_decs) . b;
    for each x in reverse vl do <<
       val := nil;
       if atom x then var := x
       else if atom cdr x then var := car x
       else << var := car x; val := cadr x >>;
       for each z in local_decs do
          if eqcar(z, 'special) then
             if memq(var, cdr z) then
                r := list('declare, list('special, var)) . r;
       r := list list('lambda . list var . r, val) >>;
    if eqcar(car r, 'declare) then r := list('lambda . nil . r)
    else r := 'progn . r;
    return r
  end;

symbolic procedure s!:comlet!*(x, env, context);
  begin
    scalar b;
    b := s!:find_local_decs cddr x;
    return s!:comval(s!:expand_let!*(cadr x, car b, cdr b),
                     env, context)
  end;

put('let!*, 's!:compfn, function s!:comlet!*);

symbolic procedure s!:restore_stack(e1, e2);
% This is used when a GO (or a RETURN-FROM) is being compiled to restore
% the stack to a proper level for the destination of the branch.
  begin
    scalar n;
    n := 0;
    while not (e1 = e2) do <<
       if null e1 then error(0, "bad block nesting with GO or RETURN-FROM");
       if numberp car e1 and car e1 > 2 then <<
          if not zerop n then s!:outlose n;
          n := car e1;
          s!:outopcode0('FREERSTR, '(FREERSTR));
          for i := 1:n do e1 := cdr e1;
          n := 0 >>
       else if car e1 = '(catch) then <<
          if not zerop n then s!:outlose n;
          s!:outopcode0('UNCATCH, '(UNCATCH));
          e1 := cdddr e1;
          n := 0 >>
       else if eqcar(car e1, 'unwind!-protect) then <<
          if not zerop n then s!:outlose n;
          s!:outopcode0('PROTECT, '(PROTECT));
          s!:comval('progn . cadar e1, e1, 2);
          s!:outopcode0('UNPROTECT, '(UNPROTECT));
          e1 := cdddr e1;
          n := 0 >>
!#if common!-lisp!-mode
       else if car e1 = '(pvbind) then <<
          if not zerop n then s!:outlose n;
          s!:outopcode0('PVRESTORE, '(PVRESTORE));
          e1 := cddr e1;
          n := 0 >>
!#endif
       else <<
          e1 := cdr e1;
          n := n + 1 >> >>;
     if not zerop n then s!:outlose n
  end;

symbolic procedure s!:comgo(x, env, context);
% Even in Common Lisp Mode I do not support (yet) GO statements that
% escape from one LAMBDA expression into an enclosing one.
  begin
    scalar pl, d;
!#if (not common!-lisp!-mode)
    if context < 4 then <<
        princ "go not in program context";
        terpri() >>;
!#endif
    pl := s!:current_proglabels;
    while pl and null d do <<
       d := atsoc(cadr x, car pl);
       if null d then pl := cdr pl >>;
    if null d then <<
       if posn() neq 0 then terpri();
       princ "+++++ label "; prin cadr x; princ " not set"; terpri();
       return >>;
    d := cadr d;
    s!:restore_stack(cdr env, cdr d);
    s!:outjump('JUMP, car d)
  end;

put('go, 's!:compfn, function s!:comgo);

symbolic procedure s!:comreturn!-from(x, env, context);
% Even in Common Lisp Mode I do not support (yet) RETURN statements that
% escape from one LAMBDA expression into an enclosing one.
  begin
    scalar tag;
!#if (not common!-lisp!-mode)
    if context < 4 then <<
       princ "+++++ return or return-from not in prog context";
       terpri() >>;
!#endif
    x := cdr x;
    tag := car x;
    if cdr x then x := cadr x else x := nil;
!#if common!-lisp!-mode
    s!:comval(x, env, 1);
!#else
    s!:comval(x, env, context-4);
!#endif
    x := atsoc(tag, s!:current_exitlab);
    if null x then error(0, list("invalid return-from", tag));
    x := cdr x;
    s!:restore_stack(cdr env, cdr x);
    s!:outjump('JUMP, car x)
  end;

put('return!-from, 's!:compfn, function s!:comreturn!-from);

symbolic procedure s!:comreturn(x, env, context);
   s!:comreturn!-from('return!-from . nil . cdr x, env, context);

put('return, 's!:compfn, function s!:comreturn);

% conditional code is generated via jumpif, which jumps to label lab
% if x evaluates to the value of neg

global '(s!:jumplts s!:jumplnils s!:jumpatoms s!:jumpnatoms);

s!:jumplts := s!:vecof '(JUMPL0T JUMPL1T JUMPL2T JUMPL3T JUMPL4T);
s!:jumplnils := s!:vecof '(JUMPL0NIL JUMPL1NIL JUMPL2NIL JUMPL3NIL JUMPL4NIL);
s!:jumpatoms := s!:vecof '(JUMPL0ATOM JUMPL1ATOM JUMPL2ATOM JUMPL3ATOM);
s!:jumpnatoms := s!:vecof '(JUMPL0NATOM JUMPL1NATOM JUMPL2NATOM JUMPL3NATOM);


symbolic procedure s!:jumpif(neg, x, env, lab);
% There are some special optimised cases for tests on simple atomic
% values - both local and free variables.
  begin
    scalar w, w1, j;
top:
    if null x then <<
       if not neg then s!:outjump('JUMP, lab);
       return nil >>
    else if x eq t or (eqcar(x, 'quote) and cadr x) or
       (atom x and not symbolp x) then <<
       if neg then s!:outjump('JUMP, lab);
       return nil >>
    else if (w := s!:islocal(x, env)) < 5 then
       return s!:outjump(getv(if neg then s!:jumplts else s!:jumplnils, w),
                         lab)
    else if w = 99999 and symbolp x then <<
       s!:should_be_fluid x;
       w := list(if neg then 'JUMPFREET else 'JUMPFREENIL, x, x);
       return s!:record_literal_for_jump(w, env, lab) >>;
    if not atom x and atom car x and (w := get(car x, 's!:testfn)) then
       return funcall(w, neg, x, env, lab);
    if not atom x then <<
       w := s!:improve x;
       if atom w or not eqcar(x, car w) then << x := w; go to top >>;
!#if common!-lisp!-mode
       if w1 := s!:local_macro car w then <<
          if atom cdr w1 then x := 'funcall . cdr w1 . cdr w
          else x := funcall('lambda . cdr w1, w);
          go to top >>;
!#endif
       if (w1 := get(car w, 's!:compilermacro)) and
          (w1 := funcall(w1, w, env, 1)) then <<
          x := w1; go to top >> >>;
% I only expand ordinary macros here if the expansion leads to something
% with a TESTFN or COMPILERMACRO property or to an atom.
remacro:
    if (not atom w) and (w1 := macro!-function car w) then <<
       w := funcall(w1, w);
       if atom w or
          eqcar(w, 'quote) or
          get(car w, 's!:testfn) or
          get(car w, 's!:compilermacro) then << x := w; go to top >>;
       go to remacro >>;
    s!:comval(x, env, 1);
    w := s!:current_block;
    while w and not atom car w do w := cdr w;
    j := '(JUMPNIL . JUMPT);
    if w then <<
       w1 := car w;
       w := cdr w;
       if w1 = 'STORELOC0 then <<
          s!:current_block := w;
          s!:current_size := s!:current_size - 1;
          j := '(JUMPST0NIL . JUMPST0T) >>
       else if w1 = 'STORELOC1 then <<
          s!:current_block := w;
          s!:current_size := s!:current_size - 1;
          j := '(JUMPST1NIL . JUMPST1T) >>
       else if w1 = 'STORELOC2 then <<
          s!:current_block := w;
          s!:current_size := s!:current_size - 1;
          j := '(JUMPST2NIL . JUMPST2T) >>
       else if eqcar(w, 'BUILTIN1) then <<
          s!:current_block := cdr w;
          s!:current_size := s!:current_size - 2;
          j := list('JUMPB1NIL, w1) . list('JUMPB1T, w1) >>
       else if eqcar(w, 'BUILTIN2) then <<
          s!:current_block := cdr w;
          s!:current_size := s!:current_size - 2;
          j := list('JUMPB2NIL, w1) . list('JUMPB2T, w1) >> >>;
    return s!:outjump(if neg then cdr j else car j, lab)
  end;

symbolic procedure s!:testnot(neg, x, env, lab);
   s!:jumpif(not neg, cadr x, env, lab);

put('null, 's!:testfn, function s!:testnot);
put('not,  's!:testfn, function s!:testnot);

symbolic procedure s!:testatom(neg, x, env, lab);
  begin
    scalar w;
    if (w := s!:islocal(cadr x, env)) < 4 then
       return s!:outjump(getv(if neg then s!:jumpatoms else s!:jumpnatoms, w),
                         lab);
    s!:comval(cadr x, env, 1);
    if neg then s!:outjump('JUMPATOM, lab)
    else s!:outjump('JUMPNATOM, lab)
  end;

put('atom, 's!:testfn, function s!:testatom);

symbolic procedure s!:testconsp(neg, x, env, lab);
  begin
    scalar w;
    if (w := s!:islocal(cadr x, env)) < 4 then
       return s!:outjump(getv(if neg then s!:jumpnatoms else s!:jumpatoms, w),
                         lab);
    s!:comval(cadr x, env, 1);
    if neg then s!:outjump('JUMPNATOM, lab)
    else s!:outjump('JUMPATOM, lab)
  end;

put('consp, 's!:testfn, function s!:testconsp);

symbolic procedure s!:comcond(x, env, context);
  begin
    scalar l1, l2, w;
    l1 := gensym();
    while (x := cdr x) do <<
      w := car x;
      if atom cdr w then <<
        s!:comval(car w, env, 1);
        s!:outjump('JUMPT, l1);
        l2 := nil >>
      else <<
         if car w = t then l2 := nil
         else <<
           l2 := gensym();
           s!:jumpif(nil, car w, env, l2) >>;
         w := cdr w;
         if null cdr w then w := car w
         else w := 'progn . w;
         s!:comval(w, env, context);
         if l2 then << s!:outjump('JUMP, l1); s!:set_label l2 >>
         else x := '(nil) >> >>;
    if l2 then s!:comval(nil, env, context);
    s!:set_label l1
  end;

put('cond, 's!:compfn, function s!:comcond);

symbolic procedure s!:comif(x, env, context);
  begin
    scalar l1, l2;
    l2 := gensym();
    s!:jumpif(nil, cadr x, env, l2);
    x := cddr x;
    s!:comval(car x, env, context);
    x := cdr x;
    if x or (context < 2 and (x := '(nil))) then <<
       l1 := gensym();
       s!:outjump('JUMP, l1);
       s!:set_label l2;
       s!:comval(car x, env, context);
       s!:set_label l1 >>
    else s!:set_label l2
  end;

put('if, 's!:compfn, function s!:comif);

symbolic procedure s!:comwhen(x, env, context);
  begin
    scalar l2;
    l2 := gensym();
    if context < 2 then <<
       s!:comval(cadr x, env, 1);
       s!:outjump('JUMPNIL, l2) >>
    else s!:jumpif(nil, cadr x, env, l2);
    s!:comval('progn . cddr x, env, context);
    s!:set_label l2
  end;

put('when, 's!:compfn, function s!:comwhen);

symbolic procedure s!:comunless(x, env, context);
   s!:comwhen(list!*('when, list('not, cadr x), cddr x), env, context);

put('unless, 's!:compfn, function s!:comunless);

% The S:ICASE function is not really intended for direct use. It is there
% to provide Lisp-code with the ability to generate the ICASE byte opcode.
% The usage is
%    (s!:icase <expression>
%        <default-value>
%        <case 0 value>
%        <case 1 value>
%        <case 2 value>
%        ...
%        <case n value>)
% and the value if selected on the basis of the expression, which will
% normally evaluate to an integer in the range 0 to n.

symbolic procedure s!:comicase(x, env, context);
  begin
    scalar l1, labs, labassoc, w;
    x := cdr x;
    for each v in cdr x do <<
        w := assoc!*!*(v, labassoc);
% If the same value occurs in several cases then I set just one label
% and re-use it.
        if w then l1 := cdr w . l1
        else <<
            l1 := gensym();
            labs := l1 . labs;
            labassoc := (v . l1) . labassoc >> >>;
    s!:comval(car x, env, 1);
    s!:outjump('ICASE, reversip labs);
    l1 := gensym();
    for each v in labassoc do <<
       s!:set_label cdr v;
       s!:comval(car v, env, context);
       s!:outjump('JUMP, l1) >>;
    s!:set_label l1
  end;

put('s!:icase, 's!:compfn, function s!:comicase);

put('JUMPLITEQ!*, 's!:opcode, get('JUMPLITEQ, 's!:opcode));
put('JUMPLITNE!*, 's!:opcode, get('JUMPLITNE, 's!:opcode));

%
% s!:jumpliteqn jumps to lab is the A register is EQL to val. In
% all sensible cases an EQ test can be used, but when that will not
% be possible (mainly floats or bignums) the EQL function itself is
% invoked. This preserves full generality!
%

symbolic procedure s!:jumpliteql(val, lab, env);
  begin
    scalar w;
    if idp val or
       eq!-safe val then <<
        w := list('JUMPLITEQ!*, val, val);
        s!:record_literal_for_jump(w, env, lab) >>
    else <<
        s!:outopcode0('PUSH, '(PUSH));
        s!:loadliteral(val, env);
        s!:outopcode1('BUILTIN2, get('eql, 's!:builtin2), 'eql);
        s!:outjump('JUMPT, lab);
        flag(list lab, 's!:jumpliteql);
        s!:outopcode0('POP, '(POP)) >>
  end;

symbolic procedure s!:casebranch(sw, env, dflt);
  begin
    scalar size, w, w1, r, g;
    size := 4+truncate(length sw,2);
% I probably do not need to go as far as making the size of my hash table
% prime, but the specific case of multiples of 13 is filtered for here
% since powers of 13 are used in the sxhash/eqlhash calculation.
    while remainder(size, 2)=0 or remainder(size, 3)=0 or
          remainder(size, 5)=0 or remainder(size, 13)=0 do size := size+1;
    for each p in sw do <<
        w := remainder(eqlhash car p, size);
        w1 := assoc!*!*(w, r);
        if w1 then rplacd(cdr w1, p . cddr w1)
        else r := list(w, gensym(), p) . r >>;
    s!:outopcode0('PUSH, '(PUSH));
    rplacd(env, 0 . cdr env);
    s!:outopcode1lit('CALL1, 'eqlhash, env);
    s!:loadliteral(size, env);
    g := gensym();
    s!:outopcode1('BUILTIN2, get('iremainder, 's!:builtin2), 'iremainder);
    s!:outjump('ICASE, g . for i := 0:size-1 collect <<
        w := assoc!*!*(i, r);
        if w then cadr w else g >>);
    for each p in r do <<
        s!:set_label cadr p;
        s!:outopcode0('POP, '(POP));
        for each q in cddr p do s!:jumpliteql(car q, cdr q, env);
        s!:outjump('JUMP, dflt) >>;
    s!:set_label g;
    s!:outopcode0('POP, '(POP));
    s!:outjump('JUMP, dflt);
    rplacd(env, cddr env)
  end;

symbolic procedure s!:comcase(x, env, context);
  begin
    scalar keyform, blocks, v, w, g, dflt, sw, keys, nonnum;
    x := cdr x;
    keyform := car x;
    for each y on cdr x do <<
        w := assoc!*!*(cdar y, blocks);
        if w then g := cdr w
        else <<
            g := gensym();
            blocks := (cdar y . g) . blocks >>;
        w := caar y;
        if null cdr y and (w = t or w = 'otherwise) then dflt := g
        else <<
            if atom w then w := list w;
            for each n in w do <<
                if idp n or
!#if common!-lisp!-mode
                        characterp n or
!#endif
                        numberp n then <<
                    if not fixp n then nonnum := t;
                    keys := n . keys;
                    sw := (n . g) . sw >>
% The test made is supposed (in Common Lisp) to be EQL. I take the
% severe view that I will not accept labels that are lists or vectors
% or strings or other things where EQL is a nasty sort of test. This is
% not in accordance with full Common Lisp, and if this really hurts me
% some time I can degenerate and turn out very clumsy sequences of test-
% and-branch code in marginal cases.
                else error(0, list("illegal case label", n)) >> >> >>;
    if null dflt then <<
        if (w := assoc!*!*(nil, blocks)) then dflt := cdr w
        else blocks := (nil . (dflt := gensym())) . blocks >>;
    if not nonnum then <<
        keys := sort(keys, function lessp);
        nonnum := car keys;
        g := lastcar keys;
        if g - nonnum < 2*length keys then <<
% If the keys are a fairly compact block of fixnums I can do an
% especially good job.
            if not (nonnum = 0) then <<
                keyform := list('xdifference, keyform, nonnum);
                sw := for each y in sw collect (car y - nonnum) . cdr y >>;
            s!:comval(keyform, env, 1);
            w := nil;
            for i := 0:g do
               if (v := assoc!*!*(i, sw)) then w := cdr v . w
               else w := dflt . w;
            w := dflt . reversip w;
            s!:outjump('ICASE, w);
            nonnum := nil >>
        else nonnum := t >>;
    if nonnum then <<
% If I have only a few cases I do repeated test/branch combinations,
% but if I have a LOT I will try hashing. The change-over point at 7
% is pretty much a GUESS for where it should reasonably go.
        s!:comval(keyform, env, 1);
        if length sw < 7 then <<
% The code here is DELICATE. This is because USUALLY the JUMPLITEQ
% code preserve the A register, but when expanded to a pair of
% instructions maybe it does not. To deal with this I use JUMPLITEQ!*
% which expands slightly differently...  Also I have to be prepared to
% cope with floats or bignums (and I do so in a very ugly way)
            for each y in sw do s!:jumpliteql(car y, cdr y, env);
            s!:outjump('JUMP, dflt) >>
        else s!:casebranch(sw, env, dflt) >>;
    g := gensym();
    for each v in blocks do <<
       s!:set_label cdr v;
       if flagp(cdr v, 's!:jumpliteql) then s!:outlose 1;
       s!:comval('progn . car v, env, context);
       s!:outjump('JUMP, g) >>;
    s!:set_label g
  end;

put('case, 's!:compfn, function s!:comcase);


fluid '(!*defn dfprint!* s!:dfprintsave s!:faslmod_name);

symbolic procedure s!:comeval!-when(x, env, context);
  begin
    scalar y;
    x := cdr x;
    y := car x;
    x := 'progn . cdr x;
    if memq('compile, y) then eval x;
    if memq('load, y) then <<
       if dfprint!* then apply1(dfprint!*, x) >>;
    if memq('eval, y) then s!:comval(x, env, context)
    else s!:comval(nil, env, context)
  end;

put('eval!-when, 's!:compfn, function s!:comeval!-when);

% (the <type> <value>) is treated here as just <value>, but in the
% longer term notice should be taken of the type information.

symbolic procedure s!:comthe(x, env, context);
   s!:comval(caddr x, env, context);

put('the, 's!:compfn, function s!:comthe);

symbolic procedure s!:comand(x, env, context);
% AND and OR are not transparent to program context, and
% are always assumed to be used for their value.
% Is it worth doing something special if all the values tested are
% known to be regular style predicates? (eg NULL, ATOM, EQ etc calls)
  begin
    scalar l;
    l := gensym();
    x := cdr x;
    s!:comval(car x, env, 1);
    while x := cdr x do <<
      s!:outjump('JUMPNIL, l);
      s!:comval(car x, env, 1) >>;
    s!:set_label l
  end;

put('and, 's!:compfn, function s!:comand);

symbolic procedure s!:comor(x, env, context);
  begin
    scalar l;
    l := gensym();
    x := cdr x;
    s!:comval(car x, env, 1);
    while x := cdr x do <<
      s!:outjump('JUMPT, l);
      s!:comval(car x, env, 1) >>;
    s!:set_label l
  end;

put('or, 's!:compfn, function s!:comor);

symbolic procedure s!:combool(neg, x, env, lab);
% Used for AND and OR when they occur in predicates rather
% than in places where their (full) value is required.
  begin
    scalar fn;
    fn := eqcar(x, 'or);
    if fn eq neg then
       while x := cdr x do
          s!:jumpif(fn, car x, env, lab)
    else <<
       neg := gensym();
       while x := cdr x do
          s!:jumpif(fn, car x, env, neg);
       s!:outjump('JUMP, lab);
       s!:set_label neg >>
  end;

put('and, 's!:testfn, function s!:combool);
put('or,  's!:testfn, function s!:combool);

symbolic procedure s!:testeq(neg, x, env, lab);
  begin
    scalar a, b;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
    if s!:eval_to_eq_unsafe a or s!:eval_to_eq_unsafe b then <<
       if posn() neq 0 then terpri();
       princ "++++ EQ on number upgraded to EQUAL in ";
       prin s!:current_function; princ " : ";
       prin a; princ " "; print b;
       return s!:testequal(neg, 'equal . cdr x, env, lab) >>;
    if !*carefuleq then <<
       s!:comval(x, env, 1);
       s!:outjump(if neg then 'JUMPT else 'JUMPNIL, lab);
       return >>;
% eq tests against nil can be optimised a bit
    if null a then s!:jumpif(not neg, b, env, lab)
    else if null b then s!:jumpif(not neg, a, env, lab)
    else if eqcar(a, 'quote) or (atom a and not symbolp a) then <<
       s!:comval(b, env, 1);
       if eqcar(a, 'quote) then a := cadr a;
       b := list(if neg then 'JUMPLITEQ else 'JUMPLITNE, a, a);
       s!:record_literal_for_jump(b, env, lab) >>
    else if eqcar(b, 'quote) or (atom b and not symbolp b) then <<
       s!:comval(a, env, 1);
       if eqcar(b, 'quote) then b := cadr b;
       a := list(if neg then 'JUMPLITEQ else 'JUMPLITNE, b, b);
       s!:record_literal_for_jump(a, env, lab) >>
    else <<
       s!:load2(a, b, env);
       if neg then s!:outjump('JUMPEQ, lab)
       else s!:outjump('JUMPNE, lab) >>;
  end;

symbolic procedure s!:testeq1(neg, x, env, lab);
  begin
    scalar a, b;
    if !*carefuleq then <<
       s!:comval(x, env, 1);
       s!:outjump(if neg then 'JUMPT else 'JUMPNIL, lab);
       return >>;
    a := s!:improve cadr x;
    b := s!:improve caddr x;
% eq tests against nil can be optimised a bit
    if null a then s!:jumpif(not neg, b, env, lab)
    else if null b then s!:jumpif(not neg, a, env, lab)
    else if eqcar(a, 'quote) or (atom a and not symbolp a) then <<
       s!:comval(b, env, 1);
       if eqcar(a, 'quote) then a := cadr a;
       b := list(if neg then 'JUMPLITEQ else 'JUMPLITNE, a, a);
       s!:record_literal_for_jump(b, env, lab) >>
    else if eqcar(b, 'quote) or (atom b and not symbolp b) then <<
       s!:comval(a, env, 1);
       if eqcar(b, 'quote) then b := cadr b;
       a := list(if neg then 'JUMPLITEQ else 'JUMPLITNE, b, b);
       s!:record_literal_for_jump(a, env, lab) >>
    else <<
       s!:load2(a, b, env);
       if neg then s!:outjump('JUMPEQ, lab)
       else s!:outjump('JUMPNE, lab) >>;
  end;

put('eq, 's!:testfn, function s!:testeq);

if eq!-safe 0 then put('iequal, 's!:testfn, function s!:testeq1)
else put('iequal, 's!:testfn, function s!:testequal);

symbolic procedure s!:testequal(neg, x, env, lab);
  begin
    scalar a, b;
    a := cadr x;
    b := caddr x;
% equal tests against nil can be optimised
    if null a then s!:jumpif(not neg, b, env, lab)
    else if null b then s!:jumpif(not neg, a, env, lab)
% comparisons involving a literal identifier or (in this
% Lisp implementation) a fixnum can be turned into uses of
% eq rather than equal, to good effect.
    else if (eqcar(a, 'quote) and (symbolp cadr a or eq!-safe cadr a)) or
            (eqcar(b, 'quote) and (symbolp cadr b or eq!-safe cadr b)) or
            eq!-safe a or eq!-safe b then
        s!:testeq1(neg, 'eq . cdr x, env, lab)
   else <<
      s!:load2(a, b, env);    % args commute here if that helps
      if neg then s!:outjump('JUMPEQUAL, lab)
      else s!:outjump('JUMPNEQUAL, lab) >>
  end;

put('equal, 's!:testfn, function s!:testequal);

symbolic procedure s!:testneq(neg, x, env, lab);
   s!:testequal(not neg, 'equal . cdr x, env, lab);

put('neq, 's!:testfn, function s!:testneq);

symbolic procedure s!:testeqcar(neg, x, env, lab);
  begin
    scalar a, b, sw, promote;
    a := cadr x;
    b := s!:improve caddr x;
    if s!:eval_to_eq_unsafe b then <<
       if posn() neq 0 then terpri();
       princ "++++ EQCAR on number upgraded to EQUALCAR in ";
       prin s!:current_function; princ " : "; print b;
       promote := t >>
    else if !*carefuleq then <<
       s!:comval(x, env, 1);
       s!:outjump(if neg then 'JUMPT else 'JUMPNIL, lab);
       return >>;
    if not promote and eqcar(b, 'quote) then <<
       s!:comval(a, env, 1);
       b := cadr b;
       a := list(if neg then 'JUMPEQCAR else 'JUMPNEQCAR, b, b);
       s!:record_literal_for_jump(a, env, lab) >>
    else <<
       sw := s!:load2(a, b, env);
       if sw then s!:outopcode0('SWOP, '(SWOP));
       if promote then
           s!:outopcode1('BUILTIN2, get('equalcar, 's!:builtin2), 'equalcar)
       else s!:outopcode0('EQCAR, '(EQCAR));
       s!:outjump(if neg then 'JUMPT else 'JUMPNIL, lab) >>
  end;

put('eqcar, 's!:testfn, function s!:testeqcar);

symbolic procedure s!:testflagp(neg, x, env, lab);
  begin
    scalar a, b, sw;
    a := cadr x;
    b := caddr x;
    if eqcar(b, 'quote) then <<
       s!:comval(a, env, 1);
       b := cadr b;
       sw := symbol!-make!-fastget(b, nil);
       if sw then <<
          s!:outopcode1('FASTGET, logor(sw, 128), b);
          s!:outjump(if neg then 'JUMPT else 'JUMPNIL, lab) >>
       else <<
          a := list(if neg then 'JUMPFLAGP else 'JUMPNFLAGP, b, b);
          s!:record_literal_for_jump(a, env, lab) >> >>
    else <<
       sw := s!:load2(a, b, env);
       if sw then s!:outopcode0('SWOP, '(SWOP));
       s!:outopcode0('FLAGP, '(FLAGP));
       s!:outjump(if neg then 'JUMPT else 'JUMPNIL, lab) >>
  end;

put('flagp, 's!:testfn, function s!:testflagp);

global '(s!:storelocs);
s!:storelocs := s!:vecof '(STORELOC0 STORELOC1 STORELOC2 STORELOC3
                           STORELOC4 STORELOC5 STORELOC6 STORELOC7);

symbolic procedure s!:comsetq(x, env, context);
  begin
    scalar n, w, var;
    x := cdr x;
    if null x then return;
    if not symbolp car x or null cdr x then
       return error(0, list("bad args for setq", x));
    s!:comval(cadr x, env, 1);
    var := car x;
    n := 0;
    w := cdr env;
% storing into a lexical variable involves stack access, otherwise
% I need to update the global value cell
    while w and not eqcar(w, var) do << n := add1 n; w := cdr w >>;
    if w then <<
       if not member!*!*('loc . w, s!:a_reg_values) then
           s!:a_reg_values := ('loc . w) . s!:a_reg_values;
       if n < 8 then s!:outopcode0(getv(s!:storelocs, n),
                                          list('storeloc, var))
       else if n > 4095 then error "stack frame > 4095"
       else if n > 255 then
          s!:outopcode2('BIGSTACK, 64+truncate(n,256), logand(n, 255),
                        list('STORELOC, var))
       else s!:outopcode1('STORELOC, n, var) >>
    else if w := s!:find_lexical(var, s!:lexical_env, 0) then <<
        if not member!*!*('lex . w, s!:a_reg_values) then
            s!:a_reg_values := ('lex . w) . s!:a_reg_values;
        s!:outlexref('STORELEX, length cdr env, car w, cadr w, var) >>
    else <<
        if null var or var eq t then
           error(0, list("bad variable in setq", var))
        else s!:should_be_fluid var;
        w := 'free . var;
        if not member!*!*(w, s!:a_reg_values) then
           s!:a_reg_values := w . s!:a_reg_values;
        s!:outopcode1lit('STOREFREE, var, env) >>;
% For this very small extra I can support (setq a A b B c C ...)
    if cddr x then return s!:comsetq(cdr x, env, context)
  end;

put('setq, 's!:compfn, function s!:comsetq);
put('noisy!-setq, 's!:compfn, function s!:comsetq);

% cons-related functions seem quite important to Lisp, so I provide
% a bit of special support - cons has a variant xcons for use when its
% arguments are most conveniently evaluated in the 'other' order, and
% list gets specialised into ncons, list2 and list3.  Two functions
% acons and list2!* provide useful combinations of a pair of cons
% operations - use of them reduces overhead associated with the allocation
% of freestore.

symbolic procedure s!:comlist(x, env, context);
 begin
    scalar w;
    if null (x := cdr x) then return s!:comval(nil, env, context);
    s!:a_reg_values := nil;
    if null (w := cdr x) then
       s!:comval(list('ncons, car x), env, context)
    else if null (w := cdr w) then
       s!:comval(list('list2, car x, cadr x), env, context)
    else if null cdr w then
       s!:comval(list('list3, car x, cadr x, car w), env, context)
    else s!:comval(list('list2!*, car x, cadr x, 'list . w), env, context)
  end;

put('list, 's!:compfn, function s!:comlist);

symbolic procedure s!:comlist!*(x, env, context);
 begin
    scalar w;
    if null (x := cdr x) then return s!:comval(nil, env, context);
    s!:a_reg_values := nil;
    if null (w := cdr x) then
       s!:comval(car x, env, context)
    else if null (w := cdr w) then
       s!:comval(list('cons, car x, cadr x), env, context)
    else if null cdr w then
       s!:comval(list('list2!*, car x, cadr x, car w), env, context)
    else s!:comval(list('list2!*, car x, cadr x, 'list!* . w), env, context)
  end;

put('list!*, 's!:compfn, function s!:comlist!*);

symbolic procedure s!:comcons(x, env, context);
  begin
    scalar a, b;
    a := cadr x;
    b := caddr x;
    if b=nil or b='(quote nil) then
       s!:comval(list('ncons, a), env, context)
    else if eqcar(a, 'cons) then
       s!:comval(list('acons, cadr a, caddr a, b), env, context)
    else if eqcar(b, 'cons) then
       if null caddr b then s!:comval(list('list2, a, cadr b), env, context)
       else s!:comval(list('list2!*, a, cadr b, caddr b), env, context)
!#if (not common!-lisp!-mode)
% For Common Lisp it seems that I *must* evaluate args strictly left-to-right.
    else if not !*ord and s!:iseasy a and not s!:iseasy b then
       s!:comval(list('xcons, b, a), env, context)
!#endif
    else s!:comcall(x, env, context)
  end;

put('cons, 's!:compfn, function s!:comcons);

!#if common!-lisp!-mode

% I must not open-compile VECTOR in Standard Lisp mode because REDUCE
% has a function of that name that is nothing like the one I support here.
% But the version here can be useful so that things like
%    (vector e1 e2 ... en)
% for large n do not generate function calls with excessive numbers of args.

symbolic procedure s!:vector_compilermacro(x, env, context);
  begin
    scalar args, n, n1, r, w, v, i;
    v := gensym();
    i := gensym();
    args := cdr x;
    n := n1 := length args;
    while n > 12 do <<
       w := nil;
       for j := 1:12 do << w := car args . w; args := cdr args >>;
       r := list('setq, i, ('fill!-vector . v . i . reverse w)) . r;
       n := n - 12 >>;
    if n > 0 then r := ('fill!-vector . v . i . args) . r;
    r := 'let .
          list(list(v, list('mkvect, n1-1)),
               list(i, 0)) .
          reverse (v . r);
    return r
  end;

put('vector, 's!:compilermacro, function s!:vector_compilermacro);

symbolic procedure s!:commv!-call(x, env, context);
  begin
    scalar fn, args;
    fn := cadr x;
    args := for each v in cddr x collect list('mv!-list!*, v);
    args := expand(args, 'append);
    if not (fn = '(function list)) then
       args := list('apply, fn, args);
    s!:comval(args, env, context)
  end;

put('multiple!-value!-call, 's!:compfn, function s!:commv!-call);

symbolic procedure s!:commv!-prog1(x, env, context);
  begin
    x := cdr x;
    if null x then return s!:comval(nil, env, context)
    else if null cdr x then return s!:comval(car x, env, context);
    s!:comval(list('mv!-list!*, car x), env, context);
    s!:outopcode0('PUSH, '(PUSH));
    rplacd(env, 0 . cdr env);
    for each a in x do
        s!:comval(a, env, if context >= 4 then context else 2);
    s!:outopcode0('POP, '(POP));
    rplacd(env, cddr env);
    s!:loadliteral('values, env);
    s!:outopcode1('BUILTIN2, get('apply1, 's!:builtin2), 'apply1)
  end;

put('multiple!-value!-prog1, 's!:compfn, function s!:commv!-prog1);

!#endif

symbolic procedure s!:comapply(x, env, context);
  begin
    scalar a, b, n;
    a := cadr x;        % fn
    b := caddr x;       % args
% I collect the very special idiom
%     (apply xxx (list A B C ...))
% and map it on to
%     (funcall xxx A B C)
% but if the list is made up on any other way (eg using a mixture of
% calls to LIST and CONS) I just let it go through the usual slower route.
    if null cdddr x and eqcar(b, 'list) then <<
       if eqcar(a, 'quote) then return <<
          n := s!:current_function;
          begin 
              scalar s!:current_function;
% the re-binding of current-function is to avoid use of callself
% in some cases (e.g. the autoloader) when the function I am
% in has just been redefined.
              s!:current_function := compress
                 append(explode n, '!! . '!. . explodec
                    (s!:current_count := s!:current_count + 1));
              return s!:comval(cadr a . cdr b, env, context)
          end >>;
       n := length (b := cdr b);
       return s!:comval('funcall . a . b, env, context) >>
    else if null b and null cdddr x then
       return s!:comval(list('funcall, a), env, context)
    else return s!:comcall(x, env, context)
  end;

put('apply, 's!:compfn, function s!:comapply);

symbolic procedure s!:imp_funcall u;
  begin
    scalar n;
    u := cdr u;
    if eqcar(car u, 'function) then return s!:improve(cadar u . cdr u);
    n := length cdr u;
    u := if n = 0 then 'apply0 . u
      else if n = 1 then 'apply1 . u
      else if n = 2 then 'apply2 . u
      else if n = 3 then 'apply3 . u
%     else if n = 4 then 'apply4 . u
      else 'funcall!* . u;
!#if record!-use!-of!-funcall
% If this flag is set when the compiler is built then every "funcall" in the
% original source will get logged. If there are too many of them this
% can be painfully expensive.
    u := list('progn, 
           list('s!:record_funcall, mkquote s!:current_function, mkquote u),
           u);
!#endif
    return u
  end;

!#if record!-use!-of!-funcall

global '(all_funcalls);

symbolic procedure s!:record_funcall(fromfn, call);
  begin
    scalar w;
    if not memq(fromfn, all_funcalls) then
       all_funcalls := fromfn . all_funcalls;
    w := get(fromfn, 'all_funcalls);
    while not atom w and not atom car w and not (caar w = call) do w := cdr w;
    if null w then
       put(fromfn, 'all_funcalls, (call . 1) . get(fromfn, 'all_funcalls))
    else rplacd(car w, cdar w + 1)
  end;

symbolic procedure display!-funcalls();
  begin
    scalar w;
    w := linelength 500;
    terpri();
    for each fn in all_funcalls do <<
      for each x in get(fn, 'all_funcalls) do <<
        princ cdr x; ttab 10; prin fn; ttab 40; prin car x; terpri() >>;
      remprop(fn, 'all_funcalls) >>;
    all_funcalls := nil;
    terpri();
    linelength w;
  end;

!#endif

put('funcall, 's!:tidy_fn, 's!:imp_funcall);


!#if (not common!-lisp!-mode)

%
% The next few cases are concerned with demoting functions that use
% equal tests into ones that use eq instead

symbolic procedure s!:eval_to_eq_safe x;
   null x or 
   x=t or 
   (not symbolp x and eq!-safe x) or
   (not atom x and flagp(car x, 'eq!-safe)) or
   (eqcar(x, 'quote) and (symbolp cadr x or eq!-safe cadr x));

symbolic procedure s!:eval_to_eq_unsafe x;
   (atom x and not symbolp x and not eq!-safe x) or
   (not atom x and flagp(car x, 'eq!-unsafe)) or
   (eqcar(x, 'quote) and (not atom cadr x or
      (not symbolp cadr x and not eq!-safe cadr x)));

flag('(eq eqcar null not greaterp lessp geq leq minusp
       atom numberp consp), 'eq!-safe);

if not eq!-safe 1 then
   flag('(length plus minus difference times quotient
          plus2 times2 expt fix float), 'eq!-unsafe);

symbolic procedure s!:list_all_eq_safe u;
  atom u or
  ((symbolp car u or eq!-safe car u) and s!:list_all_eq_safe cdr u);

symbolic procedure s!:eval_to_list_all_eq_safe x;
  null x or
  (eqcar(x, 'quote) and s!:list_all_eq_safe cadr x) or
  (eqcar(x, 'list) and
   (null cdr x or
    (s!:eval_to_eq_safe cadr x and
     s!:eval_to_list_all_eq_safe ('list . cddr x)))) or
  (eqcar(x, 'cons) and
   s!:eval_to_eq_safe cadr x and
   s!:eval_to_list_all_eq_safe caddr x);

symbolic procedure s!:eval_to_eq_unsafe x;
   (numberp x and not eq!-safe x) or
   stringp x or
   (eqcar(x, 'quote) and
       (not atom cadr x or
        (numberp cadr x and not eq!-safe cadr x) or
        stringp cadr x));

symbolic procedure s!:list_some_eq_unsafe u;
  not atom u and
  (s!:eval_to_eq_unsafe car u or s!:list_some_eq_unsafe cdr u);

symbolic procedure s!:eval_to_list_some_eq_unsafe x;
  if atom x then nil
  else if eqcar(x, 'quote) then s!:list_some_eq_unsafe cadr x
  else if eqcar(x, 'list) and cdr x then
     s!:eval_to_eq_unsafe cadr x or s!:eval_to_list_some_eq_unsafe ('list . cddr x)
  else if eqcar(x, 'cons) then
     s!:eval_to_eq_unsafe cadr x or s!:eval_to_list_some_eq_unsafe caddr x
  else nil;

symbolic procedure s!:eval_to_car_eq_safe x;
  (eqcar(x, 'cons) or eqcar(x, 'list)) and
  not null cdr x and
  s!:eval_to_eq_safe cadr x;

symbolic procedure s!:eval_to_car_eq_unsafe x;
  (eqcar(x, 'cons) or eqcar(x, 'list)) and
  not null cdr x and
  s!:eval_to_eq_unsafe cadr x;

symbolic procedure s!:alist_eq_safe u;
  atom u or
  (not atom car u and
   (symbolp caar u or eq!-safe caar u) and 
   s!:alist_eq_safe cdr u);

symbolic procedure s!:eval_to_alist_eq_safe x;
  null x or
  (eqcar(x, 'quote) and s!:alist_eq_safe cadr x) or
  (eqcar(x, 'list) and
   (null cdr x or
    (s!:eval_to_car_eq_safe cadr x and
     s!:eval_to_alist_eq_safe ('list . cddr x)))) or
  (eqcar(x, 'cons) and
   s!:eval_to_car_eq_safe cadr x and
   s!:eval_to_alist_eq_safe caddr x);


symbolic procedure s!:alist_eq_unsafe u;
  not atom u and
  not atom car u and
  (not atom caar u or
   (not symbolp caar u and not eq!-safe caar u) or 
   s!:alist_eq_unsafe cdr u);

symbolic procedure s!:eval_to_alist_eq_unsafe x;
  if null x then nil
  else if eqcar(x, 'quote) then s!:alist_eq_unsafe cadr x
  else if eqcar(x, 'list) then
   (cdr x and
    (s!:eval_to_car_eq_unsafe cadr x or
     s!:eval_to_alist_eq_unsafe ('list . cddr x)))
  else if eqcar(x, 'cons) then
   s!:eval_to_car_eq_unsafe cadr x or
   s!:eval_to_alist_eq_safe caddr x
  else nil;

symbolic procedure s!:comequal(x, env, context);
   if s!:eval_to_eq_safe cadr x or
      s!:eval_to_eq_safe caddr x then
      s!:comcall('eq . cdr x, env, context)
   else s!:comcall(x, env, context);

put('equal, 's!:compfn, function s!:comequal);

symbolic procedure s!:comeq(x, env, context);
   if s!:eval_to_eq_unsafe cadr x or
      s!:eval_to_eq_unsafe caddr x then <<
      if posn() neq 0 then terpri();
      princ "++++ EQ on number upgraded to EQUAL in ";
      prin s!:current_function; princ " : ";
      prin cadr x; princ " "; print caddr x;
      s!:comcall('equal . cdr x, env, context) >>
   else s!:comcall(x, env, context);

put('eq, 's!:compfn, function s!:comeq);

symbolic procedure s!:comeqcar(x, env, context);
   if s!:eval_to_eq_unsafe caddr x then <<
      if posn() neq 0 then terpri();
      princ "++++ EQCAR on number upgraded to EQUALCAR in ";
      prin s!:current_function; princ " : ";
      prin caddr x;
      s!:comcall('equalcar . cdr x, env, context) >>
   else s!:comcall(x, env, context);

put('eqcar, 's!:compfn, function s!:comeqcar);

symbolic procedure s!:comsublis(x, env, context);
   if s!:eval_to_alist_eq_safe cadr x then
      s!:comval('subla . cdr x, env, context)
   else s!:comcall(x, env, context);

put('sublis, 's!:compfn, function s!:comsublis);

symbolic procedure s!:comsubla(x, env, context);
   if s!:eval_to_alist_eq_unsafe cadr x then <<
       if posn() neq 0 then terpri();
       princ "++++ SUBLA on number upgraded to SUBLIS in ";
       prin s!:current_function; princ " : ";
       print cadr x;
       s!:comval('sublis . cdr x, env, context) >>
   else s!:comcall(x, env, context);

put('subla, 's!:compfn, function s!:comsubla);

symbolic procedure s!:comassoc(x, env, context);
   if (s!:eval_to_eq_safe cadr x or s!:eval_to_alist_eq_safe caddr x) and length x = 3 then
      s!:comval('atsoc . cdr x, env, context)
   else if length x = 3 then s!:comcall('assoc!*!* . cdr x, env, context)
   else s!:comcall(x, env, context);

put('assoc, 's!:compfn, function s!:comassoc);
put('assoc!*!*, 's!:compfn, function s!:comassoc);

symbolic procedure s!:comatsoc(x, env, context);
   if (s!:eval_to_eq_unsafe cadr x or
       s!:eval_to_alist_eq_unsafe caddr x) then <<
       if posn() neq 0 then terpri();
       princ "++++ ATSOC on number upgraded to ASSOC in ";
       prin s!:current_function; princ " : ";
       prin cadr x; princ " "; print caddr x;
       s!:comval('assoc . cdr x, env, context) >>
   else s!:comcall(x, env, context);

put('atsoc, 's!:compfn, function s!:comatsoc);

symbolic procedure s!:commember(x, env, context);
   if (s!:eval_to_eq_safe cadr x or s!:eval_to_list_all_eq_safe caddr x) and length x = 3 then
      s!:comval('memq . cdr x, env, context)
   else s!:comcall(x, env, context);

put('member, 's!:compfn, function s!:commember);
put('member!*!*, 's!:compfn, function s!:commember);

symbolic procedure s!:commemq(x, env, context);
   if (s!:eval_to_eq_unsafe cadr x or s!:eval_to_list_some_eq_unsafe caddr x) then <<
       if posn() neq 0 then terpri();
       princ "++++ MEMQ on number upgraded to MEMBER in ";
       prin s!:current_function; princ " : ";
       prin cadr x; princ " "; print caddr x;
       s!:comval('member . cdr x, env, context) >>
   else s!:comcall(x, env, context);

put('memq, 's!:compfn, function s!:commemq);

!#if (not common!-lisp!-mode)

symbolic procedure s!:comdelete(x, env, context);
   if (s!:eval_to_eq_safe cadr x or s!:eval_to_list_all_eq_safe caddr x) and length x = 3 then
      s!:comval('deleq . cdr x, env, context)
   else s!:comcall(x, env, context);

put('delete, 's!:compfn, function s!:comdelete);

symbolic procedure s!:comdeleq(x, env, context);
   if (s!:eval_to_eq_unsafe cadr x or s!:eval_to_list_some_eq_unsafe caddr x) then <<
       if posn() neq 0 then terpri();
       princ "++++ DELEQ on number upgraded to DELETE in ";
       prin s!:current_function; princ " : ";
       prin cadr x; princ " "; print caddr x;
       s!:comval('delete . cdr x, env, context) >>
   else s!:comcall(x, env, context);

put('deleq, 's!:compfn, function s!:comdeleq);

!#endif

% mapcar etc are compiled specially as a fudge to achieve an effect as
% if proper environment-capture was implemented for the functional
% argument (which I do not support at present). Not done (here) for
% Common Lisp since args to mapcar etc are in the other order.

symbolic procedure s!:commap(fnargs, env, context);
  begin
    scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed;
    fn := car fnargs;
% if the value of a mapping function is not needed I demote from mapcar to
% mapc or from maplist to map.
    if context > 1 then <<
       if fn = 'mapcar then fn := 'mapc
       else if fn = 'maplist then fn := 'map >>;
    if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t;
    fnargs := cdr fnargs;
    if atom fnargs then error(0,"bad arguments to map function");
    fn1 := cadr fnargs;
    while eqcar(fn1, 'function) or
          (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do <<
       fn1 := cadr fn1;
       closed := t >>;
% if closed is false I will insert FUNCALL since I am invoking a function
% stored in a variable - NB this means that the word FUNCTION becomes
% essential when using mapping operators - this is because I have built
% a 2-Lisp rather than a 1-Lisp.
    args := car fnargs;
    l1 := gensym();
    r := gensym();
    s := gensym();
    var := gensym();
    avar := var;
    if carp then avar := list('car, avar);
% Here if closed is true and fn1 is of the form (lambda (w) ... w ...) where
% the local variable occurs only once in the body, and w is not fluid or
% global (and there had better be no other bindings to wreck scope) then I
% might simplify by doing a textual substitution here rather than a real
% lambda binding. Maybe I should detect such cases in the code that
% compiles the application of lambda expressions?  For now do not bother!
    if closed then fn1 := list(fn1, avar)
    else fn1 := list('funcall, fn1, avar);
    moveon := list('setq, var, list('cdr, var));
    if fn = 'map or fn = 'mapc then fn := sublis(
       list('l1 . l1, 'var . var,
            'fn . fn1, 'args . args, 'moveon . moveon),
       '(prog (var)
             (setq var args)
       l1    (cond
                ((not var) (return nil)))
             fn
             moveon
             (go l1)))
    else if fn = 'maplist or fn = 'mapcar then fn := sublis(
       list('l1 . l1, 'var . var,
            'fn . fn1, 'args . args, 'moveon . moveon, 'r . r),
       '(prog (var r)
             (setq var args)
       l1    (cond
                ((not var) (return (reversip r))))
             (setq r (cons fn r))
             moveon
             (go l1)))
    else fn := sublis(
       list('l1 . l1, 'l2 . gensym(), 'var . var,
            'fn . fn1, 'args . args, 'moveon . moveon,
            'r . gensym(), 's . gensym()),
       '(prog (var r s)
             (setq var args)
             (setq r (setq s (list nil)))
       l1    (cond
                ((not var) (return (cdr r))))
             (rplacd s fn)
       l2    (cond
                ((not (atom (cdr s))) (setq s (cdr s)) (go l2)))
             moveon
             (go l1)));
    s!:comval(fn, env, context)
  end;

put('map,     's!:compfn, function s!:commap);
put('maplist, 's!:compfn, function s!:commap);
put('mapc,    's!:compfn, function s!:commap);
put('mapcar,  's!:compfn, function s!:commap);
put('mapcon,  's!:compfn, function s!:commap);
put('mapcan,  's!:compfn, function s!:commap);

!#endif

!#if common!-lisp!-mode

% The next few cases are concerned with demoting functions that use
% equal tests into ones that use eq instead

symbolic procedure s!:eval_to_eq_safe x;
   null x or x=t or eq!-safe x or
   (eqcar(x, 'quote) and (symbolp cadr x or eq!-safe cadr x));

symbolic procedure s!:list_all_eq_safe u;
  atom u or
  ((symbolp car u or eq!-safe car u) and s!:list_all_eq_safe cdr u);

symbolic procedure s!:eval_to_list_some_eq_unsafe x;
  null x or
  (eqcar(x, 'quote) and s!:list_all_eq_safe cadr x) or
  (eqcar(x, 'list) and
   (null cdr x or
    (s!:eval_to_eq_safe cadr x and
     s!:eval_to_list_some_eq_unsafe ('list . cddr x)))) or
  (eqcar(x, 'cons) and
   s!:eval_to_eq_safe cadr x and
   s!:eval_to_list_some_eq_unsafe caddr x);

symbolic procedure s!:eval_to_car_eq_safe x;
  (eqcar(x, 'cons) or eqcar(x, 'list)) and
  not null cdr x and
  s!:eval_to_eq_safe cadr x;

symbolic procedure s!:alist_eq_safe u;
  atom u or
  (not atom car u and
   (symbolp caar u or eq!-safe caar u) and 
   s!:alist_eq_safe cdr u);

symbolic procedure s!:eval_to_alist_eq_safe x;
  null x or
  (eqcar(x, 'quote) and s!:alist_eq_safe cadr x) or
  (eqcar(x, 'list) and
   (null cdr x or
    (s!:eval_to_car_eq_safe cadr x and
     s!:eval_to_alist_eq_safe ('list . cddr x)))) or
  (eqcar(x, 'cons) and
   s!:eval_to_car_eq_safe cadr x and
   s!:eval_to_alist_eq_safe caddr x);

symbolic procedure s!:comsublis(x, env, context);
   if s!:eval_to_alist_eq_safe cadr x then
      s!:comval('subla . cdr x, env, context)
   else s!:comcall(x, env, context);

put('sublis, 's!:compfn, function s!:comsublis);

symbolic procedure s!:comassoc(x, env, context);
   if length x = 3 then s!:comcall('atsoc . cdr x, env, context)
   else if length x = 5 and 
           cadddr x = '!:test and 
           (cadddr cdr x = '(function equal) or
            cadddr cdr x = '(quote equal) or
            cadddr cdr x = 'equal) then
      s!:comval(list('assoc!*!*, cadr x, caddr x), env, context)
   else s!:comcall(x, env, context);

put('assoc, 's!:compfn, function s!:comassoc);

symbolic procedure s!:comassoc!*!*(x, env, context);
   if s!:eval_to_eq_safe cadr x or s!:eval_to_alist_eq_safe caddr x then
      s!:comval('atsoc . cdr x, env, context)
   else s!:comcall(x, env, context);

put('assoc!*!*, 's!:compfn, function s!:comassoc!*!*);

symbolic procedure s!:commember(x, env, context);
   if length x = 3 then s!:comcall('memq . cdr x, env, context)
   else if length x = 5 and
           cadddr x = '!:test and
           (cadddr cdr x = '(function equal) or
            cadddr cdr x = '(quote equal) or
            cadddr cdr x = 'equal) then
      s!:comval(list('member!*!*, cadr x, caddr x), env, context)
   else if length x = 5 and cadddr x = !:test then begin
      scalar r, g0, g1, g2;
      g0 := gensym(); g1 := gensym(); g2 := gensym();
      r := list('prog, list(g0, g1),
             list('setq, g0, cadr x),
             list('setq, g1, caddr x),
             g2,
             list('cond,
                list(list('null, g1), list('return, nil)),
                list(list('funcall, cadddr cdr x, g0, list('car, g1)),
                     list('return, g1))),
             list('setq, g1, list('cdr, g1)),
             list('go, g2));
      return s!:comval(r, env, context) end
   else s!:comcall(x, env, context);

put('member, 's!:compfn, function s!:commember);

symbolic procedure s!:commember!*!*(x, env, context);
   if s!:eval_to_eq_safe cadr x or s!:eval_to_list_some_eq_unsafe caddr x then <<
       if posn() neq 0 then terpri();
       princ "++++ MEMQ on number upgraded to MEMBER in ";
       prin s!:current_function; princ " : ";
       prin cadr x; princ " "; print caddr x;
       s!:comval('memq . cdr x, env, context) >>;
   else s!:comcall(x, env, context);

put('member!*!*, 's!:compfn, function s!:commember!*!*);

!#endif

symbolic procedure s!:nilargs use;
   if null use then t
   else if car use = 'nil or car use = '(quote nil) then s!:nilargs cdr use
   else nil;

symbolic procedure s!:subargs(args, use);
   if null use then t
   else if null args then s!:nilargs use
   else if not (car args = car use) then nil
   else s!:subargs(cdr args, cdr use);

fluid '(!*where_defined!*);

symbolic procedure clear_source_database();
  << !*where_defined!* := mkhash(10, 2, 1.5);
     nil >>;

symbolic procedure load_source_database filename;
  begin
    scalar a, b;
    clear_source_database();
!#if common!-lisp!-mode
    a := open(filename, !:direction, !:input, !:if!-does!-not!-exist, nil);
!#else
    a := open(filename, 'input);
!#endif
    if null a then return nil;
    a := rds a;
    while (b := read()) do
       puthash(car b, !*where_defined!*, cdr b);
    close rds a;
    return nil
  end;

symbolic procedure save_source_database filename;
  begin
    scalar a;
!#if common!-lisp!-mode
    a := open(filename, !:direction, !:output);
!#else
    a := open(filename, 'output);
!#endif
    if null a then return nil;
    a := wrs a;
    for each z in sort(hashcontents !*where_defined!*, function orderp) do <<
       prin z; terpri() >>;
    princ nil; terpri();
    wrs a;
    !*where_defined!* := nil;
    return nil
  end;

symbolic procedure display_source_database();
  begin
    scalar w;
    if null !*where_defined!* then return nil;
    w := hashcontents !*where_defined!*;
    w := sort(w, function orderp);
    terpri();
    for each x in w do <<
       princ car x;
       ttab 40;
       prin cdr x;
       terpri() >>
  end;

% s!:compile1 directs the compilation of a single function, and bind all the
% major fluids used by the compilation process

symbolic procedure s!:compile1(name, args, body, s!:lexical_env);
  begin
    scalar w, aargs, oargs, oinit, restarg, svars, nargs, nopts, env, fluids,
           s!:current_function, s!:current_label, s!:current_block,
           s!:current_size, s!:current_procedure, s!:current_exitlab,
           s!:current_proglabels, s!:other_defs, local_decs, s!:has_closure,
           s!:local_macros, s!:recent_literals, s!:a_reg_values, w1, w2,
           s!:current_count;
    s!:current_function := name;
    s!:current_count := 0;
    if !*where_defined!* then <<
!#if common!-lisp!-mode
        w := symbol!-package name;
        if w then w := list(package!-name w, symbol!-name name);
!#else
        w := name;
!#endif
        puthash(w, !*where_defined!*, where!-was!-that()) >>;
    body := s!:find_local_decs body;
    local_decs := car body; body := cdr body;
    if atom body then body := nil
    else if null cdr body then body := car body
    else body := 'progn . body;
    nargs := nopts := 0;
    while args and
          not eqcar(args, '!&optional) and
          not eqcar(args, '!&rest) do <<
       if car args = '!&key or car args = '!&aux then error(0, "&key/&aux");
       aargs := car args . aargs;
       nargs := nargs + 1;
       args := cdr args >>;
    if eqcar(args, '!&optional) then <<
       args := cdr args;
       while args and not eqcar(args, '!&rest) do <<
          if car args = '!&key or car args = '!&aux then error(0, "&key/&aux");
          w := car args;
% Things that are written as (v) or (v nil) might as well have
% been treated as just v. I use a WHILE loop so that silly people
% who write (((((v))))) get their code reduced to just v.
          while not atom w and
             (atom cdr w or cdr w = '(nil)) do w := car w;
          args := cdr args;
          oargs := w . oargs;
          nopts := nopts + 1;
          if atom w then aargs := w . aargs
          else <<
             oinit := t;
             aargs := car w . aargs;
             if not atom cddr w then svars := caddr w . svars >> >> >>;
    if eqcar(args, '!&rest) then <<
       w := cadr args;
       aargs := w . aargs;
       restarg := w;
       args := cddr args;
       if args then error(0, "&rest arg not at end") >>;
% NB I have not allowed for &aux or &key - I take the view that
% they will be expanded out by a DEFUN macro.
    args := reverse aargs;
% The variable args is now a map of how my arguments will actually be
% presented to me on the stack.
    oargs := reverse oargs;   % Optional args, possibly with initforms
                              % oinit is true if there are initforms.
% Now I will TRY to be kind.  If any variable mentioned in the argument list
% is a GLOBAL I will convert it to FLUID, but tell the user that that
% has happened.
    for each v in append(svars, args) do <<
       if globalp v then <<
           if !*pwrds then <<
              if posn() neq 0 then terpri();
              princ "+++++ global ";
              prin v;
              princ " converted to fluid";
              terpri() >>;
           unglobal list v;
           fluid list v >> >>;
    if oinit then
       return s!:compile2(name, nargs, nopts,
                          args, oargs, restarg, body, local_decs);
    w := nil;
    for each v in args do w := s!:instate_local_decs(v, local_decs, w);
    for each v on args do <<
       if fluidp car v then begin
          scalar g;
          g := gensym();
          fluids := (car v . g) . fluids;
          rplaca(v, g) end >>;
% In the case that the variables a and b are fluid, I map
%  (lambda (a b) X) onto
%  (lambda (g1 g2) (prog (a b) (setq a g1) (setq b g2) (return X)))
% and then let the compilation of the PROG deal with the fluid bindings.
% [I worry a bit about adding an extra PROG here, since it can mean that
% RETURN becomes valid when it used not to...].  Note that since the
% variable g1, g2 ... are all new gensyms none of them can be locally special
% so at least I do not have muddle because of that.
    if fluids then <<
       body := list list('return, body);
       for each v in fluids do
          body := list('setq, car v, cdr v) . body;
       body := 'prog .
         (for each v in fluids collect car v) . body >>;
% If I am compiling in-store I will common up literals only if they are EQL.
% However if s!:faslmod_name is set then I am compiling to a file, and in
% that case I will dare common things up if they are EQUAL.  The reasoning
% behind this is that going via a file necesarily loses EQ-ness on some
% things, so one can afford to do som while for in-store compilation it
% could make sense to preserve sharing (or not) between literal lists in
% the code being compiled.
    env := mkhash(10, (if s!:faslmod_name then 2 else 1), 1.5) .
           reverse args;
    puthash(name, car env, 10000000 . nil);
    w := s!:residual_local_decs(local_decs, w);
    s!:start_procedure(nargs, nopts, restarg);
% Now, so that I will be able to take special action on cases which would
% compile into nothing more than a tail-call operation, I do a bit of
% early expansion. If this does not reveal that I have a definition
% of the form (de f1 (a b c ...) (f2 a b c)) then I ignore what I have done
% to let comval handle it in the normal way...
    w1 := body;
more:
    if atom w1 then nil
    else if car w1 = 'block and length w1 = 3 then << 
       w1 := caddr w1; go to more >>
    else if car w1 = 'progn and length w1 = 2 then <<
       w1 := cadr w1; go to more >>
    else if atom (w2 := car w1) and (w2 := get(w2, 's!:newname)) then <<
       w1 := w2 . cdr w1; go to more >>
    else if atom (w2 := car w1) and (w2 := macro!-function w2) then <<
        w1 := funcall(w2, w1); go to more >>;
    if not ((w2 := s!:improve w1) = w1) then << w1 := w2; go to more >>;

    if not atom w1 and atom car w1 and not special!-form!-p car w1 and 
       s!:subargs(args, cdr w1) and
% Just for the moment I will only enable this special case code for
% instances where the new function has less than 3 args and the one it calls
% does not need nil-padding.
       nargs <= 3 and nopts = 0 and not restarg and
       length cdr w1 <= nargs then <<
        s!:cancel_local_decs w;
        if restarg then nopts := nopts + 512;
% The argument count info gets bits added in here to show how many args
% must be passed on. If this is larger than the number originally provided
% it means that nils should be padded onto the end.
        nopts := nopts + 1024*length w1;
        nargs := nargs + 256*nopts;
        if !*pwrds then <<
            if posn() neq 0 then terpri();
            princ "+++ "; prin name; princ " compiled as link to ";
            princ car w1; terpri() >>;
        return (name . nargs . nil . car w1) . s!:other_defs >>;
    s!:comval(body, env, 0);
    s!:cancel_local_decs w;
% This returns a list of values suitable for handing to symbol-set-definition
    if restarg then nopts := nopts + 512;
    nargs := nargs + 256*nopts;
    return (name . nargs . s!:endprocedure(name, env)) . s!:other_defs;
  end;

symbolic procedure s!:compile2(name, nargs, nopts,
                               args, oargs, restarg, body, local_decs);
% If I have any &optional args that have initforms then I will generate
% code in a very cautious, slow and pessimistic manner - because I need
% to be able to evaluate the initforms in an environment where the
% previously mentioned arguments have all been bound, but subsequent
% ones have not.
  begin
    scalar fluids, env, penv, g, v, init, atend, w;
% I start off with an environment that shows how deep my stack is, but
% which does not give any names to the locations on it.
    for each v in args do <<
       env := 0 . env;
       penv := env . penv >>;
    env := mkhash(10, (if s!:faslmod_name then 2 else 1), 1.5) . env;
    puthash(name, car env, 10000000 . nil);
    penv := reversip penv;
% I make the list of optional args as long as the complete arg list - with
% zero entries for things that are not optional.
    if restarg then oargs := append(oargs, '(0));
    for i := 1:nargs do oargs := 0 . oargs;
    s!:start_procedure(nargs, nopts, restarg);
    while args do <<
       v := car args;
       init := car oargs;
       if init = 0 then <<
          w := s!:instate_local_decs(v, local_decs, w);
          if fluidp v then <<
              g := gensym();
              rplaca(car penv, g);
              s!:outopcode1lit('FREEBIND, s!:vecof list v, env);
              rplacd(env, 3 . 0 . 0 . cdr env);
              atend := 'FREERSTR . atend;
              s!:comval(list('setq, v, g), env, 2) >>
          else rplaca(car penv, v) >>
       else begin
          scalar ival, sp, l1, l2;
          if not atom init then <<
             init := cdr init;
             ival := car init;
             if not atom cdr init then sp := cadr init >>;
          l1 := gensym();
          g := gensym();
          rplaca(car penv, g);
          if null ival and null sp then
             s!:comval(list('setq, g, list('spid!-to!-nil, g)), env, 1)
          else <<
             s!:jumpif(nil, list('is!-spid, g), env, l1);
% Here is code for when an initform must be activated.
             s!:comval(list('setq, g, ival), env, 1);
             if sp then <<
                if fluidp sp then <<
                   s!:outopcode1lit('FREEBIND, s!:vecof list sp, env);
                   s!:outjump('JUMP, l2 := gensym());
                   s!:set_label l1;
                   s!:outopcode1lit('FREEBIND, s!:vecof list sp, env);
                   rplacd(env, 3 . 0 . 0 . cdr env);
                   s!:comval(list('setq, sp, t), env, 1);
                   s!:set_label l2;
                   atend := 'FREERSTR . atend >>
                else <<
                   s!:outopcode0('PUSHNIL, '(PUSHNIL));
                   s!:outjump('JUMP, l2 := gensym());
                   s!:set_label l1;
                   s!:loadliteral(t, env);
                   s!:outopcode0('PUSH, '(PUSH));
                   s!:set_label l2;
                   rplacd(env, sp . cdr env);
                   atend := 'LOSE . atend >> >>
             else s!:set_label l1 >>;
          w := s!:instate_local_decs(v, local_decs, w);
          if fluidp v then <<
             s!:outopcode1lit('FREEBIND, s!:vecof list v, env);
             rplacd(env, 3 . 0 . 0 . cdr env);
             s!:comval(list('setq, v, g), env, 1);
             atend := 'FREERSTR . atend >>
          else rplaca(car penv, v)
          end;
       args := cdr args;
       oargs := cdr oargs;
       penv := cdr penv >>;
    w := s!:residual_local_decs(local_decs, w);
    s!:comval(body, env, 0);
    while atend do <<
       s!:outopcode0(car atend, list car atend);
       atend := cdr atend >>;
    s!:cancel_local_decs w;
    nopts := nopts + 256;     % Always have complex &optional here
    if restarg then nopts := nopts + 512;
    nargs := nargs + 256*nopts;
    return (name . nargs . s!:endprocedure(name, env)) . s!:other_defs;
  end;


% compile-all may be invoked at any time to ensure that everything that can be
% has been compiled

!#if common!-lisp!-mode

symbolic procedure compile!-all;
% Bootstrapping issues mean that I can not easily use do-all-symbols() here
  for each p in list!-all!-packages() do begin
    scalar !*package!*;
    !*package!* := find!-package p;
    for each x in oblist() do
      begin scalar w;
        w := getd x;
        if (eqcar(w, 'expr) or eqcar(w, 'macro)) and
            eqcar(cdr w, 'lambda) then <<
           princ "Compile: "; prin x; terpri();
           errorset(list('compile, mkquote list x), t, t) >> end end;

!#else

symbolic procedure compile!-all;
   for each x in oblist() do begin
      scalar w;
      w := getd x;
      if (eqcar(w, 'expr) or eqcar(w, 'macro)) and
          eqcar(cdr w, 'lambda) then <<
         princ "Compile: "; prin x; terpri();
         errorset(list('compile, mkquote list x), t, t) >> end;

!#endif

% Support for a FASL mechanism, styled after that which I expect existing
% Standard Lisp applications to require.

% The 'eval and 'ignore flags are to help the RLISP interface to the
% fasl mechanism

flag('(rds deflist flag fluid global
       remprop remflag unfluid
       unglobal dm defmacro carcheck
       faslend c_end), 'eval);

flag('(rds), 'ignore);

fluid '(!*backtrace);

symbolic procedure s!:fasl_supervisor;
  begin
    scalar u, w, !*echo;
top:u := errorset('(read), t, !*backtrace);
    if atom u then return;      % failed, or maybe EOF
    u := car u;
    if u = !$eof!$ then return; % end of file
    if not atom u then u := macroexpand u; % In case it expands into (DE ...)
    if atom u then go to top
% the apply('faslend, nil) is here because faslend has a "stat" property
% and so it will mis-parse if I just write "faslend()".  Yuk.
    else if eqcar(u, 'faslend) then return apply('faslend, nil)
!#if common!-lisp!-mode
    else if eqcar(u, 'load) then << <<
       w := open(u := eval cadr u, !:direction, !:input,
                                   !:if!-does!-not!-exist, nil);
!#else
    else if eqcar(u, 'rdf) then <<
       w := open(u := eval cadr u, 'input);
!#endif
       if w then <<
          terpri();
          princ "Reading file "; prin u; terpri();
          w := rds w;
          s!:fasl_supervisor();
          princ "End of file "; prin u; terpri();
          close rds w >>
       else << princ "Failed to open file "; prin u; terpri() >> >>
!#if common!-lisp!-mode
       >> where !*package!* = !*package!*
!#endif
    else s!:fslout0 u;
    go to top
  end;

symbolic procedure s!:fslout0 u;
   s!:fslout1(u, nil);

symbolic procedure s!:fslout1(u, loadonly);
  begin
    scalar w;
    if not atom u then u := macroexpand u;
    if atom u then return nil
    else if eqcar(u, 'progn) then <<
       for each v in cdr u do s!:fslout1(v, loadonly);
       return >>
    else if eqcar(u, 'eval!-when) then return begin
      w := cadr u;
      u := 'progn . cddr u;
      if memq('compile, w) and not loadonly then eval u;
      if memq('load, w) then s!:fslout1(u, t);
      return nil end
% When called from REDUCE the treatment of things flagged as EVAL here
% will end up leading to them getting evaluated twice.  Often this will
% not matter - a case where I have had to be careful is in (faslend) which
% can thus be called twice: the second call must be ignored.
    else if flagp(car u, 'eval) or
% The special treatment here is so that (setq x (carcheck 0)) will get
% picked up as needing compile-time evaluation.
          (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then
       if not loadonly then errorset(u, t, !*backtrace);
!#if common!-lisp!-mode
    if eqcar(u, 'load) then << begin
       w := open(u := eval cadr u, !:direction, !:input,
                                   !:if!-does!-not!-exist, nil);
!#else
    if eqcar(u, 'rdf) then begin
       w := open(u := eval cadr u, 'input);
!#endif
       if w then <<
          princ "Reading file "; prin u; terpri();
          w := rds w;
          s!:fasl_supervisor();
          princ "End of file "; prin u; terpri();
          close rds w
       >>
       else << princ "Failed to open file "; prin u; terpri() >> end
!#if common!-lisp!-mode
       >> where !*package!* = !*package!*
!#endif
    else if !*nocompile then <<  % Funny option not for general use!
       if not eqcar(u, 'faslend) and
          not eqcar(u, 'carcheck) then write!-module u >>
    else if eqcar(u, 'de) or eqcar(u, 'defun) then <<
        u := cdr u;
        if (w := get(car u, 'c!-version)) and
            w = md60 (cadr u . s!:fully_macroexpand_list cddr u) then <<
            princ "+++ "; prin car u;
            printc " not compiled (C version available)";
            write!-module list('restore!-c!-code, mkquote car u) >>
        else if flagp(car u, 'lose) then <<
            princ "+++ "; prin car u;
            printc " not compiled (LOSE flag)" >>
        else for each p in s!:compile1(car u, cadr u, cddr u, nil) do 
            s!:fslout2(p, u) >>
    else if eqcar(u, 'dm) or eqcar(u, 'defmacro) then begin
        scalar g;
        g := hashtagged!-name(cadr u, cddr u);
        u := cdr u;
% At present (and maybe for ever?) macros can not be compiled into C.
%
%       if (w := get(car u, 'c!-version)) and
%           md60 u = w then <<
%           princ "+++ "; prin car u;
%           printc " not compiled (C version available flag)";
%           return nil >>
%       else 
        if flagp(car u, 'lose) then <<
            princ "+++ "; prin car u;
            printc " not compiled (LOSE flag)";
            return nil >>;
        w := cadr u;
        if w and null cdr w then w := car w . '!&optional . gensym() . nil;
        for each p in s!:compile1(g, w, cddr u, nil) do s!:fslout2(p, u);
        write!-module list('dm, car u, '(u !&optional e), list(g, 'u, 'e))
      end    
    else if eqcar(u, 'putd) then begin
% If people put (putd 'name 'expr '(lambda ...)) in their file I will
% expand it out as if it had been a (de name ...) [similarly for macros].
      scalar a1, a2, a3;
      a1 := cadr u; a2 := caddr u; a3 := cadddr u;
      if eqcar(a1, 'quote) and
         (a2 = '(quote expr) or a2 = '(quote macro)) and
         (eqcar(a3, 'quote) or eqcar(a3, 'function)) and
         eqcar(cadr a3, 'lambda) then <<
         a1 := cadr a1; a2 := cadr a2; a3 := cadr a3;
         u := (if a2 = 'expr then 'de else 'dm) . a1 . cdr a3;
% More complicated uses of PUTD may defeat the C-version hack...
         s!:fslout1(u, loadonly) >>
      else write!-module u end
    else if not eqcar(u, 'faslend) and
            not eqcar(u, 'carcheck) then write!-module u
  end;

symbolic procedure s!:fslout2(p, u);
  begin
    scalar name, nargs, code, env, w;
    name := car p;
    nargs := cadr p;
    code := caddr p;
    env := cdddr p;
    if !*savedef and name = car u then <<
% I associate the saved definition with the top-level function
% that is being defined, and ignore any embedded lambda expressions
        define!-in!-module(-1);    % savedef marker
        write!-module('lambda . cadr u . s!:fully_macroexpand_list cddr u) >>;
% If the FASL file format tail-call definitions are represented by giving the
% number of args in the thing to chain to as an integer where otherwise
% a vector of bytecodes would be provided.
    w := irightshift(nargs, 18);
    nargs := logand(nargs, 262143); % 0x3ffff
    if not (w = 0) then code := w - 1;
    define!-in!-module nargs;
    write!-module name;
    write!-module code;
    write!-module env
  end;

symbolic procedure faslend;
  begin
    if null s!:faslmod_name then return nil;
    start!-module nil;
    dfprint!* := s!:dfprintsave;
    !*defn := nil;
    !*comp := cdr s!:faslmod_name;
    s!:faslmod_name := nil;
    return nil
  end;

put('faslend, 'stat, 'endstat);

symbolic procedure faslout u;
  begin
    terpri();
    princ "FASLOUT ";
    prin u; princ ": IN files;  or type in expressions"; terpri();
    princ "When all done, execute FASLEND;"; terpri();
% I permit the argument to be either a name, or a list of one item
% that is a name.  The idea here is that when called from RLISP it is
% most convenient for the call to map onto (faslout '(xxx)), while direct
% use from Lisp favours (faslout 'xxx)
    if not atom u then u := car u;
    if not start!-module u then <<
       if posn() neq 0 then terpri();
       princ "+++ Failed to open FASL output file"; terpri();
       return nil >>;
    s!:faslmod_name := u . !*comp;
    s!:dfprintsave := dfprint!*;
    dfprint!* := 's!:fslout0;
    !*defn := t;
    !*comp := nil;
    if getd 'begin then return nil;
    s!:fasl_supervisor();
  end;

put('faslout, 'stat, 'rlis);

symbolic procedure s!:c_supervisor;
  begin
    scalar u, w, !*echo;
top:u := errorset('(read), t, !*backtrace);
    if atom u then return;      % failed, or maybe EOF
    u := car u;
    if u = !$eof!$ then return; % end of file
    if not atom u then u := macroexpand u; % In case it expands into (DE ...)
    if atom u then go to top
% the apply('c_end, nil) is here because c_end has a "stat" property
% and so it will mis-parse if I just write "c_end()".  Yuk.
    else if eqcar(u, 'c_end) then return apply('c_end, nil)
!#if common!-lisp!-mode
    else if eqcar(u, 'load) then << <<
       w := open(u := eval cadr u, !:direction, !:input,
                                   !:if!-does!-not!-exist, nil);
!#else
    else if eqcar(u, 'rdf) then <<
       w := open(u := eval cadr u, 'input);
!#endif
       if w then <<
          terpri();
          princ "Reading file "; prin u; terpri();
          w := rds w;
          s!:c_supervisor();
          princ "End of file "; prin u; terpri();
          close rds w
       >>
       else << princ "Failed to open file "; prin u; terpri() >> >>
!#if common!-lisp!-mode
       >> where !*package!* = !*package!*
!#endif
    else s!:cout0 u;
    go to top
  end;

symbolic procedure s!:cout0 u;
   s!:cout1(u, nil);

symbolic procedure s!:cout1(u, loadonly);
  begin
    scalar s!:into_c;
    s!:into_c := t;
    if not atom u then u := macroexpand u;
    if atom u then return nil
    else if eqcar(u, 'progn) then <<
       for each v in cdr u do s!:cout1(v, loadonly);
       return >>
    else if eqcar(u, 'eval!-when) then return begin
      scalar w;
      w := cadr u;
      u := 'progn . cddr u;
      if memq('compile, w) and not loadonly then eval u;
      if memq('load, w) then s!:cout1(u, t);
      return nil end
% When called from REDUCE the treatment of things flagged as EVAL here
% will end up leading to them getting evaluated twice.  Often this will
% not matter - a case where I have had to be careful is in (c_end) which
% can thus be called twice: the second call must be ignored.
    else if flagp(car u, 'eval) or
% The special treatment here is so that (setq x (carcheck 0)) will get
% picked up as needing compile-time evaluation.
          (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then
       if not loadonly then errorset(u, t, !*backtrace);
!#if common!-lisp!-mode
    if eqcar(u, 'load) then << begin
       scalar w;
       w := open(u := eval cadr u, !:direction, !:input,
                                   !:if!-does!-not!-exist, nil);
!#else
    if eqcar(u, 'rdf) then begin
       scalar w;
       w := open(u := eval cadr u, 'input);
!#endif
       if w then <<
          princ "Reading file "; prin u; terpri();
          w := rds w;
          s!:c_supervisor();
          princ "End of file "; prin u; terpri();
          close rds w
       >>
       else << princ "Failed to open file "; prin u; terpri() >> end
!#if common!-lisp!-mode
       >> where !*package!* = !*package!*
!#endif
    else if eqcar(u, 'de) or eqcar(u, 'defun) then begin
        scalar w;
        u := cdr u;
        w := s!:compile1(car u, cadr u, cddr u, nil);
        for each p in w do s!:cgen(car p, cadr p, caddr p, cdddr p)
      end
    else if eqcar(u, 'dm) or eqcar(u, 'defmacro) then begin
        scalar w, g;
        g := hashtagged!-name(cadr u, cddr u);
        u := cdr u;
        w := cadr u;  % List of bound vars. Either (u) or (u &optional e) (?)
        if w and null cdr w then w := car w . '!&optional . gensym() . nil;
        w := s!:compile1(g, w, cddr u, nil);
        for each p in w do s!:cgen(car p, cadr p, caddr p, cdddr p);
        s!:cinit list('dm, car u, '(u !&optional e), list(g, 'u, 'e))
      end    
    else if eqcar(u, 'putd) then begin
% If people put (putd 'name 'expr '(lambda ...)) in their file I will
% expand it out as if it had been a (de name ...) [similarly for macros].
% This is done at least once in REDUCE.
      scalar a1, a2, a3;
      a1 := cadr u; a2 := caddr u; a3 := cadddr u;
      if eqcar(a1, 'quote) and
         (a2 = '(quote expr) or a2 = '(quote macro)) and
         (eqcar(a3, 'quote) or eqcar(a3, 'function)) and
         eqcar(cadr a3, 'lambda) then <<
         a1 := cadr a1; a2 := cadr a2; a3 := cadr a3;
         u := (if a2 = 'expr then 'de else 'dm) . a1 . cdr a3;
         s!:cout1(u, loadonly) >>
      else s!:cinit u end
    else if not eqcar(u, 'c_end) and
            not eqcar(u, 'carcheck) then s!:cinit u
  end;

fluid '(s!:cmod_name);

symbolic procedure c_end;
  begin
    if null s!:cmod_name then return nil;
    s!:cend();
    dfprint!* := s!:dfprintsave;
    !*defn := nil;
    !*comp := cdr s!:cmod_name;
    s!:cmod_name := nil;
    return nil
  end;

put('c_end, 'stat, 'endstat);

symbolic procedure c_out u;
  begin
    terpri();
    princ "C_OUT ";
    prin u; princ ": IN files;  or type in expressions"; terpri();
    princ "When all done, execute C_END;"; terpri();
% I permit the argument to be either a name, or a list of one item
% that is a name.  The idea here is that when called from RLISP it is
% most convenient for the call to map onto (c_out '(xxx)), while direct
% use from Lisp favours (c_out 'xxx)
    if not atom u then u := car u;
    if null s!:cstart u then <<
       if posn() neq 0 then terpri();
       princ "+++ Failed to open C output file"; terpri();
       return nil >>;
    s!:cmod_name := u . !*comp;
    s!:dfprintsave := dfprint!*;
    dfprint!* := 's!:cout0;
    !*defn := t;
    !*comp := nil;
    if getd 'begin then return nil;
    s!:c_supervisor();
  end;

put('c_out, 'stat, 'rlis);

symbolic procedure s!:compile!-file!*(fromfile,
                                      !&optional, tofile, verbose, !*pwrds);
  begin
    scalar !*comp, w, save;
    if null tofile then tofile := fromfile;
    if verbose then <<
       if posn() neq 0 then terpri();
!#if common!-lisp!-mode
       princ ";; Compiling file ";
!#else
       princ "+++ Compiling file ";
!#endif
       prin fromfile;
       terpri();
       save := verbos nil;
       verbos ilogand(save, 4) >>;
    if not start!-module tofile then <<
       if posn() neq 0 then terpri();
       princ "+++ Failed to open FASL output file"; terpri();
       if save then verbos save;
       return nil >>;
!#if common!-lisp!-mode
       << w := open(fromfile, !:direction, !:input,
                              !:if!-does!-not!-exist, nil);
!#else
          w := open(fromfile, 'input);
!#endif
          if w then <<
             w := rds w;
             s!:fasl_supervisor();
             close rds w >>
          else << princ "Failed to open file "; prin fromfile; terpri() >>
!#if common!-lisp!-mode
       >> where !*package!* = !*package!*;
!#else
       ;
!#endif
    if save then verbos save;
    start!-module nil;
    if verbose then <<
       if posn() neq 0 then terpri();
!#if common!-lisp!-mode
       princ ";; Compilation complete";
!#else
       princ "+++ Compilation complete";
!#endif
       terpri() >>;
    return t
  end;

% I provide a version that will suffice for Standard Lisp and replace it
% later on in the Common Lisp case (where keyword args are needed)

symbolic procedure compile!-file!*(fromfile, !&optional, tofile);
   s!:compile!-file!*(fromfile, tofile, t, t);

symbolic procedure compd(name, type, defn);
  begin
    scalar g, !*comp;
    !*comp := t;
    if eqcar(defn, 'lambda) then << 
       g := dated!-name type;
       symbol!-set!-definition(g, defn);
       compile list g;
       defn := g >>;
     put(name, type, defn);
    return name
  end;

symbolic procedure s!:compile0 name;
  begin
    scalar w, args, defn;
    defn := getd name;
    if eqcar(defn, 'macro) and eqcar(cdr defn, 'lambda) then 
       begin
         scalar !*comp, lx, vx, bx;
% If I have a macro definition
%    (dm fff (v) (ggg ...))
% I will usually map it onto a pair of definitions
%    (dm fff (v) (fff!* v))
%    (de fff!* (v) (ggg ...))
% and then compile fff!* but not fff itself.  If this has been done already
% or the initial definition of fff was in the required form then I will
% not perform any transformation and I will not compile fff.
% I also need to detect the case
%    (dm fff (v &optional e) (fff!* v e))
         lx := cdr defn;    % (LAMBDA vx bx)
         if not ((length lx = 3 and
                  not atom (bx := caddr lx) and
                  cadr lx = cdr bx) or
                 (length lx = 3 and
                  not atom (bx := caddr lx) and
                  not atom cadr lx and eqcar(cdadr lx, '!&optional) and
                  not atom (bx := cdr bx) and caadr lx = car bx and
                  cddadr lx = cdr bx)) then <<
            w := hashtagged!-name(name, defn);
            symbol!-set!-definition(w, cdr defn);
            s!:compile0 w;
            if 1 = length cadr lx then
                symbol!-set!-env(name, list('(u !&optional env),
                                       list(w, 'u)))
            else symbol!-set!-env(name, list('(u !&optional env),
                                        list(w, 'u, 'env))) >>
       end
    else if not eqcar(defn, 'expr) or not eqcar(cdr defn, 'lambda) then <<
       if !*pwrds then <<
          if posn() neq 0 then terpri();
          princ "+++ "; prin name; princ " not compilable"; terpri() >> >>
    else <<
       args := cddr defn;
       defn := cdr args;
       args := car args;
       if stringp args then <<
          if !*pwrds then <<
             if posn() neq 0 then terpri();
             princ "+++ "; prin name; princ " was already compiled";
             terpri() >> >>
       else <<
          if !*savedef then
             put(name, '!*savedef,
                       'lambda . args . s!:fully_macroexpand_list defn);
          w := s!:compile1(name, args, defn, nil);
          for each p in w do
             symbol!-set!-definition(car p, cdr p) >> >>
  end;

symbolic procedure s!:fully_macroexpand_list l;
   for each u in l collect s!:fully_macroexpand u;

symbolic procedure s!:fully_macroexpand x;
% This MUST match the logic in s!:comval, so that there are no oddities
% about which order expansions are done in. 
  begin
    scalar helper;
    if atom x or eqcar(x, 'quote) then return x
    else if eqcar(car x, 'lambda) then return
       ('lambda . cadar x . s!:fully_macroexpand_list cddar x) .
          s!:fully_macroexpand_list cdr x
!#if common!-lisp!-mode
    else if helper := s!:local_macro car x then <<
       if atom cdr helper then
          s!:fully_macroexpand('funcall . cdr helper . cdr x)
       else s!:fully_macroexpand funcall('lambda . cdr helper, x) >>
!#endif
% NB I do not expand compilermacros here. Actually at present "vector"
% seems to be the only function that has one.
    else if (helper := get(car x, 's!:newname)) then
        return s!:fully_macroexpand (helper . cdr x)
    else if helper := get(car x, 's!:expandfn) then
        return funcall(helper, x)
    else if helper := macro!-function car x then
       return s!:fully_macroexpand funcall(helper, x)
    else return car x . s!:fully_macroexpand_list cdr x
  end;

symbolic procedure s!:expandfunction u;
   u;

symbolic procedure s!:expandflet u;
   error("expand", u);

symbolic procedure s!:expandlabels u;
   error("expand", u);

symbolic procedure s!:expandmacrolet u;
   error("expand", u);

symbolic procedure s!:expandprog u;
   car u . cadr u . s!:fully_macroexpand_list cddr u;

symbolic procedure s!:expandtagbody u;
   s!:fully_macroexpand_list u;

symbolic procedure s!:expandprogv u;
   car u . cadr u . caddr u . s!:fully_macroexpand_list cadddr u;

symbolic procedure s!:expandblock u;
   car u . cadr u . s!:fully_macroexpand_list cddr u;

symbolic procedure s!:expanddeclare u;
   u;

symbolic procedure s!:expandlet u;
   car u . (for each x in cadr u collect s!:fully_macroexpand_list x) .
      s!:fully_macroexpand_list cddr u;

symbolic procedure s!:expandlet!* u;
   s!:expandlet u;

symbolic procedure s!:expandgo u;
   u;

symbolic procedure s!:expandreturn!-from u;
   car u . cadr u . s!:fully_macroexpand_list cddr u;

symbolic procedure s!:expandcond u;
   car u . for each x in cdr u collect s!:fully_macroexpand_list x;

symbolic procedure s!:expandcase u;
   car u . for each x in cdr u collect 
           (car x . s!:fully_macroexpand_list cdr x);

symbolic procedure s!:expandeval!-when u;
   car u . cadr u . s!:fully_macroexpand_list cddr u;

symbolic procedure s!:expandthe u;
   car u . cadr u . s!:fully_macroexpand_list cddr u;

symbolic procedure s!:expandmv!-call u;
   car u . cadr u . s!:fully_macroexpand_list cddr u;


put('function, 's!:expandfn, function s!:expandfunction);
put('flet, 's!:expandfn, function s!:expandflet);
put('labels, 's!:expandfn, function s!:expandlabels);
put('macrolet, 's!:expandfn, function s!:expandmacrolet);
put('prog, 's!:expandfn, function s!:expandprog);
put('tagbody, 's!:expandfn, function s!:expandtagbody);
put('progv, 's!:expandfn, function s!:expandprogv);
!#if common!-lisp!-mode
put('block, 's!:expandfn, function s!:expandblock);
!#else
put('!~block, 's!:expandfn, function s!:expandblock);
!#endif
put('declare, 's!:expandfn, function s!:expanddeclare);
!#if common!-lisp!-mode
put('let, 's!:expandfn, function s!:expandlet);
!#else
put('!~let, 's!:expandfn, function s!:expandlet);
!#endif
put('let!*, 's!:expandfn, function s!:expandlet!*);
put('go, 's!:expandfn, function s!:expandgo);
put('return!-from, 's!:expandfn, function s!:expandreturn!-from);
put('cond, 's!:expandfn, function s!:expandcond);
put('case, 's!:expandfn, function s!:expandcase);
put('eval!-when, 's!:expandfn, function s!:expandeval!-when);
put('the, 's!:expandfn, function s!:expandthe);
put('multiple!-value!-call, 's!:expandfn, function s!:expandmv!-call);


% As soon as compile() is defined, !*comp enables automatic compilation
% when functions are defined - so I must put the definition of compile
% right at the end of this file so that nothing untoward happens during
% initial building.

symbolic procedure compile l;
  begin
     if atom l and not null l then l := list l;
     for each name in l do
        errorset(list('s!:compile0, mkquote name), t, t);
     return l
  end;

end;

% End of compiler.red