reduce-historical/r35/cslsrc/cslrend.red

module cslrend; % CSL REDUCE "back-end".

% Authors: Martin L. Griss and Anthony C. Hearn.
% Modified by Arthur Norman for use with CSL.

create!-package('(cslrend csl),'(build));

fluid '(!*break
        !*echo
        !*eolinstringok
        !*int
        !*mode
        !*raise
        !*lower
        !*keepsqrts);

global '(!$eol!$
         !*extraecho
         cr!*
         crchar!*
         date!*
         esc!*
         ff!*
         ifl!*
         ipl!*
         largest!-small!-modulus
         ofl!*
         spare!*
         statcounter
         crbuflis!*
         tab!*
         version!*
         symchar!*);

% Constants used in scanner.

flag('(define!-constant),'eval);

cr!* := compress(list('!!, special!-char 6));   % carriage return
ff!* := compress(list('!!, special!-char 5));   % form feed
tab!*:= compress(list('!!, special!-char 3));   % tab key


% One inessential reference to REVERSIP in this module (left unchanged).

% This file defines the system dependent code necessary to run REDUCE
% under CSL.

Comment The following functions, which are referenced in the basic
REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to
complete the definition of REDUCE:

        BYE
        EVLOAD
        ERROR1
        FILETYPE
        MKFIL
        ORDERP
        QUIT
        SEPRP
        SETPCHAR.

Prototypical descriptions of these functions are as follows;

remprop('bye,'stat);

symbolic procedure bye;
   %Returns control to the computer's operating system command level.
   %The current REDUCE job cannot be restarted;
   <<close!-output!-files(); stop 0>>;

deflist('((bye endstat)),'stat);

remprop('quit,'stat);

symbolic procedure quit;
   %Returns control to the computer's operating system command level.
   %The current REDUCE job cannot be restarted;
   <<close!-output!-files(); stop 0>>;

deflist('((quit endstat)),'stat);

% evload is now defined in cslprolo.red - this has to be the case
% so it can be used (via load_package) to load rlisp and cslrend.
% symbolic procedure evload l;
%   for each m in l do load!-module m;

symbolic procedure seprp u;
   % Returns true if U is a blank, end-of-line, tab, carriage return or
   % form feed.  This definition replaces the one in the BOOT file.
   u eq '!  or u eq tab!* or u eq !$eol!$ or u eq ff!* or u eq cr!*;

symbolic procedure filetype u;
   % Determines if string U has a specific file type.
   begin scalar v,w;
      v := cdr explode u;
      while v and not(car v eq '!.) do
        <<if car v eq '!< then while not(car v eq '!>) do v := cdr v;
          v := cdr v>>;
      if null v then return nil;
      v := cdr v;
      while v and not(car v eq '!") do <<w := car v . w; v := cdr v>>;
      return intern compress reversip w
   end;

symbolic procedure mkfil u;
   % Converts file descriptor U into valid system filename.
   if stringp u then u
    else if not idp u then typerr(u,"file name")
    else string!-downcase u;


Comment The following functions are only referenced if various flags are
set, or the functions are actually defined. They are defined in another
module, which is not needed to build the basic system. The name of the
flag follows the function name, enclosed in parentheses:

        CEDIT (?)
        COMPD (COMP)
        EDIT1   This function provides a link to an editor. However, a
                definition is not necessary, since REDUCE checks to see
                if it has a function value.
        EMBFN (?)
        EZGCDF (EZGCD)
        PRETTYPRINT (DEFN --- also called by DFPRINT)
                This function is used in particular for output of RLISP
                expressions in LISP syntax. If that feature is needed,
                and the prettyprint module is not available, then it
                should be defined as PRINT
        RPRINT (PRET)
        TIME (TIME) returns elapsed time from some arbitrary initial
                    point in milliseconds;



Comment The following operator is used to save a REDUCE session as a
file for later use;

symbolic procedure savesession u;
   preserve('begin);

flag('(savesession),'opfn);

flag('(savesession),'noval);


Comment make "system" available as an operator;

flag('(system),'opfn);

flag('(system),'noval);


Comment to make "faslend" an endstat;

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


Comment The current REDUCE model allows for the availability of fast
arithmetical operations on small integers (called "inums").  All modern
LISPs provide such support.  However, the program will still run without
these constructs.  The relevant functions that should be defined for
this purpose are as follows;

flag('(iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp
       idifference iquotient iremainder ilessp igreaterp ileq igeq
       izerop ionep), 'lose);

Comment There are also a number of system constants required for each
implementation. In systems that don't support inums, the equivalent
single precision integers should be used;

% LARGEST!-SMALL!-MODULUS is the largest power of two that can
% fit in the fast arithmetic (inum) range of the implementation.
% This is constant for the life of the system and could be
% compiled in-line if the compiler permits it.

largest!-small!-modulus := 2**24 - 1; % I could use up to 2^27-1, but
         % stick to 2^24-1 since that's what Cambridge Lisp used to use.

flag('(modular!-difference modular!-minus modular!-number
       modular!-plus modular!-quotient modular!-reciprocal
       modular!-times modular!-expt set!-small!-modulus), 'lose);

% See comments about gensym() below - which apply also to the
% effects of having different random number generators in different
% host Lisp systems.
% From 3.5 onwards (with a new random generator built into the
% REDUCE sources) I am happy to use the portable version.

% flag('(random next!-random!-number), 'lose);

set!-small!-modulus 3;

% The following are now built into CSL, where by using the C library
% and (hence?) maybe low level tricks or special floating point
% microcode things can go fast.

flag('(acos acosd acosh acot acotd acoth acsc acscd acsch asec asecd
       asech asin asind asinh atan atand atan2 atan2d atanh cbrt cos
       cosd cosh cot cotd coth csc cscd csch exp expt hypot ln log
       logb log10 sec secd sech sin sind sinh sqrt tan tand tanh fix
       ceiling floor round clrhash puthash gethash remhash), 'lose);

symbolic procedure int!-gensym1 u;
% in Codemist Lisp compress interns - hence version in int.red is bad;
   gensym1 u;



Comment We need to define a function BEGIN, which acts as the top-level
call to REDUCE, and sets the appropriate variables;

remflag('(begin),'go);

global '(patchdate!*);

symbolic procedure begin;
   begin
        scalar w;
        !*int := not batchp();
        !*echo := not !*int;
        !*extraecho := t;
        ifl!* := ipl!* := ofl!* := nil;
        if date!* then <<
           verbos nil;
% The linelength may need to be adjusted if we are running in a window.
           linelength 80;
% The next four lines have been migrated into the C code in "restart.c"
% so that some sort of information gets back to the user nice an early...
%              prin2 version!*;
%              prin2 ", ";
%              prin2 date!*;
%              prin2t " ...";
           !*mode := if getd 'addsq then 'algebraic else 'symbolic;
           %since most REDUCE users won't use LISP
           date!* := nil >>;
        % crchar!* := '! ;
% If there is a patches module that is later than one that I currently have
% installed then load it up now.
        w := modulep 'patches;
        if w and (null patchdate!* or datelessp(patchdate!*, w)) then begin
            scalar !*redefmsg;   % Avoid silly messages
            load!-module 'patches;
            patchdate!* := w end;
        while errorp errorset('(begin1), !*backtrace, !*backtrace) do nil;
        prin2t "Leaving REDUCE ... "
 end;

flag('(begin),'go);

% The following function is used in some CSL-specific operations. It is
% also defined in util/rprint, but is repeated here to avoid loading
% that module unnecessarily, and because the definition given there is
% rather PSL specific.

remflag('(string!-downcase),'lose);

symbolic procedure string!-downcase u;
   compress('!" . append(explode2lc u,'(!")));

flag('(string!-downcase),'lose);

% This function is used in Rlisp '88.

symbolic procedure igetv(u,v); getv(u,v);

% The following functions are NOT in Standard Lisp and should NOT be used
% anywhere in the REDUCE sources, but the amount of trouble I have had with
% places where they do creep in has encouraged me to define them here anyway
% and put up with the (small) waste of space.

symbolic procedure first x; car x;

symbolic procedure second x; cadr x;

symbolic procedure third x; caddr x;

symbolic procedure fourth x; cadddr x;

symbolic procedure rest x; cdr x;


Comment Initial setups for REDUCE;

spare!* := 11;   % We need this for bootstrapping.

symchar!* := t;  % Changed prompt when in symbolic mode.


% PSL has gensyms with names g0001, g0002 etc., and in a few places
% REDUCE will insert gensyms into formulae in such a way that their
% names can influence the ordering of terms.  The next fragment of
% commented out code make CSL use similar names (but interned).  This
% is not sufficient to guarantee a match with PSL though, since in (for
% instance) the code
%      list(gensym(), gensym(), gensym())
% there is no guarantee which gensym will have the smallest serial
% number.  Also if !*comp is true and the user defines a procedure it is
% probable that the compiler does a number (just how many we do not
% wish to say) of calls to gensym, upsetting the serial number
% sequence.  Thus other ways of ensuring consistent output from REDUCE
% are needed.

%- global '(gensym!-counter);

%- gensym!-counter := 1;

%- symbolic procedure reduce!-gensym();
%-   begin
%-     scalar w;
%-     w := explode gensym!-counter;
%-     gensym!-counter := gensym!-counter+1;
%-     while length w < 4 do w := '!0 . w;
%-     return compress ('g . w)
%-   end;

%- remflag('(gensym), 'lose);
%- remprop('gensym, 's!:builtin0);

%- smacro procedure gensym();
%-    reduce!-gensym();

symbolic procedure initreduce;
   initrlisp();   % For compatibility.

symbolic procedure initrlisp;
  % Initial declarations for REDUCE
  <<statcounter := 0;
%-  gensym!-counter := 1;
    crbuflis!* := nil;
    spare!* := 11;
    !*int := not batchp()>>;

symbolic procedure rlispmain;
    lispeval '(begin);

flag('(rdf preserve reclaim),'opfn);

flag('(rdf preserve),'noval);

remflag('(showtime), 'lose);

symbolic procedure showtime;
   begin scalar x,y;
      x := otime!*;
      otime!* := time();
      x := otime!* - x;
      y := ogctime!*;
      ogctime!* := gctime();
      y := ogctime!* - y;
%     x := x - y;
      terpri();
      prin2 "Time: "; prin2 x; prin2 " ms";
      if y = 0 then return terpri();
      prin2 "  plus GC time: "; prin2 y; prin2 " ms"
   end;

flag('(showtime), 'lose);

flag('(load reload),'noform);

deflist('((load rlis) (reload rlis)),'stat);

symbolic macro procedure load x; PSL!-load(cdr x, nil);
symbolic macro procedure reload x; PSL!-load(cdr x, t);

global '(PSL!-loaded!*);
PSL!-loaded!* := nil;

symbolic procedure PSL!-load(mods, reloadp);
  for each x in mods do <<
    if reloadp or not member(x, PSL!-loaded!*) then <<
       load!-module x;
       PSL!-loaded!* := union(list x, PSL!-loaded!*) >> >>;

symbolic macro procedure tr x;
   list('trace, list('quote, cdr x));

symbolic macro procedure untr x;
   list('untrace, list('quote, cdr x));

symbolic macro procedure trst x;
   list('traceset, list('quote, cdr x));

symbolic macro procedure untrst x;
   list('untraceset, list('quote, cdr x));

flag('(tr untr
      trst untrst
      ),'noform);

deflist('((tr rlis)     (trst rlis)
          (untr rlis)   (untrst rlis)
         ),'stat);

symbolic procedure prop x; plist x;  % Yukky PSL compatibility.

Comment The following declarations are needed to build various modules;

flag('(mkquote spaces subla boundp error1),'lose);

% The exact order of items in the lists produced by these is important
% to REDUCE.
flag('(union intersection), 'lose);

flag('(safe!-fp!-plus safe!-fp!-times safe!-fp!-quot
       safe!-fp!-pl safe!-fp!-pl0), 'lose);

flag('(threevectorp ordp), 'lose);

deflist('((imports rlis)),'stat);

endmodule;


module csl;  % Support for fast floating point arithmetic in CSL.

imports ash, ash1, logand, msd;

exports msd!:;

fluid '(!!nbfpd);

remflag ('(fl2bf msd!: fix2 rndpwr timbf),'lose);

symbolic smacro procedure fix2 u; fix u;

symbolic smacro procedure lshift(m,d); ash(m,d);

symbolic smacro procedure ashift(m,d); ash1(m,d);

symbolic smacro procedure land(a,b); logand(a,b);

symbolic smacro procedure msd!: u; msd u;

symbolic smacro procedure make!:ibf (mt, ep);
  '!:rd!: . (mt . ep);

fluid '(!:bprec!:);

symbolic smacro procedure rndpwr j;
  begin
    scalar !#w;   % I use an odd name here to avoid clashes (smacro)
    !#w := mt!: j;
    if !#w = 0 then return make!:ibf(0, 0);
    !#w := inorm(!#w, !:bprec!:);
    return make!:ibf(car !#w, cdr !#w + ep!: j)
  end;

% This is introduced as a privately-named function and an associated
% smacro to avoid unwanted interactions between 3 versions of this
% function: the one here, the version of this code compiled into C, and
% the original version in arith.red.  Note thus that CSL_normbf is not
% flagged as 'lose here (but it will be when a version compiled into
% C exists), and the standard version of normbf will still get compiled
% in arith.red, but all references to it will get turned into calls
% to CSL_normbf.  The SMACRO does not need a 'lose flag either.

symbolic procedure CSL_normbf x;
   begin
      scalar mt,s;
      integer ep;
% Note I write out mt!: and ep!: here because the smacros for them are
% not yet available.
      if (mt := cadr x)=0 then return '(!:rd!: 0 . 0);
      if mt<0 then <<mt := -mt; s := t>>;
      ep := lsd mt;
      mt := lshift(mt, -ep);
      if s then mt := -mt;
      ep := ep + cddr x;
      return make!:ibf(mt,ep)
   end;

symbolic smacro procedure normbf x; CSL_normbf x;

symbolic procedure CSL_timbf(u, v);
  begin
     scalar m;
     m := mt!: u * mt!: v;
     if m = 0 then return '(!:rd!: 0 . 0);
     m := inorm(m, !:bprec!:);
     return make!:ibf(car m, cdr m + ep!: u + ep!: v)
  end;

symbolic smacro procedure timbf(u, v); CSL_timbf(u, v);

symbolic procedure fl2bf x;
  begin scalar u;
    u := frexp x;
    x := cdr u; % mantissa between 0.5 and 1
    u := car u; % exponent
    x := fix(x*2**!!nbfpd);
    return normbf make!:ibf(x,u-!!nbfpd)
  end;

flag ('(fl2bf msd!: fix2 rndpwr timbf), 'lose);

set!-print!-precision 14;

% The following definition is appropriate for MSDOS, and the value of
% !!maxbflexp should be OK for all IEEE systems. BEWARE if you have a
% computer with non-IEEE arithmetic, and worry a bit about !!flexperr
% (which is hardly ever used anyway...).
% I put this here to avoid having arith.red do a loop that is terminated
% by a floating point exception, since as of Nov 1994 CSL built using
% Watcom C 10.0a can not recover from such errors more than (about) ten times
% in any one run - this avoids that during system building.

global '(!!flexperr !!!~xx !!maxbflexp);

remflag('(find!!maxbflexp), 'lose);

symbolic procedure find!!maxbflexp();
  << !!flexperr := t;
     !!!~xx := expt(2.0, 1023);
     !!maxbflexp := 1022 >>;

flag('(find!!maxbflexp), 'lose);

remflag('(copyd), 'lose);

symbolic procedure copyd(new,old);
% Copy the function definition from old id to new.
   begin scalar x;
      x := getd old;
% If loading with !*savedef = '!*savedef then the actual definitions
% do not get loaded, but the source forms do...
      if null x then <<
        if not (!*savedef = '!*savedef)
          then rerror('rlisp,1,list(old,"has no definition in copyd")) >>
      else << putd(new,car x,cdr x);
              if flagp(old, 'lose) then flag(list new, 'lose) >>;
% The transfer of the saved definition is needed if the REDUCE "patch"
% mechanism is to work fully properly.
      if (x := get(old, '!*savedef)) then put(new, '!*savedef, x);
      return new
   end;

flag('(copyd), 'lose);

smacro procedure int2id x; compress list('!!, x);
smacro procedure id2int x; car explode2n x;

smacro procedure bothtimes x; eval!-when((compile load eval), x);
smacro procedure compiletime x; eval!-when((compile eval), x);
smacro procedure loadtime x; eval!-when((load eval), x);

smacro procedure csl x; x;
smacro procedure psl x; nil;

symbolic macro procedure printf u;
  list('printf1, cadr u, 'list . cddr u);

symbolic procedure printf1(fmt, args);
% this is the inner works of print formatting.
% the special sequences that can occur in format strings are
%       %b    do that many spaces
%       %c    next arg is a numeric character code. display character
% *     %f    do a terpri() unless posn()=0
%       %l    prin2 items from given list, blank separated
% *     %n    do a terpri()
%       %o    print in octal
%       %p    print using prin1
%       %t    do a ttab to move to given column
%       %w    use prin2
%       %x    print in hexadecimal
% *     %%    print a '%' character (items marked * do not use an arg).
  begin
    scalar a, c;
    fmt := explode2 fmt;
    while fmt do <<
      c := car fmt;
      fmt := cdr fmt;
      if c = '!% then <<
         c := car fmt;
         fmt := cdr fmt;
         if c = '!f then << if not zerop posn() then terpri() >>
         else if c = '!n then terpri()
         else if c = '!% then prin2 c
         else <<
            a := car args;
            args := cdr args;
            if c = '!b then spaces a
            else if c = '!c then tyo a
            else if c = '!l then <<
               if not atom a then <<
                  prin2 car a;
                  for each w in cdr a do << prin2 " "; prin2 w >> >> >>
            else if c = '!o then prinoctal a
            else if c = '!p then prin1 a
            else if c = '!t then ttab a
            else if c = '!w then prin2 a
            else if c = '!x then prinhex a
            else rerror('cslrend,1,list(c,"bad format character")) >> >>
      else prin2 c >>
  end;

symbolic macro procedure bldmsg u;
  list('bldmsg1, cadr u, 'list . cddr u);

symbolic procedure bldstring r;
  begin
    scalar w;
    w := '(!");
    while r do <<
       w := car r . w;
       if car r eq '!" then w := '!" . w;
       r := cdr r >>;
    return compress ('!" . w)
  end;

symbolic procedure bldcolumn(s, n);
  if null s or eqcar(s, !$eol!$) then n
  else bldcolumn(cdr s, n+1);

symbolic procedure bldmsg1(fmt, args);
  begin
    scalar a, c, r;
    fmt := explode2 fmt;
    while fmt do <<
      c := car fmt;
      fmt := cdr fmt;
      if c = '!% then <<
         c := car fmt;
         fmt := cdr fmt;
         if c = '!f then <<
             if not zerop bldcolumn(r, 0) then r := !$eol!$ . r >>
         else if c = '!n then r := !$eol!$ . r
         else if c = '!% then r := c . r
         else <<
            a := car args;
            args := cdr args;
            if c = '!b then for i := 1:a do r := '!  . r
            else if c = '!c then r := a . r
            else if c = '!l then <<
               if not atom a then <<
                  r := append(reverse explode2 car a, r);
                  for each w in cdr a do <<
                     r := '!  . r;
                     r := append(reverse explode2 w, r) >> >> >>
            else if c = '!o then r := append(reverse explodeoctal a, r)
            else if c = '!p then r := append(reverse explode a, r)
            else if c = '!t then while bldcolumn(r, 0)<a do r := '!  . r
            else if c = '!w then r := append(reverse explode2 a, r)
            else if c = '!x then r := append(reverse explodehex a, r)
            else rerror('cslrend,1,list(c,"bad format character")) >> >>
      else r := c . r >>;
    return bldstring r
  end;

endmodule;

end;