X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=tests%2Fautomated%2Flisp-tests.el;h=66c9272d064133e5a0e6fd8b763df67c2d503438;hp=840afc1041223fa6703f0144d37429f21f226a48;hb=34360e98c9689b0a7eedab93e14df13281141bbd;hpb=cb9f6f4eadc44f1becb32cbbd1db26449e347755

diff --git a/tests/automated/lisp-tests.el b/tests/automated/lisp-tests.el
index 840afc1..66c9272 100644
--- a/tests/automated/lisp-tests.el
+++ b/tests/automated/lisp-tests.el
@@ -22,7 +22,7 @@
 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;; 02111-1307, USA.
 
-;;; Synched up with: not in FSF Emacs.
+;;; Synched up with: Not in FSF.
 
 ;;; Commentary:
 
@@ -119,7 +119,7 @@
 
 (Check-Error wrong-type-argument (nconc 'foo nil))
 
-(dolist (length `(1 2 3 4 1000 2000))
+(dolist (length '(1 2 3 4 1000 2000))
   (Check-Error circular-list (nconc (make-circular-list length) 'foo))
   (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
   (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
@@ -158,7 +158,7 @@
   (Assert (eq (last x 3) (cdr x)))
   (Assert (eq (last x 4) x))
   (Assert (eq (last x 9) x))
-  (Assert (eq (last `(1 . 2) 0) 2))
+  (Assert (eq (last '(1 . 2) 0) 2))
   )
 
 ;;-----------------------------------------------------
@@ -213,7 +213,7 @@
 (Check-Error circular-list (copy-list (make-circular-list 1)))
 (Check-Error circular-list (copy-list (make-circular-list 2000)))
 (Assert (eq '() (copy-list '())))
-(dolist (x `((1) (1 2) (1 2 3) (1 2 . 3)))
+(dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
   (let ((y (copy-list x)))
     (Assert (and (equal x y) (not (eq x y))))))
 
@@ -229,6 +229,8 @@
 (Assert (= (+ 1.0 1) 2.0))
 (Assert (= (+ 1.0 1 1) 3.0))
 (Assert (= (+ 1 1 1.0) 3.0))
+(Assert (eq (1+ most-positive-fixnum) most-negative-fixnum))
+(Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))
 
 ;; Test `-'
 (Check-Error wrong-number-of-arguments (-))
@@ -242,7 +244,7 @@
   (Assert (= (- one one) 0))
   (Assert (= (- one one one) -1))
   (Assert (= (+ one 1) 2))
-  (dolist (zero `(0 0.0 ?\0))
+  (dolist (zero '(0 0.0 ?\0))
     (Assert (= (+ 1 zero) 1))
     (Assert (= (+ zero 1) 1))
     (Assert (= (- zero) zero))
@@ -253,10 +255,13 @@
 (Assert (= (- 1.5 1) .5))
 (Assert (= (- 1 1.5) (- .5)))
 
+(Assert (eq (1- most-negative-fixnum) most-positive-fixnum))
+(Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))
+
 ;; Test `/'
 
 ;; Test division by zero errors
-(dolist (zero `(0 0.0 ?\0))
+(dolist (zero '(0 0.0 ?\0))
   (Check-Error arith-error (/ zero))
   (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
     (Check-Error arith-error (/ n1 zero))
@@ -269,14 +274,14 @@
   (Assert (= (/ (setq x 2))   0))
   (Assert (= (/ (setq x 2.0)) 0.5)))
 
-(dolist (six `(6 6.0 ?\06))
-  (dolist (two `(2 2.0 ?\02))
-    (dolist (three `(3 3.0 ?\03))
+(dolist (six '(6 6.0 ?\06))
+  (dolist (two '(2 2.0 ?\02))
+    (dolist (three '(3 3.0 ?\03))
       (Assert (= (/ six two) three)))))
 
-(dolist (three `(3 3.0 ?\03))
+(dolist (three '(3 3.0 ?\03))
   (Assert (= (/ three 2.0) 1.5)))
-(dolist (two `(2 2.0 ?\02))
+(dolist (two '(2 2.0 ?\02))
   (Assert (= (/ 3.0 two) 1.5)))
 
 ;; Test `*'
@@ -285,18 +290,18 @@
 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
   (Assert (= 1 (* one))))
 
-(dolist (two `(2 2.0 ?\02))
+(dolist (two '(2 2.0 ?\02))
   (Assert (= 2 (* two))))
 
-(dolist (six `(6 6.0 ?\06))
-  (dolist (two `(2 2.0 ?\02))
-    (dolist (three `(3 3.0 ?\03))
+(dolist (six '(6 6.0 ?\06))
+  (dolist (two '(2 2.0 ?\02))
+    (dolist (three '(3 3.0 ?\03))
       (Assert (= (* three two) six)))))
 
-(dolist (three `(3 3.0 ?\03))
-  (dolist (two `(2 2.0 ?\02))
+(dolist (three '(3 3.0 ?\03))
+  (dolist (two '(2 2.0 ?\02))
     (Assert (= (* 1.5 two) three))
-    (dolist (five `(5 5.0 ?\05))
+    (dolist (five '(5 5.0 ?\05))
       (Assert (= 30 (* five two three))))))
 
 ;; Test `+'
@@ -305,12 +310,12 @@
 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
   (Assert (= 1 (+ one))))
 
-(dolist (two `(2 2.0 ?\02))
+(dolist (two '(2 2.0 ?\02))
   (Assert (= 2 (+ two))))
 
-(dolist (five `(5 5.0 ?\05))
-  (dolist (two `(2 2.0 ?\02))
-    (dolist (three `(3 3.0 ?\03))
+(dolist (five '(5 5.0 ?\05))
+  (dolist (two '(2 2.0 ?\02))
+    (dolist (three '(3 3.0 ?\03))
       (Assert (= (+ three two) five))
       (Assert (= 10 (+ five two three))))))
 
@@ -341,7 +346,7 @@
 (Check-Error wrong-type-argument (logior 3.0))
 (Check-Error wrong-type-argument (logand 3.0))
 
-(dolist (three `(3 ?\03))
+(dolist (three '(3 ?\03))
   (Assert (eq 3 (logand three)))
   (Assert (eq 3 (logxor three)))
   (Assert (eq 3 (logior three)))
@@ -350,11 +355,11 @@
   (Assert (eq 3 (logior three three))))
 
 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
-  (dolist (two `(2 ?\02))
+  (dolist (two '(2 ?\02))
     (Assert (eq 0 (logand one two)))
     (Assert (eq 3 (logior one two)))
     (Assert (eq 3 (logxor one two))))
-  (dolist (three `(3 ?\03))
+  (dolist (three '(3 ?\03))
     (Assert (eq 1 (logand one three)))
     (Assert (eq 3 (logior one three)))
     (Assert (eq 2 (logxor one three)))))
@@ -468,7 +473,7 @@
 
 ;; Meat
 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
-  (dolist (two `(2 2.0 ?\02))
+  (dolist (two '(2 2.0 ?\02))
     (Assert (<  one two))
     (Assert (<= one two))
     (Assert (<= two two))
@@ -489,7 +494,7 @@
     ))
 
 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
-  (dolist (two `(2 2.0 ?\02))
+  (dolist (two '(2 2.0 ?\02))
     (Assert (<  one two))
     (Assert (<= one two))
     (Assert (<= two two))
@@ -537,7 +542,7 @@
 	 (Check-Error wrong-number-of-arguments (,fun))
 	 (Check-Error wrong-number-of-arguments (,fun nil))
 	 (Check-Error malformed-list (,fun nil 1))
-	 ,@(loop for n in `(1 2 2000)
+	 ,@(loop for n in '(1 2 2000)
 	     collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
      (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
 
@@ -750,6 +755,29 @@
 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3"))
 (Assert (equal (mapconcat #'identity ["1" "2" "3"]  "|") "1|2|3"))
 
+;; The following 2 functions used to crash XEmacs via mapcar1().
+;; We don't test the actual values of the mapcar, since they're undefined.
+(Assert 
+ (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
+   (mapcar
+    (lambda (y)
+      "Devious evil mapping function"
+      (when (eq (car y) 2) ; go out onto a limb
+	(setcdr x nil)     ; cut it off behind us
+	(garbage-collect)) ; are we riding a magic broomstick?
+      (car y))             ; sorry, hard landing
+    x)))
+
+(Assert 
+ (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
+   (mapcar
+    (lambda (y)
+      "Devious evil mapping function"
+      (when (eq (car y) 1)
+	(setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
+      (car y))
+    x)))
+
 ;;-----------------------------------------------------
 ;; Test vector functions
 ;;-----------------------------------------------------
@@ -776,3 +804,144 @@
 (Assert (equal (bit-vector 0 1 0) #*010))
 (Assert (equal (make-bit-vector 3 1) #*111))
 (Assert (equal (make-bit-vector 3 0) #*000))
+
+;;-----------------------------------------------------
+;; Test buffer-local variables used as (ugh!) function parameters
+;;-----------------------------------------------------
+(make-local-variable 'test-emacs-buffer-local-variable)
+(byte-compile
+ (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
+   (setq test-emacs-buffer-local-variable nil)))
+(test-emacs-buffer-local-parameter nil)
+
+;;-----------------------------------------------------
+;; Test split-string
+;;-----------------------------------------------------
+;; Hrvoje didn't like these tests so I'm disabling them for now. -sb
+;(Assert (equal (split-string "foo" "") '("" "f" "o" "o" "")))
+;(Assert (equal (split-string "foo" "^") '("" "foo")))
+;(Assert (equal (split-string "foo" "$") '("foo" "")))
+(Assert (equal (split-string "foo,bar" ",") '("foo" "bar")))
+(Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")))
+(Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,")))
+(Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" "")))
+(Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")))
+(Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")))
+(Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")))
+(Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar")))
+(Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")))
+
+(Assert (not (string-match "\\(\\.\\=\\)" ".")))
+
+;;-----------------------------------------------------
+;; Test near-text buffer functions.
+;;-----------------------------------------------------
+(with-temp-buffer
+  (erase-buffer)
+  (Assert (eq (char-before) nil))
+  (Assert (eq (char-before (point)) nil))
+  (Assert (eq (char-before (point-marker)) nil))
+  (Assert (eq (char-before (point) (current-buffer)) nil))
+  (Assert (eq (char-before (point-marker) (current-buffer)) nil))
+  (Assert (eq (char-after) nil))
+  (Assert (eq (char-after (point)) nil))
+  (Assert (eq (char-after (point-marker)) nil))
+  (Assert (eq (char-after (point) (current-buffer)) nil))
+  (Assert (eq (char-after (point-marker) (current-buffer)) nil))
+  (Assert (eq (preceding-char) 0))
+  (Assert (eq (preceding-char (current-buffer)) 0))
+  (Assert (eq (following-char) 0))
+  (Assert (eq (following-char (current-buffer)) 0))
+  (insert "foobar")
+  (Assert (eq (char-before) ?r))
+  (Assert (eq (char-after) nil))
+  (Assert (eq (preceding-char) ?r))
+  (Assert (eq (following-char) 0))
+  (goto-char (point-min))
+  (Assert (eq (char-before) nil))
+  (Assert (eq (char-after) ?f))
+  (Assert (eq (preceding-char) 0))
+  (Assert (eq (following-char) ?f))
+  )
+
+;;-----------------------------------------------------
+;; Test plist manipulation functions.
+;;-----------------------------------------------------
+(let ((sym (make-symbol "test-symbol")))
+  (Assert (eq t (get* sym t t)))
+  (Assert (eq t (get  sym t t)))
+  (Assert (eq t (getf nil t t)))
+  (Assert (eq t (plist-get nil t t)))
+  (put sym 'bar 'baz)
+  (Assert (eq 'baz (get sym 'bar)))
+  (Assert (eq 'baz (getf '(bar baz) 'bar)))
+  (Assert (eq 'baz (getf (symbol-plist sym) 'bar)))
+  (Assert (eq 2 (getf '(1 2) 1)))
+  (Assert (eq 4 (put sym 3 4)))
+  (Assert (eq 4 (get sym 3)))
+  (Assert (eq t (remprop sym 3)))
+  (Assert (eq nil (remprop sym 3)))
+  (Assert (eq 5 (get sym 3 5)))
+  )
+
+(loop for obj in
+  (list (make-symbol "test-symbol")
+	"test-string"
+	(make-extent nil nil nil)
+	(make-face 'test-face))
+  do
+  (Assert (eq 2 (get obj ?1 2)))
+  (Assert (eq 4 (put obj ?3 4)))
+  (Assert (eq 4 (get obj ?3)))
+  (when (or (stringp obj) (symbolp obj))
+    (Assert (equal '(?3 4) (object-plist obj))))
+  (Assert (eq t (remprop obj ?3)))
+  (when (or (stringp obj) (symbolp obj))
+    (Assert (eq '() (object-plist obj))))
+  (Assert (eq nil (remprop obj ?3)))
+  (when (or (stringp obj) (symbolp obj))
+    (Assert (eq '() (object-plist obj))))
+  (Assert (eq 5 (get obj ?3 5)))
+  )
+
+(Check-Error-Message
+ error "Object type has no properties"
+ (get 2 'property))
+
+(Check-Error-Message
+ error "Object type has no settable properties"
+ (put (current-buffer) 'property 'value))
+
+(Check-Error-Message
+ error "Object type has no removable properties"
+ (remprop ?3 'property))
+
+(Check-Error-Message
+ error "Object type has no properties"
+ (object-plist (symbol-function 'car)))
+
+(Check-Error-Message
+ error "Can't remove property from object"
+ (remprop (make-extent nil nil nil) 'detachable))
+
+;;-----------------------------------------------------
+;; Test subseq
+;;-----------------------------------------------------
+(Assert (equal (subseq nil 0) nil))
+(Assert (equal (subseq [1 2 3] 0) [1 2 3]))
+(Assert (equal (subseq [1 2 3] 1 -1) [2]))
+(Assert (equal (subseq "123" 0) "123"))
+(Assert (equal (subseq "1234" -3 -1) "23"))
+(Assert (equal (subseq #*0011 0) #*0011))
+(Assert (equal (subseq #*0011 -3 3) #*01))
+(Assert (equal (subseq '(1 2 3) 0) '(1 2 3)))
+(Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)))
+
+(Check-Error 'wrong-type-argument (subseq 3 2))
+(Check-Error 'args-out-of-range (subseq [1 2 3] -42))
+(Check-Error 'args-out-of-range (subseq [1 2 3] 0 42))
+
+;;-----------------------------------------------------
+;; Time-related tests
+;;-----------------------------------------------------
+(Assert (= (length (current-time-string)) 24))