/[cmucl]/src/code/bignum-test.lisp
ViewVC logotype

Contents of /src/code/bignum-test.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Mon Oct 31 04:11:27 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +1 -3 lines
Fix headed boilerplate.
1 ram 1.1 ;;;; -*- Package: Bignum -*-
2 ram 1.2 ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 ram 1.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/bignum-test.lisp,v 1.4 1994/10/31 04:11:27 ram Rel $")
9 ram 1.2 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; Some stuff to check that bignum operations are retuning the correct
13     ;;; results.
14     ;;;
15 ram 1.1 (in-package "BIGNUM")
16    
17     (defvar *in-bignum-wrapper* nil)
18    
19 wlott 1.3 (defmacro def-bignum-wrapper (name lambda-list &body body)
20 ram 1.1 (let ((var-name (ext:symbolicate "*OLD-" name "*"))
21 wlott 1.3 (wrap-name (ext:symbolicate "WRAP-" name))
22     (args (mapcar #'(lambda (x)
23     (if (listp x) (car x) x))
24     (remove-if #'(lambda (x)
25     (member x lambda-list-keywords))
26     lambda-list))))
27 ram 1.1 `(progn
28     (defvar ,var-name (fdefinition ',name))
29 wlott 1.3 (defun ,wrap-name ,lambda-list
30 ram 1.1 (if *in-bignum-wrapper*
31     (funcall ,var-name ,@args)
32     (let ((*in-bignum-wrapper* t))
33     ,@body)))
34     (setf (fdefinition ',name) #',wrap-name))))
35    
36     (defun big= (x y)
37     (= (if (typep x 'bignum)
38     (%normalize-bignum x (%bignum-length x))
39     x)
40     (if (typep y 'bignum)
41     (%normalize-bignum y (%bignum-length y))
42     y)))
43    
44     (def-bignum-wrapper add-bignums (x y)
45     (let ((res (funcall *old-add-bignums* x y)))
46     (assert (big= (- res y) x))
47     res))
48    
49     (def-bignum-wrapper multiply-bignums (x y)
50     (let ((res (funcall *old-multiply-bignums* x y)))
51     (if (zerop x)
52     (assert (zerop res))
53     (multiple-value-bind (q r) (truncate res x)
54     (assert (and (zerop r) (big= q y)))))
55     res))
56    
57 wlott 1.3 (def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
58     (let ((res (funcall *old-negate-bignum* x fully-normalized)))
59 ram 1.1 (assert (big= (- res) x))
60     res))
61    
62     (def-bignum-wrapper subtract-bignum (x y)
63     (let ((res (funcall *old-subtract-bignum* x y)))
64     (assert (big= (+ res y) x))
65     res))
66    
67     (def-bignum-wrapper multiply-bignum-and-fixnum (x y)
68     (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
69     (if (zerop x)
70     (assert (zerop res))
71     (multiple-value-bind (q r) (truncate res x)
72     (assert (and (zerop r) (big= q y)))))
73     res))
74    
75     (def-bignum-wrapper multiply-fixnums (x y)
76     (let ((res (funcall *old-multiply-fixnums* x y)))
77     (if (zerop x)
78     (assert (zerop res))
79     (multiple-value-bind (q r) (truncate res x)
80     (assert (and (zerop r) (big= q y)))))
81     res))
82    
83     (def-bignum-wrapper bignum-ashift-right (x shift)
84     (let ((res (funcall *old-bignum-ashift-right* x shift)))
85     (assert (big= (ash res shift) (logand x (ash -1 shift))))
86     res))
87    
88     (def-bignum-wrapper bignum-ashift-left (x shift)
89     (let ((res (funcall *old-bignum-ashift-left* x shift)))
90     (assert (big= (ash res (- shift)) x))
91     res))
92    
93     (def-bignum-wrapper bignum-truncate (x y)
94     (multiple-value-bind (q r)
95     (funcall *old-bignum-truncate* x y)
96     (assert (big= (+ (* q y) r) x))
97     (values q r)))
98    
99     (def-bignum-wrapper bignum-compare (x y)
100     (let ((res (funcall *old-bignum-compare* x y)))
101     (assert (big= (signum (- x y)) res))
102     res))

  ViewVC Help
Powered by ViewVC 1.1.5