File r34.3/src/clrend.red artifact c346a3165a part of check-in 5f584e9b52


module rend; % CL REDUCE "back-end".

% Copyright (c) 1991 RAND.  All Rights Reserved.

symbolic procedure delcp u;
   % Returns true if U is a semicolon, dollar sign, or other delimiter.
   % This definition replaces one in the BOOT file.
   u eq '!; or u eq '!$;

symbolic procedure seprp u;
   % Returns true if U is a blank or other separator (eg, tab or ff).
   % This definition replaces one in the BOOT file.
     u eq '!  or u eq '!         or u eq !$eol!$;

% Common LISP specific definitions.

flag('(load),'opfn);

% The next one is added since it is a familiar name for this
% operation.

symbolic procedure prop u; symbol!-plist u;
  

% tr and untr are defined in clend.lisp.

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


% The FACTOR module also requires a definition for GCTIME. Since this
% is currently undefined in CL, we provide the following definition.

symbolic procedure gctime; 0;

% yesp1 is more or less equivalent to y-or-n-p.

remflag('(yesp1),'lose);

symbolic procedure yesp1; y!-or!-n!-p();

flag('(yesp1),'lose);

% The Common Lisp TOKEN function returns tokens rather than characters,
% so CEDIT must be modified.

remflag('(cedit),'lose);

symbolic procedure cedit n;
   begin scalar x,ochan;
      if null terminalp() then rederr "Edit must be from a terminal";
      ochan := wrs nil;
      if n eq 'fn then x := reversip crbuf!*
       else if null n
        then if null crbuflis!*
               then <<statcounter := statcounter-1;
                      rederr "No previous entry">>
              else x := cdar crbuflis!*
       else if (x := assoc(car n,crbuflis!*))
        then x := cedit0(cdr x,car n)
       else <<statcounter := statcounter-1;
              rederr list("Entry",car n,"not found")>>;
      crbuf!* := nil;
      % Following line changed for CL version.
      x := foreach y in x conc explodec y;
      terpri();
      editp x;
      terpri();
      x := cedit1 x;
      wrs ochan;
      if x eq 'failed then nil
      % Following changed for CL version.
      else 
        crbuf1!* := compress(append('(!") ,
                                       append(x, '(!" ))));
   end;

flag('(cedit),'lose);

% FLOOR is already defined.

flag('(floor),'lose);

% CL doesn't like '(function ...) in defautoload (module entry).

remflag('(mkfunction),'lose);

smacro procedure mkfunction u; mkquote u;

flag('(mkfunction),'lose);

remflag('(not_imag_num),'lose);

fluid '(!*keepsqrts !*msg !*numval dmode!*);

symbolic procedure not_imag_num a;
 % Tests true if a is a number that is not a pure imaginary number.
   begin scalar v,!*keepsqrts,!*msg,!*numval,dmode, sqrtfn;
      dmode := dmode!*;
      !*numval := t;
      sqrtfn := get('sqrt, 'simpfn);
      put('sqrt, 'simpfn, 'simpsqrt);
      on rounded,complex;
      a := resimp simp a;
      a := numberp cdr a and domainp car a and car repartsq a;
      off rounded,complex;
      if dmode then onoff(get(dmode,'dname),t);
      put('sqrt, 'simpfn, sqrtfn);
      return a
   end;


flag('(not_imag_num),'lose);

% The following redefines a function in the roots package.

remflag('(nrstrt0),'lose);

fluid '(!*bftag !*gfp !*hardtst !*xn !*xobf !*xo acc!# prec!# !:prec!:);

global '(!!nfpd);

symbolic procedure nrstrt0(q,r,p1);
   begin scalar rr,x,b,pr,ps,p2,qf; pmsg pbfprint q; b := !*bftag;
      ps := !:prec!:; pr := if b then ps else !!nfpd;
      p2 := gfzerop(rr := a2gf r); !*gfp := qf := q;
      if b then go to r2;
      if errorp(q := errorset!*(list('cflotem,mkquote qf),nil))
        or errorp(r := errorset!*(list('gf2fl,mkquote rr),nil))
         then go to r1 else <<q := car q; r := car r>>;
      if (x := gfrootset(q,r,b)) then
         <<q := qf; !*xn := gf2bf !*xn;
           !*xobf := !*xo := gf2bf !*xo; go to r3>>;
  r1: q := qf; b := !*bftag := t; r := gf2bf rr;
  r2: x := gfrootfind(q,r); !*xobf := !*xo := gf2bf !*xo;
  r3: if not !*hardtst then x := ckacc(q,if p1 then p1 else q,!*xn);
      x := accuroot(
      if bfzp gfim r then (car !*xn) . bfabs cdr !*xn else !*xn,q,!*xo);
      if prec!#<pr+2 then
         <<setflbf b; !:prec!: := ps; return acc!# . x>>;
      pr := !:prec!: := prec!#;
      if not !*bftag then b := !*bftag := t;
      if p2 then go to r2 else <<p2 := t; go to r1>> end;

flag('(nrstrt0),'lose);

% Needed by library packages.

symbolic procedure ncons u; u . nil;

remflag('(boundssincos),'lose);

symbolic procedure boundssincos u;
   % Reason if one of the turn points (n*pi) is in the
   % range. If yes, include the corresponding value 1 or -1.
   % Otherwise compute the range spanned by the end points.
  begin scalar n,lo,hi,alo,ahi,!1pi,!2pi,!3pi,l,m;
        integer s;
     n := errorset(list('boundseval2,mkquote cadr u),nil,nil);
     if atom n then goto trivial;
     n := car n;
     lo := car n; hi := cdr n; 
     !1pi := simp 'pi;
     if not domainp car !1pi then goto trivial;
     !2pi := addsq(!1pi,!1pi); !3pi := addsq(!1pi,!2pi);
       % convert sin to cos
     if car u = 'sin then <<m :=multsq(!1pi, (-1) . 2);
         lo := addsq(lo,m); hi := addsq(hi,m)>>; 
     m := negsq multsq(!2pi,fixsq quotsq(lo,!2pi));
       % move interval to main interval
     lo:=addsq(lo,m); hi:=addsq(hi,m);
     if minusf car lo then
     <<lo := addsq(lo,!2pi); hi := addsq(hi,!2pi)>>;
     if null car lo or sqgreaterp(hi,!2pi) then l:= (1 . 1) . l;
     if (sqgreaterp(!1pi,lo) and  sqgreaterp(hi,!1pi))
      or(sqgreaterp(!3pi,lo) and  sqgreaterp(hi,!3pi))
       then l := ((-1) . 1) . l;
     if l and cdr l then goto trivial;
     l := num!-cossq lo . num!-cossq hi . l;
     return minsq l . maxsq l;
 trivial:
     return ((-1) . 1) . (1 . 1);
  end;

flag('(boundssincos),'lose);

endmodule;

end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]