Artifact c346a3165abc4856027576fe86a38916aeaec0670b024f7067c35b1fb5342a95:
- File
r34.3/src/clrend.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5697) [annotate] [blame] [check-ins using] [more...]
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;