- cmucl-cvs - mailman3.common-lisp.net

[git] CMU Common Lisp branch master updated. snapshot-2014-06-24-g2ade088
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 2ade088e991102f642e20a3d20239bf8b2b52633 (commit) from 06ca7d326f688d40ad8730bbd2faa8ca7813d2f0 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 2ade088e991102f642e20a3d20239bf8b2b52633 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Jul 26 09:00:35 2014 -0700 Some cleanup of the trig code. * code/exports.lisp: * Export %ieee754-rem-pi/2 and %sincos. * code/irrat.lisp: * Remove some conditionalization that is always true now. * compiler/float-tran.lisp: * %sincos is exported so we don't need the package qualifier. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index ca0a60b..5c8168d 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2342,7 +2342,10 @@ "%COMPLEX-DOUBLE-FLOAT" "%COMPLEX-DOUBLE-DOUBLE-FLOAT" "STANDARD-READTABLE-MODIFIED-ERROR" - "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR") + "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" + + "%IEEE754-REM-PI/2" + "%SINCOS") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 032a6ac..c48d09d 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -64,19 +64,11 @@ ;;; Please refer to the Unix man pages for details about these routines. ;;; Trigonometric. -#-(and x86 (not sse2)) -(progn - ;; For x86 (without sse2), we can use x87 instructions to implement - ;; these. With sse2, we don't currently support that, so these - ;; should be disabled. -;; (def-math-rtn "sin" 1) -;; (def-math-rtn "cos" 1) - ;; (def-math-rtn "tan" 1) - (def-math-rtn ("fdlibm_sin" %sin) 1) - (def-math-rtn ("fdlibm_cos" %cos) 1) - (def-math-rtn ("fdlibm_tan" %tan) 1) - (def-math-rtn "atan" 1) - (def-math-rtn "atan2" 2)) +(def-math-rtn ("fdlibm_sin" %sin) 1) +(def-math-rtn ("fdlibm_cos" %cos) 1) +(def-math-rtn ("fdlibm_tan" %tan) 1) +(def-math-rtn "atan" 1) +(def-math-rtn "atan2" 2) (def-math-rtn "asin" 1) (def-math-rtn "acos" 1) (def-math-rtn "sinh" 1) @@ -87,19 +79,15 @@ (def-math-rtn "atanh" 1) ;;; Exponential and Logarithmic. -#-(and x86 (not sse2)) -(progn - (def-math-rtn "exp" 1) - (def-math-rtn "log" 1) - (def-math-rtn "log10" 1)) +(def-math-rtn "exp" 1) +(def-math-rtn "log" 1) +(def-math-rtn "log10" 1) (def-math-rtn "pow" 2) #-(or x86 sparc-v7 sparc-v8 sparc-v9) (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) -;; Don't want log1p to use the x87 instruction. -#-(or hpux (and x86 (not sse2))) (def-math-rtn "log1p" 1) ;; These are needed for use by byte-compiled files. But don't use @@ -199,6 +187,7 @@ ;; easier for the user, and we don't have to wrap calls with ;; without-gcing. (declaim (inline %ieee754-rem-pi/2)) +(export '%ieee754-rem-pi/2) (alien:def-alien-routine ("ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int (x double-float) (y0 double-float :out) @@ -211,6 +200,7 @@ (c double-float :out)) (declaim (inline %sincos)) +(export '%sincos) (defun %sincos (x) (declare (double-float x)) (multiple-value-bind (ign s c) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 41e0d42..7da6b95 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -734,19 +734,19 @@ (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) `(,prim x)))) -(defknown (kernel::%sincos) +(defknown (%sincos) (double-float) (values double-float double-float) (movable foldable flushable)) (deftransform cis ((x) (single-float) * :when :both) `(multiple-value-bind (s c) - (kernel::%sincos (coerce x 'double-float)) + (%sincos (coerce x 'double-float)) (complex (coerce c 'single-float) (coerce s 'single-float)))) (deftransform cis ((x) (double-float) * :when :both) `(multiple-value-bind (s c) - (kernel::%sincos x) + (%sincos x) (complex c s))) #+double-double ----------------------------------------------------------------------- Summary of changes: src/code/exports.lisp | 5 ++++- src/code/irrat.lisp | 30 ++++++++++-------------------- src/compiler/float-tran.lisp | 6 +++--- 3 files changed, 17 insertions(+), 24 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-08-2-gdcaac99
by cshapiro＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via dcaac995271f5ec60221877673e080361b1d2d27 (commit) from b90e144d86ca206d498891a2eb4b552cecef59ab (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit dcaac995271f5ec60221877673e080361b1d2d27 Author: Carl Shapiro <cshapiro(a)common-lisp.net> Date: Thu Aug 8 00:19:52 2013 -0700 Allow any unsigned-reg for the check-type and type-predicate temporary. diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 2597c6d..95ede9d 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -60,7 +60,7 @@ (emit-test))) (results))) -(defmacro test-type (value target not-p &rest type-codes) +(defmacro test-type (value temp target not-p &rest type-codes) ;; Determine what interesting combinations we need to test for. (let* ((type-codes (mapcar #'eval type-codes)) (fixnump (and (member even-fixnum-type type-codes) @@ -90,7 +90,7 @@ (when immediates (error "Can't mix fixnum testing with other immediates.")) (if headers - `(%test-fixnum-and-headers ,value ,target ,not-p + `(%test-fixnum-and-headers ,value ,temp ,target ,not-p ',(canonicalize-headers headers)) `(%test-fixnum ,value ,target ,not-p))) (immediates @@ -100,17 +100,17 @@ (error "Can't mix testing of immediates with testing of lowtags.")) (when (cdr immediates) (error "Can't test multiple immediates at the same time.")) - `(%test-immediate ,value ,target ,not-p ,(car immediates))) + `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates))) (lowtags (when (cdr lowtags) (error "Can't test multiple lowtags at the same time.")) (if headers `(%test-lowtag-and-headers - ,value ,target ,not-p ,(car lowtags) + ,value ,temp ,target ,not-p ,(car lowtags) ,function-p ',(canonicalize-headers headers)) - `(%test-lowtag ,value ,target ,not-p ,(car lowtags)))) + `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags)))) (headers - `(%test-headers ,value ,target ,not-p ,function-p + `(%test-headers ,value ,temp ,target ,not-p ,function-p ',(canonicalize-headers headers))) (t (error "Nothing to test?"))))) @@ -143,13 +143,13 @@ (generate-fixnum-test value) (inst jmp (if not-p :nz :z) target)) -(defun %test-fixnum-and-headers (value target not-p headers) +(defun %test-fixnum-and-headers (value temp target not-p headers) (let ((drop-through (gen-label))) (generate-fixnum-test value) (inst jmp :z (if not-p drop-through target)) - (%test-headers value target not-p nil headers drop-through))) + (%test-headers value temp target not-p nil headers drop-through))) -(defun %test-immediate (value target not-p immediate) +(defun %test-immediate (value temp target not-p immediate) ;; Code a single instruction byte test if possible. (let ((offset (tn-offset value))) (cond ((and (sc-is value any-reg descriptor-reg) @@ -160,25 +160,27 @@ :offset offset) immediate)) (t - (move eax-tn value) - (inst cmp al-tn immediate)))) + (move temp value) + (inst and temp type-mask) + (inst cmp temp immediate)))) (inst jmp (if not-p :ne :e) target)) -(defun %test-lowtag (value target not-p lowtag &optional al-loaded) - (unless al-loaded - (move eax-tn value) - (inst and al-tn lowtag-mask)) - (inst cmp al-tn lowtag) +(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded) + (unless temp-loaded + (move temp value) + (inst and temp lowtag-mask)) + (inst cmp temp lowtag) (inst jmp (if not-p :ne :e) target)) -(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers) +(defun %test-lowtag-and-headers (value temp target not-p lowtag + function-p headers) (let ((drop-through (gen-label))) - (%test-lowtag value (if not-p drop-through target) nil lowtag) - (%test-headers value target not-p function-p headers drop-through t))) + (%test-lowtag value temp (if not-p drop-through target) nil lowtag) + (%test-headers value temp target not-p function-p headers drop-through t))) -(defun %test-headers (value target not-p function-p headers - &optional (drop-through (gen-label)) al-loaded) +(defun %test-headers (value temp target not-p function-p headers + &optional (drop-through (gen-label)) temp-loaded) (let ((lowtag (if function-p function-pointer-type other-pointer-type))) (multiple-value-bind (equal less-or-equal when-true when-false) @@ -188,15 +190,15 @@ (if not-p (values :ne :a drop-through target) (values :e :na target drop-through)) - (%test-lowtag value when-false t lowtag al-loaded) - (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (%test-lowtag value temp when-false t lowtag temp-loaded) + (load-type temp value (- lowtag)) (do ((remaining headers (cdr remaining))) ((null remaining)) (let ((header (car remaining)) (last (null (cdr remaining)))) (cond ((atom header) - (inst cmp al-tn header) + (inst cmp temp header) (if last (inst jmp equal target) (inst jmp :e when-true))) @@ -204,9 +206,9 @@ (let ((start (car header)) (end (cdr header))) (unless (= start bignum-type) - (inst cmp al-tn start) + (inst cmp temp start) (inst jmp :b when-false)) ; was :l - (inst cmp al-tn end) + (inst cmp temp end) (if last (inst jmp less-or-equal target) (inst jmp :be when-true))))))) ; was :le @@ -217,7 +219,7 @@ ;; both cmp and sub take 2 cycles so maybe its a wash #+nil (defun %test-headers (value target not-p function-p headers - &optional (drop-through (gen-label)) al-loaded) + &optional (drop-through (gen-label)) temp-loaded) (let ((lowtag (if function-p function-pointer-type other-pointer-type))) (multiple-value-bind (equal less-or-equal when-true when-false) @@ -227,8 +229,8 @@ (if not-p (values :ne :a drop-through target) (values :e :na target drop-through)) - (%test-lowtag value when-false t lowtag al-loaded) - (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (%test-lowtag value when-false t lowtag temp-loaded) + (load-type temp value (- lowtag)) (let ((delta 0)) (do ((remaining headers (cdr remaining))) ((null remaining)) @@ -236,7 +238,7 @@ (last (null (cdr remaining)))) (cond ((atom header) - (inst sub al-tn (- header delta)) + (inst sub temp (- header delta)) (setf delta header) (if last (inst jmp equal target) @@ -245,10 +247,10 @@ (let ((start (car header)) (end (cdr header))) (unless (= start bignum-type) - (inst sub al-tn (- start delta)) + (inst sub temp (- start delta)) (setf delta start) (inst jmp :l when-false)) - (inst sub al-tn (- end delta)) + (inst sub temp (- end delta)) (setf delta end) (if last (inst jmp less-or-equal target) @@ -261,15 +263,13 @@ (define-vop (check-type) (:args (value :target result :scs (any-reg descriptor-reg))) (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax) - (:ignore eax) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:vop-var vop) (:save-p :compute-only)) (define-vop (type-predicate) (:args (value :scs (any-reg descriptor-reg))) - (:temporary (:sc unsigned-reg :offset eax-offset) eax) - (:ignore eax) + (:temporary (:scs (unsigned-reg)) temp) (:conditional) (:info target not-p) (:policy :fast-safe)) @@ -303,13 +303,13 @@ `((define-vop (,pred-name type-predicate) (:translate ,pred-name) (:generator ,cost - (test-type value target not-p ,@type-codes))))) + (test-type value temp target not-p ,@type-codes))))) ,@(when check-name `((define-vop (,check-name check-type) (:generator ,cost (let ((err-lab (generate-error-code vop ,error-code value))) - (test-type value err-lab t ,@type-codes) + (test-type value temp err-lab t ,@type-codes) (move result value)))))) ,@(when ptype `((primitive-type-vop ,check-name (:check) ,ptype)))))) @@ -322,13 +322,13 @@ `((define-vop (,pred-name simple-type-predicate) (:translate ,pred-name) (:generator ,cost - (test-type value target not-p ,@type-codes))))) + (test-type value temp target not-p ,@type-codes))))) ,@(when check-name `((define-vop (,check-name simple-check-type) (:generator ,cost (let ((err-lab (generate-error-code vop ,error-code value))) - (test-type value err-lab t ,@type-codes) + (test-type value temp err-lab t ,@type-codes) (move result value)))))) ,@(when ptype `((primitive-type-vop ,check-name (:check) ,ptype)))))) @@ -634,12 +634,12 @@ (values target not-target)) (generate-fixnum-test value) (inst jmp :e yep) - (move eax-tn value) - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (move temp value) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) - (loadw eax-tn value 0 other-pointer-type) - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (loadw temp value 0 other-pointer-type) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp (if not-p :ne :e) target)) NOT-TARGET)) @@ -650,12 +650,12 @@ value))) (generate-fixnum-test value) (inst jmp :e yep) - (move eax-tn value) - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (move temp value) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) - (loadw eax-tn value 0 other-pointer-type) - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (loadw temp value 0 other-pointer-type) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp :ne nope)) YEP (move result value))) @@ -677,35 +677,35 @@ (values target not-target)) ;; Is it a fixnum? (generate-fixnum-test value) - (move eax-tn value) + (move temp value) (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) ;; Get the header. - (loadw eax-tn value 0 other-pointer-type) + (loadw temp value 0 other-pointer-type) ;; Is it one? - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp :e single-word) ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type)) + (inst cmp temp (+ (ash 2 type-bits) bignum-type)) (inst jmp :ne nope) ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type) + (loadw temp value (1+ bignum-digits-offset) other-pointer-type) ;; All zeros, its an (unsigned-byte 32). - (inst or eax-tn eax-tn) + (inst test temp temp) (inst jmp :z yep) (inst jmp nope) (emit-label single-word) ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-type) + (loadw temp value bignum-digits-offset other-pointer-type) ;; positive implies (unsigned-byte 32). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst test temp temp) (inst jmp (if not-p :s :ns) target) (emit-label not-target))))) @@ -720,35 +720,35 @@ ;; Is it a fixnum? (generate-fixnum-test value) - (move eax-tn value) + (move temp value) (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) ;; Get the header. - (loadw eax-tn value 0 other-pointer-type) + (loadw temp value 0 other-pointer-type) ;; Is it one? - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp :e single-word) ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type)) + (inst cmp temp (+ (ash 2 type-bits) bignum-type)) (inst jmp :ne nope) ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type) + (loadw temp value (1+ bignum-digits-offset) other-pointer-type) ;; All zeros, its an (unsigned-byte 32). - (inst or eax-tn eax-tn) + (inst or temp temp) (inst jmp :z yep) (inst jmp nope) (emit-label single-word) ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-type) + (loadw temp value bignum-digits-offset other-pointer-type) ;; positive implies (unsigned-byte 32). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst or temp temp) (inst jmp :s nope) (emit-label yep) @@ -766,7 +766,7 @@ (let ((is-symbol-label (if not-p drop-thru target))) (inst cmp value nil-value) (inst jmp :e is-symbol-label) - (test-type value target not-p symbol-header-type)) + (test-type value temp target not-p symbol-header-type)) DROP-THRU)) (define-vop (check-symbol check-type) @@ -774,7 +774,7 @@ (let ((error (generate-error-code vop object-not-symbol-error value))) (inst cmp value nil-value) (inst jmp :e drop-thru) - (test-type value error t symbol-header-type)) + (test-type value temp error t symbol-header-type)) DROP-THRU (move result value))) @@ -784,7 +784,7 @@ (let ((is-not-cons-label (if not-p target drop-thru))) (inst cmp value nil-value) (inst jmp :e is-not-cons-label) - (test-type value target not-p list-pointer-type)) + (test-type value temp target not-p list-pointer-type)) DROP-THRU)) (define-vop (check-cons check-type) @@ -792,5 +792,5 @@ (let ((error (generate-error-code vop object-not-cons-error value))) (inst cmp value nil-value) (inst jmp :e error) - (test-type value error t list-pointer-type) + (test-type value temp error t list-pointer-type) (move result value)))) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/type-vops.lisp | 148 +++++++++++++++++++-------------------- 1 file changed, 74 insertions(+), 74 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-05-4-g0b5c125
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 0b5c1254cc522e4e10d0f14ea248cc74b82fae69 (commit) from 7889e989541ed40a753b2a884f7fbcf25e0a951d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 0b5c1254cc522e4e10d0f14ea248cc74b82fae69 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 16 19:17:56 2013 -0700 Forgot to commit changes to code/x86-vm.lisp to: Wrap exports in eval-when for x86 as was done for sparc and add CHAR-BYTES to x86-x86 cross-compile script. diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 961dacb..6b7c881 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -26,10 +26,12 @@ (intl:textdomain "cmucl-x86-vm") +(eval-when (:compile-toplevel :load-toplevel :execute) (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution)) +) #+complex-fp-vops (sys:register-lisp-feature :complex-fp-vops) ----------------------------------------------------------------------- Summary of changes: src/code/x86-vm.lisp | 2 ++ 1 file changed, 2 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-41-gd08b5bf
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via d08b5bf8259bcd458beec17ba65a7b85f454edda (commit) from b48c235255ef3e9cf0f47446a3adf8ce0abbe07f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit d08b5bf8259bcd458beec17ba65a7b85f454edda Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Aug 27 21:22:18 2014 -0700 Add some tests for ROUND. Two tests currently fail. diff --git a/tests/srctran.lisp b/tests/srctran.lisp index f88e977..e3cba34 100644 --- a/tests/srctran.lisp +++ b/tests/srctran.lisp @@ -80,3 +80,25 @@ (c::ceiling-rem-bound (c::make-interval :low '(-1.3) :high 10.3))) (assert-equalp (c::make-interval :low '(-20.3) :high '(20.3)) (c::ceiling-rem-bound (c::make-interval :low '(-20.3) :high 10.3)))) + +(define-test round-quotient-bound + "Test the first value of ROUND returns the correct interval" + (assert-equalp (c::make-interval :low 0 :high 10) + (c::round-quotient-bound (c::make-interval :low 0.3 :high 10.5))) + (assert-equalp (c::make-interval :low 0 :high 12) + (c::round-quotient-bound (c::make-interval :low 0.3 :high 11.5))) + (assert-equalp (c::make-interval :low 0 :high 10) + (c::round-quotient-bound (c::make-interval :low 0.3 :high '(10.5)))) + ;; Known failure: returns high limit of 12 instead of 11 + (assert-equalp (c::make-interval :low 0 :high 11) + (c::round-quotient-bound (c::make-interval :low 0.3 :high '(11.5)))) + (assert-equalp (c::make-interval :low 2 :high 10) + (c::round-quotient-bound (c::make-interval :low 1.5 :high 10.5))) + (assert-equalp (c::make-interval :low 2 :high 10) + (c::round-quotient-bound (c::make-interval :low '(1.5) :high 10.5))) + ;; Known failure: returns high limit of 0 instead of 1 + (assert-equalp (c::make-interval :low 1 :high 10) + (c::round-quotient-bound (c::make-interval :low '(0.5) :high 10.5))) + ) + + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: tests/srctran.lisp | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-22-g2c4a13a
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 2c4a13afde093c0e1eb415c7252efaad6ca362f5 (commit) from 33097329493c7a767bcc4434f3212badcb33236a (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 2c4a13afde093c0e1eb415c7252efaad6ca362f5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Aug 21 21:56:26 2014 -0700 Re-enable the x87 floating-point mode stuff. On 32-bit linux, we can still get FP exceptions using x87 because 32-bit linux can still use x87 instructions for arithmetic. Because of this, we need to re-enable the support x87 floating-point modes, including getting and setting the modes and also extracting the modes from a sigcontext. * src/code/float-trap.lisp: * Put back support for getting and setting the x87 FP modes. * src/compiler/x86/float.lisp: * Add comment on the layout of the status and control words for x87. * src/lisp/Linux-os.c: * Put back support for getting the x87 (and sse2) FP modes. Needed in the sigfpe-handler in float-trap.lisp. Some of this needs to be cleaned up because we always require sse2 now. diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 7f27ffd..d97d04e 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -64,17 +64,62 @@ (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new)) ) +#+(and x86 (not sse2)) +(progn + (defun floating-point-modes () + (let ((x87-modes (vm::x87-floating-point-modes))) + ;; Massage the bits from x87-floating-point-modes into the order + ;; that the rest of the system wants them to be. (Must match + ;; format in the SSE2 mxcsr register.) + (logior (ash (logand #x3f x87-modes) 7) ; control + (logand #x3f (ash x87-modes -16))))) + (defun (setf floating-point-modes) (new) + (let* ((rc (ldb float-rounding-mode new)) + (x87-modes + (logior (ash (logand #x3f new) 16) + (ash rc 10) + (logand #x3f (ash new -7)) + ;; Set precision control to be 53-bit, always. + ;; (The compiler takes care of handling + ;; single-float precision, and we don't support + ;; long-floats.) + (ash 2 8)))) + (setf (x87-floating-point-modes) x87-modes))) + ) + #+sse2 (progn (defun floating-point-modes () - ;; Get just the SSE2 mode bits. - (vm::sse2-floating-point-modes)) + ;; Combine the modes from the FPU and SSE2 units. Since the sse + ;; mode contains all of the common information we want, we massage + ;; the x87-modes to match, and then OR the x87 and sse2 modes + ;; together. Note: We ignore the rounding control bits from the + ;; FPU and only use the SSE2 rounding control bits. + (let* ((x87-modes (vm::x87-floating-point-modes)) + (sse-modes (vm::sse2-floating-point-modes)) + (final-mode (logior sse-modes + (ash (logand #x3f x87-modes) 7) ; control + (logand #x3f (ash x87-modes -16))))) + + final-mode)) (defun (setf floating-point-modes) (new-mode) (declare (type (unsigned-byte 24) new-mode)) - ;; Set the floating point modes for SSE2. - (setf (vm::sse2-floating-point-modes) new-mode) + ;; Set the floating point modes for both X87 and SSE2. This + ;; include the rounding control bits. + (let* ((rc (ldb float-rounding-mode new-mode)) + (x87-modes + (logior (ash (logand #x3f new-mode) 16) + (ash rc 10) + (logand #x3f (ash new-mode -7)) + ;; Set precision control to be 64-bit, always. We + ;; don't use the x87 registers with sse2, so this + ;; is ok and would be the correct setting if we + ;; ever support long-floats. + (ash 3 8)))) + (setf (vm::sse2-floating-point-modes) new-mode) + (setf (vm::x87-floating-point-modes) x87-modes)) new-mode) - ) +) ;;; SET-FLOATING-POINT-MODES -- Public ;;; diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index a515e40..e617149 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -2303,6 +2303,43 @@ (defknown ((setf x87-floating-point-modes)) (float-modes) float-modes) +;; For the record, here is the format of the x86 FPU status word +;; +;; Bit +;; 15 FPU Busy +;; 14 C3 (condition code) +;; 13-11 Top of stack +;; 10 C2 (condition code) +;; 9 C1 (condition code) +;; 8 C0 (condition code) +;; 7 Error summary status +;; 6 Stack fault +;; 5 precision flag (inexact) +;; 4 underflow flag +;; 3 overflow flag +;; 2 divide-by-zero flag +;; 1 denormalized operand flag +;; 0 invalid operation flag +;; +;; When one of the flag bits (0-5) is set, then that exception has +;; been detected since the bits were last cleared. +;; +;; The control word: +;; +;; 15-13 reserved +;; 12 infinity control +;; 11-10 rounding control +;; 9-8 precision control +;; 7-6 reserved +;; 5 precision masked +;; 4 underflow masked +;; 3 overflow masked +;; 2 divide-by-zero masked +;; 1 denormal operand masked +;; 0 invalid operation masked +;; +;; When one of the mask bits (0-5) is set, then that exception is +;; masked so that no exception is generated. (define-vop (x87-floating-point-modes) (:results (res :scs (unsigned-reg))) (:result-types unsigned-num) diff --git a/src/lisp/Linux-os.c b/src/lisp/Linux-os.c index 2da60fb..7f7a4d7 100644 --- a/src/lisp/Linux-os.c +++ b/src/lisp/Linux-os.c @@ -217,13 +217,16 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) if (fpregs) { if (offset < 8) { reg = (unsigned char *) &fpregs->_st[offset]; - } else if (offset < 16) { + } +#ifdef FEATURE_SSE2 + else { struct _fpstate *fpstate; fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; if (fpstate->magic != 0xffff) { reg = (unsigned char *) &fpstate->_xmm[offset - 8]; } } +#endif } return reg; } @@ -231,27 +234,39 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) { - unsigned int modes = 0; - - /* - * Get the SSE2 modes. FIXME: What should we do if the magic - * value indicates that the mxcsr value is not in the context? - */ - struct _fpstate *fpstate; - unsigned long mxcsr; + unsigned int modes; + unsigned short cw, sw; - fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; - if (fpstate->magic == 0xffff) { - mxcsr = 0; + if (scp->uc_mcontext.fpregs == NULL) { + cw = 0; + sw = 0x3f; } else { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); + cw = scp->uc_mcontext.fpregs->cw & 0xffff; + sw = scp->uc_mcontext.fpregs->sw & 0xffff; } - modes |= mxcsr; + modes = ((cw & 0x3f) << 7) | (sw & 0x3f); + +#ifdef FEATURE_SSE2 + /* + * Add in the SSE2 part, if we're running the sse2 core. + */ + if (fpu_mode == SSE2) { + struct _fpstate *fpstate; + unsigned long mxcsr; + + fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; + if (fpstate->magic == 0xffff) { + mxcsr = 0; + } else { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); + } + modes |= mxcsr; + } +#endif - /* Convert exception mask to exception enable */ modes ^= (0x3f << 7); return modes; } @@ -528,19 +543,25 @@ void restore_fpu(ucontext_t *context) { if (context->uc_mcontext.fpregs) { - struct _fpstate *fpstate; - unsigned int mxcsr; + short cw = context->uc_mcontext.fpregs->cw; + DPRINTF(0, (stderr, "restore_fpu: cw = %08x\n", cw)); + __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)); +#ifdef FEATURE_SSE2 + if (fpu_mode == SSE2) { + struct _fpstate *fpstate; + unsigned int mxcsr; - fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; - if (fpstate->magic != 0xffff) { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); - __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); + fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; + if (fpstate->magic != 0xffff) { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); + __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); + } } +#endif } } - #ifdef i386 boolean os_support_sse2() ----------------------------------------------------------------------- Summary of changes: src/code/float-trap.lisp | 55 ++++++++++++++++++++++++++++++---- src/compiler/x86/float.lisp | 37 +++++++++++++++++++++++ src/lisp/Linux-os.c | 69 ++++++++++++++++++++++++++++--------------- 3 files changed, 132 insertions(+), 29 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-2-gcef7a42
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via cef7a420993388f21ea2ba733b57b3651f4f5b3b (commit) from 0cf9036d307ffcf6690851b114607b7571706799 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit cef7a420993388f21ea2ba733b57b3651f4f5b3b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jun 30 21:01:23 2014 -0700 Fix declaration of min-av-mem-age in generation-stats. It's an int, not a double. diff --git a/src/code/gc.lisp b/src/code/gc.lisp index b12daba..5af87ed 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -581,7 +581,7 @@ (num-gc c-call:int) (trigger-age c-call:int) (cum-sum-bytes-allocated c-call:int) - (min-av-mem-age c-call:double))) + (min-av-mem-age c-call:int))) (defun gencgc-stats (generation) "Return some GC statistics for the specified GENERATION. The ----------------------------------------------------------------------- Summary of changes: src/code/gc.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-45-g576eca2
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 576eca29f2af906cd5931ebb338cb872ac10c912 (commit) from a00d8a9a746933ad02f39fb22149a11299ea6a9b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 576eca29f2af906cd5931ebb338cb872ac10c912 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jan 3 10:15:33 2014 -0800 Make interactive use of tests a little easier. * Split LOAD-AND-RUN-ALL-TESTS into two routines: one to load and one to run the tests. * Export the main routines. diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index 0a7da54..84df410 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -13,8 +13,11 @@ (defpackage :cmucl-test-runner (:use :cl) - (:export #:run-all-tests - #:load-and-run-all-tests + (:export #:*test-files* + #:*test-names* + #:load-test-files + #:run-loaded-tests + #:run-all-tests #:print-test-results)) (in-package :cmucl-test-runner) @@ -28,23 +31,30 @@ (defvar *load-path* *load-pathname*) +(defvar *test-files* + nil) + +(defvar *test-names* + nil) + +(defun load-test-files (&optional (test-directory #p"tests/")) + (dolist (file (directory (merge-pathnames "*.lisp" test-directory))) + (unless (equal file *load-path*) + (let ((basename (pathname-name file))) + (push (concatenate 'string (string-upcase basename) "-TESTS") + *test-names*) + (push file *test-files*) + (load file)))) + (setf *test-files* (nreverse *test-files*)) + (setf *test-names* (nreverse *test-names*))) + ;; Look through all the files in the tests directory and load them. ;; Then run all of the tests. For each file, it ia assumed that a ;; package is created that is named with "-TESTS" appended to he ;; pathname-name of the file. -(defun load-and-run-all-tests () - (let (test-names - test-results) - (dolist (file (directory "tests/*.lisp")) - (unless (equal file *load-path*) - (let ((basename (pathname-name file))) - ;; Create the package name from the pathname name so we know - ;; how to run the test. - (push (concatenate 'string (string-upcase basename) "-TESTS") - test-names) - (load file)))) - (setf test-names (nreverse test-names)) - (dolist (test test-names) +(defun run-loaded-tests () + (let (test-results) + (dolist (test *test-names*) (push (lisp-unit:run-tests :all test) test-results)) (nreverse test-results))) @@ -89,8 +99,9 @@ (t (unix:unix-exit 0))))) -(defun run-all-tests () - (print-test-results (load-and-run-all-tests))) +(defun run-all-tests (&optional (test-directory #P"tests/")) + (load-test-files test-directory) + (print-test-results (run-loaded-tests))) ;;(run-all-tests) ;;(quit) ----------------------------------------------------------------------- Summary of changes: tests/run-tests.lisp | 45 ++++++++++++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 17 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch rtoy-lisp-trig created. snapshot-2013-12-a-5-g7190b61
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, rtoy-lisp-trig has been created at 7190b61cf97c8320d6a218c430471c0fb0bf518e (commit) - Log ----------------------------------------------------------------- commit 7190b61cf97c8320d6a218c430471c0fb0bf518e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 14 21:21:50 2013 -0800 Add test for sincos(-0d0). diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp index a0c8c15..9555b11 100644 --- a/src/tests/trig.lisp +++ b/src/tests/trig.lisp @@ -142,6 +142,10 @@ -4.08066388841804238545143494525595117765084022768d-1) +(rt:deftest sincos.0 + (multiple-value-list (kernel::%sincos -0d0)) + (-0d0 1d0)) + (rt:deftest sincos.1 (let (results) (dotimes (k 1000) commit b79c28727f40f1dd3cdd035eb86fd929594b0d64 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 14 21:20:00 2013 -0800 Implement sincos using the new Lisp trig routines. This can now be used for all platforms. code/irrat.lisp:: * Implement %SINCOS compiler/float-tran.lisp:: * Update deftransforms for CIS. %SINCOS can be used on any platform. tests/trig.lisp: * Add tests to verify %sincos returns exactly the same values as for sin and cos. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 660c519..c23321d 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -202,7 +202,9 @@ ;; Block compile so the trig routines don't cons their args when ;; calling the kernel trig routines. -(declaim (ext:start-block kernel-sin kernel-cos kernel-tan %sin %cos %tan)) +(declaim (ext:start-block kernel-sin kernel-cos kernel-tan + %sin %cos %tan + %sincos)) ;; kernel sin function on [-pi/4, pi/4], pi/4 ~ 0.7854 ;; Input x is assumed to be bounded by ~pi/4 in magnitude. @@ -592,63 +594,32 @@ ;; flag = 1 if n even, -1 if n odd (kernel-tan y0 y1 flag))))))) +(defun %sincos (x) + (declare (double-float x) + (optimize (speed 3))) + (cond ((<= (abs x) (/ pi 4)) + (values (kernel-sin x 0d0 0) + (kernel-cos x 0d0))) + (t + ;; Argument reduction needed + (multiple-value-bind (n y0 y1) + (%ieee754-rem-pi/2 x) + (case (logand n 3) + (0 + (values (kernel-sin y0 y1 1) + (kernel-cos y0 y1))) + (1 + (values (kernel-cos y0 y1) + (- (kernel-sin y0 y1 1)))) + (2 + (values (- (kernel-sin y0 y1 1)) + (- (kernel-cos y0 y1)))) + (3 + (values (- (kernel-cos y0 y1)) + (kernel-sin y0 y1 1)))))))) + (declaim (ext:end-block)) -;; Linux and sparc have a sincos function in the C library. Use it. -;; But on linux we need to do pi reduction ourselves because the C -;; library doesn't do accurate reduction. Sparc does accurate pi -;; reduction, so we don't need to do it ourselves. -#+(or (and linux x86) sparc) -(progn -(declaim (inline %%sincos)) -(export '%%sincos) -(alien:def-alien-routine ("sincos" %%sincos) c-call:void - (x double-float) - (sin double-float :out) - (cos double-float :out)) - -#+(and linux x86) -(defun %sincos (theta) - (declare (double-float theta)) - ;; Accurately reduce theta. - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 theta) - (multiple-value-bind (ignore s c) - (%%sincos y0) - (declare (ignore ignore)) - ;; Figure out which quadrant to use, and finish out the - ;; computation using y1. This is done by using a 1st-order - ;; Taylor expansion about y0. - (flet ((sin2 (s c y) - ;; sin(x+y) = sin(x) + cos(x)*y - (+ s (* c y))) - (cos2 (s c y) - ;; cos(x+y) = cos(x) - sin(x)*y - (- c (* s y)))) - (case (logand n 3) - (0 - (values (sin2 s c y1) - (cos2 s c y1))) - (1 - (values (cos2 s c y1) - (- (sin2 s c y1)))) - (2 - (values (- (sin2 s c y1)) - (- (cos2 s c y1)))) - (3 - (values (- (cos2 s c y1)) - (sin2 s c y1)))))))) -#+sparc -(declaim (inline %sinccos)) -#+sparc -(defun %sincos (theta) - (multiple-value-bind (ignore s c) - (%%sincos theta) - (declare (ignore ignore)) - (values s c))) -) - - ;;;; Power functions. @@ -1303,9 +1274,6 @@ "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)." (if (complexp theta) (error (intl:gettext "Argument to CIS is complex: ~S") theta) - #-(or (and linux x86) sparc) - (complex (cos theta) (sin theta)) - #+(or (and linux x86) sparc) (number-dispatch ((theta real)) ((rational) (let ((arg (coerce theta 'double-float))) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index a8147d9..d123d18 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -731,8 +731,6 @@ (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) `(,prim x)))) -#+(or (and linux x86) sparc) -(progn (defknown (kernel::%sincos) (double-float) (values double-float double-float) (movable foldable flushable)) @@ -752,7 +750,7 @@ (deftransform cis ((z) (double-double-float) *) ;; Cis. '(complex (cos z) (sin z))) -) + ;;; The argument range is limited on the x86 FP trig. functions. A ;;; post-test can detect a failure (and load a suitable result), but diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp index 49f16fb..a0c8c15 100644 --- a/src/tests/trig.lisp +++ b/src/tests/trig.lisp @@ -140,4 +140,89 @@ (rt:deftest tan.misc.1 (tan (scale-float 1d0 120)) -4.08066388841804238545143494525595117765084022768d-1) - + + +(rt:deftest sincos.1 + (let (results) + (dotimes (k 1000) + (let* ((x (random (/ pi 4))) + (s-exp (sin x)) + (c-exp (cos x))) + (multiple-value-bind (s c) + (kernel::%sincos x) + (unless (and (= s s-exp) + (= c c-exp)) + (push (list x + (list s s-exp) + (list c c-exp)) + results))))) + results) + nil) + +(rt:deftest sincos.2 + (let (results) + (dotimes (k 1000) + (let* ((x (random 16d0)) + (s-exp (sin x)) + (c-exp (cos x))) + (multiple-value-bind (s c) + (kernel::%sincos x) + (unless (and (= s s-exp) + (= c c-exp)) + (push (list x + (list s s-exp) + (list c c-exp)) + results))))) + results) + nil) + +(rt:deftest sincos.3 + (let (results) + (dotimes (k 1000) + (let* ((x (random (scale-float 1d0 120))) + (s-exp (sin x)) + (c-exp (cos x))) + (multiple-value-bind (s c) + (kernel::%sincos x) + (unless (and (= s s-exp) + (= c c-exp)) + (push (list x + (list s s-exp) + (list c c-exp)) + results))))) + results) + nil) + +(rt:deftest sincos.3a + (let (results) + (dotimes (k 1000) + (let* ((x (- (random (scale-float 1d0 120)))) + (s-exp (sin x)) + (c-exp (cos x))) + (multiple-value-bind (s c) + (kernel::%sincos x) + (unless (and (= s s-exp) + (= c c-exp)) + (push (list x + (list s s-exp) + (list c c-exp)) + results))))) + results) + nil) + +(rt:deftest sincos.4 + (let (results) + (dotimes (k 1000) + (let* ((x (random (scale-float 1d0 1023))) + (s-exp (sin x)) + (c-exp (cos x))) + (multiple-value-bind (s c) + (kernel::%sincos x) + (unless (and (= s s-exp) + (= c c-exp)) + (push (list x + (list s s-exp) + (list c c-exp)) + results))))) + results) + nil) commit e6a9577f0093b72d5d5e0c90cb0930df6a16bb8b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 14 20:35:56 2013 -0800 Implement trig functions in Lisp code/irrat.lisp:: * Add Lisp implementation for sin, cos, and tan, based on code from fdlibm. Requires the C reduction routines. Only working so far on systems that already include the reduction routies. tests/trig.lisp:: * Tests for the new sin, cos, and tan functions. Tests pass on x86/darwin. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 270f1dc..660c519 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -187,30 +187,6 @@ (%sqrt x)) ) -;;; The standard libm routines for sin, cos, and tan on x86 (Linux, -;;; 32-bit. 64-bit is apparently ok) and ppc are not very accurate -;;; for large arguments when compared to sparc (and maxima). This is -;;; basically caused by the fact that those libraries do not do an -;;; accurate argument reduction. The following functions use some -;;; routines Sun's free fdlibm library to do accurate reduction. Then -;;; we call the standard C functions (or vops for x86) on the reduced -;;; argument. This produces much more accurate values. -;;; -;;; You can test this by computing (cos (scale-float 1d0 120)). The -;;; true answer is -0.9258790228548379d0. - -#+(or ppc x86) -(progn -(declaim (inline %%ieee754-rem-pi/2)) -;; Basic argument reduction routine. It returns two values: n and y -;; such that (n + 8*k)*pi/2+y = x where |y|<pi/4 and n indicates in -;; which octant the arg lies. Y is actually computed in two parts, -;; y[0] and y[1] such that the sum is y, for accuracy. - -(alien:def-alien-routine ("__ieee754_rem_pio2" %%ieee754-rem-pi/2) c-call:int - (x double-float) - (y (* double-float))) - ;; Same as above, but instead of needing to pass an array in, the ;; output array is broken up into two output values instead. This is ;; easier for the user, and we don't have to wrap calls with @@ -221,93 +197,402 @@ (y0 double-float :out) (y1 double-float :out)) -) - -;; If the C library is accurate, use %trig as the Lisp name. -#-(or ppc (and sse2 (not darwin))) -(progn -(declaim (inline %sin %cos %tan)) -(macrolet ((frob (alien-name lisp-name) - `(alien:def-alien-routine (,alien-name ,lisp-name) double-float - (x double-float)))) - (frob "sin" %sin) - (frob "cos" %cos) - (frob "tan" %tan)) -) +;; Implement sin/cos/tan in Lisp. These are based on the routines +;; from fdlibm. -;; Make %%trig be the C library routines that don't do accurate -;; reduction. This is for PPC and for any SSE2 build except on -;; Darwin. Darwin has accurate C library routines. -#+(or ppc (and sse2 (not darwin))) -(progn -(declaim (inline %%sin %%cos %%tan)) -(macrolet ((frob (alien-name lisp-name) - `(alien:def-alien-routine (,alien-name ,lisp-name) double-float - (x double-float)))) - (frob "sin" %%sin) - (frob "cos" %%cos) - (frob "tan" %%tan)) -) +;; Block compile so the trig routines don't cons their args when +;; calling the kernel trig routines. +(declaim (ext:start-block kernel-sin kernel-cos kernel-tan %sin %cos %tan)) -;; When the C library is not accurate, define %trig to do accurate -;; argument reduction and call the appropriate C function on the -;; reduced arg. For x87, we can use the x87 FPU trig instructions. -#+(or ppc (and x86 (not darwin))) -(macrolet - ((frob (sin cos tan) - `(progn - ;; In all of the routines below, we just compute the sum of - ;; y0 and y1 and use that as the (reduced) argument for the - ;; trig functions. This is slightly less accurate than what - ;; fdlibm does, which calls special functions using y0 and - ;; y1 separately, for greater accuracy. This isn't - ;; implemented, and some spot checks indicate that what we - ;; have here is accurate. - ;; - ;; For x86 with an fsin/fcos/fptan instruction, the pi/4 is - ;; probably too restrictive. - (defun %sin (x) - (declare (double-float x)) - (if (< (abs x) (/ pi 4)) - (,sin x) - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (let ((reduced (+ y0 y1))) - (case (logand n 3) - (0 (,sin reduced)) - (1 (,cos reduced)) - (2 (- (,sin reduced))) - (3 (- (,cos reduced)))))))) - (defun %cos (x) - (declare (double-float x)) - (if (< (abs x) (/ pi 4)) - (,cos x) - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (let ((reduced (+ y0 y1))) - (case (logand n 3) - (0 (,cos reduced)) - (1 (- (,sin reduced))) - (2 (- (,cos reduced))) - (3 (,sin reduced))))))) - (defun %tan (x) - (declare (double-float x)) - (if (< (abs x) (/ pi 4)) - (,tan x) - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (let ((reduced (+ y0 y1))) - (if (evenp n) - (,tan reduced) - (- (/ (,tan reduced))))))))))) - ;; Don't want %sin-quick and friends with sse2. - #+(and x86 (not sse2)) - (frob %sin-quick %cos-quick %tan-quick) - #+(or ppc sse2) - (frob %%sin %%cos %%tan)) +;; kernel sin function on [-pi/4, pi/4], pi/4 ~ 0.7854 +;; Input x is assumed to be bounded by ~pi/4 in magnitude. +;; Input y is the tail of x. +;; Input iy indicates whether y is 0. (if iy=0, y assume to be 0). +;; +;; Algorithm +;; 1. Since sin(-x) = -sin(x), we need only to consider positive x. +;; 2. if x < 2^-27 (hx<0x3e400000 0), return x with inexact if x!=0. +;; 3. sin(x) is approximated by a polynomial of degree 13 on +;; [0,pi/4] +;; 3 13 +;; sin(x) ~ x + S1*x + ... + S6*x +;; where +;; +;; |sin(x) 2 4 6 8 10 12 | -58 +;; |----- - (1+S1*x +S2*x +S3*x +S4*x +S5*x +S6*x )| <= 2 +;; | x | +;; +;; 4. sin(x+y) = sin(x) + sin'(x')*y +;; ~ sin(x) + (1-x*x/2)*y +;; For better accuracy, let +;; 3 2 2 2 2 +;; r = x *(S2+x *(S3+x *(S4+x *(S5+x *S6)))) +;; then 3 2 +;; sin(x) = x + (S1*x + (x *(r-y/2)+y)) + +(declaim (ftype (function (double-float double-float fixnum) + double-float) + kernel-sin)) + +(defun kernel-sin (x y iy) + (declare (type (double-float -1d0 1d0) x y) + (fixnum iy) + (optimize (speed 3) (safety 0))) + (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) + (when (< ix #x3e400000) + (if (zerop (truncate x)) + (return-from kernel-sin x) + (return-from kernel-sin x))) + (let* ((s1 -1.66666666666666324348d-01) + (s2 8.33333333332248946124d-03) + (s3 -1.98412698298579493134d-04) + (s4 2.75573137070700676789d-06) + (s5 -2.50507602534068634195d-08) + (s6 1.58969099521155010221d-10) + (z (* x x)) + (v (* z x)) + (r (+ s2 + (* z + (+ s3 + (* z + (+ s4 + (* z + (+ s5 + (* z s6)))))))))) + (if (zerop iy) + (+ x (* v (+ s1 (* z r)))) + (- x (- (- (* z (- (* .5 y) + (* v r))) + y) + (* v s1))))))) + +;; kernel cos function on [-pi/4, pi/4], pi/4 ~ 0.785398164 +;; Input x is assumed to be bounded by ~pi/4 in magnitude. +;; Input y is the tail of x. +;; +;; Algorithm +;; 1. Since cos(-x) = cos(x), we need only to consider positive x. +;; 2. if x < 2^-27 (hx<0x3e400000 0), return 1 with inexact if x!=0. +;; 3. cos(x) is approximated by a polynomial of degree 14 on +;; [0,pi/4] +;; 4 14 +;; cos(x) ~ 1 - x*x/2 + C1*x + ... + C6*x +;; where the remez error is +;; +;; | 2 4 6 8 10 12 14 | -58 +;; |cos(x)-(1-.5*x +C1*x +C2*x +C3*x +C4*x +C5*x +C6*x )| <= 2 +;; | | +;; +;; 4 6 8 10 12 14 +;; 4. let r = C1*x +C2*x +C3*x +C4*x +C5*x +C6*x , then +;; cos(x) = 1 - x*x/2 + r +;; since cos(x+y) ~ cos(x) - sin(x)*y +;; ~ cos(x) - x*y, +;; a correction term is necessary in cos(x) and hence +;; cos(x+y) = 1 - (x*x/2 - (r - x*y)) +;; For better accuracy when x > 0.3, let qx = |x|/4 with +;; the last 32 bits mask off, and if x > 0.78125, let qx = 0.28125. +;; Then +;; cos(x+y) = (1-qx) - ((x*x/2-qx) - (r-x*y)). +;; Note that 1-qx and (x*x/2-qx) is EXACT here, and the +;; magnitude of the latter is at least a quarter of x*x/2, +;; thus, reducing the rounding error in the subtraction. +(declaim (ftype (function (double-float double-float) + double-float) + kernel-cos)) + +(defun kernel-cos (x y) + (declare (type (double-float -1d0 1d0) x y) + (optimize (speed 3) (safety 0))) + ;; cos(-x) = cos(x), so we just compute cos(|x|). + (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) + ;; cos(x) = 1 when |x| < 2^-27 + (when (< ix #x3e400000) + ;; Signal inexact if x /= 0 + (if (zerop (truncate x)) + (return-from kernel-cos 1d0) + (return-from kernel-cos 1d0))) + (let* ((c1 4.16666666666666019037d-02) + (c2 -1.38888888888741095749d-03) + (c3 2.48015872894767294178d-05) + (c4 -2.75573143513906633035d-07) + (c5 2.08757232129817482790d-09) + (c6 -1.13596475577881948265d-11) + (z (* x x)) + (r (* z + (+ c1 + (* z + (+ c2 + (* z + (+ c3 + (* z + (+ c4 + (* z + (+ c5 + (* z c6))))))))))))) + (cond ((< ix #x3fd33333) + ;; \x| < 0.3 + (- 1 (- (* .5 z) + (- (* z r) + (* x y))))) + (t + (let* ((qx (if (> ix #x3fe90000) + 0.28125d0 + ;; x/4, exactly, and also dropping the + ;; least significant 32 bits of the + ;; fraction. (Why?) + (kernel:make-double-float (- ix #x00200000) + 0))) + (hz (- (* 0.5 z) qx)) + (a (- 1 qx))) + (- a (- hz (- (* z r) + (* x y)))))))))) + +(declaim (type (simple-array double-float (*)) tan-coef)) +(defconstant tan-coef + (make-array 13 :element-type 'double-float + :initial-contents + '(3.33333333333334091986d-01 + 1.33333333333201242699d-01 + 5.39682539762260521377d-02 + 2.18694882948595424599d-02 + 8.86323982359930005737d-03 + 3.59207910759131235356d-03 + 1.45620945432529025516d-03 + 5.88041240820264096874d-04 + 2.46463134818469906812d-04 + 7.81794442939557092300d-05 + 7.14072491382608190305d-05 + -1.85586374855275456654d-05 + 2.59073051863633712884d-05))) + +;; kernel tan function on [-pi/4, pi/4], pi/4 ~ 0.7854 +;; Input x is assumed to be bounded by ~pi/4 in magnitude. +;; Input y is the tail of x. +;; Input k indicates whether tan (if k = 1) or -1/tan (if k = -1) is returned. +;; +;; Algorithm +;; 1. Since tan(-x) = -tan(x), we need only to consider positive x. +;; 2. if x < 2^-28 (hx<0x3e300000 0), return x with inexact if x!=0. +;; 3. tan(x) is approximated by a odd polynomial of degree 27 on +;; [0,0.67434] +;; 3 27 +;; tan(x) ~ x + T1*x + ... + T13*x +;; where +;; +;; |tan(x) 2 4 26 | -59.2 +;; |----- - (1+T1*x +T2*x +.... +T13*x )| <= 2 +;; | x | +;; +;; Note: tan(x+y) = tan(x) + tan'(x)*y +;; ~ tan(x) + (1+x*x)*y +;; Therefore, for better accuracy in computing tan(x+y), let +;; 3 2 2 2 2 +;; r = x *(T2+x *(T3+x *(...+x *(T12+x *T13)))) +;; then +;; 3 2 +;; tan(x+y) = x + (T1*x + (x *(r+y)+y)) +;; +;; 4. For x in [0.67434,pi/4], let y = pi/4 - x, then +;; tan(x) = tan(pi/4-y) = (1-tan(y))/(1+tan(y)) +;; = 1 - 2*(tan(y) - (tan(y)^2)/(1+tan(y))) +(declaim (ftype (function (double-float double-float fixnum) + double-float) + kernel-tan)) + +(defun kernel-tan (x y iy) + (declare (type (double-float -1d0 1d0) x y) + (type (member -1 1) iy) + (optimize (speed 3) (safety 0))) + (let* ((hx (kernel:double-float-high-bits x)) + (ix (logand hx #x7fffffff)) + (w 0d0) + (z 0d0) + (v 0d0) + (s 0d0) + (r 0d0)) + (declare (double-float w z v s r)) + (when (< ix #x3e300000) + ;; |x| < 2^-28 + (when (zerop (truncate x)) + (cond ((zerop (logior (logior ix (kernel:double-float-low-bits x)) + (+ iy 1))) + ;; x = 0 and iy = -1 (cot) + (return-from kernel-tan (/ (abs x)))) + ((= iy 1) + (return-from kernel-tan x)) + (t + ;; x /= 0 and iy = -1 (cot) + ;; Compute -1/(x+y) carefully + (let ((a 0d0) + (tt 0d0)) + (setf w (+ x y)) + (setf z (kernel:make-double-float (kernel:double-float-high-bits w) 0)) + (setf v (- y (- z x))) + (setf a (/ -1 w)) + (setf tt (kernel:make-double-float (kernel:double-float-high-bits a) 0)) + (setf s (+ 1 (* tt z))) + (return-from kernel-tan (+ tt + (* a (+ s (* tt v)))))))))) + (when (>= ix #x3FE59428) + ;; |x| > .6744 + (when (minusp hx) + (setf x (- x)) + (setf y (- y))) + ;; z = pi/4-x + (setf z (- (kernel:make-double-float #x3FE921FB #x54442D18) x)) + ;; w = pi/4_lo - y + (setf w (- (kernel:make-double-float #x3C81A626 #x33145C07) y)) + (setf x (+ z w)) + (setf y 0d0)) + (setf z (* x x)) + (setf w (* z z)) + ;; Break x^5*(T[1]+x^2*T[2]+...) into + ;; x^5(T[1]+x^4*T[3]+...+x^20*T[11]) + + ;; x^5(x^2*(T[2]+x^4*T[4]+...+x^22*[T12])) + (setf r (+ (aref tan-coef 1) + (* w + (+ (aref tan-coef 3) + (* w + (+ (aref tan-coef 5) + (* w + (+ (aref tan-coef 7) + (* w + (+ (aref tan-coef 9) + (* w (aref tan-coef 11)))))))))))) + (setf v (* z + (+ (aref tan-coef 2) + (* w + (+ (aref tan-coef 4) + (* w + (+ (aref tan-coef 6) + (* w + (+ (aref tan-coef 8) + (* w + (+ (aref tan-coef 10) + (* w (aref tan-coef 12))))))))))))) + (setf s (* z x)) + (setf r (+ y (* z (+ (* s (+ r v)) + y)))) + (incf r (* s (aref tan-coef 0))) + (setf w (+ x r)) + (when (>= ix #x3FE59428) + (let ((v (float iy 1d0))) + (return-from kernel-tan + (* (- 1 (logand 2 (ash hx -30))) + (- v + (* 2 + (- x (- (/ (* w w) + (+ w v)) + r)))))))) + (when (= iy 1) + (return-from kernel-tan w)) + ;; + (let ((a 0d0) + (tt 0d0)) + (setf z (kernel:make-double-float (kernel:double-float-high-bits w) 0)) + (setf v (- r (- r x))) ; z + v = r + x + (setf a (/ -1 w)) + (setf tt (kernel:make-double-float (kernel:double-float-high-bits a) 0)) + (setf s (+ 1 (* tt z))) + (+ tt + (* a + (+ s (* tt v))))))) + +;; Return sine function of x. +;; +;; kernel function: +;; __kernel_sin ... sine function on [-pi/4,pi/4] +;; __kernel_cos ... cose function on [-pi/4,pi/4] +;; __ieee754_rem_pio2 ... argument reduction routine +;; +;; Method. +;; Let S,C and T denote the sin, cos and tan respectively on +;; [-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2 +;; in [-pi/4 , +pi/4], and let n = k mod 4. +;; We have +;; +;; n sin(x) cos(x) tan(x) +;; ---------------------------------------------------------- +;; 0 S C T +;; 1 C -S -1/T +;; 2 -S -C T +;; 3 -C S -1/T +;; ---------------------------------------------------------- +;; +;; Special cases: +;; Let trig be any of sin, cos, or tan. +;; trig(+-INF) is NaN, with signals; +;; trig(NaN) is that NaN; +;; +;; Accuracy: +;; TRIG(x) returns trig(x) nearly rounded +(defun %sin (x) + (declare (double-float x) + (optimize (speed 3))) + (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) + (cond + ((<= ix #x3fe921fb) + ;; |x| < pi/4, approx + (kernel-sin x 0d0 0)) + ((>= ix #x7ff00000) + ;; sin(Inf or NaN) is NaN + (- x x)) + (t + ;; Argument reduction needed + (multiple-value-bind (n y0 y1) + (kernel::%ieee754-rem-pi/2 x) + (case (logand n 3) + (0 + (kernel-sin y0 y1 1)) + (1 + (kernel-cos y0 y1)) + (2 + (- (kernel-sin y0 y1 1))) + (3 + (- (kernel-cos y0 y1))))))))) + +(defun %cos (x) + (declare (double-float x) + (optimize (speed 3))) + (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) + (cond + ((< ix #x3fe921fb) + ;;|x| < pi/4, approx + (kernel-cos x 0d0)) + ((>= ix #x7ff00000) + ;; cos(Inf or NaN) is NaN + (- x x)) + (t + ;; Argument reduction needed + (multiple-value-bind (n y0 y1) + (kernel::%ieee754-rem-pi/2 x) + (ecase (logand n 3) + (0 + (kernel-cos y0 y1)) + (1 + (- (kernel-sin y0 y1 1))) + (2 + (- (kernel-cos y0 y1))) + (3 + (kernel-sin y0 y1 1)))))))) + +(defun %tan (x) + (declare (double-float x) + (optimize (speed 3))) + (let ((ix (logand #x7fffffff (kernel:double-float-high-bits x)))) + (cond ((<= ix #x3fe921fb) + (kernel-tan x 0d0 1)) + ((>= ix #x7ff00000) + (- x x)) + (t + (multiple-value-bind (n y0 y1) + (kernel::%ieee754-rem-pi/2 x) + (let ((flag (- 1 (ash (logand n 1) 1)))) + ;; flag = 1 if n even, -1 if n odd + (kernel-tan y0 y1 flag))))))) + +(declaim (ext:end-block)) ;; Linux and sparc have a sincos function in the C library. Use it. ;; But on linux we need to do pi reduction ourselves because the C diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp new file mode 100644 index 0000000..49f16fb --- /dev/null +++ b/src/tests/trig.lisp @@ -0,0 +1,143 @@ +(rt:deftest sin.1 + (sin 0d0) + 0d0) + +(rt:deftest sin.2 + (sin -0d0) + -0d0) + +(rt:deftest sin.3 + ;; Tests the case for |x| < 2^-27, but not 0. + (sin (scale-float 1d0 -28)) + #.(scale-float 1d0 -28)) + +(rt:deftest sin.4 + ;; Just a random test, without argument reduction + (sin .5d0) + 0.479425538604203d0) + +(rt:deftest sin.5 + ;; Test for arg near pi/2 + (sin (/ pi 2)) + 1d0) + +(rt:deftest sin.red.0 + ;; Test for argument reduction with n mod 4 = 0 + (sin (* 7/4 pi)) + -7.07106781186547675943154203316156531867416581156d-1) + +(rt:deftest sin.red.1 + ;; Test for argument reduction with n mod 4 = 1 + (sin (* 9/4 pi)) + 7.07106781186547329560731709118834541043171055432d-1) + +(rt:deftest sin.red.2 + ;; Test for argument reduction with n mod 4 = 2 + (sin (* 11/4 pi)) + 7.07106781186548390575743300374993861263439430213d-1) + +(rt:deftest sin.red.3 + ;; Test for argument reduction with n mod 4 = 3 + (sin (* 13/4 pi)) + -7.07106781186547871002109559079472349116005337743d-1) + +(rt:deftest sin.misc.1 + ;; Test for argument reduction + (sin (scale-float 1d0 120)) + 0.377820109360752d0) + +(rt:deftest cos.1 + (cos 0d0) + 1d0) + +(rt:deftest cos.2 + (cos -0d0) + 1d0) + +(rt:deftest cos.3 + ;; Test for |x| < 2^-27 + (cos (scale-float 1d0 -28)) + 1d0) + +(rt:deftest cos.4 + ;; Test for branch |x| < .3 + (cos 0.25d0) + 0.9689124217106447d0) + +(rt:deftest cos.5 + ;; Test for branch |x| > .3 and \x| < .78125 + (cos 0.5d0) + 8.7758256189037271611628158260382965199164519711d-1) + +(rt:deftest cos.6 + ;; Test for branch |x| > .3 and |x| > .78125 + (cos 0.785d0) + 0.7073882691671998d0) + +(rt:deftest cos.7 + ;; Random test near pi/2 + (cos (/ pi 2)) + 6.123233995736766d-17) + +(rt:deftest cos.misc.1 + ;; Test for argument reduction + (cos (scale-float 1d0 120)) + -0.9258790228548379d0) + +(rt:deftest cos.red.0 + ;; Test for argument reduction with n mod 4 = 0 + (cos (* 7/4 pi)) + 7.07106781186547372858534520893509069186435867941d-1) + +(rt:deftest cos.red.1 + ;; Test for argument reduction with n mod 4 = 1 + (cos (* 9/4 pi)) + 7.0710678118654771924095701509080985020443197242d-1) + +(rt:deftest cos.red.2 + ;; Test for argument reduction with n mod 4 = 2 + (cos (* 11/4 pi)) + -7.07106781186546658225945423833643190916000739026d-1) + +(rt:deftest cos.red.3 + ;; Test for argument reduction with n mod 4 = 3 + (cos (* 13/4 pi)) + -7.07106781186547177799579165130055836531929091466d-1) + +(rt:deftest tan.1 + (tan 0d0) + 0d0) + +(rt:deftest tan.2 + (tan -0d0) + -0d0) + +(rt:deftest tan.3 + ;; |x| < 2^-28 + (tan (scale-float 1d0 -29)) + #.(scale-float 1d0 -29)) + +(rt:deftest tan.4 + ;; |x| < .6744 + (tan 0.5d0) + 5.4630248984379051325517946578028538329755172018d-1) + +(rt:deftest tan.5 + ;; |x = 11/16 = 0.6875 > .6744 + (tan (float 11/16 1d0)) + 8.21141801589894121911423965374711700875371645309d-1) + +(rt:deftest tan.red.0 + ;; Test for argument reduction with n even + (tan (* 7/4 pi)) + -1.00000000000000042862637970157370388940976433505d0) + +(rt:deftest tan.red.1 + ;; Test for argument reduction with n odd + (tan (* 9/4 pi)) + 9.99999999999999448908940383691222098948324989275d-1) + +(rt:deftest tan.misc.1 + (tan (scale-float 1d0 120)) + -4.08066388841804238545143494525595117765084022768d-1) + commit 32bdd53bf002fca1c9ad6b543d522a6558cae768 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 14 20:22:40 2013 -0800 Add RT. src/contrib/rt:: * Add RT code, including asdf. src/code/module.lisp:: * Add RT as a module diff --git a/src/code/module.lisp b/src/code/module.lisp index 70ccba7..42b0ac2 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -148,6 +148,12 @@ (defmodule "asdf" "modules:asdf/asdf") +(defmodule :rt + "modules:rt/rt") + +(defmodule "rt" + "modules:rt/rt") + ;; Allow user to specify "cmu-contribs" or :cmu-contribs. (defmodule "cmu-contribs" "modules:contrib") diff --git a/src/contrib/rt/rt.asd b/src/contrib/rt/rt.asd new file mode 100644 index 0000000..718e965 --- /dev/null +++ b/src/contrib/rt/rt.asd @@ -0,0 +1,33 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: rt.asd +;;;; Purpose: ASDF definition file for Rt +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of cl-rt, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; cl-rt users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU Lesser General Public License +;;;; (http://www.gnu.org/licenses/lgpl.html) +;;;; ************************************************************************* + +(in-package :asdf) + +(defsystem :rt + :name "cl-rt" + :version "1990.12.19" + :maintainer "Kevin M. Rosenberg <kmr(a)debian.org>" + :licence "MIT" + :description "MIT Regression Tester" + :long-description "RT provides a framework for writing regression test suites" + :perform (load-op :after (op rt) + (pushnew :rt cl:*features*)) + :components + ((:file "rt"))) + + diff --git a/src/contrib/rt/rt.lisp b/src/contrib/rt/rt.lisp new file mode 100644 index 0000000..3df87c4 --- /dev/null +++ b/src/contrib/rt/rt.lisp @@ -0,0 +1,409 @@ +;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +(defpackage #:regression-test + (:nicknames #:rtest #-lispworks #:rt) + (:use #:cl) + (:export #:*do-tests-when-defined* #:*test* #:continue-testing + #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) + (:documentation "The MIT regression tester with pfdietz's modifications")) + +;;This was the December 19, 1990 version of the regression tester, but +;;has since been modified. + +(in-package :regression-test) + +(declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) +(declaim (type list *entries*)) +(declaim (ftype (function (t &rest t) t) report-error)) +(declaim (ftype (function (t &optional t) t) do-entry)) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.") +(defvar *entries-tail* *entries* "Tail of the *entries* list") +(defvar *entries-table* (make-hash-table :test #'equal) + "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") + +(defvar *compile-tests* nil "When true, compile the tests before running them.") +(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") +(defvar *optimization-settings* '((safety 3))) + +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defvar *notes* (make-hash-table :test 'equal) + "A mapping from names of notes to note objects.") + +(defstruct (entry (:conc-name nil)) + pend name props form vals) + +;;; Note objects are used to attach information to tests. +;;; A typical use is to mark tests that depend on a particular +;;; part of a set of requirements, or a particular interpretation +;;; of the requirements. + +(defstruct note + name + contents + disabled ;; When true, tests with this note are considered inactive + ) + +;; (defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) + (let ((var (gensym))) + `(let ((,var ,entry)) + (list* (name ,var) (form ,var) (vals ,var))))) + +(defun entry-notes (entry) + (let* ((props (props entry)) + (notes (getf props :notes))) + (if (listp notes) + notes + (list notes)))) + +(defun has-disabled-note (entry) + (let ((notes (entry-notes entry))) + (loop for n in notes + for note = (if (note-p n) n + (gethash n *notes*)) + thereis (and note (note-disabled note))))) + +(defun pending-tests () + (loop for entry in (cdr *entries*) + when (and (pend entry) (not (has-disabled-note entry))) + collect (name entry))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + (setq *entries-tail* *entries*) + (clrhash *entries-table*) + nil) + +(defun rem-test (&optional (name *test*)) + (let ((pred (gethash name *entries-table*))) + (when pred + (if (null (cddr pred)) + (setq *entries-tail* pred) + (setf (gethash (name (caddr pred)) *entries-table*) pred)) + (setf (cdr pred) (cddr pred)) + (remhash name *entries-table*) + name))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry ;; (find name (the list (cdr *entries*)) + ;; :key #'name :test #'equal) + (cadr (gethash name *entries-table*)) + )) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name &rest body) + (let* ((p body) + (properties + (loop while (keywordp (first p)) + unless (cadr p) + do (error "Poorly formed deftest: ~A~%" + (list* 'deftest name body)) + append (list (pop p) (pop p)))) + (form (pop p)) + (vals p)) + `(add-entry (make-entry :pend t + :name ',name + :props ',properties + :form ',form + :vals ',vals)))) + +(defun add-entry (entry) + (setq entry (copy-entry entry)) + (let* ((pred (gethash (name entry) *entries-table*))) + (cond + (pred + (setf (cadr pred) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry))) + (t + (setf (gethash (name entry) *entries-table*) *entries-tail*) + (setf (cdr *entries-tail*) (cons entry nil)) + (setf *entries-tail* (cdr *entries-tail*)) + ))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args))) + nil) + +(defun do-test (&optional (name *test*)) + #-sbcl (do-entry (get-entry name)) + #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) + (do-entry (get-entry name)))) + +(defun my-aref (a &rest args) + (apply #'aref a args)) + +(defun my-row-major-aref (a index) + (row-major-aref a index)) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters. + Currently doesn't work on arrays of dimension > 2." + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (my-aref x) (my-aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for i from 0 below x-len + for e1 = (my-aref x i) + for e2 = (my-aref y i) + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (my-row-major-aref x i) + (my-row-major-aref y i)))))) + + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (cond + (*compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry)))))) + (*expanded-eval* + (multiple-value-list + (expanded-eval (form entry)))) + (t + (multiple-value-list + (eval (form entry))))))) + (if *catch-errors* + (handler-bind + (#-ecl (style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (handler-case + (let ((st (format nil "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))) + (format s "~A" st)) + (error () (format s "Actual value: #<error during printing>~%") + )) + (finish-output s) + )))) + (when (not (pend entry)) *test*)) + +(defun expanded-eval (form) + "Split off top level of a form and eval separately. This reduces the chance that + compiler optimizations will fold away runtime computation." + (if (not (consp form)) + (eval form) + (let ((op (car form))) + (cond + ((eq op 'let) + (let* ((bindings (loop for b in (cadr form) + collect (if (consp b) b (list b nil)))) + (vars (mapcar #'car bindings)) + (binding-forms (mapcar #'cadr bindings))) + (apply + (the function + (eval `(lambda ,vars ,@(cddr form)))) + (mapcar #'eval binding-forms)))) + ((and (eq op 'let*) (cadr form)) + (let* ((bindings (loop for b in (cadr form) + collect (if (consp b) b (list b nil)))) + (vars (mapcar #'car bindings)) + (binding-forms (mapcar #'cadr bindings))) + (funcall + (the function + (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))) + (eval (car binding-forms))))) + ((eq op 'progn) + (loop for e on (cdr form) + do (if (null (cdr e)) (return (eval (car e))) + (eval (car e))))) + ((and (symbolp op) (fboundp op) + (not (macro-function op)) + (not (special-operator-p op))) + (apply (symbol-function op) + (mapcar #'eval (cdr form)))) + (t (eval form)))))) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries* (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (the list (cdr *entries*)) :key #'pend) + (length (cdr *entries*))) + (finish-output s) + (dolist (entry (cdr *entries*)) + (when (and (pend entry) + (not (has-disabled-note entry))) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)) + (finish-output s) + )) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (finish-output s) + (null pending)))) + +(defun do-entries (s) + #-sbcl (do-entries* s) + #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) + (do-entries* s))) + +;;; Note handling functions and macros + +(defmacro defnote (name contents &optional disabled) + `(eval-when (:load-toplevel :execute) + (let ((note (make-note :name ',name + :contents ',contents + :disabled ',disabled))) + (setf (gethash (note-name note) *notes*) note) + note))) + +(defun disable-note (n) + (let ((note (if (note-p n) n + (setf n (gethash n *notes*))))) + (unless note (error "~A is not a note or note name." n)) + (setf (note-disabled note) t) + note)) + +(defun enable-note (n) + (let ((note (if (note-p n) n + (setf n (gethash n *notes*))))) + (unless note (error "~A is not a note or note name." n)) + (setf (note-disabled note) nil) + note)) ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-94-g8af0300
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 8af0300cad9ffa57cde0dd5a0378ff762cf4cdec (commit) from b424b78d3e33bf8438a364920c5a2987aa0cacb8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8af0300cad9ffa57cde0dd5a0378ff762cf4cdec Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Aug 4 19:00:43 2014 -0700 Update LDFLAGS for NetBSD so motifd will build and run correctly on NetBSD. Reported by Robert Swindells who also provided the fix. diff --git a/src/motif/server/Config.NetBSD b/src/motif/server/Config.NetBSD index 7c58488..83591ac 100644 --- a/src/motif/server/Config.NetBSD +++ b/src/motif/server/Config.NetBSD @@ -1,5 +1,5 @@ CFLAGS = -O2 -I/usr/pkg/include -I/usr/X11R7/include -I. -I$(VPATH) -LDFLAGS = -L/usr/X11R7/lib -L/usr/pkg/lib +LDFLAGS = -R/usr/X11R7/lib -L/usr/X11R7/lib -R/usr/pkg/lib -L/usr/pkg/lib LIBS = -lXm -lXt -lXext -lX11 -lSM -lICE -lXp # This def assumes you are building in the same or parallel # tree to the CVS souce layout. Sites may need to customize ----------------------------------------------------------------------- Summary of changes: src/motif/server/Config.NetBSD | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-09-2-g7e2a98e
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 7e2a98eea48abc007e74490fa099da019b440ddc (commit) from 44abdb520938a95395c7b1ba00148d65d4db6aac (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 7e2a98eea48abc007e74490fa099da019b440ddc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Sep 11 19:51:29 2013 -0700 Allow disabling the use of git for the file-comment. * src/compiler/main.lisp: * Add *FILE-COMMENT-FROM-GIT* to control whether to use git to derive the file-comment. Default is T. Otherwise, the actual file-comment is used. * Update PROCESS-FILE-COMMENT to use *FILE-COMMENT-FROM-GIT*. * bin/build-all.sh * bin/build.sh * bin/build-world.sh * Add -G option to control whether file-comment's are derived from git. diff --git a/bin/build-all.sh b/bin/build-all.sh index d5823af..0bf6ed5 100755 --- a/bin/build-all.sh +++ b/bin/build-all.sh @@ -35,12 +35,13 @@ usage () echo " -P On the last build, (re)generate cmucl.pot and the" echo " translations" echo " -R Force recompilation of C runtime" + echo " -G Don't use git to fill file-comment information" } CREATE_OPT="" UPDATE_POT="-P" -while getopts "PRUB:b:v:C:o:8:?" arg +while getopts "PRUGB:b:v:C:o:8:?" arg do case $arg in b) BASE="$OPTARG" ;; @@ -53,6 +54,7 @@ do U) UPDATE_TRANS="-U" ;; P) UPDATE_POT="" ;; R) RECOMPILEC="-R" ;; + G) GIT_FILE_COMMENT="-G" ;; \?) usage; exit 1 ;; esac done @@ -87,15 +89,15 @@ buildx86 () if [ -n "$OLD8" ]; then # Build non-unicode versions set -x - $BINDIR/build.sh -f x87 -b ${BASE}-8bit $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} -o "$OLD8" - $BINDIR/build.sh -f sse2 -b ${BASE}-8bit $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} -o "$OLD8" + $BINDIR/build.sh -f x87 -b ${BASE}-8bit $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLD8" + $BINDIR/build.sh -f sse2 -b ${BASE}-8bit $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLD8" set +x fi # Build the unicode versions if [ -n "$OLDLISP" ]; then set -x - $BINDIR/build.sh -f x87 -b ${BASE} $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} -o "$OLDLISP" - $BINDIR/build.sh -f sse2 -b ${BASE} $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} -o "$OLDLISP" + $BINDIR/build.sh -f x87 -b ${BASE} $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLDLISP" + $BINDIR/build.sh -f sse2 -b ${BASE} $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLDLISP" set +x fi } @@ -108,13 +110,13 @@ buildsun4 () # Build non-unicode versions if [ -n "$OLD8" ]; then set -x - $BINDIR/build.sh -b ${BASE}-8bit $bootfiles ${VERS} -C "$CREATE_OPT" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} -o "$OLD8" + $BINDIR/build.sh -b ${BASE}-8bit $bootfiles ${VERS} -C "$CREATE_OPT" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLD8" set +x fi # Build the unicode version. if [ -n "$OLDLISP" ]; then set -x - $BINDIR/build.sh -b ${BASE} $bootfiles ${VERS} -C "$CREATE_OPT" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} -o "$OLDLISP" + $BINDIR/build.sh -b ${BASE} $bootfiles ${VERS} -C "$CREATE_OPT" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLDLISP" set +x fi } diff --git a/bin/build-world.sh b/bin/build-world.sh index f354915..8a20911 100755 --- a/bin/build-world.sh +++ b/bin/build-world.sh @@ -26,6 +26,12 @@ if [ -n "$MAKE_POT" ]; then SAVEPOT='(intl::dump-pot-files :output-directory "default:src/i18n/locale/")' fi +if [ "$GIT_FILE_COMMENT" = "no" ]; then + GIT_FILE_COMMENT="(setf c::*file-comment-from-git* nil)" +else + GIT_FILE_COMMENT= +fi + $LISP "$@" -noinit -nositeinit <<EOF (in-package :cl-user) @@ -56,6 +62,8 @@ $LISP "$@" -noinit -nositeinit <<EOF (setq debug:*debug-print-level* nil) (setq debug:*debug-print-length* nil) +$GIT_FILE_COMMENT + (load "target:tools/worldcom") #-(or no-compiler runtime) (load "target:tools/comcom") ;; Compile at least new-genesis, so that genesis doesn't take ages @@ -64,7 +72,6 @@ $LISP "$@" -noinit -nositeinit <<EOF $GETFMT $SAVEPOT - (setq *gc-verbose* t *interactive* t) (load "target:tools/worldbuild") diff --git a/bin/build.sh b/bin/build.sh index 4aa8f24..9be48e4 100755 --- a/bin/build.sh +++ b/bin/build.sh @@ -45,6 +45,8 @@ BINDIR=bin TOOLDIR=$BINDIR OLDLISPFLAGS="-noinit -nositeinit" OLDLISP="cmulisp" +GIT_FILE_COMMENT="yes" +export GIT_FILE_COMMENT SKIPUTILS=no @@ -66,7 +68,7 @@ fi usage () { - echo "build.sh [-123obvuBCU?]" + echo "build.sh [-123obvuBCUG?]" echo " -1 Skip build 1" echo " -2 Skip build 2" echo " -3 Skip build 3" @@ -96,6 +98,7 @@ usage () echo " The flags always include -noinit -nositeinit" echo " -R Force recompiling the C runtime. Normally, just runs make to " echo " recompile anything that has changed." + echo " -G Don't use git to fill file-comment information" exit 1 } @@ -152,7 +155,7 @@ BUILDWORLD="$TOOLDIR/build-world.sh" BUILD_POT="yes" UPDATE_TRANS= -while getopts "123PRo:b:v:uB:C:Ui:f:w:O:?" arg +while getopts "123PRGo:b:v:uB:C:Ui:f:w:O:?" arg do case $arg in 1) ENABLE2="no" ;; @@ -172,6 +175,7 @@ do U) UPDATE_TRANS="yes";; O) OLDLISPFLAGS="$OLDLISPFLAGS $OPTARG" ;; R) REBUILD_LISP="yes";; + G) GIT_FILE_COMMENT="no";; \?) usage ;; esac diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index cba62e9..6abe478 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1094,34 +1094,41 @@ ;;; ;;; Stash file comment in the file-info structure. ;;; + +(defvar *file-comment-from-git* t + "If non-Nil, use git to derive the file-comment. This info includes + the sha1 hash, the time and the author of the change. Otherwise, + just use the supplied file-comment.") + (defun process-file-comment (form) (unless (and (= (length form) 2) (stringp (second form))) (compiler-error _N"Bad FILE-COMMENT form: ~S." form)) (let ((file (first (source-info-current-file *source-info*)))) (labels ((run-git (path) - (let ((cwd (default-directory)) - (new (make-pathname :directory (pathname-directory path)))) - (unwind-protect - (progn - ;; Cd to the directory containing the file so that - ;; git can find the git repo, if available. - (setf (default-directory) new) - ;; Run git to get the info. Don't signal any - ;; errors if we can't find git and discard any - ;; error messages from git. We only use the - ;; result if git returns a zero exit code, anyway. - (handler-case - (run-program "git" - (list "log" - "-1" - "--pretty=format:%h %ai %an" - (namestring path)) - :output :stream - :error nil) - (error () - nil))) - (setf (default-directory) cwd)))) + (when *file-comment-from-git* + (let ((cwd (default-directory)) + (new (make-pathname :directory (pathname-directory path)))) + (unwind-protect + (progn + ;; Cd to the directory containing the file so that + ;; git can find the git repo, if available. + (setf (default-directory) new) + ;; Run git to get the info. Don't signal any + ;; errors if we can't find git and discard any + ;; error messages from git. We only use the + ;; result if git returns a zero exit code, anyway. + (handler-case + (run-program "git" + (list "log" + "-1" + "--pretty=format:%h %ai %an" + (namestring path)) + :output :stream + :error nil) + (error () + nil))) + (setf (default-directory) cwd))))) (generate-comment (file-info) (let* ((name (pathname (source-info-stream file-info))) (proc (run-git name)) ----------------------------------------------------------------------- Summary of changes: bin/build-all.sh | 16 ++++++++------- bin/build-world.sh | 9 ++++++++- bin/build.sh | 8 ++++++-- src/compiler/main.lisp | 51 +++++++++++++++++++++++++++--------------------- 4 files changed, 52 insertions(+), 32 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0