Menu
▾
▴
[Maxima-commits] CVS: maxima/src suprv1.lisp, 1.74, 1.75 nrat4.lisp, 1.17, 1.18 numth.lisp, 1.14, 1.15 outmis.lisp, 1.18, 1.19 polyrz.lisp, 1.12, 1.13 rat3d.lisp, 1.15, 1.16 ratout.lisp, 1.14, 1.15
|
From: Andreas E. <ar...@us...> - 2009-02-07 14:41:08
|
Update of /cvsroot/maxima/maxima/src In directory 23jxhf1.ch3.sourceforge.com:/tmp/cvs-serv9387 Modified Files: suprv1.lisp nrat4.lisp numth.lisp outmis.lisp polyrz.lisp rat3d.lisp ratout.lisp Log Message: changed lambda bindings to let bindings for clarity and readability Index: suprv1.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/suprv1.lisp,v retrieving revision 1.74 retrieving revision 1.75 diff -u -d -r1.74 -r1.75 --- suprv1.lisp 1 Feb 2009 18:22:52 -0000 1.74 +++ suprv1.lisp 7 Feb 2009 14:40:56 -0000 1.75 @@ -499,65 +499,65 @@ (nth 2 r))) (defmfun errbreak (y) ; The ERRSET interrupt function - (cond - (*mdebug* - ((lambda (brklvl varlist genvar errbrkl linelable) - (declare (special $help)) - (prog (x ^q #.ttyoff o^r tim $%% $backtrace retval oldst) - (setq errset 'errbreak1) - (setq tim (get-internal-run-time) - $%% '$%% - ;; just in case baktrcl is cons'd on the stack - $backtrace (cons '(mlist simp) (copy-list baktrcl))) - (setq o^r #.writefilep #.writefilep (and #.writefilep (not dskfnp))) - (cond ((eq y 'noprint)) - (t - (mterpri) - (if y (princ 'macsyma-break) (princ 'error-break)) - (unless (zerop brklvl) (princ " level ") (princ brklvl)) - (princ " Type exit; to quit, help; for more help."))) - (setq $help - "BACKTRACE; will give a successive list of forms + (cond (*mdebug* + (let ((brklvl (1+ brklvl)) + (varlist varlist) + (genvar genvar) + (errbrkl (cons bindlist loclist)) + (linelable linelable)) + (declare (special $help)) + (prog (x ^q #.ttyoff o^r tim $%% $backtrace retval oldst) + (setq errset 'errbreak1) + (setq tim (get-internal-run-time) + $%% '$%% + ;; just in case baktrcl is cons'd on the stack + $backtrace (cons '(mlist simp) (copy-list baktrcl))) + (setq o^r #.writefilep #.writefilep (and #.writefilep (not dskfnp))) + (cond ((eq y 'noprint)) + (t + (mterpri) + (if y (princ 'macsyma-break) (princ 'error-break)) + (unless (zerop brklvl) (princ " level ") (princ brklvl)) + (princ " Type exit; to quit, help; for more help."))) + (setq $help + "BACKTRACE; will give a successive list of forms (you must have already set ?DEBUG:ALL; for BACKTRACE to record) LISP; goes to lisp TOPLEVEL; goes all the way to top level EXIT; exits one level of the error break") - (mterpri) - a (cond - ((null - (catch 'macsyma-break - (let ((state-pdl (cons 'macsyma-break state-pdl))) - (errset - (cond ((eq (setq x - (retrieve1 nil - (if y "_ " "(debug) " - ))) '$exit) - (timeorg tim) - (setq retval 'exit) (go end)) - ((eq x '$lisp) - (setq retval 'lisp) - (go end)) - ((eq x '$toplevel) - (cond ((catch 'mbreak - (let (st oldst rephrase - (mbreak (cons bindlist loclist))) - (incf $linenum) - (continue))) + (mterpri) + a (cond ((null + (catch 'macsyma-break + (let ((state-pdl (cons 'macsyma-break state-pdl))) + (errset + (cond ((eq (setq x + (retrieve1 nil + (if y "_ " "(debug) " + ))) '$exit) + (timeorg tim) + (setq retval 'exit) (go end)) + ((eq x '$lisp) + (setq retval 'lisp) (go end)) - (t (mtell-open "Back to the break~%")))) - (t (let (($dispflag dispflag)) (setq $%% (meval x))) - (if dispflag (displa $%%) (mterpri)))))))) - (errlfun1 errbrkl) - (mtell-open "~%(Still in break loop)~%"))) - (go a) - end (unless (eq y 'noprint) - (princ "Exited from the break ") - (if (not (zerop brklvl)) (princ brklvl)) - (mterpri) - ) - (if o^r (setq #.writefilep t)) - (return retval))) - (1+ brklvl) varlist genvar (cons bindlist loclist) linelable)))) + ((eq x '$toplevel) + (cond ((catch 'mbreak + (let (st oldst rephrase + (mbreak (cons bindlist loclist))) + (incf $linenum) + (continue))) + (go end)) + (t (mtell-open "Back to the break~%")))) + (t (let (($dispflag dispflag)) (setq $%% (meval x))) + (if dispflag (displa $%%) (mterpri)))))))) + (errlfun1 errbrkl) + (mtell-open "~%(Still in break loop)~%"))) + (go a) + end (unless (eq y 'noprint) + (princ "Exited from the break ") + (unless (zerop brklvl) (princ brklvl)) + (mterpri)) + (if o^r (setq #.writefilep t)) + (return retval)))))) (defun errbreak1 (ign) (declare (ignore ign)) @@ -669,27 +669,28 @@ (do ((i numbp (1- i)) (l2)) ((zerop i) (setq l1 (nconc l1 l2))) (setq l2 (cons (car l) l2) l (cdr l))) loop (if (null l1) (return '$done)) - ((lambda (errset incharp) - (errset - (cond ((and (not nostringp) incharp) - (let ((linelable (car l1))) (mterpri) (printlabel)) - (if grindp - (mgrind (meval1 (car l1)) nil) - (mapc #'(lambda (x) (write-char x)) (mstring (meval1 (car l1))))) ;gcl doesn't like a + (let ((errset 'errbreak2) + (incharp (char= (getlabcharn (car l1)) inchar))) + (errset + (cond ((and (not nostringp) incharp) + (let ((linelable (car l1))) (mterpri) (printlabel)) + (if grindp + (mgrind (meval1 (car l1)) nil) + (mapc #'(lambda (x) (write-char x)) (mstring (meval1 (car l1))))) ;gcl doesn't like a ; simple write-char, therefore wrapped it up in a lambda - are_muc - (if (get (car l1) 'nodisp) (princ "$") (princ ";")) - (mterpri)) - ((or incharp - (prog2 (when (and timep (setq l (get (car l1) 'time))) - (setq x (gctimep timep (cdr l))) - (mtell-open "~A sec." (car l)) - (if x (mtell-open " GCtime= ~A sec." (cdr l))) - (mterpri)) - (not (or inputp (get (car l1) 'nodisp))))) - (mterpri) (displa (list '(mlable) (car l1) (meval1 (car l1))))) - (t (go a))))) - 'errbreak2 (char= (getlabcharn (car l1)) inchar)) - (if (and slowp (cdr l1) (not (continuep))) (return '$terminated)) + (if (get (car l1) 'nodisp) (princ "$") (princ ";")) + (mterpri)) + ((or incharp + (prog2 (when (and timep (setq l (get (car l1) 'time))) + (setq x (gctimep timep (cdr l))) + (mtell-open "~A sec." (car l)) + (if x (mtell-open " GCtime= ~A sec." (cdr l))) + (mterpri)) + (not (or inputp (get (car l1) 'nodisp))))) + (mterpri) (displa (list '(mlable) (car l1) (meval1 (car l1))))) + (t (go a))))) + (when (and slowp (cdr l1) (not (continuep))) + (return '$terminated)) a (setq l1 (cdr l1)) (go loop)))) @@ -1041,15 +1042,12 @@ (setq *features* (delete ($mkey item) *features*)) t) (t (error "know only how to set and remove feature status")))) -(do ((l '($sqrt $sin $cos $tan $log $plog $sec $csc $cot $sinh $cosh - $tanh $sech $csch $coth $asin $acos $atan $acot $acsc $asec $asinh - $acosh $atanh $acsch $asech $acoth $binomial $gamma $genfact $del) - (cdr l))) - ((null l)) - ((lambda (x) - (putprop (car l) x 'alias) - (putprop x (car l) 'reversealias)) - ($nounify (car l)))) +(dolist (l '($sqrt $sin $cos $tan $log $plog $sec $csc $cot $sinh $cosh + $tanh $sech $csch $coth $asin $acos $atan $acot $acsc $asec $asinh + $acosh $atanh $acsch $asech $acoth $binomial $gamma $genfact $del)) + (let ((x ($nounify l))) + (putprop l x 'alias) + (putprop x l 'reversealias))) ($nounify '$sum) ($nounify '$product) Index: nrat4.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/nrat4.lisp,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- nrat4.lisp 2 Jun 2008 02:23:09 -0000 1.17 +++ nrat4.lisp 7 Feb 2009 14:40:56 -0000 1.18 @@ -12,7 +12,7 @@ (macsyma-module nrat4) -(declare-top (special $ratsimpexpons *exp *exp2 *radsubst *loglist $radsubstflag +(declare-top (special $ratsimpexpons *exp *exp2 *radsubst *loglist $radsubstflag $radexpand $logsimp *v *var fr-factor radcanp ratsubvl)) (load-macsyma-macros rzmac ratmac) @@ -111,7 +111,7 @@ (setq *radsubst nil ratsubvl t) ;SUBST ON VARLIST -(defmfun $ratsubst (a b c) ;NEEDS CODE FOR FAC. FORM +(defmfun $ratsubst (a b c) ;NEEDS CODE FOR FAC. FORM (prog (varlist newvarlist dontdisrepit $ratfac genvar) ;;hard to maintain user ordering info. (if ($ratp c) (setq dontdisrepit t)) @@ -226,7 +226,7 @@ ((pcoefp b) (list (setq maxpow (do ((b b (quotient b a)) - (ans 0 (f1+ ans))) + (ans 0 (1+ ans))) ((or (> (abs a) (abs b)) (eqn maxpow ans)) ans))) @@ -241,26 +241,29 @@ (t (everysubst1 a b maxpow)))) (defun everypterms (x p n maxpow) - (if (< (cadr x) n) (list 0 x) + (if (< (cadr x) n) + (list 0 x) (prog (k ans q part) (setq k (car x)) (setq x (cdr x)) l (setq q (min maxpow (quotient (car x) n))) - m (cond ((eqn q 0) - (return (cond ((null x) ans) - (t (cons 0 - (cons (psimp k x) ans))))))) + m (when (eqn q 0) + (return (if (null x) + ans + (cons 0 (cons (psimp k x) ans))))) (setq part (everysubst p (cadr x) q)) (setq ans (nconc (everypterms1 part k n (car x)) ans)) (setq x (cddr x)) - (cond ((null x) (setq q 0) (go m))) + (when (null x) + (setq q 0) + (go m)) (go l)))) (defun everypterms1 (l k n j) (do ((ptr l (cddr ptr))) ((null ptr) l) (setf (cadr ptr) - (ptimes (psimp k (list (- j (f* n (car ptr))) 1)) + (ptimes (psimp k (list (- j (* n (car ptr))) 1)) (cadr ptr))))) (defun substforsum (a b maxpow) @@ -307,7 +310,7 @@ (null (cdddr x)) (pureprod (caddr x))))) -(defmfun $bothcoef (r var) +(defmfun $bothcoef (r var) (prog (*var h varlist genvar $ratfac) (unless ($ratp r) (return `((mlist) @@ -326,10 +329,10 @@ (rdis* (ratreduce (car var) (cdr r))) (rdis* (ratreduce (cdr var) (cdr r)))))) (t (merror "Bad arguments to `bothcoeff'"))))) - + ;;COEFF OF A IN B -(defun bothprodcoef (a b) +(defun bothprodcoef (a b) (let ((c (prodcoef a b))) (if (pzerop c) (cons (pzero) b) (cons c (pdifference b (ptimes c a)))))) @@ -337,7 +340,7 @@ (defmfun argsfreeof (var e) (let ((argsfreeofp t)) (freeof var e))) - + ;;; This is a version of freeof for a list first argument (defmfun $lfreeof (l e) "`freeof' for a list first argument" (unless ($listp l) (merror "First argument must be a list")) @@ -346,20 +349,20 @@ (unless (freeof ($totaldisrep var) exp) (return nil))))) (defmfun $freeof (&rest args) - (prog (l e) + (prog (l e) (setq l (mapcar #'$totaldisrep (nreverse args)) e (car l)) loop (or (setq l (cdr l)) (return t)) (if (freeof (getopr (car l)) e) (go loop)) (return nil))) -(defun freeof (var e) +(defun freeof (var e) (cond ((alike1 var e) nil) ((atom e) t) ((and (not argsfreeofp) - (or - (alike1 var ($verbify (caar e))) - (alike1 var ($nounify (caar e))))) + (or + (alike1 var ($verbify (caar e))) + (alike1 var ($nounify (caar e))))) nil) ((and (or (member (caar e) '(%product %sum %laplace) :test #'eq) (and (eq (caar e) '%integrate) (cdddr e)) @@ -406,7 +409,7 @@ (fr1 (rdis *exp) nil))))) (defun spc0 () - (prog (*v *loglist) + (prog (*v *loglist) (if (allatoms varlist) (return nil)) (setq varlist (mapcar #'spc1 varlist)) ;make list of logs (setq *loglist (factorlogs *loglist)) @@ -421,7 +424,7 @@ (defun allatoms (l) (loop for x in l always (atom x))) -(defun rjfsimp (x &aux expon) +(defun rjfsimp (x &aux expon) (cond ((and *radsubst $radsubstflag) x) ((not (m$exp? (setq x (let ($logsimp) (resimplify x))))) x) ((mlogp (setq expon (caddr x))) (cadr expon)) @@ -438,7 +441,7 @@ nil)))) (rischflag (return x))))))) -(defun dsubsta (x y zl) +(defun dsubsta (x y zl) (cond ((null zl) zl) (t (cond ((alike1 y (car zl)) (rplaca zl x)) ((not (atom (car zl))) (dsubsta x y (cdar zl)))) @@ -469,28 +472,25 @@ (dsubsta (cdr p) (car p) varlist)) (defun spc2a (x) ;CONVERTS FACTORED - ((lambda (sum) ;RFORM LOGAND TO SUM - (if (cdr sum) (cons '(mplus) sum) ;OF LOGS - (car sum))) - (mapcar #'spc2b x))) - + (let ((sum (mapcar #'spc2b x))) ;RFORM LOGAND TO SUM + (if (cdr sum) ;OF LOGS + (cons '(mplus) sum) + (car sum)))) + (defun spc2b (x) (let ((log `((%log simp ratsimp irreducible) ,(pdis (car x))))) (if (equal 1 (cdr x)) log (list '(mtimes) (cdr x) log)))) - -(defun spc3 (x v &aux y) - (when - (and (m$exp? x) - (not (atom (setq y (caddr x)))) - (mplusp (setq y (expand1 (if *var ($partfrac y *var) y) - 10 10)))) - (setq y (cons '(mtimes) (mapcar #'(lambda (z) ($ratsimp ($exp z))) - (cdr y)))) + +(defun spc3 (x v &aux y) + (when (and (m$exp? x) + (not (atom (setq y (caddr x)))) + (mplusp (setq y (expand1 (if *var ($partfrac y *var) y) 10 10)))) + (setq y (cons '(mtimes) (mapcar #'(lambda (z) ($ratsimp ($exp z))) (cdr y)))) (radsubst (rform y) (rget v)) (dsubsta y x varlist))) -(defun spc4 (x) +(defun spc4 (x) (if (and (m$exp? x) (not (memalike (caddr x) *v))) (push (caddr x) *v))) @@ -505,7 +505,7 @@ ;;(GCMnpair occurrencepairn1 occurrencepairn2 ...)) ;;where GCMpairs are lists of ratforms and prefix forms for the greatest common ;;multiple of the occurrencepairs. Each of these pairs is a list of a ratform -;;and a prefix form. The prefix form is a pointer into the varlist. +;;and a prefix form. The prefix form is a pointer into the varlist. ;;The occurrences are exponents of the base %E. (defun spc5 (vl oldvarlist oldgenvar &aux gcdlist varlist genvar) @@ -522,17 +522,17 @@ (rplaca g ($exp (div rd (cadr g)))))) (spc5b gcdlist oldvarlist oldgenvar)) -;;(DEFUN SPC5B (V VARLIST GENVAR) +;;(DEFUN SPC5B (V VARLIST GENVAR) ;; (DOLIST (L V) ;; (DOLIST (X (CDDR L)) ;; (UNLESS (EQUAL (CADR L) (CADR X)) ;; (RADSUBST (RATEXPT (RFORM (CAR L)) ;; (CAR (QUOTIENT (CADR X) (CADR L)))) ;; (RFORM (CAR X)))))) -;; (CONS VARLIST GENVAR)) +;; (CONS VARLIST GENVAR)) - -(defun spc5b (v varlist genvar) + +(defun spc5b (v varlist genvar) (dolist (l v) (dolist (x (cddr l)) (unless (equal (cadr l) (cadr x)) Index: numth.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/numth.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- numth.lisp 25 Dec 2008 17:24:13 -0000 1.14 +++ numth.lisp 7 Feb 2009 14:40:56 -0000 1.15 @@ -23,7 +23,7 @@ ;;; Sum of divisors and Totient functions (defmfun $divsum (n &optional (k 1)) - (let (($intfaclim nil)) + (let (($intfaclim nil)) (if (and (integerp k) (integerp n)) (let ((n (abs n))) (cond ((= n 1) 1) @@ -79,11 +79,10 @@ (abs (cexpt i (ash (1- modulus) -2) ))) (defun psumsq (p) - ((lambda (x) - (cond ((equal p 2) (list 1 1)) - ((null x) nil) - (t (psumsq1 p x)))) - (imodp p))) + (let ((x (imodp p))) + (cond ((equal p 2) (list 1 1)) + ((null x) nil) + (t (psumsq1 p x))))) (defun psumsq1 (p x) (do ((sp ($isqrt p)) @@ -120,8 +119,8 @@ (if (equal rp 0) ip (list '(mplus) rp ip)))))) - -(defun gcfactor (a b &aux tem) + +(defun gcfactor (a b &aux tem) (prog (gl cd dc econt p e1 e2 ans plis nl $intfaclim ) (setq e1 0 e2 0 @@ -169,12 +168,12 @@ (and (not (zerop e2)) (setq ans (cons (reverse cd) (cons e2 ans))) (setq e2 0)) - (go loop) + (go loop) ret (setq cd (gcexpt (list 0 -1) (rem econt 4))) (setq a (gctimes a b (car cd) (cadr cd))) ;;a hasn't been divided by p yet.. - (setq a (mapcar 'signum a)) + (setq a (mapcar 'signum a)) #+cl (assert (or (zerop (car a))(zerop (second a)))) (cond ((or (equal (car a) -1) (equal (cadr a) -1)) (setq plis (cons -1 (cons 1 plis))))) Index: outmis.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/outmis.lisp,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- outmis.lisp 7 Dec 2007 14:53:13 -0000 1.18 +++ outmis.lisp 7 Feb 2009 14:40:56 -0000 1.19 @@ -19,15 +19,15 @@ (macsyma-module outmis) -(declare-top (special *xvar $exptisolate $labels $dispflag errorsw)) +(declare-top (special *xvar $exptisolate $labels $dispflag errorsw)) (defmvar $exptisolate nil) (defmvar $isolate_wrt_times nil) (defmfun $isolate (e *xvar) - (setq *xvar (getopr *xvar)) (iso1 e)) + (setq *xvar (getopr *xvar)) (iso1 e)) -(defun iso1 (e) +(defun iso1 (e) (cond ((specrepp e) (iso1 (specdisrep e))) ((and (free e 'mplus) (or (null $isolate_wrt_times) (free e 'mtimes))) e) ((freeof *xvar e) (mgen2 e)) @@ -48,8 +48,8 @@ (t u)))))) (t (cons (car e) (mapcar #'iso1 (cdr e)))))) -(defun iso2 (e) - (prog (hasit doesnt op) +(defun iso2 (e) + (prog (hasit doesnt op) (setq op (ncons (caar e))) (do ((i (cdr e) (cdr i))) ((null i)) (cond ((freeof *xvar (car i)) (setq doesnt (cons (car i) doesnt))) @@ -62,20 +62,20 @@ (free doesnt 'mtimes))))) (t (setq doesnt (mgen2 doesnt)))) (setq doesnt (ncons doesnt)) - ret (return (simplifya (cons op (nconc hasit doesnt)) nil)))) + ret (return (simplifya (cons op (nconc hasit doesnt)) nil)))) (defun mgen2 (h) (cond ((memsimilarl h (cdr $labels) (getlabcharn $linechar))) - (t (setq h (displine h)) (and $dispflag (mterpri)) h))) + (t (setq h (displine h)) (and $dispflag (mterpri)) h))) -(defun memsimilarl (item list linechar) +(defun memsimilarl (item list linechar) (cond ((null list) nil) ((and (char= (getlabcharn (car list)) linechar) (boundp (car list)) (memsimilar item (car list) (symbol-value (car list))))) - (t (memsimilarl item (cdr list) linechar)))) + (t (memsimilarl item (cdr list) linechar)))) -(defun memsimilar (item1 item2 item2ev) +(defun memsimilar (item1 item2 item2ev) (cond ((equal item2ev 0) nil) ((alike1 item1 item2ev) item2) (t (let ((errorsw t) r) @@ -89,17 +89,17 @@ ((or (atom x) (and (eq (caar x) 'mminus) (atom (cadr x)))) x) ((= lev 0) (mgen2 x)) ((and (atom (cdr x)) (cdr x)) x) - (t (cons (car x) (mapcar #'(lambda (y) ($pickapart y (1- lev))) (cdr x)))))) + (t (cons (car x) (mapcar #'(lambda (y) ($pickapart y (1- lev))) (cdr x)))))) -(defmfun $reveal (e lev) +(defmfun $reveal (e lev) (setq e (format1 e)) (cond ((and (eq (ml-typep lev) 'fixnum) (> lev 0)) (reveal e 1 lev)) (t (merror "Second argument to reveal must be positive integer.")))) (defun simple (x) - (or (atom x) (member (caar x) '(rat bigfloat) :test #'eq))) + (or (atom x) (member (caar x) '(rat bigfloat) :test #'eq))) -(defun reveal (e nn lev) +(defun reveal (e nn lev) (cond ((simple e) e) ((= nn lev) (cond ((eq (caar e) 'mplus) (cons '(|$Sum| simp) (ncons (length (cdr e))))) @@ -117,7 +117,7 @@ (t (cons u v))))))) (declare-top (special atvars munbound $props $gradefs $features opers - $contexts $activecontexts $aliases)) + $contexts $activecontexts $aliases)) (defmspec $properties (x) (setq x (getopr (fexprcheck x))) @@ -133,22 +133,22 @@ '((mlist) $alphabetic) '((mlist))) (do ((y (symbol-plist x) (cddr y)) - (l (cons '(mlist simp) (and (boundp x) + (l (cons '(mlist simp) (and (boundp x) (if (optionp x) (ncons "system value") (ncons '$value))))) - (prop)) - ((null y) - - (if (member x (cdr $features) :test #'eq) (nconc l (ncons '$feature))) - (if (member x (cdr $contexts) :test #'eq) (nconc l (ncons '$context))) - (if (member x (cdr $activecontexts) :test #'eq) + (prop)) + ((null y) + + (if (member x (cdr $features) :test #'eq) (nconc l (ncons '$feature))) + (if (member x (cdr $contexts) :test #'eq) (nconc l (ncons '$context))) + (if (member x (cdr $activecontexts) :test #'eq) (nconc l (ncons '$activecontext))) - (cond ((null (symbol-plist x)) + (cond ((null (symbol-plist x)) (if (fboundp x) (nconc l (list "system function"))))) - - l) - - ;; TOP-LEVEL PROPERTIES + + l) + + ;; TOP-LEVEL PROPERTIES (cond ((setq prop (assoc (car y) `((bindtest . $bindtest) (sp2 . $deftaylor) (sp2subs . $deftaylor) @@ -233,46 +233,45 @@ ((eq s '$matchdeclare) (dispmatchdeclares r)) (t (merror "Unknown `property' - `printprops': ~:M" s))))) -(defun dispatvalues (l) +(defun dispatvalues (l) (do ((l l (cdr l))) ((null l)) (do ((ll (mget (car l) 'atvalues) (cdr ll))) ((null ll)) (mtell-open "~M~%" - (list '(mlable) nil + (list '(mlable) nil (list '(mequal) (atdecode (car l) (caar ll) (cadar ll)) (caddar ll)))))) '$done) ;;(declare-top (FIXNUM N)) -(defun atdecode (fun dl vl) +(defun atdecode (fun dl vl) (setq vl (copy-list vl)) (atvarschk vl) - ((lambda (eqs nvarl) - (cond ((not (member nil (mapcar #'(lambda (x) (signp e x)) dl) :test #'eq)) - (do ((vl vl (cdr vl)) (varl atvars (cdr varl))) - ((null vl)) - (and (eq (car vl) munbound) (rplaca vl (car varl)))) - (cons (list fun) vl)) - (t (setq fun (cons (list fun) - (do ((n (length vl) (1- n)) - (varl atvars (cdr varl)) - (l nil (cons (car varl) l))) - ((zerop n) (nreverse l))))) - (do ((vl vl (cdr vl)) (varl atvars (cdr varl))) - ((null vl)) - (and (not (eq (car vl) munbound)) - (setq eqs (cons (list '(mequal) (car varl) (car vl)) eqs)))) - (setq eqs (cons '(mlist) (nreverse eqs))) - (do ((varl atvars (cdr varl)) (dl dl (cdr dl))) - ((null dl) (setq nvarl (nreverse nvarl))) - (and (not (zerop (car dl))) - (setq nvarl (cons (car dl) (cons (car varl) nvarl))))) - (list '(%at) (cons '(%derivative) (cons fun nvarl)) eqs)))) - nil nil)) + (let ((eqs nil) (nvarl nil)) + (cond ((not (member nil (mapcar #'(lambda (x) (signp e x)) dl) :test #'eq)) + (do ((vl vl (cdr vl)) (varl atvars (cdr varl))) + ((null vl)) + (and (eq (car vl) munbound) (rplaca vl (car varl)))) + (cons (list fun) vl)) + (t (setq fun (cons (list fun) + (do ((n (length vl) (1- n)) + (varl atvars (cdr varl)) + (l nil (cons (car varl) l))) + ((zerop n) (nreverse l))))) + (do ((vl vl (cdr vl)) (varl atvars (cdr varl))) + ((null vl)) + (and (not (eq (car vl) munbound)) + (setq eqs (cons (list '(mequal) (car varl) (car vl)) eqs)))) + (setq eqs (cons '(mlist) (nreverse eqs))) + (do ((varl atvars (cdr varl)) (dl dl (cdr dl))) + ((null dl) (setq nvarl (nreverse nvarl))) + (and (not (zerop (car dl))) + (setq nvarl (cons (car dl) (cons (car varl) nvarl))))) + (list '(%at) (cons '(%derivative) (cons fun nvarl)) eqs))))) -(defun dispatomgrads (l) +(defun dispatomgrads (l) (do ((i l (cdr i))) ((null i)) (do ((j (mget (car i) '$atomgrad) (cdr j))) @@ -281,9 +280,9 @@ (list '(mlable) nil (list '(mequal) (list '(%derivative) (car i) (caar j) 1) (cdar j)))))) - '$done) + '$done) -(defun dispgradefs (l) +(defun dispgradefs (l) (do ((i l (cdr i))) ((null i)) (setq l (get (car i) 'grad)) @@ -294,9 +293,9 @@ (mtell-open "~M~%" (list '(mlable) nil (list '(mequal) (list '(%derivative) thing (car j) 1.) (car k)))))) - '$done) + '$done) -(defun dispmatchdeclares (l) +(defun dispmatchdeclares (l) (do ((i l (cdr i)) (ret)) ((null i) (cons '(mlist) ret)) @@ -308,7 +307,7 @@ (declare-top (special trans ovar nvar tfun invfun $programmode nfun *roots *failures varlist genvar $ratfac)) -(defmfun $changevar (expr trans nvar ovar) +(defmfun $changevar (expr trans nvar ovar) (let (invfun nfun $ratfac) (cond ((or (atom expr) (eq (caar expr) 'rat) (eq (caar expr) 'mrat)) expr) ((atom trans) (merror "2nd arg must not be atomic")) @@ -341,7 +340,7 @@ deriv) (kernsubst ($ratsimp (mul (cadr expr) deriv)) - trans ovar)))) + trans ovar)))) (cond ;; DEFINITE INTEGRAL,SUMMATION, OR PRODUCT ((cdddr expr) (or invfun (setq invfun (solvable trans nvar t))) @@ -355,7 +354,7 @@ '$minus))) (t ;INDEFINITE INTEGRAL (list '(%integrate) nfun nvar)))) - (t expr)))))) + (t expr)))))) (defun kernsubst (expr form ovar) (let (varlist genvar nvarlist) @@ -367,22 +366,22 @@ (prog2 (setq expr (ratrep* expr) varlist nvarlist) (rdis (cdr expr)))))) - -(declare-top (special $listconstvars facfun)) + +(declare-top (special $listconstvars facfun)) (defmfun $factorsum (e) - (factorsum0 e '$factor)) + (factorsum0 e '$factor)) (defmfun $gfactorsum (e) - (factorsum0 e '$gfactor)) + (factorsum0 e '$gfactor)) -(defun factorsum0 (e facfun) +(defun factorsum0 (e facfun) (cond ((mplusp (setq e (funcall facfun e))) (factorsum1 (cdr e))) - (t (factorsum2 e)))) + (t (factorsum2 e)))) -(defun factorsum1 (e) - (prog (f lv llv lex cl lt c) +(defun factorsum1 (e) + (prog (f lv llv lex cl lt c) loop (setq f (car e)) (setq lv (cdr ($showratvars f))) (cond ((null lv) (setq cl (cons f cl)) (go skip))) @@ -417,41 +416,41 @@ (rplaca q (cons (dcon f) (car q))) (return (setq f nil))))) (and f - (setq lv (cons c lv) + (setq lv (cons c lv) lt (cons (ncons (dcon f)) lt)))))) (setq lex - (mapcar #'(lambda (s q) + (mapcar #'(lambda (s q) (simptimes (list '(mtimes) s (cond ((cdr q) (cons '(mplus) q)) (t (car q)))) 1 nil)) lv lt)) - (return (simplus (cons '(mplus) (nconc cl lex llv)) 1 nil)))) + (return (simplus (cons '(mplus) (nconc cl lex llv)) 1 nil)))) -(defun dcon (mt) - (cond ((cdddr mt) (cons (car mt) (cddr mt))) (t (caddr mt)))) +(defun dcon (mt) + (cond ((cdddr mt) (cons (car mt) (cddr mt))) (t (caddr mt)))) -(defun factorsum2 (e) +(defun factorsum2 (e) (cond ((not (mtimesp e)) e) (t (cons '(mtimes) - (mapcar #'(lambda (f) + (mapcar #'(lambda (f) (cond ((mplusp f) (factorsum1 (cdr f))) (t f))) - (cdr e)))))) + (cdr e)))))) (declare-top (special $combineflag)) (defmvar $combineflag t) -(defmfun $combine (e) +(defmfun $combine (e) (cond ((or (atom e) (eq (caar e) 'rat)) e) ((eq (caar e) 'mplus) (combine (cdr e))) - (t (recur-apply #'$combine e)))) + (t (recur-apply #'$combine e)))) -(defun combine (e) - (prog (term r ld sw nnu d ln xl) +(defun combine (e) + (prog (term r ld sw nnu d ln xl) again(setq term (car e) e (cdr e)) (when (or (not (or (ratnump term) (mtimesp term) (mexptp term))) (equal (setq d ($denom term)) 1)) @@ -470,8 +469,8 @@ end (and e (go again)) (and xl (setq xl (cond ((cdr xl) ($xthru (addn xl t))) (t (car xl))))) - (mapc - #'(lambda (nu de) + (mapc + #'(lambda (nu de) (setq r (cons (mul2 (addn nu nil) (power* de -1)) r))) ln ld) (return (addn (if xl (cons xl r) r) nil)))) Index: polyrz.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/polyrz.lisp,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- polyrz.lisp 4 Sep 2007 20:45:05 -0000 1.12 +++ polyrz.lisp 7 Feb 2009 14:40:56 -0000 1.13 @@ -168,7 +168,8 @@ (defun makpoint (pt) (cond ((eq pt '$inf) 1) ((eq pt '$minf) -1) - (t (makrat ((lambda ($numer) (meval pt)) t))))) + (t (makrat (let (($numer t)) + (meval pt)))))) (defmfun $nroots (exp &optional (l '$minf) (r '$inf)) (let (varlist $keepfloat $ratfac) Index: rat3d.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/rat3d.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- rat3d.lisp 5 Apr 2008 08:36:13 -0000 1.15 +++ rat3d.lisp 7 Feb 2009 14:40:56 -0000 1.16 @@ -116,7 +116,7 @@ (not (pcoefp (setq p0 (pcsubsty l gv (pmod p))))) (pcoefp (pgcd p0 (pderivative p0 (car p0)))) (list l gv p0)))) - + (defun monom->facl (p) (cond ((pcoefp p) (if (equal p 1) nil (list p 1))) (t (list* (pget (car p)) (cadr p) (monom->facl (caddr p)))))) @@ -151,7 +151,7 @@ a (setq r (pgcdcofacts r p) p (caddr r) mult (1+ mult)) - (and algfac* (cadddr r) (setq adn* (ptimes adn* (cadddr r)))) + (and algfac* (cadddr r) (setq adn* (ptimes adn* (cadddr r)))) (cond ((not (pcoefp (cadr r))) (setq factors (cons (cadr r) @@ -330,9 +330,9 @@ minpoly*))) (mapc #'(lambda (y z) (putprop y z (quote disrep))) genvar - varlist) + varlist) (return (retfactor (cdr q) fn l)))) - + (defun factorout1 (l p) (do ((gv genvar (cdr gv)) (dl l (cdr dl)) @@ -354,23 +354,20 @@ (t (setq p (factorout p)) (cond ((equal (cadr p) 1) (car p)) ((numberp (cadr p)) (append (cfactor (cadr p)) (car p))) - (t ((lambda (cont) - (nconc - (cond ((equal (car cont) 1) nil) - (algfac* - (cond (modulus (list (car cont) 1)) - ((equal (car cont) '(1 . 1)) nil) - ((equal (cdar cont) 1) - (list (caar cont) 1)) - (t (list (caar cont) 1 (cdar cont) -1)))) - (t (cfactor (car cont)))) - (pfactor11 (psqfr (cadr cont))) - (car p))) - (cond (modulus (list (leadalgcoef (cadr p)) - (monize (cadr p)))) - (algfac* (algcontent (cadr p))) - (t (pcontent (cadr p)))))))))) - + (t (let ((cont (cond (modulus (list (leadalgcoef (cadr p)) (monize (cadr p)))) + (algfac* (algcontent (cadr p))) + (t (pcontent (cadr p)))))) + (nconc + (cond ((equal (car cont) 1) nil) + (algfac* + (cond (modulus (list (car cont) 1)) + ((equal (car cont) '(1 . 1)) nil) + ((equal (cdar cont) 1) (list (caar cont) 1)) + (t (list (caar cont) 1 (cdar cont) -1)))) + (t (cfactor (car cont)))) + (pfactor11 (psqfr (cadr cont))) + (car p)))))))) + (defun pfactor11 (p) (cond ((null p) nil) ((numberp (car p)) @@ -450,5 +447,5 @@ (cond ((null x) nil) (t (cons (car x) (cons (- (cadr x)) (revsign (cddr x))))))) - + ;; THIS IS THE END OF THE NEW RATIONAL FUNCTION PACKAGE PART 4 Index: ratout.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/ratout.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- ratout.lisp 27 May 2007 21:55:21 -0000 1.14 +++ ratout.lisp 7 Feb 2009 14:40:56 -0000 1.15 @@ -308,35 +308,32 @@ (prog (maxexp i l *p factors factor errrjfflag) (setq maxexp (quotient (cadr p) 2)) (setq i 1) - a (cond ((> i maxexp) (return (cons p factors)))) - (setq l (p1 (reverse ((lambda (p i $factorflag) - (pfactor2 p i)) - p - i - t)))) - b (cond ((null l) (go d))) + a (when (> i maxexp) (return (cons p factors))) + (setq l (p1 (reverse (let ((p p) (i i) ($factorflag t)) + (pfactor2 p i))))) + b (when (null l) (go d)) (setq *l (car l)) (setq *p (car p)) (setq errrjfflag t) (setq factor (errset (pinterpolate *l *p) nil)) (setq errrjfflag nil) (setq l (cdr l)) - (cond ((atom factor) (go b)) - (t (setq factor (car factor)))) - (cond ((or (pcoefp factor) - (not (eqn (car p) (car factor))) - (not (pzerop (prem p factor)))) - (go b))) + (if (atom factor) + (go b) + (setq factor (car factor))) + (when (or (pcoefp factor) + (not (eqn (car p) (car factor))) + (not (pzerop (prem p factor)))) + (go b)) (cond (modulus (pmonicize (cdr factor))) ((pminusp factor) (setq factor (pminus factor)))) (setq p (pquotient p factor)) (setq maxexp (quotient (cadr p) 2)) (setq factors (cons factor factors)) - (cond ((or (eqn p 1) (eqn p -1)) (return factors))) - (go a) - d (setq i (1+ i)) + (when (or (eqn p 1) (eqn p -1)) (return factors)) (go a) - )) + d (incf i) + (go a))) (defun pfactor2 (p i) (cond ((< i 0) nil) @@ -527,18 +524,18 @@ (defun wtptimes2 (y) - (cond ((null y) nil) - (t ((lambda (ii) (declare (fixnum ii)) - (cond ((> ii $ratwtlvl) (wtptimes2 (cddr y))) - (t (pcoefadd (+ (car *x*) (car y)) - (wtptimes (cadr *x*) (cadr y) ii) - (wtptimes2 (cddr y)))))) - (+ (* xweight (+ (car *x*) (car y))) wtsofar))))) + (if (null y) + nil + (let ((ii (+ (* xweight (+ (car *x*) (car y))) wtsofar))) + (if (> ii $ratwtlvl) + (wtptimes2 (cddr y)) + (pcoefadd (+ (car *x*) (car y)) + (wtptimes (cadr *x*) (cadr y) ii) + (wtptimes2 (cddr y))))))) (defun wtptimes3 (y) (prog ((e 0) u c) - (declare (fixnum e) (special v)) - + (declare (special v)) a1 (cond ((null y) (return nil))) (setq e (+ (car *x*) (car y))) (setq c (wtptimes (cadr y) (cadr *x*) (+ wtsofar (* xweight e)))) |