Code cleanups (misc.lisp)
- Subject: Code cleanups (misc.lisp)
- From: Andreas Eder
- Date: Sun, 3 Apr 2005 13:52:41 +0200
Hi,
a few days ago I posted to the list about a cleanup of misc.lisp.
I did some forther investigation and found out, that *rearray was used
to effect only in combin.lisp (for the computation of euler and
bernoulli numbers). All the other calls were empty calls doing
nothing.
So I eliminated *rearray alltogether and rewrrote the small portions
of combin.lisp to use adjustable arrays and adjust-array.
Now, misc.lisp is almost empty and the only definition left should be
easy to replace in the few places where it occurs, but I leave that
for another time.
I think the code looks cleaner now.
'Andreas
You can find the diffs below:
*** combin.lisp 2004-11-25 03:36:00.000000000 +0100
--- ../works/combin.lisp 2005-04-03 11:29:49.561878000 +0200
***************
*** 323,375 ****
(cond ((and p1 p2) (cons (rdis (cons p1 p2)) '(0)))
(t (cons '0 (list r))))))
! ;;(declare-top (splitfile eulbrn)
! ;; (array* (notype *eu* 1 *bn* 1 *bd* 1)
! ;; )
!
! ;;(comment euler and bernoulli stuff)
!
! (eval-when (compile eval load)
!
! (defvar *bn*
! (vector nil -1. 1. -1. 5. -691. 7. -3617. 43867. -174611. 854513.
! -236364091. 8553103. -23749461029. 8615841276005.
! -7709321041217. 2577687858367.))
!
! (defvar *bd*
! (vector nil 30. 42. 30. 66. 2730. 6. 510. 798. 330. 138. 2730. 6. 870.
! 14322. 510. 6.))
!
! (defvar *eu*
! (vector -1. 5. -61. 1385. -50521. 2702765. -199360981. 19391512145.
! -2404879675441. 370371188237525. -69348874393137901.)))
!
! ;;#-cl
! ;;(progn 'compile
! ;;(defvar *bn* (*array nil t 20.))
! ;;(defvar *bd* (*array nil t 20.))
! ;;(defvar *eu* (*array nil t 20.))
!
! ;;(setq i 0)
! ;;(mapc #'(lambda (q)
! ;; (store (aref *bn* (setq i (f1+ i))) q))
! ;; '(-1. 1. -1. 5. -691. 7. -3617. 43867. -174611. 854513. -236364091.
! ;; 8553103. -23749461029. 8615841276005. -7709321041217. 2577687858367.))
!
!
! ;;(setq i 0)
! ;;(mapc #'(lambda (a)
! ;; (store (aref *bd* (setq i (f1+ i))) a))
! ;; '(30. 42. 30. 66. 2730. 6. 510. 798. 330. 138. 2730. 6. 870. 14322.
! ;; 510. 6.))
!
! ;;(setq i -1)
! ;;(mapc #'(lambda (a)
! ;; (store (aref *eu* (setq i (f1+ i))) a))
! ;; '(-1. 5. -61. 1385. -50521. 2702765. -199360981. 19391512145.
! ;; -2404879675441. 370371188237525. -69348874393137901.))
! ;;)
(putprop '*eu* 11 'lim)
(putprop 'bern 16 'lim)
--- 323,349 ----
(cond ((and p1 p2) (cons (rdis (cons p1 p2)) '(0)))
(t (cons '0 (list r))))))
! ;; euler and bernoulli stuff
+ (defvar *bn* (make-array 17 :adjustable t
+ :element-type 'integer
+ :initial-contents '(0 -1 1 -1 5 -691 7 -3617 43867
+ -174611 854513 -236364091
+ 8553103 -23749461029
+ 8615841276005 -7709321041217
+ 2577687858367)))
+
+ (defvar *bd* (make-array 17 :adjustable t
+ :element-type 'integer
+ :initial-contents '(0 30 42 30 66 2730 6 510 798 330
+ 138 2730 6 870 14322 510 6)))
+
+ (defvar *eu* (make-array 11 :adjustable t
+ :element-type 'integer
+ :initial-contents '(-1 5 -61 1385 -50521 2702765
+ -199360981 19391512145
+ -2404879675441 370371188237525
+ -69348874393137901)))
(putprop '*eu* 11 'lim)
(putprop 'bern 16 'lim)
***************
*** 385,395 ****
(aref *eu* (f1- (// %n 2))))
((eq $zerobern '%$/#&)
(euler %n))
! ((*rearray '*eu* t (f1+ (// %n 2)))
(euler %n))))
((null (> %n (get '*eu* 'lim)))
(aref *eu* (f1- %n)))
! ((*rearray '*eu* t (f1+ %n))
(euler (f* 2 %n))))))
(simplify s))
--- 359,369 ----
(aref *eu* (f1- (// %n 2))))
((eq $zerobern '%$/#&)
(euler %n))
! ((adjust-array *eu* (f1+ (// %n 2)))
(euler %n))))
((null (> %n (get '*eu* 'lim)))
(aref *eu* (f1- %n)))
! ((adjust-array *eu* (f1+ %n))
(euler (f* 2 %n))))))
(simplify s))
***************
*** 428,438 ****
((null (> (setq %n (f1- (// %n 2))) (get 'bern 'lim)))
(list '(rat) (aref *bn* %n) (aref *bd* %n)))
((eq $zerobern '$/#&) (bern (f* 2 (f1+ %n))))
! (t (*rearray '*bn* t (setq %n (f1+ %n)))
! (*rearray '*bd* t %n) (bern (f* 2 %n)))))
((null (> %n (get 'bern 'lim)))
(list '(rat) (aref *bn* %n) (aref *bd* %n)))
! (t (*rearray '*bn* t (f1+ %n)) (*rearray '*bd* t (f1+ %n))
(bern %n)))))
(simplify s))
--- 402,416 ----
((null (> (setq %n (f1- (// %n 2))) (get 'bern 'lim)))
(list '(rat) (aref *bn* %n) (aref *bd* %n)))
((eq $zerobern '$/#&) (bern (f* 2 (f1+ %n))))
! (t
! (setq %n (f1+ %n))
! (adjust-array *bn* %n)
! (adjust-array *bd* %n)
! (bern (f* 2 %n)))))
((null (> %n (get 'bern 'lim)))
(list '(rat) (aref *bn* %n) (aref *bd* %n)))
! (t (adjust-array *bn* (f1+ %n))
! (adjust-array *bd* (f1+ %n))
(bern %n)))))
(simplify s))
*** cpoly.lisp 2004-11-25 03:36:00.000000000 +0100
--- ../works/cpoly.lisp 2005-04-03 09:18:38.904633000 +0200
***************
*** 200,208 ****
(and res (store (aref *pr-sl* l) (float res)))
(setq complex t))))))
;;;this should catch expressions like sin(x)-x
! (progn (*rearray '*pr-sl*)
! (*rearray '*pi-sl*)
! (cpoly-err expr1)))
(setq *shr-sl* (*array nil 'flonum nn))
(setq *shi-sl* (*array nil 'flonum nn))
(setq *qpr-sl* (*array nil 'flonum nn))
--- 200,206 ----
(and res (store (aref *pr-sl* l) (float res)))
(setq complex t))))))
;;;this should catch expressions like sin(x)-x
! (cpoly-err expr1))
(setq *shr-sl* (*array nil 'flonum nn))
(setq *shi-sl* (*array nil 'flonum nn))
(setq *qpr-sl* (*array nil 'flonum nn))
***************
*** 217,235 ****
(setq nn degree)
(cond (complex (setq res (errset (cpoly-sl degree))))
((setq res (errset (rpoly-sl degree)))))
- (*rearray '*shr-sl*)
- (*rearray '*shi-sl*)
- (*rearray '*qpr-sl*)
- (*rearray '*hr-sl*)
- (*rearray '*qhr-sl*)
- (cond (complex (*rearray '*qpi-sl*)
- (*rearray '*hi-sl*)
- (*rearray '*qhi-sl*)))
(or res
(mtell "~%Unexpected error. Treat results with caution."))
(cond ((= nn degree)
- (*rearray '*pr-sl*)
- (*rearray '*pi-sl*)
(merror "~%No roots found")))
(setq res nil)
(cond
--- 215,223 ----
***************
*** 296,303 ****
(t (displine expr))))
(simplify (list '(mequal) var expr)))
res)))))
- (*rearray '*pr-sl*)
- (*rearray '*pi-sl*)
(return (simplify (cond ($polyfactor (cons '(mtimes) res))
((cons '(mlist) (nreverse res))))))))
--- 284,289 ----
*** homog.lisp 2001-01-31 06:31:22.000000000 +0100
--- ../works/homog.lisp 2005-04-03 09:21:50.404521000 +0200
***************
*** 78,84 ****
((> i m)
(do ((ans)
(i m (f1- i)))
! ((< i 1) (*rearray arr) ans)
(push (arraycall t arr i 0) ans)))
(do ((vecl)
(j m (f1- j)))
--- 78,84 ----
((> i m)
(do ((ans)
(i m (f1- i)))
! ((< i 1) ans)
(push (arraycall t arr i 0) ans)))
(do ((vecl)
(j m (f1- j)))
*** linnew.lisp 2004-11-25 03:36:03.000000000 +0100
--- ../works/linnew.lisp 2005-04-03 12:00:36.112159000 +0200
***************
*** 216,222 ****
varlist
genvar)
(tmdet '*a2* n)))
- (*tmrearray '*a2*)
(tmrearray n)
(return r)))
--- 216,221 ----
***************
*** 316,322 ****
result))
res)))
(tmlin '*a2* n m nx))))
- (*tmrearray '*a2*)
(show *a2*)
(return r)))
--- 315,320 ----
***************
*** 367,375 ****
(prog nil
(do ((i 1. (f1+ i)))
((> i n))
! (cond ((atom (aref *tmarrays* i)) (*tmrearray (aref *tmarrays* i)))
(t (tm$kill (car (aref *tmarrays* i))))))
! (*tmrearray '*tmarrays*)))
(defun tmaccess (index)
(prog (l)
--- 365,373 ----
(prog nil
(do ((i 1. (f1+ i)))
((> i n))
! (cond ((atom (aref *tmarrays* i)) )
(t (tm$kill (car (aref *tmarrays* i))))))
! ))
(defun tmaccess (index)
(prog (l)
***************
*** 456,466 ****
(list '(mtimes simp)
(list '(mexpt simp) (cadar r) -1.)
(cons '($matrix simp) (cdr r))))
- (*tmrearray '*a2*)
(return r)))
- (defun *tmrearray (x) (*rearray x))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;THIS IS A UTILITY PACKAGE FOR SPARSE
;;MATRIX INVERSION. A3 IS A N*N MATRIX.
--- 454,461 ----
***************
*** 507,515 ****
;; (SETQ NODELIST
;; (CONS (TMPULL-OVER I N) NODELIST)))))
;; EXIT
- ;; (*TMREARRAY 'B)
- ;; (*TMREARRAY 'ROW)
- ;; (*TMREARRAY 'COL)
;; (RETURN (REVERSE NODELIST)))))
;; (DEFUN TMPULL-OVER (P N)
--- 502,507 ----
***************
*** 637,643 ****
;; L)))))))))
;; ;RECOVER THE ORDER.
;; (TMPERMUTE 'X N M 0. 0. 'ROW N 'ROW)
! ;; EXIT (*TMREARRAY 'ROW) (*TMREARRAY 'AA) (RETURN FLAG-NONSINGULAR)))
;;TMPERMUTE PERMUTES THE ROWS OR COLUMNS
;;OF THE N*M MATRIX AX ACCORDING TO THE
--- 629,635 ----
;; L)))))))))
;; ;RECOVER THE ORDER.
;; (TMPERMUTE 'X N M 0. 0. 'ROW N 'ROW)
! ;; EXIT (RETURN FLAG-NONSINGULAR)))
;;TMPERMUTE PERMUTES THE ROWS OR COLUMNS
;;OF THE N*M MATRIX AX ACCORDING TO THE
***************
*** 684,690 ****
flag)
(setq l k)
(go loop)))))))
! (*tmrearray '*indx*)))
(defun tmmove (ax n m rbias cbias i j flag)
(prog (ll)
--- 676,682 ----
flag)
(setq l k)
(go loop)))))))
! ))
(defun tmmove (ax n m rbias cbias i j flag)
(prog (ll)
***************
*** 771,779 ****
))
(tmlattice1 1.)
(setq res (tmsort-lattice xrow xcol))
! exit (*tmrearray '*b*)
! (*tmrearray '*row*)
! (*tmrearray '*col*)
(return res)))
(defun tmlattice1 (k)
--- 763,769 ----
))
(tmlattice1 1.)
(setq res (tmsort-lattice xrow xcol))
! exit
(return res)))
(defun tmlattice1 (k)
***************
*** 891,898 ****
(store (aref *colinv* (aref *col* i)) i))
(tmpermute a3 n m 0. n '*colinv* n '*row*)
(tmpermute a3 n m 0. n '*rowinv* n '*col*)
! (*tmrearray '*rowinv*)
! (*tmrearray '*colinv*)))
#-nil
(declare-top(unspecial n #-cl vlist nx ix))
--- 881,887 ----
(store (aref *colinv* (aref *col* i)) i))
(tmpermute a3 n m 0. n '*colinv* n '*row*)
(tmpermute a3 n m 0. n '*rowinv* n '*col*)
! ))
#-nil
(declare-top(unspecial n #-cl vlist nx ix))
*** mat.lisp 2004-11-25 03:36:03.000000000 +0100
--- ../works/mat.lisp 2005-04-03 09:28:12.501396000 +0200
***************
*** 213,219 ****
(t (forward t) (cond ($backsubst (backward)))
(recoverorder2)
(list dependentrows inconsistentrows variableorder))))
- (*rearray '*row*) (*rearray '*col*) (*rearray '*colinv*)
(return result)))
;;FORWARD ELIMINATION
--- 213,218 ----
*** matrix.lisp 2004-11-25 03:36:03.000000000 +0100
--- ../works/matrix.lisp 2005-04-03 09:30:23.954412000 +0200
***************
*** 302,308 ****
(setq k nil)
(cond ((diagp '*mat* m) (diaginv '*mat* m)) (t (tfgeli0 '*mat* m n)))
(setq k (atomat '*mat* m n (f1+ m)))
- (*rearray '*mat*)
(return k)))
(defun diagp (ax m)
--- 302,307 ----
***************
*** 394,400 ****
(prog ((j 0) row mat a)
(declare (fixnum j ))
(setq m (f1+ m))
! loop1(cond ((= m 1) #+maclisp (*rearray name) (return mat)))
(setq m (f1- m) j 0 a nil)
loop2(cond ((= j n) (setq mat (cons row mat) row nil) (go loop1)))
(setq j (f1+ j))
--- 393,399 ----
(prog ((j 0) row mat a)
(declare (fixnum j ))
(setq m (f1+ m))
! loop1(cond ((= m 1) (return mat)))
(setq m (f1- m) j 0 a nil)
loop2(cond ((= j n) (setq mat (cons row mat) row nil) (go loop1)))
(setq j (f1+ j))
***************
*** 420,426 ****
(declare (fixnum j))
(store (aref nam 0 0) 1)
(setq m (f1+ m))
! loop1(cond ((= m 1) #+maclisp (*rearray nam) (return mat)))
(setq m (f1- m) j 0)
loop2(cond ((= j n) (setq mat (cons row mat) row nil) (go loop1)))
(setq j (f1+ j))
--- 419,425 ----
(declare (fixnum j))
(store (aref nam 0 0) 1)
(setq m (f1+ m))
! loop1(cond ((= m 1) (return mat)))
(setq m (f1- m) j 0)
loop2(cond ((= j n) (setq mat (cons row mat) row nil) (go loop1)))
(setq j (f1+ j))
*** misc.lisp 2004-11-25 03:36:03.000000000 +0100
--- ../works/misc.lisp 2005-04-03 12:40:12.554891000 +0200
***************
*** 7,43 ****
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package "MAXIMA")
- ;; Maclisp compatibility package for the Lisp Machine -- run time
! ;; This function should really bash the array or use an invisible pointer
! ;; to be compatible with maclisp. ARRAY-SYMBOL can be either an array object
! ;; or a symbol. This only works for one dimensional arrays right now.
! ;; IGNORE is normally the type, but Maclisp only has ART-Q arrays.
! ;; *REARRAY of one arg is supposed to return the array.
! ;; Rewrite at some point to use ADJUST-ARRAY-SIZE.
! (defun *rearray (array-symbol &optional ign &rest dims) ign
! (check-arg array-symbol
! (or (symbolp array-symbol) (arrayp array-symbol))
! "a symbol or an array")
! ;;All references to *rearray now are to symbols with the
! ;; value cell being used for the array.
! (macrolet ((symbol-array (x) `(symbol-value ,x)))
! (cond ((null dims))
! ((null (cdr dims))
! (let ((old-array (if (symbolp array-symbol)
! (symbol-array array-symbol) array-symbol))
! (new-array (make-array (car dims)))
! (min-array-length))
! (setq min-array-length (min (array-dimension-n 1 old-array)
! (array-dimension-n 1 new-array)))
! (do ((i 0 (f1+ i))) ((= i min-array-length))
! (aset (aref old-array i) new-array i))
! (if (symbolp array-symbol) (setf (symbol-array array-symbol) new-array))
! new-array))
! (t (error "Can't handle *rearray with more than one dimension")))))
!
! (defun runtime nil (#-cl time
! #+cl get-internal-run-time))
--- 7,16 ----
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package "MAXIMA")
! ;; Maclisp compatibility package
! (defun runtime ()
! (get-internal-run-time))
*** newdet.lisp 2004-11-25 03:36:03.000000000 +0100
--- ../works/newdet.lisp 2005-04-03 09:31:34.635667000 +0200
***************
*** 148,161 ****
(setq j (sub1 j))
(go back)
! ret(*rearray '*binom*)
! (*rearray '*input*)
(setq r (cons (list 'mrat
'simp
varlist
genvar)
(aref *minor1* old 0.)))
- (*rearray '*minor1*)
(return r)))
(defun pascal (n)
--- 148,159 ----
(setq j (sub1 j))
(go back)
! ret
(setq r (cons (list 'mrat
'simp
varlist
genvar)
(aref *minor1* old 0.)))
(return r)))
(defun pascal (n)
*** numerm.lisp 2004-10-04 04:25:55.000000000 +0200
--- ../works/numerm.lisp 2005-04-03 09:33:31.303931000 +0200
***************
*** 46,62 ****
)
(defmacro free-array% (a)
- #+maclisp
- `(*rearray ,a)
#+(or cl nil)
- ;; not useful to call return-array unless it is at end of area.
- ;; programs do better to save arrays as a resource, this works
- ;; in maclisp too.
a
)
(defmacro free-array$ (a)
- #+maclisp
- `(*rearray ,a)
#+(or cl nil)
a
)
--- 46,55 ----
*** risch.lisp 2004-11-25 03:36:05.000000000 +0100
--- ../works/risch.lisp 2005-04-03 09:34:38.676689000 +0200
***************
*** 657,663 ****
(ptorat '*jm* (f1- d) d)
(setq m2 (xrutout '*jm* (f1- d) d nil nil))
(setq m2 (lsafix (cdr m2) (caddr m)))
- (*rearray '*jm*)
(return m2)))
(defun lsafix (l n)
--- 657,662 ----
*** rombrg.lisp 2004-11-25 03:36:05.000000000 +0100
--- ../works/rombrg.lisp 2005-04-03 09:35:41.940071000 +0200
***************
*** 99,106 ****
(t (abs y))))))))
(> l $rombergmin))
(setq $rombergit_used l)
- #+maclisp
- (progn (*rearray tt) (*rearray rr))
(return y)))))))
--- 99,104 ----
*** solve.lisp 2004-11-25 03:36:05.000000000 +0100
--- ../works/solve.lisp 2005-04-03 09:36:22.346928000 +0200
***************
*** 956,962 ****
(mapcar #'(lambda (x) (ith varl x))
(caddr ans))
ind))
- (*rearray 'xa*)
(if $programmode
(setq varl (make-mlist-l (linsort (cdr varl) *varl))))
(return varl)))
--- 956,961 ----
*** sprdet.lisp 2004-10-04 04:25:54.000000000 +0200
--- ../works/sprdet.lisp 2005-04-03 09:37:07.655040000 +0200
***************
*** 252,259 ****
(setq r0 (nreverse(bbsort r0 (function car>))))
(cond ((not(mxcomp c0 r0))(atranspose x n)(setq c0 r0)))
(setq *detsign* (prmusign (mapcar (function car) c0)))
! (newmat 'x* x n c0)
! (*rearray x)))
(defun newmat(x y n l)
;; (setq y (get-array-pointer y))
--- 252,258 ----
(setq r0 (nreverse(bbsort r0 (function car>))))
(cond ((not(mxcomp c0 r0))(atranspose x n)(setq c0 r0)))
(setq *detsign* (prmusign (mapcar (function car) c0)))
! (newmat 'x* x n c0)))
(defun newmat(x y n l)
;; (setq y (get-array-pointer y))
--
Wherever I lay my .emacs, there's my $HOME.