Style-Warnings
- Subject: Style-Warnings
- From: Andreas Eder
- Date: Fri, 7 May 2004 13:31:07 +0200
Well, since I cannot figure out the problem with GCL for lack of
knowledge of GCL, I decided to leave the eval-when issue aside for the
moment and go for the easier ones. :-) (As far as I can se there are
still a lot of these).
Another try on numth.lisp to get rid of a spurious warning about
ignoring a special var:
--- numth.lisp.old 2004-05-06 13:24:51.000000000 +0200
+++ numth.lisp.new 2004-05-07 13:15:06.000000000 +0200
@@ -9,57 +9,69 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package "MAXIMA")
+
;;; *****************************************************************
;;; ***** NUMTH ******* VARIOUS NUMBER THEORY FUNCTIONS *************
;;; *****************************************************************
(macsyma-module numth)
-(declare-top(special primechannel $intfaclim))
+(declare-top (special $intfaclim))
-(load-macsyma-macros rzmac)
+#-(or cl NIL)
+(declare-top (special *primechannel*))
-(comment PRIME number generator)
+(load-macsyma-macros rzmac)
-(defmvar $maxprime 489318.)
+;;; PRIME number generator
-(or (boundp 'primechannel) (setq primechannel nil))
;#+ITS
;(defun open-primechannel nil
-; (setq primechannel (open '|mc:maxdmp;ptable >| '(in fixnum))
-; $maxprime (f1- (car (syscall 1 'fillen primechannel)))))
+; (setq *primechannel* (open '|mc:maxdmp;ptable >| '(in fixnum))
+; $maxprime (f1- (car (syscall 1 'fillen *primechannel*)))))
;#+LISPM
;(defun open-primechannel nil
-; (setq primechannel
+; (setq *primechannel*
; (open "mc:maxdmp;ptable >" '(:read :fixnum :byte-size 9))))
+
+;#+obsolete
+;(defun input-word (n)
+; (funcall *primechannel* ':set-pointer (f* 4 (f1- n)))
+; (dpb (byte-in *primechannel*) 3311
+; (dpb (byte-in *primechannel*) 2211
+; (dpb (byte-in *primechannel*) 1111 (byte-in *primechannel*)))))
+
+#+(or cl NIL)
+(defmfun $prime (i)
+ (declare (ignore i))
+ (MERROR "PRIME doesn't work yet."))
+
+
+(defmvar $maxprime 489318.)
+
+#-(or cl NIL)
+(unless (boundp '*primechannel*)
+ (setq *primechannel* nil))
+
+
#-(or cl NIL)
(defun prime (n)
(cond ((or (< n 1) (> n $maxprime))
nil)
((input-word n))))
-
-#+cl
-(defmacro byte-in (file) `(read-byte ,file))
-#+obsolete
-(defun input-word (n)
- (funcall primechannel ':set-pointer (f* 4 (f1- n)))
- (dpb (byte-in primechannel) 3311
- (dpb (byte-in primechannel) 2211
- (dpb (byte-in primechannel) 1111 (byte-in primechannel)))))
-
+#-(or cl NIL)
(defmfun $prime (n)
- #+(or cl NIL) (MERROR "PRIME doesn't work yet in NIL.")
- #-(or cl NIL) (prog2 (open-primechannel)
- (if (eq (ml-typep n) 'fixnum)
- (or (prime n) (list '($prime) n))
- (list '($prime) n))
- (close primechannel)))
-
-(comment Sum of divisors and Totient functions)
+ (prog2 (open-primechannel)
+ (if (eq (ml-typep n) 'fixnum)
+ (or (prime n) (list '($prime) n))
+ (list '($prime) n))
+ (close *primechannel*)))
+
+;;; Sum of divisors and Totient functions
(DEFMFUN $divsum n
(or (< n 3)
@@ -104,14 +116,15 @@
(sub1 (cadr factors))))))
((null factors) total)))))
(t (list '($totient) n))))
-
-(comment JACOBI symbol and Gaussian factoring)
-(declare-top(special *incl modulus $intfaclim))
-(setq *incl (list 2 4))
+;;; JACOBI symbol and Gaussian factoring
+
+(declare-top (special *incl* modulus $intfaclim))
+
+(setq *incl* (list 2 4))
-(and (nconc *incl *incl) 'noprint)
+(and (nconc *incl* *incl*) 'noprint)
(defun rtzerl2 (n)
(cond ((zerop n) 0)
@@ -123,7 +136,7 @@
((equal (remainder p 8) 5) (imodp1 2 p))
((equal (remainder p 24) 17) (imodp1 3 p)) ;p=2(mod 3)
(t (do ((i 5 (plus i (car j))) ;p=1(mod 24)
- (j *incl (cdr j)))
+ (j *incl* (cdr j)))
((equal (jacobi i p) -1) (imodp1 i p))))))
(defun imodp1 (i modulus)
@@ -176,7 +189,7 @@
-(declare-top(*lexpr $rat))
+(declare-top (*lexpr $rat))
;(DEFMFUN $gcfactor (n)
@@ -243,9 +256,9 @@
; (setq plis (cons p (cons (cadr gl) plis)))
; (setq gl (cddr gl)) (go loop))
; ((equal p (car nl))
-; (cond ((zerop (remainder (setq tem (plus (times a (car cd)) ;gcremainder
+; (cond ((zerop (remainder (setq tem (plus (times a (car cd)) ;gcremainder
; (times b (cadr cd))))
-; p)) ;remainder(real((a+bi)cd~),p) z~ is complex conjugate
+; p)) ;remainder(real((a+bi)cd~),p) z~ is complex conjugate
; (setq e1 (cadr nl)) (setq dc cd))
; (t (setq e2 (cadr nl))
; (setq dc (reverse cd))))
@@ -299,80 +312,83 @@
; dif)
(defun gcfactor (a b &aux tem)
- (prog (gl cd dc econt p e1 e2 ans plis nl $intfaclim )
- (setq e1 0
- e2 0
- econt 0
- gl (gcd a b)
- a (quotient a gl)
- b (quotient b gl)
- nl (cfactorw (plus (times a a) (times b b)))
- gl (cfactorw gl))
- (and (equal 1 (car gl)) (setq gl nil))
- (and (equal 1 (car nl)) (setq nl nil))
-loop
- (cond ((null gl)
- (cond ((null nl) (go ret))
- ((setq p (car nl)))))
- ((null nl) (setq p (car gl)))
- (t (setq p (max (car gl) (car nl)))))
- (setq cd (psumsq p))
- (cond ((null cd)
- (setq plis (cons p (cons (cadr gl) plis)))
- (setq gl (cddr gl)) (go loop))
- ((equal p (car nl))
- (cond ((zerop (remainder (setq tem (plus (times a (car cd)) ;gcremainder
- (times b (cadr cd))))
- p)) ;remainder(real((a+bi)cd~),p) z~ is complex conjugate
- (setq e1 (cadr nl)) (setq dc cd))
- (t (setq e2 (cadr nl))
- (setq dc (reverse cd))))
- (setq dc (gcexpt dc (cadr nl)) ;
- dc (gctimes a b (car dc) (minus (cadr dc)))
- a (quotient (car dc) p)
- b (quotient (cadr dc) p)
- nl (cddr nl))))
- (cond ((equal p (car gl))
- (setq econt (plus econt (cadr gl)))
- (cond ((equal p 2)
- (setq e1 (f+ e1 (f* 2 (cadr gl)))))
- (t (setq e1 (f+ e1 (cadr gl))
- e2 (f+ e2 (cadr gl)))))
- (setq gl (cddr gl))))
- (and (not (zerop e1))
- (setq ans (cons cd (cons e1 ans)))
- (setq e1 0))
- (and (not (zerop e2))
- (setq ans (cons (reverse cd) (cons e2 ans)))
- (setq e2 0))
- (go loop)
-ret (setq cd (gcexpt (list 0 -1)
- (remainder econt 4)))
- (setq a (gctimes a b (car cd) (cadr cd)))
- ;;a hasn't been divided by p yet..
- (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)))))
- (cond ((equal (car a) 0)
- (setq ans (cons '(0 1) (cons 1 ans)))))
- (setq ans (nconc plis ans))
- (return ans)))
+ (prog (gl cd dc econt p e1 e2 ans plis nl $intfaclim )
+ (setq e1 0
+ e2 0
+ econt 0
+ gl (gcd a b)
+ a (quotient a gl)
+ b (quotient b gl)
+ nl (cfactorw (plus (times a a) (times b b)))
+ gl (cfactorw gl))
+ (and (equal 1 (car gl)) (setq gl nil))
+ (and (equal 1 (car nl)) (setq nl nil))
+ loop
+ (cond ((null gl)
+ (cond ((null nl) (go ret))
+ ((setq p (car nl)))))
+ ((null nl) (setq p (car gl)))
+ (t (setq p (max (car gl) (car nl)))))
+ (setq cd (psumsq p))
+ (cond ((null cd)
+ (setq plis (cons p (cons (cadr gl) plis)))
+ (setq gl (cddr gl)) (go loop))
+ ((equal p (car nl))
+ (cond ((zerop (remainder
+ (setq tem (plus (times a (car cd)) ;gcremainder
+ (times b (cadr cd))))
+ p)) ;remainder(real((a+bi)cd~),p)
+ ;z~ is complex conjugate
+ (setq e1 (cadr nl)) (setq dc cd))
+ (t (setq e2 (cadr nl))
+ (setq dc (reverse cd))))
+ (setq dc (gcexpt dc (cadr nl)) ;
+ dc (gctimes a b (car dc) (minus (cadr dc)))
+ a (quotient (car dc) p)
+ b (quotient (cadr dc) p)
+ nl (cddr nl))))
+ (cond ((equal p (car gl))
+ (setq econt (plus econt (cadr gl)))
+ (cond ((equal p 2)
+ (setq e1 (f+ e1 (f* 2 (cadr gl)))))
+ (t (setq e1 (f+ e1 (cadr gl))
+ e2 (f+ e2 (cadr gl)))))
+ (setq gl (cddr gl))))
+ (and (not (zerop e1))
+ (setq ans (cons cd (cons e1 ans)))
+ (setq e1 0))
+ (and (not (zerop e2))
+ (setq ans (cons (reverse cd) (cons e2 ans)))
+ (setq e2 0))
+ (go loop)
+ ret (setq cd (gcexpt (list 0 -1)
+ (remainder econt 4)))
+ (setq a (gctimes a b (car cd) (cadr cd)))
+ ;;a hasn't been divided by p yet..
+ (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)))))
+ (cond ((equal (car a) 0)
+ (setq ans (cons '(0 1) (cons 1 ans)))))
+ (setq ans (nconc plis ans))
+ (return ans)))
(defun multiply-gcfactors (lis)
(sloop for (term exp) on (cddr lis) by 'cddr
- with answ = (cond ((numberp (car lis))(list (pexpt (car lis) (second lis)) 0))
- (t(gcexpt (car lis) (second lis))))
- when (numberp term)
- do (setq answ (list (times (first answ) term) (times (second answ) term)))
- (show answ)
- else
- do (setq answ (apply 'gctimes (append answ (gcexpt term exp))))
- finally (return answ)))
+ with answ = (cond ((numberp (car lis))(list (pexpt (car lis) (second lis)) 0))
+ (t(gcexpt (car lis) (second lis))))
+ when (numberp term)
+ do (setq answ (list (times (first answ) term) (times (second answ) term)))
+ (show answ)
+ else
+ do (setq answ (apply 'gctimes (append answ (gcexpt term exp))))
+ finally (return answ)))
(defun gcexpt (a n)
- (cond ((zerop n) '(1 0))
- ((equal n 1) a)
- (t (gctime1 a (gcexpt a (f1- n))))))
+ (cond ((zerop n) '(1 0))
+ ((equal n 1) a)
+ (t (gctime1 a (gcexpt a (f1- n))))))
-(defun gctime1 (a b) (gctimes (car a) (cadr a) (car b) (cadr b)))
+(defun gctime1 (a b)
+ (gctimes (car a) (cadr a) (car b) (cadr b)))
And still an easy one in transs.lisp:
276a277
> (declare (ignore warnings-p))
There is still a lot wrong with transs.lisp (there is a boutload of
undefined functions in there), but this will take longer to unravel.
At the moment I intend to first go after the easy picks and then delve
deeper intp the matter.
Have a nice weekend,
Andreas
--
Wherever I lay my .emacs, there's my $HOME.