1 ;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
3 ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 ;; 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Dave Gillespie <daveg@synaptics.com>
8 ;; Keywords: extensions
9 ;; Obsolete-since: 23.3
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
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.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This file has been obsolete since Emacs 23.3.
30 ;; These are extensions to Emacs Lisp that provide a degree of
31 ;; Common Lisp compatibility, beyond what is already built-in
34 ;; This package was written by Dave Gillespie; it is a complete
35 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
37 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
39 ;; Bug reports, comments, and suggestions are welcome!
41 ;; This file contains emulations of internal routines of the older
42 ;; CL package which users may have called directly from their code.
43 ;; Use (require 'cl-compat) to get these routines.
45 ;; See cl.el for Change Log.
51 ;; (or (featurep 'cl) (require 'cl))
52 ;; which just has the effect of fooling the byte-compiler into not
53 ;; loading cl when compiling. However, that leads to some bogus
54 ;; compiler warnings. Loading cl when compiling cannot do any harm,
55 ;; because for a long time bootstrap-emacs contained 'cl, due to being
56 ;; dumped from uncompiled files that eval-when-compile'd cl. So every
57 ;; file was compiled with 'cl loaded.
61 ;;; Keyword routines not supported by new package.
63 (defmacro defkeyword
(x &optional doc
)
64 (list* 'defconst x
(list 'quote x
) (and doc
(list doc
))))
66 (defun keyword-of (sym)
67 (or (keywordp sym
) (keywordp (intern (format ":%s" sym
)))))
70 ;;; Multiple values. Note that the new package uses a different
71 ;;; convention for multiple values. The following definitions
72 ;;; emulate the old convention; all function names have been changed
73 ;;; by capitalizing the first letter: Values, Multiple-value-*,
74 ;;; to avoid conflict with the new-style definitions in cl-macs.
76 (defvar *mvalues-values
* nil
)
78 (defun Values (&rest val-forms
)
79 (setq *mvalues-values
* val-forms
)
82 (defun Values-list (val-forms)
83 (apply 'values val-forms
))
85 (defmacro Multiple-value-list
(form)
86 (list 'let
* (list '(*mvalues-values
* nil
) (list '*mvalues-temp
* form
))
87 '(or (and (eq *mvalues-temp
* (car *mvalues-values
*)) *mvalues-values
*)
88 (list *mvalues-temp
*))))
90 (defmacro Multiple-value-call
(function &rest args
)
94 (mapcar (function (lambda (x) (list 'Multiple-value-list x
)))
97 (defmacro Multiple-value-bind
(vars form
&rest body
)
99 (list* 'multiple-value-bind vars
(list 'Multiple-value-list form
) body
))
101 (defmacro Multiple-value-setq
(vars form
)
103 (list 'multiple-value-setq vars
(list 'Multiple-value-list form
)))
105 (defmacro Multiple-value-prog1
(form &rest body
)
107 (list 'prog1 form
(list* 'let
'((*mvalues-values
* nil
)) body
)))
110 ;;; Routines for parsing keyword arguments.
112 (defun build-klist (arglist keys
&optional allow-others
)
113 (let ((res (Multiple-value-call 'mapcar
* 'cons
(unzip-lists arglist
))))
115 (let ((bad (set-difference (mapcar 'car res
) keys
)))
116 (if bad
(error "Bad keywords: %s not in %s" bad keys
))))
119 (defun extract-from-klist (klist key
&optional def
)
120 (let ((res (assq key klist
))) (if res
(cdr res
) def
)))
122 (defun keyword-argument-supplied-p (klist key
)
125 (defun elt-satisfies-test-p (item elt klist
)
126 (let ((test-not (cdr (assq ':test-not klist
)))
127 (test (cdr (assq ':test klist
)))
128 (key (cdr (assq ':key klist
))))
129 (if key
(setq elt
(funcall key elt
)))
130 (if test-not
(not (funcall test-not item elt
))
131 (funcall (or test
'eql
) item elt
))))
134 ;;; Rounding functions with old-style multiple value returns.
136 (defun cl-floor (a &optional b
) (Values-list (floor* a b
)))
137 (defun cl-ceiling (a &optional b
) (Values-list (ceiling* a b
)))
138 (defun cl-round (a &optional b
) (Values-list (round* a b
)))
139 (defun cl-truncate (a &optional b
) (Values-list (truncate* a b
)))
141 (defun safe-idiv (a b
)
142 (let* ((q (/ (abs a
) (abs b
)))
143 (s (* (signum a
) (signum b
))))
144 (Values q
(- a
(* s q b
)) s
)))
147 ;; Internal routines.
149 (defun pair-with-newsyms (oldforms)
150 (let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms
)))
151 (Values (mapcar* 'list newsyms oldforms
) newsyms
)))
153 (defun zip-lists (evens odds
)
154 (mapcan 'list evens odds
))
156 (defun unzip-lists (list)
157 (let ((e nil
) (o nil
))
159 (setq e
(cons (car list
) e
) o
(cons (cadr list
) o
) list
(cddr list
)))
160 (Values (nreverse e
) (nreverse o
))))
162 (defun reassemble-argslists (list)
163 (let ((n (apply 'min
(mapcar 'length list
))) (res nil
))
164 (while (>= (setq n
(1- n
)) 0)
165 (setq res
(cons (mapcar (function (lambda (x) (elt x n
))) list
) res
)))
168 (defun duplicate-symbols-p (list)
171 (if (memq (car list
) (cdr list
)) (setq res
(cons (car list
) res
)))
172 (setq list
(cdr list
)))
178 (defun setnth (n list x
)
179 (setcar (nthcdr n list
) x
))
181 (defun setnthcdr (n list x
)
182 (setcdr (nthcdr (1- n
) list
) x
))
184 (defun setelt (seq n x
)
185 (if (consp seq
) (setcar (nthcdr n seq
) x
) (aset seq n x
)))
188 ;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
189 ;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
190 ;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
191 ;;; all names with embedded `$'.
197 ;; byte-compile-warnings: (not cl-functions)
200 ;;; cl-compat.el ends here