Use `declare' in defmacros.
[bpt/emacs.git] / lisp / emacs-lisp / cl-compat.el
CommitLineData
be010748 1;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
fcd73769 2
d59c3137 3;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
114f9c96 4;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
fcd73769
RS
5
6;; Author: Dave Gillespie <daveg@synaptics.com>
7;; Version: 2.02
8;; Keywords: extensions
bd78fa1d 9;; Package: emacs
fcd73769
RS
10
11;; This file is part of GNU Emacs.
12
d6cba7ae 13;; GNU Emacs is free software: you can redistribute it and/or modify
fcd73769 14;; it under the terms of the GNU General Public License as published by
d6cba7ae
GM
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
fcd73769
RS
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
d6cba7ae 24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
fcd73769 25
07b3798c 26;;; Commentary:
fcd73769
RS
27
28;; These are extensions to Emacs Lisp that provide a degree of
29;; Common Lisp compatibility, beyond what is already built-in
30;; in Emacs Lisp.
31;;
32;; This package was written by Dave Gillespie; it is a complete
33;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
34;;
35;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
36;;
37;; Bug reports, comments, and suggestions are welcome!
38
39;; This file contains emulations of internal routines of the older
40;; CL package which users may have called directly from their code.
41;; Use (require 'cl-compat) to get these routines.
42
43;; See cl.el for Change Log.
44
45
07b3798c 46;;; Code:
fcd73769 47
e3d95497
GM
48;; This used to be:
49;; (or (featurep 'cl) (require 'cl))
50;; which just has the effect of fooling the byte-compiler into not
51;; loading cl when compiling. However, that leads to some bogus
52;; compiler warnings. Loading cl when compiling cannot do any harm,
53;; because for a long time bootstrap-emacs contained 'cl, due to being
54;; dumped from uncompiled files that eval-when-compile'd cl. So every
55;; file was compiled with 'cl loaded.
56(require 'cl)
fcd73769
RS
57
58
59;;; Keyword routines not supported by new package.
60
61(defmacro defkeyword (x &optional doc)
62 (list* 'defconst x (list 'quote x) (and doc (list doc))))
63
fcd73769
RS
64(defun keyword-of (sym)
65 (or (keywordp sym) (keywordp (intern (format ":%s" sym)))))
66
67
68;;; Multiple values. Note that the new package uses a different
69;;; convention for multiple values. The following definitions
70;;; emulate the old convention; all function names have been changed
71;;; by capitalizing the first letter: Values, Multiple-value-*,
72;;; to avoid conflict with the new-style definitions in cl-macs.
73
fcd73769
RS
74(defvar *mvalues-values* nil)
75
76(defun Values (&rest val-forms)
77 (setq *mvalues-values* val-forms)
78 (car val-forms))
79
80(defun Values-list (val-forms)
81 (apply 'values val-forms))
82
83(defmacro Multiple-value-list (form)
84 (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form))
85 '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*)
86 (list *mvalues-temp*))))
87
88(defmacro Multiple-value-call (function &rest args)
f291fe60 89 (declare (indent 1))
fcd73769
RS
90 (list 'apply function
91 (cons 'append
92 (mapcar (function (lambda (x) (list 'Multiple-value-list x)))
93 args))))
94
95(defmacro Multiple-value-bind (vars form &rest body)
f291fe60 96 (declare (indent 2))
fcd73769
RS
97 (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
98
99(defmacro Multiple-value-setq (vars form)
f291fe60 100 (declare (indent 2))
fcd73769
RS
101 (list 'multiple-value-setq vars (list 'Multiple-value-list form)))
102
103(defmacro Multiple-value-prog1 (form &rest body)
f291fe60 104 (declare (indent 1))
fcd73769
RS
105 (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
106
107
108;;; Routines for parsing keyword arguments.
109
110(defun build-klist (arglist keys &optional allow-others)
111 (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist))))
112 (or allow-others
113 (let ((bad (set-difference (mapcar 'car res) keys)))
114 (if bad (error "Bad keywords: %s not in %s" bad keys))))
115 res))
116
117(defun extract-from-klist (klist key &optional def)
118 (let ((res (assq key klist))) (if res (cdr res) def)))
119
120(defun keyword-argument-supplied-p (klist key)
121 (assq key klist))
122
123(defun elt-satisfies-test-p (item elt klist)
124 (let ((test-not (cdr (assq ':test-not klist)))
125 (test (cdr (assq ':test klist)))
126 (key (cdr (assq ':key klist))))
127 (if key (setq elt (funcall key elt)))
128 (if test-not (not (funcall test-not item elt))
129 (funcall (or test 'eql) item elt))))
130
131
132;;; Rounding functions with old-style multiple value returns.
133
134(defun cl-floor (a &optional b) (Values-list (floor* a b)))
135(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b)))
136(defun cl-round (a &optional b) (Values-list (round* a b)))
137(defun cl-truncate (a &optional b) (Values-list (truncate* a b)))
138
139(defun safe-idiv (a b)
140 (let* ((q (/ (abs a) (abs b)))
141 (s (* (signum a) (signum b))))
142 (Values q (- a (* s q b)) s)))
143
144
145;; Internal routines.
146
147(defun pair-with-newsyms (oldforms)
ab3d4bb2 148 (let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms)))
fcd73769
RS
149 (Values (mapcar* 'list newsyms oldforms) newsyms)))
150
151(defun zip-lists (evens odds)
152 (mapcan 'list evens odds))
153
154(defun unzip-lists (list)
155 (let ((e nil) (o nil))
156 (while list
157 (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list)))
158 (Values (nreverse e) (nreverse o))))
159
160(defun reassemble-argslists (list)
161 (let ((n (apply 'min (mapcar 'length list))) (res nil))
162 (while (>= (setq n (1- n)) 0)
163 (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res)))
164 res))
165
166(defun duplicate-symbols-p (list)
167 (let ((res nil))
168 (while list
169 (if (memq (car list) (cdr list)) (setq res (cons (car list) res)))
170 (setq list (cdr list)))
171 res))
172
173
174;;; Setf internals.
175
176(defun setnth (n list x)
177 (setcar (nthcdr n list) x))
178
179(defun setnthcdr (n list x)
180 (setcdr (nthcdr (1- n) list) x))
181
182(defun setelt (seq n x)
183 (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x)))
184
185
186;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
187;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
188;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
189;;; all names with embedded `$'.
190
191
192(provide 'cl-compat)
193
7187be8b
GM
194;; Local variables:
195;; byte-compile-warnings: (not cl-functions)
196;; End:
197
ab3d4bb2 198;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163
fcd73769 199;;; cl-compat.el ends here