1 ;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
3 ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Dave Gillespie <daveg@synaptics.com>
8 ;; Keywords: extensions
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 ;; These are extensions to Emacs Lisp that provide a degree of
29 ;; Common Lisp compatibility, beyond what is already built-in
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.
35 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
37 ;; Bug reports, comments, and suggestions are welcome!
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.
43 ;; See cl.el for Change Log.
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.
59 ;;; Keyword routines not supported by new package.
61 (defmacro defkeyword
(x &optional doc
)
62 (list* 'defconst x
(list 'quote x
) (and doc
(list doc
))))
64 (defun keyword-of (sym)
65 (or (keywordp sym
) (keywordp (intern (format ":%s" sym
)))))
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.
74 (put 'Multiple-value-bind
'lisp-indent-function
2)
75 (put 'Multiple-value-setq
'lisp-indent-function
2)
76 (put 'Multiple-value-call
'lisp-indent-function
1)
77 (put 'Multiple-value-prog1
'lisp-indent-function
1)
79 (defvar *mvalues-values
* nil
)
81 (defun Values (&rest val-forms
)
82 (setq *mvalues-values
* val-forms
)
85 (defun Values-list (val-forms)
86 (apply 'values val-forms
))
88 (defmacro Multiple-value-list
(form)
89 (list 'let
* (list '(*mvalues-values
* nil
) (list '*mvalues-temp
* form
))
90 '(or (and (eq *mvalues-temp
* (car *mvalues-values
*)) *mvalues-values
*)
91 (list *mvalues-temp
*))))
93 (defmacro Multiple-value-call
(function &rest args
)
96 (mapcar (function (lambda (x) (list 'Multiple-value-list x
)))
99 (defmacro Multiple-value-bind
(vars form
&rest body
)
100 (list* 'multiple-value-bind vars
(list 'Multiple-value-list form
) body
))
102 (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
)
106 (list 'prog1 form
(list* 'let
'((*mvalues-values
* nil
)) body
)))
109 ;;; Routines for parsing keyword arguments.
111 (defun build-klist (arglist keys
&optional allow-others
)
112 (let ((res (Multiple-value-call 'mapcar
* 'cons
(unzip-lists arglist
))))
114 (let ((bad (set-difference (mapcar 'car res
) keys
)))
115 (if bad
(error "Bad keywords: %s not in %s" bad keys
))))
118 (defun extract-from-klist (klist key
&optional def
)
119 (let ((res (assq key klist
))) (if res
(cdr res
) def
)))
121 (defun keyword-argument-supplied-p (klist key
)
124 (defun elt-satisfies-test-p (item elt klist
)
125 (let ((test-not (cdr (assq ':test-not klist
)))
126 (test (cdr (assq ':test klist
)))
127 (key (cdr (assq ':key klist
))))
128 (if key
(setq elt
(funcall key elt
)))
129 (if test-not
(not (funcall test-not item elt
))
130 (funcall (or test
'eql
) item elt
))))
133 ;;; Rounding functions with old-style multiple value returns.
135 (defun cl-floor (a &optional b
) (Values-list (floor* a b
)))
136 (defun cl-ceiling (a &optional b
) (Values-list (ceiling* a b
)))
137 (defun cl-round (a &optional b
) (Values-list (round* a b
)))
138 (defun cl-truncate (a &optional b
) (Values-list (truncate* a b
)))
140 (defun safe-idiv (a b
)
141 (let* ((q (/ (abs a
) (abs b
)))
142 (s (* (signum a
) (signum b
))))
143 (Values q
(- a
(* s q b
)) s
)))
146 ;; Internal routines.
148 (defun pair-with-newsyms (oldforms)
149 (let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms
)))
150 (Values (mapcar* 'list newsyms oldforms
) newsyms
)))
152 (defun zip-lists (evens odds
)
153 (mapcan 'list evens odds
))
155 (defun unzip-lists (list)
156 (let ((e nil
) (o nil
))
158 (setq e
(cons (car list
) e
) o
(cons (cadr list
) o
) list
(cddr list
)))
159 (Values (nreverse e
) (nreverse o
))))
161 (defun reassemble-argslists (list)
162 (let ((n (apply 'min
(mapcar 'length list
))) (res nil
))
163 (while (>= (setq n
(1- n
)) 0)
164 (setq res
(cons (mapcar (function (lambda (x) (elt x n
))) list
) res
)))
167 (defun duplicate-symbols-p (list)
170 (if (memq (car list
) (cdr list
)) (setq res
(cons (car list
) res
)))
171 (setq list
(cdr list
)))
177 (defun setnth (n list x
)
178 (setcar (nthcdr n list
) x
))
180 (defun setnthcdr (n list x
)
181 (setcdr (nthcdr (1- n
) list
) x
))
183 (defun setelt (seq n x
)
184 (if (consp seq
) (setcar (nthcdr n seq
) x
) (aset seq n x
)))
187 ;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
188 ;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
189 ;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
190 ;;; all names with embedded `$'.
196 ;; byte-compile-warnings: (not cl-functions)
199 ;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163
200 ;;; cl-compat.el ends here