Mercurial > hg > xemacs-beta
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." |