Mercurial > hg > xemacs-beta
annotate lisp/cl-extra.el @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Mon, 07 Feb 2011 12:01:24 +0000 |
parents | ba62563ec7c7 |
children | 5f5d48053e86 0af042a0c116 |
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 ;;; Type coercion. | |
55 | |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
56 (defun coerce (object type) |
428 | 57 "Coerce OBJECT to type TYPE. |
58 TYPE is a Common Lisp type specifier." | |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
59 (cond ((eq type 'list) (if (listp object) object (append object nil))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
60 ((eq type 'vector) (if (vectorp object) object (vconcat object))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
61 ((eq type 'string) (if (stringp object) object (concat object))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
62 ((eq type 'array) (if (arrayp object) object (vconcat object))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
63 ((and (eq type 'character) (stringp object) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
64 (eql (length object) 1)) (aref object 0)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
65 ((and (eq type 'character) (symbolp object)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
66 (coerce (symbol-name object) type)) |
2153 | 67 ;; XEmacs addition character <-> integer coercions |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
68 ((and (eq type 'character) (char-int-p object)) (int-char object)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
69 ((and (memq type '(integer fixnum)) (characterp object)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
70 (char-int object)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
71 ((eq type 'float) (float object)) |
2153 | 72 ;; XEmacs addition: enhanced numeric type coercions |
2367 | 73 ((and-fboundp 'coerce-number |
5257
30bf66dd3ca0
Add fixnum as an accepted destination type, #'coerce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5242
diff
changeset
|
74 (memq type '(integer ratio bigfloat fixnum)) |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
75 (coerce-number object type))) |
2153 | 76 ;; 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
|
77 ((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
|
78 (eq type 'simple-bit-vector)) |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
79 (if (bit-vector-p object) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
80 object |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
81 (apply 'bit-vector (append object nil)))) |
2153 | 82 ;; XEmacs addition: weak-list coercion |
428 | 83 ((eq type 'weak-list) |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
84 (if (weak-list-p object) object |
428 | 85 (let ((wl (make-weak-list))) |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
86 (set-weak-list-list wl (if (listp object) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
87 object |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
88 (append object nil))) |
428 | 89 wl))) |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4800
diff
changeset
|
90 ((and |
5305
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
91 (memq (car-safe type) '(vector simple-array)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
92 (loop |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
93 for (ignore elements length) = type |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
94 initially (declare (special ignore)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
95 return (if (or (memq length '(* nil)) (eql length (length object))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
96 (cond |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
97 ((memq elements '(t * nil)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
98 (coerce object 'vector)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
99 ((memq elements '(string-char character)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
100 (coerce object 'string)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
101 ((eq elements 'bit) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
102 (coerce object 'bit-vector))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
103 (error |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
104 'wrong-type-argument |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
105 "Type specifier length must equal sequence length" |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
106 type))))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
107 ((eq (car-safe type) 'simple-vector) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
108 (coerce object (list* 'vector t (cdr type)))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
109 ((memq (car-safe type) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
110 '(string simple-string base-string simple-base-string)) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
111 (coerce object (list* 'vector 'character (cdr type)))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
112 ((eq (car-safe type) 'bit-vector) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
113 (coerce object (list* 'vector 'bit (cdr type)))) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
114 ((typep object type) object) |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
115 (t (error 'invalid-operation |
09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
116 "Can't coerce object to type" object type)))) |
428 | 117 |
5219
2d0937dc83cf
Tidying of CL files; make docstrings read better, remove commented-out code
Aidan Kehoe <kehoea@parhasard.net>
parents:
5162
diff
changeset
|
118 ;; XEmacs; #'equalp is in C. |
428 | 119 |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
120 ;; 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
|
121 ;; are now in C, together with #'map-into, which was never in this file. |
428 | 122 |
5226
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
123 ;; The compiler macro for this in cl-macs.el means if #'complement is handed |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
124 ;; a constant expression, byte-compiled code will see a byte-compiled |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
125 ;; function. |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
126 (defun complement (function &optional documentation) |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
127 "Return a function which gives the logical inverse of what FUNCTION would." |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
128 `(lambda (&rest arguments) ,@(if documentation (list documentation)) |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
129 (not (apply ',function arguments)))) |
7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5219
diff
changeset
|
130 |
5312
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
131 (defun notany (cl-predicate cl-seq &rest cl-rest) |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
132 "Return true if PREDICATE is false of every element of SEQUENCE. |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
133 |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
134 With optional SEQUENCES, call PREDICATE each time with as many arguments as |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
135 there are SEQUENCES (plus one for the element from SEQUENCE). |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
136 |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
137 arguments: (PREDICATE SEQUENCES &rest SEQUENCES)" |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
138 (not (apply 'some cl-predicate cl-seq cl-rest))) |
428 | 139 |
5312
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
140 (defun notevery (cl-predicate cl-seq &rest cl-rest) |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
141 "Return true if PREDICATE is false of some element of SEQUENCE. |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
142 |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
143 With optional SEQUENCES, call PREDICATE each time with as many arguments as |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
144 there are SEQUENCES (plus one for the element from SEQUENCE). |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
145 |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
146 arguments: (PREDICATE SEQUENCES &rest SEQUENCES)" |
f6471e4ae703
Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5305
diff
changeset
|
147 (not (apply 'every cl-predicate cl-seq cl-rest))) |
428 | 148 |
149 ;;; Support for `loop'. | |
2153 | 150 (defalias 'cl-map-keymap 'map-keymap) |
428 | 151 |
152 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) | |
153 (or cl-base | |
2153 | 154 (setq cl-base (copy-sequence [0]))) |
155 (map-keymap | |
428 | 156 (function |
157 (lambda (cl-key cl-bind) | |
158 (aset cl-base (1- (length cl-base)) cl-key) | |
159 (if (keymapp cl-bind) | |
160 (cl-map-keymap-recursively | |
161 cl-func-rec cl-bind | |
2153 | 162 (vconcat cl-base (list 0))) |
428 | 163 (funcall cl-func-rec cl-base cl-bind)))) |
164 cl-map)) | |
165 | |
166 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) | |
167 (or cl-what (setq cl-what (current-buffer))) | |
168 (if (bufferp cl-what) | |
169 (let (cl-mark cl-mark2 (cl-next t) cl-next2) | |
2153 | 170 (with-current-buffer cl-what |
428 | 171 (setq cl-mark (copy-marker (or cl-start (point-min)))) |
172 (setq cl-mark2 (and cl-end (copy-marker cl-end)))) | |
173 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) | |
2153 | 174 (setq cl-next (if cl-prop (next-single-property-change |
175 cl-mark cl-prop cl-what) | |
176 (next-property-change cl-mark cl-what)) | |
177 cl-next2 (or cl-next (with-current-buffer cl-what | |
178 (point-max)))) | |
428 | 179 (funcall cl-func (prog1 (marker-position cl-mark) |
180 (set-marker cl-mark cl-next2)) | |
181 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) | |
182 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) | |
183 (or cl-start (setq cl-start 0)) | |
184 (or cl-end (setq cl-end (length cl-what))) | |
185 (while (< cl-start cl-end) | |
2153 | 186 (let ((cl-next (or (if cl-prop (next-single-property-change |
187 cl-start cl-prop cl-what) | |
188 (next-property-change cl-start cl-what)) | |
428 | 189 cl-end))) |
190 (funcall cl-func cl-start (min cl-next cl-end)) | |
191 (setq cl-start cl-next))))) | |
192 | |
193 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) | |
194 (or cl-buffer (setq cl-buffer (current-buffer))) | |
502 | 195 (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change) |
196 (if-fboundp 'overlay-lists | |
428 | 197 |
502 | 198 ;; This is the preferred algorithm, though overlay-lists is |
199 ;; undocumented. | |
200 (let (cl-ovl) | |
2153 | 201 (with-current-buffer cl-buffer |
502 | 202 (setq cl-ovl (overlay-lists)) |
203 (if cl-start (setq cl-start (copy-marker cl-start))) | |
204 (if cl-end (setq cl-end (copy-marker cl-end)))) | |
205 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) | |
206 (while (and cl-ovl | |
207 (or (not (overlay-start (car cl-ovl))) | |
208 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) | |
209 (and cl-start (<= (overlay-end (car cl-ovl)) | |
210 cl-start)) | |
211 (not (funcall cl-func (car cl-ovl) cl-arg)))) | |
212 (setq cl-ovl (cdr cl-ovl))) | |
213 (if cl-start (set-marker cl-start nil)) | |
214 (if cl-end (set-marker cl-end nil))) | |
215 | |
216 ;; This alternate algorithm fails to find zero-length overlays. | |
2153 | 217 (let ((cl-mark (with-current-buffer cl-buffer |
218 (copy-marker (or cl-start (point-min))))) | |
219 (cl-mark2 (and cl-end (with-current-buffer cl-buffer | |
220 (copy-marker cl-end)))) | |
502 | 221 cl-pos cl-ovl) |
222 (while (save-excursion | |
223 (and (setq cl-pos (marker-position cl-mark)) | |
224 (< cl-pos (or cl-mark2 (point-max))) | |
225 (progn | |
226 (set-buffer cl-buffer) | |
227 (setq cl-ovl (overlays-at cl-pos)) | |
228 (set-marker cl-mark (next-overlay-change cl-pos))))) | |
229 (while (and cl-ovl | |
230 (or (/= (overlay-start (car cl-ovl)) cl-pos) | |
231 (not (and (funcall cl-func (car cl-ovl) cl-arg) | |
232 (set-marker cl-mark nil))))) | |
233 (setq cl-ovl (cdr cl-ovl)))) | |
234 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))) | |
428 | 235 |
236 ;;; Support for `setf'. | |
237 (defun cl-set-frame-visible-p (frame val) | |
238 (cond ((null val) (make-frame-invisible frame)) | |
239 ((eq val 'icon) (iconify-frame frame)) | |
240 (t (make-frame-visible frame))) | |
241 val) | |
242 | |
243 ;;; Support for `progv'. | |
244 (defvar cl-progv-save) | |
245 (defun cl-progv-before (syms values) | |
246 (while syms | |
2153 | 247 (push (if (boundp (car syms)) |
428 | 248 (cons (car syms) (symbol-value (car syms))) |
249 (car syms)) cl-progv-save) | |
250 (if values | |
2153 | 251 (set (pop syms) (pop values)) |
252 (makunbound (pop syms))))) | |
428 | 253 |
254 (defun cl-progv-after () | |
255 (while cl-progv-save | |
256 (if (consp (car cl-progv-save)) | |
257 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) | |
258 (makunbound (car cl-progv-save))) | |
2153 | 259 (pop cl-progv-save))) |
428 | 260 |
261 ;;; Numbers. | |
262 | |
263 (defun gcd (&rest args) | |
264 "Return the greatest common divisor of the arguments." | |
2153 | 265 (let ((a (abs (or (pop args) 0)))) |
428 | 266 (while args |
2153 | 267 (let ((b (abs (pop args)))) |
428 | 268 (while (> b 0) (setq b (% a (setq a b)))))) |
269 a)) | |
270 | |
271 (defun lcm (&rest args) | |
272 "Return the least common multiple of the arguments." | |
273 (if (memq 0 args) | |
274 0 | |
2153 | 275 (let ((a (abs (or (pop args) 1)))) |
428 | 276 (while args |
2153 | 277 (let ((b (abs (pop args)))) |
428 | 278 (setq a (* (/ a (gcd a b)) b)))) |
279 a))) | |
280 | |
281 (defun isqrt (a) | |
282 "Return the integer square root of the argument." | |
283 (if (and (integerp a) (> a 0)) | |
284 ;; XEmacs change | |
285 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) | |
286 ((>= a 100) 100) (t 10))) | |
287 g2) | |
288 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
289 (setq g g2)) | |
290 g) | |
291 (if (eq a 0) 0 (signal 'arith-error nil)))) | |
292 | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
293 ;; 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
|
294 ;; definition-and-call: |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
295 ((macro . (lambda (&rest symbols) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
296 "Make some old CL package truncate and round functions available. |
428 | 297 |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
298 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
|
299 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
|
300 (let (symbol result) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
301 (while symbols |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
302 (setq symbol (car symbols) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
303 symbols (cdr symbols)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
304 (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
|
305 ',symbol "21.5.29") |
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
306 result) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
307 (push |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
308 `(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
|
309 ,(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
|
310 symbol) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
311 (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
|
312 result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
313 (cons 'progn result)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
314 ceiling floor round truncate) |
428 | 315 |
316 (defun mod* (x y) | |
317 "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
|
318 (nth-value 1 (floor x y))) |
428 | 319 |
320 (defun rem* (x y) | |
321 "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
|
322 (nth-value 1 (truncate x y))) |
428 | 323 |
324 (defun signum (a) | |
325 "Return 1 if A is positive, -1 if negative, 0 if zero." | |
326 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | |
327 | |
328 ;; Random numbers. | |
329 | |
330 (defvar *random-state*) | |
331 (defun random* (lim &optional state) | |
332 "Return a random nonnegative number less than LIM, an integer or float. | |
333 Optional second arg STATE is a random-state object." | |
334 (or state (setq state *random-state*)) | |
335 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. | |
336 (let ((vec (aref state 3))) | |
337 (if (integerp vec) | |
338 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) | |
339 (aset state 3 (setq vec (make-vector 55 nil))) | |
340 (aset vec 0 j) | |
341 (while (> (setq i (% (+ i 21) 55)) 0) | |
342 (aset vec i (setq j (prog1 k (setq k (- j k)))))) | |
343 (while (< (setq i (1+ i)) 200) (random* 2 state)))) | |
344 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) | |
345 (j (aset state 2 (% (1+ (aref state 2)) 55))) | |
346 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) | |
347 (if (integerp lim) | |
348 (if (<= lim 512) (% n lim) | |
349 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) | |
350 (let ((mask 1023)) | |
351 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) | |
352 (if (< (setq n (logand n mask)) lim) n (random* lim state)))) | |
353 (* (/ n '8388608e0) lim))))) | |
354 | |
355 (defun make-random-state (&optional state) | |
356 "Return a copy of random-state STATE, or of `*random-state*' if omitted. | |
357 If STATE is t, return a new state object seeded from the time of day." | |
358 (cond ((null state) (make-random-state *random-state*)) | |
359 ((vectorp state) (cl-copy-tree state t)) | |
360 ((integerp state) (vector 'cl-random-state-tag -1 30 state)) | |
361 (t (make-random-state (cl-random-time))))) | |
362 | |
363 (defun random-state-p (object) | |
364 "Return t if OBJECT is a random-state object." | |
365 (and (vectorp object) (= (length object) 4) | |
366 (eq (aref object 0) 'cl-random-state-tag))) | |
367 | |
368 | |
369 ;; Implementation limits. | |
370 | |
371 (defun cl-finite-do (func a b) | |
372 (condition-case nil | |
373 (let ((res (funcall func a b))) ; check for IEEE infinity | |
374 (and (numberp res) (/= res (/ res 2)) res)) | |
375 (arith-error nil))) | |
376 | |
377 (defun cl-float-limits () | |
378 (or most-positive-float (not (numberp '2e1)) | |
379 (let ((x '2e0) y z) | |
380 ;; Find maximum exponent (first two loops are optimizations) | |
381 (while (cl-finite-do '* x x) (setq x (* x x))) | |
382 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) | |
383 (while (cl-finite-do '+ x x) (setq x (+ x x))) | |
384 (setq z x y (/ x 2)) | |
385 ;; Now fill in 1's in the mantissa. | |
386 (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) | |
387 (setq x (+ x y) y (/ y 2))) | |
388 (setq most-positive-float x | |
389 most-negative-float (- x)) | |
390 ;; Divide down until mantissa starts rounding. | |
391 (setq x (/ x z) y (/ 16 z) x (* x y)) | |
392 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) | |
393 (arith-error nil)) | |
394 (setq x (/ x 2) y (/ y 2))) | |
395 (setq least-positive-normalized-float y | |
396 least-negative-normalized-float (- y)) | |
397 ;; Divide down until value underflows to zero. | |
398 (setq x (/ 1 z) y x) | |
399 (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) | |
400 (setq x (/ x 2))) | |
401 (setq least-positive-float x | |
402 least-negative-float (- x)) | |
403 (setq x '1e0) | |
404 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) | |
405 (setq float-epsilon (* x 2)) | |
406 (setq x '1e0) | |
407 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) | |
408 (setq float-negative-epsilon (* x 2)))) | |
409 nil) | |
410 | |
5219
2d0937dc83cf
Tidying of CL files; make docstrings read better, remove commented-out code
Aidan Kehoe <kehoea@parhasard.net>
parents:
5162
diff
changeset
|
411 ;; XEmacs; call cl-float-limits at dump time. |
2d0937dc83cf
Tidying of CL files; make docstrings read better, remove commented-out code
Aidan Kehoe <kehoea@parhasard.net>
parents:
5162
diff
changeset
|
412 (cl-float-limits) |
428 | 413 |
414 ;;; Sequence functions. | |
415 | |
5219
2d0937dc83cf
Tidying of CL files; make docstrings read better, remove commented-out code
Aidan Kehoe <kehoea@parhasard.net>
parents:
5162
diff
changeset
|
416 ;; XEmacs; #'subseq is in C. |
428 | 417 |
418 (defun concatenate (type &rest seqs) | |
419 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | |
2153 | 420 ;; XEmacs change: use case instead of cond for clarity |
428 | 421 (case type |
422 (vector (apply 'vconcat seqs)) | |
423 (string (apply 'concat seqs)) | |
5339
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5312
diff
changeset
|
424 (list (reduce 'append seqs :from-end t :initial-value nil)) |
5242
f3eca926258e
Bit vectors are also sequences; enforce this in some CL functions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5226
diff
changeset
|
425 (bit-vector (apply 'bvconcat seqs)) |
5339
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5312
diff
changeset
|
426 (t (coerce (reduce 'append seqs :from-end t :initial-value nil) type)))) |
428 | 427 |
428 ;;; List functions. | |
429 | |
430 (defun revappend (x y) | |
431 "Equivalent to (append (reverse X) Y)." | |
432 (nconc (reverse x) y)) | |
433 | |
434 (defun nreconc (x y) | |
435 "Equivalent to (nconc (nreverse X) Y)." | |
436 (nconc (nreverse x) y)) | |
437 | |
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
438 ;; XEmacs; check LIST for type and circularity. |
428 | 439 (defun tailp (sublist list) |
440 "Return true if SUBLIST is a tail of LIST." | |
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
441 (check-argument-type #'listp list) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
442 (let ((before list) (evenp t)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
443 (while (and (consp list) (not (eq sublist list))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
444 (setq list (cdr list) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
445 evenp (not evenp)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
446 (if evenp (setq before (cdr before))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
447 (if (eq before list) (error 'circular-list list))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
448 (eql sublist list))) |
428 | 449 |
2153 | 450 (defalias 'cl-copy-tree 'copy-tree) |
428 | 451 |
452 ;;; Property lists. | |
453 | |
454 ;; XEmacs: our `get' groks DEFAULT. | |
455 (defalias 'get* 'get) | |
442 | 456 (defalias 'getf 'plist-get) |
428 | 457 |
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
458 ;; XEmacs; these are built-in. |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
459 (defalias 'cl-set-getf 'plist-put) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
460 (defalias 'cl-do-remf 'plist-remprop) |
2153 | 461 (defalias 'cl-remprop 'remprop) |
462 | |
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
463 (defun get-properties (plist indicator-list) |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
464 "Find a property from INDICATOR-LIST in PLIST. |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
465 Return 3 values: |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
466 - the first property found, |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
467 - its value, |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
468 - 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
|
469 (do ((plst plist (cddr plst))) |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
470 ((null plst) (values nil nil nil)) |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
471 (cond ((atom (cdr plst)) |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
472 (error "Malformed property list: %S." plist)) |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
473 ((memq (car plst) indicator-list) |
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
474 (return (values (car plst) (cadr plst) plst)))))) |
2153 | 475 |
5075
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
476 ;; 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
|
477 (defun constantly (value &rest more-values) |
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
478 "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
|
479 |
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
480 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
|
481 |
6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4997
diff
changeset
|
482 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
|
483 `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
|
484 (symbol-macrolet |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
485 ((arglist '(&rest ignore))) |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
486 (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
|
487 `(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
|
488 (make-byte-code |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
489 arglist |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
490 (eval-when-compile |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
491 (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
|
492 (declare (ignore ignore)) |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
493 'placeholder)))) |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
494 (assert (and |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
495 (equal [placeholder] |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
496 (compiled-function-constants compiled)) |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
497 (= 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
|
498 t |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
499 "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
|
500 (compiled-function-instructions compiled))) |
868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5056
diff
changeset
|
501 (vector value) 1)))) |
2153 | 502 |
428 | 503 ;;; Hash tables. |
504 | |
505 ;; The `regular' Common Lisp hash-table stuff has been moved into C. | |
506 ;; Only backward compatibility stuff remains here. | |
507 (defun make-hashtable (size &optional test) | |
508 (make-hash-table :test test :size size)) | |
509 (defun make-weak-hashtable (size &optional test) | |
510 (make-hash-table :test test :size size :weakness t)) | |
511 (defun make-key-weak-hashtable (size &optional test) | |
512 (make-hash-table :test test :size size :weakness 'key)) | |
513 (defun make-value-weak-hashtable (size &optional test) | |
514 (make-hash-table :test test :size size :weakness 'value)) | |
515 | |
516 (define-obsolete-function-alias 'hashtablep 'hash-table-p) | |
517 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) | |
518 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) | |
519 (define-obsolete-function-alias 'hashtable-type 'hash-table-type) | |
520 (define-obsolete-function-alias 'hashtable-size 'hash-table-size) | |
521 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table) | |
522 | |
523 (make-obsolete 'make-hashtable 'make-hash-table) | |
524 (make-obsolete 'make-weak-hashtable 'make-hash-table) | |
525 (make-obsolete 'make-key-weak-hashtable 'make-hash-table) | |
526 (make-obsolete 'make-value-weak-hashtable 'make-hash-table) | |
527 (make-obsolete 'hash-table-type 'hash-table-weakness) | |
528 | |
529 (when (fboundp 'x-keysym-hash-table) | |
530 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) | |
531 | |
532 ;; Compatibility stuff for old kludgy cl.el hash table implementation | |
533 (defvar cl-builtin-gethash (symbol-function 'gethash)) | |
534 (defvar cl-builtin-remhash (symbol-function 'remhash)) | |
535 (defvar cl-builtin-clrhash (symbol-function 'clrhash)) | |
536 (defvar cl-builtin-maphash (symbol-function 'maphash)) | |
537 | |
538 (defalias 'cl-gethash 'gethash) | |
539 (defalias 'cl-puthash 'puthash) | |
540 (defalias 'cl-remhash 'remhash) | |
541 (defalias 'cl-clrhash 'clrhash) | |
542 (defalias 'cl-maphash 'maphash) | |
2153 | 543 ;; These three actually didn't exist in Emacs-20. |
544 (defalias 'cl-make-hash-table 'make-hash-table) | |
545 (defalias 'cl-hash-table-p 'hash-table-p) | |
546 (defalias 'cl-hash-table-count 'hash-table-count) | |
428 | 547 |
548 ;;; Some debugging aids. | |
549 | |
550 (defun cl-prettyprint (form) | |
551 "Insert a pretty-printed rendition of a Lisp FORM in current buffer." | |
5162
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
552 (let ((pt (point)) last just) |
428 | 553 (insert "\n" (prin1-to-string form) "\n") |
554 (setq last (point)) | |
555 (goto-char (1+ pt)) | |
5162
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
556 (while (re-search-forward "(\\(?:\\(?:function\\|quote\\) \\)" last t) |
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
557 (delete-region (match-beginning 0) (match-end 0)) |
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
558 (if (= (length "(function ") (- (match-end 0) (match-beginning 0))) |
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
559 (insert "#'") |
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
560 (insert "'")) |
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
561 (setq just (point)) |
428 | 562 (forward-sexp) |
5162
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
563 (delete-char 1) |
41262f87eb39
Handle (function ...) specially, cl-prettyprint.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5075
diff
changeset
|
564 (goto-char just)) |
428 | 565 (goto-char (1+ pt)) |
566 (cl-do-prettyprint))) | |
567 | |
568 (defun cl-do-prettyprint () | |
569 (skip-chars-forward " ") | |
570 (if (looking-at "(") | |
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
571 (let ((skip (or (looking-at "((") |
2153 | 572 ;; XEmacs: be selective about trailing stuff after prog |
1729 | 573 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") |
428 | 574 (looking-at "(unwind-protect ") |
575 (looking-at "(function (") | |
576 (looking-at "(cl-block-wrapper "))) | |
577 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) | |
578 (let (or (looking-at "(let\\*? ") (looking-at "(while "))) | |
579 (set (looking-at "(p?set[qf] "))) | |
580 (if (or skip let | |
581 (progn | |
582 (forward-sexp) | |
583 (and (>= (current-column) 78) (progn (backward-sexp) t)))) | |
584 (let ((nl t)) | |
585 (forward-char 1) | |
586 (cl-do-prettyprint) | |
587 (or skip (looking-at ")") (cl-do-prettyprint)) | |
588 (or (not two) (looking-at ")") (cl-do-prettyprint)) | |
589 (while (not (looking-at ")")) | |
590 (if set (setq nl (not nl))) | |
591 (if nl (insert "\n")) | |
592 (lisp-indent-line) | |
593 (cl-do-prettyprint)) | |
594 (forward-char 1)))) | |
595 (forward-sexp))) | |
596 | |
597 (defvar cl-macroexpand-cmacs nil) | |
598 (defvar cl-closure-vars nil) | |
599 | |
600 (defun cl-macroexpand-all (form &optional env) | |
601 "Expand all macro calls through a Lisp FORM. | |
602 This also does some trivial optimizations to make the form prettier." | |
603 (while (or (not (eq form (setq form (macroexpand form env)))) | |
604 (and cl-macroexpand-cmacs | |
605 (not (eq form (setq form (compiler-macroexpand form))))))) | |
606 (cond ((not (consp form)) form) | |
607 ((memq (car form) '(let let*)) | |
608 (if (null (nth 1 form)) | |
609 (cl-macroexpand-all (cons 'progn (cddr form)) env) | |
610 (let ((letf nil) (res nil) (lets (cadr form))) | |
611 (while lets | |
2153 | 612 (push (if (consp (car lets)) |
428 | 613 (let ((exp (cl-macroexpand-all (caar lets) env))) |
614 (or (symbolp exp) (setq letf t)) | |
615 (cons exp (cl-macroexpand-body (cdar lets) env))) | |
616 (let ((exp (cl-macroexpand-all (car lets) env))) | |
617 (if (symbolp exp) exp | |
618 (setq letf t) (list exp nil)))) res) | |
619 (setq lets (cdr lets))) | |
620 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) | |
621 (nreverse res) (cl-macroexpand-body (cddr form) env))))) | |
622 ((eq (car form) 'cond) | |
623 (cons (car form) | |
624 (mapcar (function (lambda (x) (cl-macroexpand-body x env))) | |
625 (cdr form)))) | |
626 ((eq (car form) 'condition-case) | |
627 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) | |
628 (mapcar (function | |
629 (lambda (x) | |
630 (cons (car x) (cl-macroexpand-body (cdr x) env)))) | |
631 (cdddr form)))) | |
632 ((memq (car form) '(quote function)) | |
633 (if (eq (car-safe (nth 1 form)) 'lambda) | |
634 (let ((body (cl-macroexpand-body (cddadr form) env))) | |
635 (if (and cl-closure-vars (eq (car form) 'function) | |
636 (cl-expr-contains-any body cl-closure-vars)) | |
637 (let* ((new (mapcar 'gensym cl-closure-vars)) | |
638 (sub (pairlis cl-closure-vars new)) (decls nil)) | |
639 (while (or (stringp (car body)) | |
640 (eq (car-safe (car body)) 'interactive)) | |
2153 | 641 (push (list 'quote (pop body)) decls)) |
428 | 642 (put (car (last cl-closure-vars)) 'used t) |
643 (append | |
644 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | |
645 (sublis sub (nreverse decls)) | |
646 (list | |
647 (list* 'list '(quote apply) | |
2153 | 648 ;; XEmacs: put a quote before the function |
428 | 649 (list 'list '(quote quote) |
650 (list 'function | |
651 (list* 'lambda | |
652 (append new (cadadr form)) | |
653 (sublis sub body)))) | |
654 (nconc (mapcar (function | |
655 (lambda (x) | |
656 (list 'list '(quote quote) x))) | |
657 cl-closure-vars) | |
658 '((quote --cl-rest--))))))) | |
659 (list (car form) (list* 'lambda (cadadr form) body)))) | |
660 (let ((found (assq (cadr form) env))) | |
5353
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
661 ;; XEmacs: cadr/caddr operate on nil without errors. But the |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
662 ;; macro definition may be compiled, in which case there's |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
663 ;; nothing for us to do. |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
664 (if (and (listp (cdr found)) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
665 (eq (cadr (caddr found)) 'cl-labels-args)) |
428 | 666 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) |
667 form)))) | |
668 ((memq (car form) '(defun defmacro)) | |
669 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) | |
670 ((and (eq (car form) 'progn) (not (cddr form))) | |
671 (cl-macroexpand-all (nth 1 form) env)) | |
672 ((eq (car form) 'setq) | |
673 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) | |
674 (while (and p (symbolp (car p))) (setq p (cddr p))) | |
675 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) | |
676 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) | |
677 | |
678 (defun cl-macroexpand-body (body &optional env) | |
679 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) | |
680 | |
681 (defun cl-prettyexpand (form &optional full) | |
682 (message "Expanding...") | |
683 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) | |
684 (byte-compile-macro-environment nil)) | |
685 (setq form (cl-macroexpand-all form | |
686 (and (not full) '((block) (eval-when))))) | |
687 (message "Formatting...") | |
688 (prog1 (cl-prettyprint form) | |
689 (message "")))) | |
690 | |
5284
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5273
diff
changeset
|
691 ;; XEmacs addition; force cl-macs to be available from here on when |
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5273
diff
changeset
|
692 ;; compiling files to be dumped. This is more reasonable than forcing other |
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5273
diff
changeset
|
693 ;; files to do the same, multiple times. |
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5273
diff
changeset
|
694 (eval-when-compile (or (cl-compiling-file) (load "cl-macs"))) |
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5273
diff
changeset
|
695 |
428 | 696 (run-hooks 'cl-extra-load-hook) |
697 | |
2153 | 698 ;; XEmacs addition |
428 | 699 (provide 'cl-extra) |
700 | |
2153 | 701 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed |
428 | 702 ;;; cl-extra.el ends here |