comparison lisp/cl-extra.el @ 380:8626e4521993 r21-2-5

Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents cc15677e0335
children 74fd4e045ea6
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
46 46
47 ;; See cl.el for Change Log. 47 ;; See cl.el for Change Log.
48 48
49 49
50 ;;; Code: 50 ;;; Code:
51 (eval-when-compile
52 (require 'obsolete))
51 53
52 (or (memq 'cl-19 features) 54 (or (memq 'cl-19 features)
53 (error "Tried to load `cl-extra' before `cl'!")) 55 (error "Tried to load `cl-extra' before `cl'!"))
54 56
55 57
466 Optional second arg STATE is a random-state object." 468 Optional second arg STATE is a random-state object."
467 (or state (setq state *random-state*)) 469 (or state (setq state *random-state*))
468 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. 470 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
469 (let ((vec (aref state 3))) 471 (let ((vec (aref state 3)))
470 (if (integerp vec) 472 (if (integerp vec)
471 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii) 473 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
472 (aset state 3 (setq vec (make-vector 55 nil))) 474 (aset state 3 (setq vec (make-vector 55 nil)))
473 (aset vec 0 j) 475 (aset vec 0 j)
474 (while (> (setq i (% (+ i 21) 55)) 0) 476 (while (> (setq i (% (+ i 21) 55)) 0)
475 (aset vec i (setq j (prog1 k (setq k (- j k)))))) 477 (aset vec i (setq j (prog1 k (setq k (- j k))))))
476 (while (< (setq i (1+ i)) 200) (random* 2 state)))) 478 (while (< (setq i (1+ i)) 200) (random* 2 state))))
500 502
501 503
502 ;; Implementation limits. 504 ;; Implementation limits.
503 505
504 (defun cl-finite-do (func a b) 506 (defun cl-finite-do (func a b)
505 (condition-case err 507 (condition-case nil
506 (let ((res (funcall func a b))) ; check for IEEE infinity 508 (let ((res (funcall func a b))) ; check for IEEE infinity
507 (and (numberp res) (/= res (/ res 2)) res)) 509 (and (numberp res) (/= res (/ res 2)) res))
508 (arith-error nil))) 510 (arith-error nil)))
509 511
510 (defvar most-positive-float) 512 (defvar most-positive-float)
529 (setq x (+ x y) y (/ y 2))) 531 (setq x (+ x y) y (/ y 2)))
530 (setq most-positive-float x 532 (setq most-positive-float x
531 most-negative-float (- x)) 533 most-negative-float (- x))
532 ;; Divide down until mantissa starts rounding. 534 ;; Divide down until mantissa starts rounding.
533 (setq x (/ x z) y (/ 16 z) x (* x y)) 535 (setq x (/ x z) y (/ 16 z) x (* x y))
534 (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) 536 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
535 (arith-error nil)) 537 (arith-error nil))
536 (setq x (/ x 2) y (/ y 2))) 538 (setq x (/ x 2) y (/ y 2)))
537 (setq least-positive-normalized-float y 539 (setq least-positive-normalized-float y
538 least-negative-normalized-float (- y)) 540 least-negative-normalized-float (- y))
539 ;; Divide down until value underflows to zero. 541 ;; Divide down until value underflows to zero.
540 (setq x (/ 1 z) y x) 542 (setq x (/ 1 z) y x)
541 (while (condition-case err (> (/ x 2) 0) (arith-error nil)) 543 (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
542 (setq x (/ x 2))) 544 (setq x (/ x 2)))
543 (setq least-positive-float x 545 (setq least-positive-float x
544 least-negative-float (- x)) 546 least-negative-float (- x))
545 (setq x '1e0) 547 (setq x '1e0)
546 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) 548 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
579 ; (setq i (1+ i) start (1+ start))) 581 ; (setq i (1+ i) start (1+ start)))
580 ; res)))))) 582 ; res))))))
581 583
582 (defun concatenate (type &rest seqs) 584 (defun concatenate (type &rest seqs)
583 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." 585 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."
584 (cond ((eq type 'vector) (apply 'vconcat seqs)) 586 (case type
585 ((eq type 'string) (apply 'concat seqs)) 587 (vector (apply 'vconcat seqs))
586 ((eq type 'list) (apply 'append (append seqs '(nil)))) 588 (string (apply 'concat seqs))
587 (t (error "Not a sequence type name: %s" type)))) 589 (list (apply 'append (append seqs '(nil))))
588 590 (t (error "Not a sequence type name: %s" type))))
589 591
590 ;;; List functions. 592 ;;; List functions.
591 593
592 (defun revappend (x y) 594 (defun revappend (x y)
593 "Equivalent to (append (reverse X) Y)." 595 "Equivalent to (append (reverse X) Y)."
664 666
665 667
666 668
667 ;;; Hash tables. 669 ;;; Hash tables.
668 670
669 (defun make-hash-table (&rest cl-keys) 671 ;; The `regular' Common Lisp hash-table stuff has been moved into C.
670 "Make an empty Common Lisp-style hash-table. 672 ;; Only backward compatibility stuff remains here.
671 If :test is `eq', `eql', or `equal', this can use XEmacs built-in hash-tables. 673 (defun make-hashtable (size &optional test)
672 In Emacs 19, or with a different test, this internally uses a-lists. 674 (make-hash-table :size size :test test :type 'non-weak))
673 Keywords supported: :test :size 675 (defun make-weak-hashtable (size &optional test)
674 The Common Lisp keywords :rehash-size and :rehash-threshold are ignored." 676 (make-hash-table :size size :test test :type 'weak))
675 (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql)) 677 (defun make-key-weak-hashtable (size &optional test)
676 (cl-size (or (car (cdr (memq ':size cl-keys))) 20))) 678 (make-hash-table :size size :test test :type 'key-weak))
677 ;; XEmacs change 679 (defun make-value-weak-hashtable (size &optional test)
678 (if (and (memq cl-test '(eq eql equal)) (fboundp 'make-hashtable)) 680 (make-hash-table :size size :test test :type 'value-weak))
679 (funcall 'make-hashtable cl-size cl-test) 681
680 (list 'cl-hash-table-tag cl-test 682 (define-obsolete-function-alias 'hashtablep 'hash-table-p)
681 (if (> cl-size 1) (make-vector cl-size 0) 683 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count)
682 (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym)) 684 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test)
683 0)))) 685 (define-obsolete-function-alias 'hashtable-type 'hash-table-type)
684 686 (define-obsolete-function-alias 'hashtable-size 'hash-table-size)
685 (defvar cl-lucid-hash-tag 687 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table)
686 (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1))) 688
687 (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--"))) 689 (make-obsolete 'make-hashtable 'make-hash-table)
688 690 (make-obsolete 'make-weak-hashtable 'make-hash-table)
689 (defun hash-table-p (x) 691 (make-obsolete 'make-key-weak-hashtable 'make-hash-table)
690 "Return t if OBJECT is a hash table." 692 (make-obsolete 'make-value-weak-hashtable 'make-hash-table)
691 (or (and (fboundp 'hashtablep) (funcall 'hashtablep x)) 693
692 (eq (car-safe x) 'cl-hash-table-tag) 694 (when (fboundp 'x-keysym-hash-table)
693 (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag)))) 695 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table))
694 696
695 (defun cl-not-hash-table (x &optional y &rest z) 697 ;; Compatibility stuff for old kludgy cl.el hash table implementation
696 (signal 'wrong-type-argument (list 'hash-table-p (or y x)))) 698 (defvar cl-builtin-gethash (symbol-function 'gethash))
697 699 (defvar cl-builtin-remhash (symbol-function 'remhash))
698 (defun cl-hash-lookup (key table) 700 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
699 (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) 701 (defvar cl-builtin-maphash (symbol-function 'maphash))
700 (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) 702
701 (if (symbolp array) (setq str nil sym (symbol-value array)) 703 (defalias 'cl-gethash 'gethash)
702 (while (or (consp str) (and (vectorp str) (> (length str) 0))) 704 (defalias 'cl-puthash 'puthash)
703 (setq str (elt str 0))) 705 (defalias 'cl-remhash 'remhash)
704 (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) 706 (defalias 'cl-clrhash 'clrhash)
705 ((symbolp str) (setq str (symbol-name str))) 707 (defalias 'cl-maphash 'maphash)
706 ((and (numberp str) (> str -8000000) (< str 8000000))
707 (or (integerp str) (setq str (truncate str)))
708 (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10"
709 "11" "12" "13" "14" "15"] (logand str 15))))
710 (t (setq str "*")))
711 (setq sym (symbol-value (intern-soft str array))))
712 (list (and sym (cond ((or (eq test 'eq)
713 (and (eq test 'eql) (not (numberp key))))
714 (assq key sym))
715 ((memq test '(eql equal)) (assoc key sym))
716 (t (assoc* key sym ':test test))))
717 sym str)))
718
719 (defvar cl-builtin-gethash
720 (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash)))
721 (symbol-function 'gethash) 'cl-not-hash-table))
722 (defvar cl-builtin-remhash
723 (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash)))
724 (symbol-function 'remhash) 'cl-not-hash-table))
725 (defvar cl-builtin-clrhash
726 (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash)))
727 (symbol-function 'clrhash) 'cl-not-hash-table))
728 (defvar cl-builtin-maphash
729 (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash)))
730 (symbol-function 'maphash) 'cl-not-hash-table))
731
732 (defun cl-gethash (key table &optional def)
733 "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."
734 (if (consp table)
735 (let ((found (cl-hash-lookup key table)))
736 (if (car found) (cdr (car found)) def))
737 (funcall cl-builtin-gethash key table def)))
738 (defalias 'gethash 'cl-gethash)
739
740 (defun cl-puthash (key val table)
741 (if (consp table)
742 (let ((found (cl-hash-lookup key table)))
743 (if (car found) (setcdr (car found) val)
744 (if (nth 2 found)
745 (progn
746 (if (> (nth 3 table) (* (length (nth 2 table)) 3))
747 (let ((new-table (make-vector (nth 3 table) 0)))
748 (mapatoms (function
749 (lambda (sym)
750 (set (intern (symbol-name sym) new-table)
751 (symbol-value sym))))
752 (nth 2 table))
753 (setcar (cdr (cdr table)) new-table)))
754 (set (intern (nth 2 found) (nth 2 table))
755 (cons (cons key val) (nth 1 found))))
756 (set (nth 2 table) (cons (cons key val) (nth 1 found))))
757 (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table)))))
758 (funcall 'puthash key val table)) val)
759
760 (defun cl-remhash (key table)
761 "Remove KEY from HASH-TABLE."
762 (if (consp table)
763 (let ((found (cl-hash-lookup key table)))
764 (and (car found)
765 (let ((del (delq (car found) (nth 1 found))))
766 (setcar (cdr (cdr (cdr table))) (1- (nth 3 table)))
767 (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del)
768 (set (nth 2 table) del)) t)))
769 (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--))
770 (funcall cl-builtin-remhash key table))))
771 (defalias 'remhash 'cl-remhash)
772
773 (defun cl-clrhash (table)
774 "Clear HASH-TABLE."
775 (if (consp table)
776 (progn
777 (or (hash-table-p table) (cl-not-hash-table table))
778 (if (symbolp (nth 2 table)) (set (nth 2 table) nil)
779 (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0)))
780 (setcar (cdr (cdr (cdr table))) 0))
781 (funcall cl-builtin-clrhash table))
782 nil)
783 (defalias 'clrhash 'cl-clrhash)
784
785 (defun cl-maphash (cl-func cl-table)
786 "Call FUNCTION on keys and values from HASH-TABLE."
787 (or (hash-table-p cl-table) (cl-not-hash-table cl-table))
788 (if (consp cl-table)
789 (mapatoms (function (lambda (cl-x)
790 (setq cl-x (symbol-value cl-x))
791 (while cl-x
792 (funcall cl-func (car (car cl-x))
793 (cdr (car cl-x)))
794 (setq cl-x (cdr cl-x)))))
795 (if (symbolp (nth 2 cl-table))
796 (vector (nth 2 cl-table)) (nth 2 cl-table)))
797 (funcall cl-builtin-maphash cl-func cl-table)))
798 (defalias 'maphash 'cl-maphash)
799
800 (defun hash-table-count (table)
801 "Return the number of entries in HASH-TABLE."
802 (or (hash-table-p table) (cl-not-hash-table table))
803 (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table)))
804
805 708
806 ;;; Some debugging aids. 709 ;;; Some debugging aids.
807 710
808 (defun cl-prettyprint (form) 711 (defun cl-prettyprint (form)
809 "Insert a pretty-printed rendition of a Lisp FORM in current buffer." 712 "Insert a pretty-printed rendition of a Lisp FORM in current buffer."