Mercurial > hg > xemacs-beta
annotate lisp/cl-extra.el @ 5090:0ca81354c4c7
Further frame-geometry cleanups
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-03 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Intro to Window and Frame Geometry):
* internals/internals.texi (The Paned Area):
* internals/internals.texi (The Displayable Area):
Update to make note of e.g. the fact that the bottom gutter is
actually above the minibuffer.
src/ChangeLog addition:
2010-03-03 Ben Wing <ben@xemacs.org>
* emacs.c:
* emacs.c (assert_equal_failed):
* lisp.h:
* lisp.h (assert_equal):
New fun assert_equal, asserting that two values == each other, and
printing out both values upon failure.
* frame-gtk.c (gtk_initialize_frame_size):
* frame-impl.h:
* frame-impl.h (FRAME_TOP_INTERNAL_BORDER_START):
* frame-impl.h (FRAME_BOTTOM_INTERNAL_BORDER_START):
* frame-impl.h (FRAME_LEFT_INTERNAL_BORDER_START):
* frame-impl.h (FRAME_PANED_TOP_EDGE):
* frame-impl.h (FRAME_NONPANED_SIZE):
* frame-x.c (x_initialize_frame_size):
* frame.c:
* gutter.c (get_gutter_coords):
* gutter.c (calculate_gutter_size):
* gutter.h:
* gutter.h (WINDOW_REAL_TOP_GUTTER_BOUNDS):
* gutter.h (FRAME_TOP_GUTTER_BOUNDS):
* input-method-xlib.c:
* input-method-xlib.c (XIM_SetGeometry):
* redisplay-output.c (clear_left_border):
* redisplay-output.c (clear_right_border):
* redisplay-output.c (redisplay_output_pixmap):
* redisplay-output.c (redisplay_clear_region):
* redisplay-output.c (redisplay_clear_top_of_window):
* redisplay-output.c (redisplay_clear_to_window_end):
* redisplay-xlike-inc.c (XLIKE_clear_frame):
* redisplay.c:
* redisplay.c (UPDATE_CACHE_RETURN):
* redisplay.c (pixel_to_glyph_translation):
* toolbar.c (update_frame_toolbars_geometry):
* window.c (Fwindow_pixel_edges):
Get rid of some redundant macros. Consistently use the
FRAME_TOP_*_START, FRAME_RIGHT_*_END, etc. format. Rename
FRAME_*_BORDER_* to FRAME_*_INTERNAL_BORDER_*. Comment out
FRAME_BOTTOM_* for gutters and the paned area due to the
uncertainty over where the paned area actually begins. (Eventually
we should probably move the gutters outside the minibuffer so that
the paned area is contiguous.) Use FRAME_PANED_* more often in the
code to make things clearer.
Update the diagram to show that the bottom gutter is inside the
minibuffer (!) and that there are "junk boxes" when you have left
and/or right gutters (dead boxes that are mistakenly left uncleared,
unlike the corresponding scrollbar dead boxes). Update the text
appropriately to cover the bottom gutter position, etc.
Rewrite gutter-geometry code to use the FRAME_*_GUTTER_* in place of
equivalent expressions referencing other frame elements, to make the
code more portable in case we move around the gutter location.
Cleanup FRAME_*_GUTTER_BOUNDS() in gutter.h.
Add some #### GEOM! comments where I think code is incorrect --
typically, it wasn't fixed up properly when the gutter was added.
Some cosmetic changes.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Wed, 03 Mar 2010 05:07:47 -0600 |
| parents | 868a9ffcc37b |
| children | 41262f87eb39 |
| rev | line source |
|---|---|
| 613 | 1 ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two) |
| 428 | 2 |
| 2153 | 3 ;; Copyright (C) 1993,2000,2003 Free Software Foundation, Inc. |
| 801 | 4 ;; Copyright (C) 2002 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Dave Gillespie <daveg@synaptics.com> | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Version: 2.02 | |
| 9 ;; Keywords: extensions, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
| 13 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 14 ;; under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 26 ;; 02111-1307, USA. | |
| 27 | |
| 2153 | 28 ;;; Synched up with: FSF 21.3. |
| 428 | 29 |
| 30 ;;; Commentary: | |
| 31 | |
| 32 ;; This file is dumped with XEmacs. | |
| 33 | |
| 34 ;; These are extensions to Emacs Lisp that provide a degree of | |
| 35 ;; Common Lisp compatibility, beyond what is already built-in | |
| 36 ;; in Emacs Lisp. | |
| 37 ;; | |
| 38 ;; This package was written by Dave Gillespie; it is a complete | |
| 39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
| 40 ;; | |
| 41 ;; Bug reports, comments, and suggestions are welcome! | |
| 42 | |
| 43 ;; This file contains portions of the Common Lisp extensions | |
| 44 ;; package which are autoloaded since they are relatively obscure. | |
| 45 | |
| 46 ;; See cl.el for Change Log. | |
| 47 | |
| 48 | |
| 49 ;;; Code: | |
| 2153 | 50 ;; XEmacs addition |
| 428 | 51 (eval-when-compile |
| 52 (require 'obsolete)) | |
| 53 | |
| 54 (or (memq 'cl-19 features) | |
| 55 (error "Tried to load `cl-extra' before `cl'!")) | |
| 56 | |
| 57 | |
| 58 ;;; Type coercion. | |
| 59 | |
| 60 (defun coerce (x type) | |
| 61 "Coerce OBJECT to type TYPE. | |
| 62 TYPE is a Common Lisp type specifier." | |
| 63 (cond ((eq type 'list) (if (listp x) x (append x nil))) | |
| 64 ((eq type 'vector) (if (vectorp x) x (vconcat x))) | |
| 65 ((eq type 'string) (if (stringp x) x (concat x))) | |
| 66 ((eq type 'array) (if (arrayp x) x (vconcat x))) | |
| 67 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) | |
| 68 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) | |
| 2153 | 69 ;; XEmacs addition character <-> integer coercions |
| 446 | 70 ((and (eq type 'character) (char-int-p x)) (int-char x)) |
| 71 ((and (eq type 'integer) (characterp x)) (char-int x)) | |
| 428 | 72 ((eq type 'float) (float x)) |
| 2153 | 73 ;; XEmacs addition: enhanced numeric type coercions |
| 2367 | 74 ((and-fboundp 'coerce-number |
| 75 (memq type '(integer ratio bigfloat)) | |
| 76 (coerce-number x type))) | |
| 2153 | 77 ;; XEmacs addition: bit-vector coercion |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
78 ((or (eq type 'bit-vector) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
79 (eq type 'simple-bit-vector)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
80 (if (bit-vector-p x) x (apply 'bit-vector (append x nil)))) |
| 2153 | 81 ;; XEmacs addition: weak-list coercion |
| 428 | 82 ((eq type 'weak-list) |
| 83 (if (weak-list-p x) x | |
| 84 (let ((wl (make-weak-list))) | |
| 85 (set-weak-list-list wl (if (listp x) x (append x nil))) | |
| 86 wl))) | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
87 ((and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
88 (consp type) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
89 (or (eq (car type) 'vector) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
90 (eq (car type) 'simple-array) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
91 (eq (car type) 'simple-vector)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
92 (cond |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
93 ((equal (cdr-safe type) '(*)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
94 (coerce x 'vector)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
95 ((equal (cdr-safe type) '(bit)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
96 (coerce x 'bit-vector)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
97 ((equal (cdr-safe type) '(character)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
98 (coerce x 'string))))) |
| 428 | 99 ((typep x type) x) |
| 100 (t (error "Can't coerce %s to type %s" x type)))) | |
| 101 | |
| 102 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
103 ;;;;; Predicates. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
104 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
105 ;;;; I'd actually prefer not to have this inline, the space |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
106 ;;;; vs. amount-it's-called trade-off isn't reasonable, but that would |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
107 ;;;; introduce bytecode problems with the compiler macro in cl-macs.el. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
108 ;;(defsubst cl-string-vector-equalp (cl-string cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
109 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
110 ;;; (check-argument-type #'stringp cl-string) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
111 ;;; (check-argument-type #'vector cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
112 ;; (let ((cl-i (length cl-string)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
113 ;; cl-char cl-other) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
114 ;; (when (= cl-i (length cl-vector)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
115 ;; (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
116 ;; (or (eq (setq cl-char (aref cl-string cl-i)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
117 ;; (setq cl-other (aref cl-vector cl-i))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
118 ;; (and (characterp cl-other) ; Note we want to call this |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
119 ;; ; as rarely as possible, it |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
120 ;; ; doesn't have a bytecode. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
121 ;; (eq (downcase cl-char) (downcase cl-other)))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
122 ;; (< cl-i 0)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
123 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
124 ;;;; See comment on cl-string-vector-equalp above. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
125 ;;(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
126 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
127 ;;; (check-argument-type #'bit-vector-p cl-bit-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
128 ;;; (check-argument-type #'vectorp cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
129 ;; (let ((cl-i (length cl-bit-vector)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
130 ;; cl-other) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
131 ;; (when (= cl-i (length cl-vector)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
132 ;; (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
133 ;; (numberp (setq cl-other (aref cl-vector cl-i))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
134 ;; ;; Differs from clisp here. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
135 ;; (= (aref cl-bit-vector cl-i) cl-other))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
136 ;; (< cl-i 0)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
137 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
138 ;;;; These two helper functions call equalp recursively, the two above have no |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
139 ;;;; need to. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
140 ;;(defsubst cl-vector-array-equalp (cl-vector cl-array) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
141 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
142 ;;; (check-argument-type #'vector cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
143 ;;; (check-argument-type #'arrayp cl-array) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
144 ;; (let ((cl-i (length cl-vector))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
145 ;; (when (= cl-i (length cl-array)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
146 ;; (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
147 ;; (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
148 ;; (< cl-i 0)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
149 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
150 ;;(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
151 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
152 ;; (symbol-macrolet |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
153 ;; ;; If someone has gone and fished the uninterned symbol out of this |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
154 ;; ;; function's constants vector, and subsequently stored it as a value |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
155 ;; ;; in a hash table, it's their own damn fault when |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
156 ;; ;; `cl-hash-table-contents-equalp' gives the wrong answer. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
157 ;; ((equalp-default '#:equalp-default)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
158 ;; (loop |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
159 ;; for x-key being the hash-key in cl-hash-table-1 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
160 ;; using (hash-value x-value) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
161 ;; with y-value = nil |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
162 ;; always (and (not (eq equalp-default |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
163 ;; (setq y-value (gethash x-key cl-hash-table-2 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
164 ;; equalp-default)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
165 ;; (equalp y-value x-value))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
166 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
167 ;;(defun equalp (x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
168 ;; "Return t if two Lisp objects have similar structures and contents. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
169 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
170 ;;This is like `equal', except that it accepts numerically equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
171 ;;numbers of different types (float, integer, bignum, bigfloat), and also |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
172 ;;compares strings and characters case-insensitively. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
173 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
174 ;;Arrays (that is, strings, bit-vectors, and vectors) of the same length and |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
175 ;;with contents that are `equalp' are themselves `equalp'. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
176 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
177 ;;Two hash tables are `equalp' if they have the same test (see |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
178 ;;`hash-table-test'), if they have the same number of entries, and if, for |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
179 ;;each entry in one hash table, its key is equivalent to a key in the other |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
180 ;;hash table using the hash table test, and its value is `equalp' to the other |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
181 ;;hash table's value for that key." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
182 ;; (cond ((eq x y)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
183 ;; ((stringp x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
184 ;; (if (stringp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
185 ;; (eq t (compare-strings x nil nil y nil nil t)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
186 ;; (if (vectorp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
187 ;; (cl-string-vector-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
188 ;; ;; bit-vectors and strings are only equalp if they're |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
189 ;; ;; zero-length: |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
190 ;; (and (equal "" x) (equal #* y))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
191 ;; ((numberp x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
192 ;; (and (numberp y) (= x y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
193 ;; ((consp x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
194 ;; (while (and (consp x) (consp y) (equalp (car x) (car y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
195 ;; (setq x (cdr x) y (cdr y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
196 ;; (and (not (consp x)) (equalp x y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
197 ;; (t |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
198 ;; ;; From here on, the type tests don't (yet) have bytecodes. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
199 ;; (let ((x-type (type-of x))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
200 ;; (cond ((eq 'vector x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
201 ;; (if (stringp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
202 ;; (cl-string-vector-equalp y x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
203 ;; (if (vectorp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
204 ;; (cl-vector-array-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
205 ;; (if (bit-vector-p y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
206 ;; (cl-bit-vector-vector-equalp y x))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
207 ;; ((eq 'character x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
208 ;; (and (characterp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
209 ;; ;; If the characters are actually identical, the |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
210 ;; ;; first eq test will have caught them above; we only |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
211 ;; ;; need to check them case-insensitively here. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
212 ;; (eq (downcase x) (downcase y)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
213 ;; ((eq 'hash-table x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
214 ;; (and (hash-table-p y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
215 ;; (eq (hash-table-test x) (hash-table-test y)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
216 ;; (= (hash-table-count x) (hash-table-count y)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
217 ;; (cl-hash-table-contents-equalp x y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
218 ;; ((eq 'bit-vector x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
219 ;; (if (bit-vector-p y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
220 ;; (equal x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
221 ;; (if (vectorp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
222 ;; (cl-bit-vector-vector-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
223 ;; ;; bit-vectors and strings are only equalp if they're |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
224 ;; ;; zero-length: |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
225 ;; (and (equal "" y) (equal #* x))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
226 ;; (t (equal x y))))))) |
| 428 | 227 |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
228 ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
229 ;; are now in C, together with #'map-into, which was never in this file. |
| 428 | 230 |
| 231 (defun notany (cl-pred cl-seq &rest cl-rest) | |
| 232 "Return true if PREDICATE is false of every element of SEQ or SEQs." | |
| 233 (not (apply 'some cl-pred cl-seq cl-rest))) | |
| 234 | |
| 235 (defun notevery (cl-pred cl-seq &rest cl-rest) | |
| 236 "Return true if PREDICATE is false of some element of SEQ or SEQs." | |
| 237 (not (apply 'every cl-pred cl-seq cl-rest))) | |
| 238 | |
| 239 ;;; Support for `loop'. | |
| 2153 | 240 (defalias 'cl-map-keymap 'map-keymap) |
| 428 | 241 |
| 242 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) | |
| 243 (or cl-base | |
| 2153 | 244 (setq cl-base (copy-sequence [0]))) |
| 245 (map-keymap | |
| 428 | 246 (function |
| 247 (lambda (cl-key cl-bind) | |
| 248 (aset cl-base (1- (length cl-base)) cl-key) | |
| 249 (if (keymapp cl-bind) | |
| 250 (cl-map-keymap-recursively | |
| 251 cl-func-rec cl-bind | |
| 2153 | 252 (vconcat cl-base (list 0))) |
| 428 | 253 (funcall cl-func-rec cl-base cl-bind)))) |
| 254 cl-map)) | |
| 255 | |
| 256 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) | |
| 257 (or cl-what (setq cl-what (current-buffer))) | |
| 258 (if (bufferp cl-what) | |
| 259 (let (cl-mark cl-mark2 (cl-next t) cl-next2) | |
| 2153 | 260 (with-current-buffer cl-what |
| 428 | 261 (setq cl-mark (copy-marker (or cl-start (point-min)))) |
| 262 (setq cl-mark2 (and cl-end (copy-marker cl-end)))) | |
| 263 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) | |
| 2153 | 264 (setq cl-next (if cl-prop (next-single-property-change |
| 265 cl-mark cl-prop cl-what) | |
| 266 (next-property-change cl-mark cl-what)) | |
| 267 cl-next2 (or cl-next (with-current-buffer cl-what | |
| 268 (point-max)))) | |
| 428 | 269 (funcall cl-func (prog1 (marker-position cl-mark) |
| 270 (set-marker cl-mark cl-next2)) | |
| 271 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) | |
| 272 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) | |
| 273 (or cl-start (setq cl-start 0)) | |
| 274 (or cl-end (setq cl-end (length cl-what))) | |
| 275 (while (< cl-start cl-end) | |
| 2153 | 276 (let ((cl-next (or (if cl-prop (next-single-property-change |
| 277 cl-start cl-prop cl-what) | |
| 278 (next-property-change cl-start cl-what)) | |
| 428 | 279 cl-end))) |
| 280 (funcall cl-func cl-start (min cl-next cl-end)) | |
| 281 (setq cl-start cl-next))))) | |
| 282 | |
| 283 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) | |
| 284 (or cl-buffer (setq cl-buffer (current-buffer))) | |
| 502 | 285 (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change) |
| 286 (if-fboundp 'overlay-lists | |
| 428 | 287 |
| 502 | 288 ;; This is the preferred algorithm, though overlay-lists is |
| 289 ;; undocumented. | |
| 290 (let (cl-ovl) | |
| 2153 | 291 (with-current-buffer cl-buffer |
| 502 | 292 (setq cl-ovl (overlay-lists)) |
| 293 (if cl-start (setq cl-start (copy-marker cl-start))) | |
| 294 (if cl-end (setq cl-end (copy-marker cl-end)))) | |
| 295 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) | |
| 296 (while (and cl-ovl | |
| 297 (or (not (overlay-start (car cl-ovl))) | |
| 298 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) | |
| 299 (and cl-start (<= (overlay-end (car cl-ovl)) | |
| 300 cl-start)) | |
| 301 (not (funcall cl-func (car cl-ovl) cl-arg)))) | |
| 302 (setq cl-ovl (cdr cl-ovl))) | |
| 303 (if cl-start (set-marker cl-start nil)) | |
| 304 (if cl-end (set-marker cl-end nil))) | |
| 305 | |
| 306 ;; This alternate algorithm fails to find zero-length overlays. | |
| 2153 | 307 (let ((cl-mark (with-current-buffer cl-buffer |
| 308 (copy-marker (or cl-start (point-min))))) | |
| 309 (cl-mark2 (and cl-end (with-current-buffer cl-buffer | |
| 310 (copy-marker cl-end)))) | |
| 502 | 311 cl-pos cl-ovl) |
| 312 (while (save-excursion | |
| 313 (and (setq cl-pos (marker-position cl-mark)) | |
| 314 (< cl-pos (or cl-mark2 (point-max))) | |
| 315 (progn | |
| 316 (set-buffer cl-buffer) | |
| 317 (setq cl-ovl (overlays-at cl-pos)) | |
| 318 (set-marker cl-mark (next-overlay-change cl-pos))))) | |
| 319 (while (and cl-ovl | |
| 320 (or (/= (overlay-start (car cl-ovl)) cl-pos) | |
| 321 (not (and (funcall cl-func (car cl-ovl) cl-arg) | |
| 322 (set-marker cl-mark nil))))) | |
| 323 (setq cl-ovl (cdr cl-ovl)))) | |
| 324 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))) | |
| 428 | 325 |
| 326 ;;; Support for `setf'. | |
| 327 (defun cl-set-frame-visible-p (frame val) | |
| 328 (cond ((null val) (make-frame-invisible frame)) | |
| 329 ((eq val 'icon) (iconify-frame frame)) | |
| 330 (t (make-frame-visible frame))) | |
| 331 val) | |
| 332 | |
| 333 ;;; Support for `progv'. | |
| 334 (defvar cl-progv-save) | |
| 335 (defun cl-progv-before (syms values) | |
| 336 (while syms | |
| 2153 | 337 (push (if (boundp (car syms)) |
| 428 | 338 (cons (car syms) (symbol-value (car syms))) |
| 339 (car syms)) cl-progv-save) | |
| 340 (if values | |
| 2153 | 341 (set (pop syms) (pop values)) |
| 342 (makunbound (pop syms))))) | |
| 428 | 343 |
| 344 (defun cl-progv-after () | |
| 345 (while cl-progv-save | |
| 346 (if (consp (car cl-progv-save)) | |
| 347 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) | |
| 348 (makunbound (car cl-progv-save))) | |
| 2153 | 349 (pop cl-progv-save))) |
| 428 | 350 |
| 351 | |
| 352 ;;; Numbers. | |
| 353 | |
| 354 (defun gcd (&rest args) | |
| 355 "Return the greatest common divisor of the arguments." | |
| 2153 | 356 (let ((a (abs (or (pop args) 0)))) |
| 428 | 357 (while args |
| 2153 | 358 (let ((b (abs (pop args)))) |
| 428 | 359 (while (> b 0) (setq b (% a (setq a b)))))) |
| 360 a)) | |
| 361 | |
| 362 (defun lcm (&rest args) | |
| 363 "Return the least common multiple of the arguments." | |
| 364 (if (memq 0 args) | |
| 365 0 | |
| 2153 | 366 (let ((a (abs (or (pop args) 1)))) |
| 428 | 367 (while args |
| 2153 | 368 (let ((b (abs (pop args)))) |
| 428 | 369 (setq a (* (/ a (gcd a b)) b)))) |
| 370 a))) | |
| 371 | |
| 372 (defun isqrt (a) | |
| 373 "Return the integer square root of the argument." | |
| 374 (if (and (integerp a) (> a 0)) | |
| 375 ;; XEmacs change | |
| 376 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) | |
| 377 ((>= a 100) 100) (t 10))) | |
| 378 g2) | |
| 379 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
| 380 (setq g g2)) | |
| 381 g) | |
| 382 (if (eq a 0) 0 (signal 'arith-error nil)))) | |
| 383 | |
| 2153 | 384 ;; XEmacs addition |
| 428 | 385 (defun cl-expt (x y) |
| 386 "Return X raised to the power of Y. Works only for integer arguments." | |
| 387 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) | |
| 388 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) | |
| 389 (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) | |
| 390 (defalias 'expt 'cl-expt)) | |
| 391 | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
392 ;; We can't use macrolet in this file; whence the literal macro |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
393 ;; definition-and-call: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
394 ((macro . (lambda (&rest symbols) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
395 "Make some old CL package truncate and round functions available. |
| 428 | 396 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
397 These functions are now implemented in C; their Lisp implementations in this |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
398 XEmacs are trivial, so we provide them and mark them obsolete." |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
399 (let (symbol result) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
400 (while symbols |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
401 (setq symbol (car symbols) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
402 symbols (cdr symbols)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
403 (push `(make-obsolete ',(intern (format "%s*" symbol)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
404 ',symbol "21.5.29") |
|
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
405 result) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
406 (push |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
407 `(defun ,(intern (format "%s*" symbol)) (number &optional divisor) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
408 ,(format "See `%s'. This returns a list, not multiple values." |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
409 symbol) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
410 (multiple-value-list (,symbol number divisor))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
411 result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
412 (cons 'progn result)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
413 ceiling floor round truncate) |
| 428 | 414 |
| 415 (defun mod* (x y) | |
| 416 "The remainder of X divided by Y, with the same sign as Y." | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
417 (nth-value 1 (floor x y))) |
| 428 | 418 |
| 419 (defun rem* (x y) | |
| 420 "The remainder of X divided by Y, with the same sign as X." | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
421 (nth-value 1 (truncate x y))) |
| 428 | 422 |
| 423 (defun signum (a) | |
| 424 "Return 1 if A is positive, -1 if negative, 0 if zero." | |
| 425 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | |
| 426 | |
| 427 ;; Random numbers. | |
| 428 | |
| 429 (defvar *random-state*) | |
| 430 (defun random* (lim &optional state) | |
| 431 "Return a random nonnegative number less than LIM, an integer or float. | |
| 432 Optional second arg STATE is a random-state object." | |
| 433 (or state (setq state *random-state*)) | |
| 434 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. | |
| 435 (let ((vec (aref state 3))) | |
| 436 (if (integerp vec) | |
| 437 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) | |
| 438 (aset state 3 (setq vec (make-vector 55 nil))) | |
| 439 (aset vec 0 j) | |
| 440 (while (> (setq i (% (+ i 21) 55)) 0) | |
| 441 (aset vec i (setq j (prog1 k (setq k (- j k)))))) | |
| 442 (while (< (setq i (1+ i)) 200) (random* 2 state)))) | |
| 443 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) | |
| 444 (j (aset state 2 (% (1+ (aref state 2)) 55))) | |
| 445 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) | |
| 446 (if (integerp lim) | |
| 447 (if (<= lim 512) (% n lim) | |
| 448 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) | |
| 449 (let ((mask 1023)) | |
| 450 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) | |
| 451 (if (< (setq n (logand n mask)) lim) n (random* lim state)))) | |
| 452 (* (/ n '8388608e0) lim))))) | |
| 453 | |
| 454 (defun make-random-state (&optional state) | |
| 455 "Return a copy of random-state STATE, or of `*random-state*' if omitted. | |
| 456 If STATE is t, return a new state object seeded from the time of day." | |
| 457 (cond ((null state) (make-random-state *random-state*)) | |
| 458 ((vectorp state) (cl-copy-tree state t)) | |
| 459 ((integerp state) (vector 'cl-random-state-tag -1 30 state)) | |
| 460 (t (make-random-state (cl-random-time))))) | |
| 461 | |
| 462 (defun random-state-p (object) | |
| 463 "Return t if OBJECT is a random-state object." | |
| 464 (and (vectorp object) (= (length object) 4) | |
| 465 (eq (aref object 0) 'cl-random-state-tag))) | |
| 466 | |
| 467 | |
| 468 ;; Implementation limits. | |
| 469 | |
| 470 (defun cl-finite-do (func a b) | |
| 471 (condition-case nil | |
| 472 (let ((res (funcall func a b))) ; check for IEEE infinity | |
| 473 (and (numberp res) (/= res (/ res 2)) res)) | |
| 474 (arith-error nil))) | |
| 475 | |
| 476 (defvar most-positive-float) | |
| 477 (defvar most-negative-float) | |
| 478 (defvar least-positive-float) | |
| 479 (defvar least-negative-float) | |
| 480 (defvar least-positive-normalized-float) | |
| 481 (defvar least-negative-normalized-float) | |
| 482 (defvar float-epsilon) | |
| 483 (defvar float-negative-epsilon) | |
| 484 | |
| 485 (defun cl-float-limits () | |
| 486 (or most-positive-float (not (numberp '2e1)) | |
| 487 (let ((x '2e0) y z) | |
| 488 ;; Find maximum exponent (first two loops are optimizations) | |
| 489 (while (cl-finite-do '* x x) (setq x (* x x))) | |
| 490 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) | |
| 491 (while (cl-finite-do '+ x x) (setq x (+ x x))) | |
| 492 (setq z x y (/ x 2)) | |
| 493 ;; Now fill in 1's in the mantissa. | |
| 494 (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) | |
| 495 (setq x (+ x y) y (/ y 2))) | |
| 496 (setq most-positive-float x | |
| 497 most-negative-float (- x)) | |
| 498 ;; Divide down until mantissa starts rounding. | |
| 499 (setq x (/ x z) y (/ 16 z) x (* x y)) | |
| 500 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) | |
| 501 (arith-error nil)) | |
| 502 (setq x (/ x 2) y (/ y 2))) | |
| 503 (setq least-positive-normalized-float y | |
| 504 least-negative-normalized-float (- y)) | |
| 505 ;; Divide down until value underflows to zero. | |
| 506 (setq x (/ 1 z) y x) | |
| 507 (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) | |
| 508 (setq x (/ x 2))) | |
| 509 (setq least-positive-float x | |
| 510 least-negative-float (- x)) | |
| 511 (setq x '1e0) | |
| 512 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) | |
| 513 (setq float-epsilon (* x 2)) | |
| 514 (setq x '1e0) | |
| 515 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) | |
| 516 (setq float-negative-epsilon (* x 2)))) | |
| 517 nil) | |
| 518 | |
| 519 | |
| 520 ;;; Sequence functions. | |
| 521 | |
| 522 ;XEmacs -- our built-in is more powerful. | |
| 523 ;(defun subseq (seq start &optional end) | |
| 524 ; "Return the subsequence of SEQ from START to END. | |
| 525 ;If END is omitted, it defaults to the length of the sequence. | |
| 526 ;If START or END is negative, it counts from the end." | |
| 527 ; (if (stringp seq) (substring seq start end) | |
| 528 ; (let (len) | |
| 529 ; (and end (< end 0) (setq end (+ end (setq len (length seq))))) | |
| 530 ; (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) | |
| 531 ; (cond ((listp seq) | |
| 532 ; (if (> start 0) (setq seq (nthcdr start seq))) | |
| 533 ; (if end | |
| 534 ; (let ((res nil)) | |
| 535 ; (while (>= (setq end (1- end)) start) | |
| 2153 | 536 ; (push (pop seq) res)) |
| 428 | 537 ; (nreverse res)) |
| 538 ; (copy-sequence seq))) | |
| 539 ; (t | |
| 540 ; (or end (setq end (or len (length seq)))) | |
| 541 ; (let ((res (make-vector (max (- end start) 0) nil)) | |
| 542 ; (i 0)) | |
| 543 ; (while (< start end) | |
| 544 ; (aset res i (aref seq start)) | |
| 545 ; (setq i (1+ i) start (1+ start))) | |
| 546 ; res)))))) | |
| 547 | |
| 548 (defun concatenate (type &rest seqs) | |
| 549 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | |
| 2153 | 550 ;; XEmacs change: use case instead of cond for clarity |
| 428 | 551 (case type |
| 552 (vector (apply 'vconcat seqs)) | |
| 553 (string (apply 'concat seqs)) | |
| 554 (list (apply 'append (append seqs '(nil)))) | |
| 555 (t (error "Not a sequence type name: %s" type)))) | |
| 556 | |
| 557 ;;; List functions. | |
| 558 | |
| 559 (defun revappend (x y) | |
| 560 "Equivalent to (append (reverse X) Y)." | |
| 561 (nconc (reverse x) y)) | |
| 562 | |
| 563 (defun nreconc (x y) | |
| 564 "Equivalent to (nconc (nreverse X) Y)." | |
| 565 (nconc (nreverse x) y)) | |
| 566 | |
| 567 (defun list-length (x) | |
| 568 "Return the length of a list. Return nil if list is circular." | |
| 569 (let ((n 0) (fast x) (slow x)) | |
| 570 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) | |
| 571 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) | |
| 572 (if fast (if (cdr fast) nil (1+ n)) n))) | |
| 573 | |
| 574 (defun tailp (sublist list) | |
| 575 "Return true if SUBLIST is a tail of LIST." | |
| 576 (while (and (consp list) (not (eq sublist list))) | |
| 577 (setq list (cdr list))) | |
| 578 (if (numberp sublist) (equal sublist list) (eq sublist list))) | |
| 579 | |
| 2153 | 580 (defalias 'cl-copy-tree 'copy-tree) |
| 428 | 581 |
| 582 | |
| 583 ;;; Property lists. | |
| 584 | |
| 585 ;; XEmacs: our `get' groks DEFAULT. | |
| 586 (defalias 'get* 'get) | |
| 442 | 587 (defalias 'getf 'plist-get) |
| 428 | 588 |
| 589 (defun cl-set-getf (plist tag val) | |
| 590 (let ((p plist)) | |
| 591 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) | |
| 592 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) | |
| 593 | |
| 594 (defun cl-do-remf (plist tag) | |
| 595 (let ((p (cdr plist))) | |
| 596 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) | |
| 597 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) | |
| 598 | |
| 2153 | 599 ;; XEmacs change: we have a builtin remprop |
| 600 (defalias 'cl-remprop 'remprop) | |
| 601 | |
|
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
602 (defun get-properties (plist indicator-list) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
603 "Find a property from INDICATOR-LIST in PLIST. |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
604 Return 3 values: |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
605 - the first property found, |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
606 - its value, |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
607 - the tail of PLIST beginning with the found entry." |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
608 (do ((plst plist (cddr plst))) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
609 ((null plst) (values nil nil nil)) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
610 (cond ((atom (cdr plst)) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
611 (error "Malformed property list: %S." plist)) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
612 ((memq (car plst) indicator-list) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
613 (return (values (car plst) (cadr plst) plst)))))) |
| 2153 | 614 |
|
5075
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
615 ;; See also the compiler macro in cl-macs.el. |
|
5056
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
616 (defun constantly (value &rest more-values) |
|
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
617 "Construct a function always returning VALUE, and possibly MORE-VALUES. |
|
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
618 |
|
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
619 The constructed function accepts any number of arguments, and ignores them. |
|
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
620 |
|
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
621 Members of MORE-VALUES, if provided, will be passed as multiple values; see |
|
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
622 `multiple-value-bind' and `multiple-value-setq'." |
|
5075
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
623 (symbol-macrolet |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
624 ((arglist '(&rest ignore))) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
625 (if (or more-values (eval-when-compile (not (cl-compiling-file)))) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
626 `(lambda ,arglist (values-list ',(cons value more-values))) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
627 (make-byte-code |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
628 arglist |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
629 (eval-when-compile |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
630 (let ((compiled (byte-compile-sexp #'(lambda (&rest ignore) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
631 (declare (ignore ignore)) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
632 'placeholder)))) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
633 (assert (and |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
634 (equal [placeholder] |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
635 (compiled-function-constants compiled)) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
636 (= 1 (compiled-function-stack-depth compiled))) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
637 t |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
638 "Our assumptions about compiled code appear not to hold.") |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
639 (compiled-function-instructions compiled))) |
|
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
640 (vector value) 1)))) |
| 2153 | 641 |
| 428 | 642 ;;; Hash tables. |
| 643 | |
| 644 ;; The `regular' Common Lisp hash-table stuff has been moved into C. | |
| 645 ;; Only backward compatibility stuff remains here. | |
| 646 (defun make-hashtable (size &optional test) | |
| 647 (make-hash-table :test test :size size)) | |
| 648 (defun make-weak-hashtable (size &optional test) | |
| 649 (make-hash-table :test test :size size :weakness t)) | |
| 650 (defun make-key-weak-hashtable (size &optional test) | |
| 651 (make-hash-table :test test :size size :weakness 'key)) | |
| 652 (defun make-value-weak-hashtable (size &optional test) | |
| 653 (make-hash-table :test test :size size :weakness 'value)) | |
| 654 | |
| 655 (define-obsolete-function-alias 'hashtablep 'hash-table-p) | |
| 656 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) | |
| 657 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) | |
| 658 (define-obsolete-function-alias 'hashtable-type 'hash-table-type) | |
| 659 (define-obsolete-function-alias 'hashtable-size 'hash-table-size) | |
| 660 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table) | |
| 661 | |
| 662 (make-obsolete 'make-hashtable 'make-hash-table) | |
| 663 (make-obsolete 'make-weak-hashtable 'make-hash-table) | |
| 664 (make-obsolete 'make-key-weak-hashtable 'make-hash-table) | |
| 665 (make-obsolete 'make-value-weak-hashtable 'make-hash-table) | |
| 666 (make-obsolete 'hash-table-type 'hash-table-weakness) | |
| 667 | |
| 668 (when (fboundp 'x-keysym-hash-table) | |
| 669 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) | |
| 670 | |
| 671 ;; Compatibility stuff for old kludgy cl.el hash table implementation | |
| 672 (defvar cl-builtin-gethash (symbol-function 'gethash)) | |
| 673 (defvar cl-builtin-remhash (symbol-function 'remhash)) | |
| 674 (defvar cl-builtin-clrhash (symbol-function 'clrhash)) | |
| 675 (defvar cl-builtin-maphash (symbol-function 'maphash)) | |
| 676 | |
| 677 (defalias 'cl-gethash 'gethash) | |
| 678 (defalias 'cl-puthash 'puthash) | |
| 679 (defalias 'cl-remhash 'remhash) | |
| 680 (defalias 'cl-clrhash 'clrhash) | |
| 681 (defalias 'cl-maphash 'maphash) | |
| 2153 | 682 ;; These three actually didn't exist in Emacs-20. |
| 683 (defalias 'cl-make-hash-table 'make-hash-table) | |
| 684 (defalias 'cl-hash-table-p 'hash-table-p) | |
| 685 (defalias 'cl-hash-table-count 'hash-table-count) | |
| 428 | 686 |
| 687 ;;; Some debugging aids. | |
| 688 | |
| 689 (defun cl-prettyprint (form) | |
| 690 "Insert a pretty-printed rendition of a Lisp FORM in current buffer." | |
| 691 (let ((pt (point)) last) | |
| 692 (insert "\n" (prin1-to-string form) "\n") | |
| 693 (setq last (point)) | |
| 694 (goto-char (1+ pt)) | |
| 695 (while (search-forward "(quote " last t) | |
| 696 (delete-backward-char 7) | |
| 697 (insert "'") | |
| 698 (forward-sexp) | |
| 699 (delete-char 1)) | |
| 700 (goto-char (1+ pt)) | |
| 701 (cl-do-prettyprint))) | |
| 702 | |
| 703 (defun cl-do-prettyprint () | |
| 704 (skip-chars-forward " ") | |
| 705 (if (looking-at "(") | |
|
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
706 (let ((skip (or (looking-at "((") |
| 2153 | 707 ;; XEmacs: be selective about trailing stuff after prog |
| 1729 | 708 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") |
| 428 | 709 (looking-at "(unwind-protect ") |
| 710 (looking-at "(function (") | |
| 711 (looking-at "(cl-block-wrapper "))) | |
| 712 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) | |
| 713 (let (or (looking-at "(let\\*? ") (looking-at "(while "))) | |
| 714 (set (looking-at "(p?set[qf] "))) | |
| 715 (if (or skip let | |
| 716 (progn | |
| 717 (forward-sexp) | |
| 718 (and (>= (current-column) 78) (progn (backward-sexp) t)))) | |
| 719 (let ((nl t)) | |
| 720 (forward-char 1) | |
| 721 (cl-do-prettyprint) | |
| 722 (or skip (looking-at ")") (cl-do-prettyprint)) | |
| 723 (or (not two) (looking-at ")") (cl-do-prettyprint)) | |
| 724 (while (not (looking-at ")")) | |
| 725 (if set (setq nl (not nl))) | |
| 726 (if nl (insert "\n")) | |
| 727 (lisp-indent-line) | |
| 728 (cl-do-prettyprint)) | |
| 729 (forward-char 1)))) | |
| 730 (forward-sexp))) | |
| 731 | |
| 732 (defvar cl-macroexpand-cmacs nil) | |
| 733 (defvar cl-closure-vars nil) | |
| 734 | |
| 735 (defun cl-macroexpand-all (form &optional env) | |
| 736 "Expand all macro calls through a Lisp FORM. | |
| 737 This also does some trivial optimizations to make the form prettier." | |
| 738 (while (or (not (eq form (setq form (macroexpand form env)))) | |
| 739 (and cl-macroexpand-cmacs | |
| 740 (not (eq form (setq form (compiler-macroexpand form))))))) | |
| 741 (cond ((not (consp form)) form) | |
| 742 ((memq (car form) '(let let*)) | |
| 743 (if (null (nth 1 form)) | |
| 744 (cl-macroexpand-all (cons 'progn (cddr form)) env) | |
| 745 (let ((letf nil) (res nil) (lets (cadr form))) | |
| 746 (while lets | |
| 2153 | 747 (push (if (consp (car lets)) |
| 428 | 748 (let ((exp (cl-macroexpand-all (caar lets) env))) |
| 749 (or (symbolp exp) (setq letf t)) | |
| 750 (cons exp (cl-macroexpand-body (cdar lets) env))) | |
| 751 (let ((exp (cl-macroexpand-all (car lets) env))) | |
| 752 (if (symbolp exp) exp | |
| 753 (setq letf t) (list exp nil)))) res) | |
| 754 (setq lets (cdr lets))) | |
| 755 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) | |
| 756 (nreverse res) (cl-macroexpand-body (cddr form) env))))) | |
| 757 ((eq (car form) 'cond) | |
| 758 (cons (car form) | |
| 759 (mapcar (function (lambda (x) (cl-macroexpand-body x env))) | |
| 760 (cdr form)))) | |
| 761 ((eq (car form) 'condition-case) | |
| 762 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) | |
| 763 (mapcar (function | |
| 764 (lambda (x) | |
| 765 (cons (car x) (cl-macroexpand-body (cdr x) env)))) | |
| 766 (cdddr form)))) | |
| 767 ((memq (car form) '(quote function)) | |
| 768 (if (eq (car-safe (nth 1 form)) 'lambda) | |
| 769 (let ((body (cl-macroexpand-body (cddadr form) env))) | |
| 770 (if (and cl-closure-vars (eq (car form) 'function) | |
| 771 (cl-expr-contains-any body cl-closure-vars)) | |
| 772 (let* ((new (mapcar 'gensym cl-closure-vars)) | |
| 773 (sub (pairlis cl-closure-vars new)) (decls nil)) | |
| 774 (while (or (stringp (car body)) | |
| 775 (eq (car-safe (car body)) 'interactive)) | |
| 2153 | 776 (push (list 'quote (pop body)) decls)) |
| 428 | 777 (put (car (last cl-closure-vars)) 'used t) |
| 778 (append | |
| 779 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | |
| 780 (sublis sub (nreverse decls)) | |
| 781 (list | |
| 782 (list* 'list '(quote apply) | |
| 2153 | 783 ;; XEmacs: put a quote before the function |
| 428 | 784 (list 'list '(quote quote) |
| 785 (list 'function | |
| 786 (list* 'lambda | |
| 787 (append new (cadadr form)) | |
| 788 (sublis sub body)))) | |
| 789 (nconc (mapcar (function | |
| 790 (lambda (x) | |
| 791 (list 'list '(quote quote) x))) | |
| 792 cl-closure-vars) | |
| 793 '((quote --cl-rest--))))))) | |
| 794 (list (car form) (list* 'lambda (cadadr form) body)))) | |
| 795 (let ((found (assq (cadr form) env))) | |
| 2153 | 796 ;; XEmacs: cadr/caddr operate on nil without errors |
| 428 | 797 (if (eq (cadr (caddr found)) 'cl-labels-args) |
| 798 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) | |
| 799 form)))) | |
| 800 ((memq (car form) '(defun defmacro)) | |
| 801 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) | |
| 802 ((and (eq (car form) 'progn) (not (cddr form))) | |
| 803 (cl-macroexpand-all (nth 1 form) env)) | |
| 804 ((eq (car form) 'setq) | |
| 805 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) | |
| 806 (while (and p (symbolp (car p))) (setq p (cddr p))) | |
| 807 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) | |
| 808 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) | |
| 809 | |
| 810 (defun cl-macroexpand-body (body &optional env) | |
| 811 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) | |
| 812 | |
| 813 (defun cl-prettyexpand (form &optional full) | |
| 814 (message "Expanding...") | |
| 815 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) | |
| 816 (byte-compile-macro-environment nil)) | |
| 817 (setq form (cl-macroexpand-all form | |
| 818 (and (not full) '((block) (eval-when))))) | |
| 819 (message "Formatting...") | |
| 820 (prog1 (cl-prettyprint form) | |
| 821 (message "")))) | |
| 822 | |
| 823 | |
| 824 | |
| 825 (run-hooks 'cl-extra-load-hook) | |
| 826 | |
| 2153 | 827 ;; XEmacs addition |
| 428 | 828 (provide 'cl-extra) |
| 829 | |
| 2153 | 830 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed |
| 428 | 831 ;;; cl-extra.el ends here |