1 ;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
3 ;; Copyright (C) 1993 Free Software Foundation, Inc.
5 ;; Author: Dave Gillespie <daveg@synaptics.com>
7 ;; Keywords: extensions
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
27 ;; These are extensions to Emacs Lisp that provide a degree of
28 ;; Common Lisp compatibility, beyond what is already built-in
31 ;; This package was written by Dave Gillespie; it is a complete
32 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
34 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
36 ;; Bug reports, comments, and suggestions are welcome!
38 ;; This file contains emulations of internal routines of the older
39 ;; CL package which users may have called directly from their code.
40 ;; Use (require 'cl-compat) to get these routines.
42 ;; See cl.el for Change Log.
47 ;; Require at load-time, but not when compiling cl-compat.
48 (or (featurep 'cl
) (require 'cl
))
51 ;;; Keyword routines not supported by new package.
53 (defmacro defkeyword
(x &optional doc
)
54 (list* 'defconst x
(list 'quote x
) (and doc
(list doc
))))
57 (and (symbolp sym
) (eq (aref (symbol-name sym
) 0) ?\
:) (set sym sym
)))
59 (defun keyword-of (sym)
60 (or (keywordp sym
) (keywordp (intern (format ":%s" sym
)))))
63 ;;; Multiple values. Note that the new package uses a different
64 ;;; convention for multiple values. The following definitions
65 ;;; emulate the old convention; all function names have been changed
66 ;;; by capitalizing the first letter: Values, Multiple-value-*,
67 ;;; to avoid conflict with the new-style definitions in cl-macs.
69 (put 'Multiple-value-bind
'lisp-indent-function
2)
70 (put 'Multiple-value-setq
'lisp-indent-function
2)
71 (put 'Multiple-value-call
'lisp-indent-function
1)
72 (put 'Multiple-value-prog1
'lisp-indent-function
1)
74 (defvar *mvalues-values
* nil
)
76 (defun Values (&rest val-forms
)
77 (setq *mvalues-values
* val-forms
)
80 (defun Values-list (val-forms)
81 (apply 'values val-forms
))
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
*))))
88 (defmacro Multiple-value-call
(function &rest args
)
91 (mapcar (function (lambda (x) (list 'Multiple-value-list x
)))
94 (defmacro Multiple-value-bind
(vars form
&rest body
)
95 (list* 'multiple-value-bind vars
(list 'Multiple-value-list form
) body
))
97 (defmacro Multiple-value-setq
(vars form
)
98 (list 'multiple-value-setq vars
(list 'Multiple-value-list form
)))
100 (defmacro Multiple-value-prog1
(form &rest body
)
101 (list 'prog1 form
(list* 'let
'((*mvalues-values
* nil
)) body
)))
104 ;;; Routines for parsing keyword arguments.
106 (defun build-klist (arglist keys
&optional allow-others
)
107 (let ((res (Multiple-value-call 'mapcar
* 'cons
(unzip-lists arglist
))))
109 (let ((bad (set-difference (mapcar 'car res
) keys
)))
110 (if bad
(error "Bad keywords: %s not in %s" bad keys
))))
113 (defun extract-from-klist (klist key
&optional def
)
114 (let ((res (assq key klist
))) (if res
(cdr res
) def
)))
116 (defun keyword-argument-supplied-p (klist key
)
119 (defun elt-satisfies-test-p (item elt klist
)
120 (let ((test-not (cdr (assq ':test-not klist
)))
121 (test (cdr (assq ':test klist
)))
122 (key (cdr (assq ':key klist
))))
123 (if key
(setq elt
(funcall key elt
)))
124 (if test-not
(not (funcall test-not item elt
))
125 (funcall (or test
'eql
) item elt
))))
128 ;;; Rounding functions with old-style multiple value returns.
130 (defun cl-floor (a &optional b
) (Values-list (floor* a b
)))
131 (defun cl-ceiling (a &optional b
) (Values-list (ceiling* a b
)))
132 (defun cl-round (a &optional b
) (Values-list (round* a b
)))
133 (defun cl-truncate (a &optional b
) (Values-list (truncate* a b
)))
135 (defun safe-idiv (a b
)
136 (let* ((q (/ (abs a
) (abs b
)))
137 (s (* (signum a
) (signum b
))))
138 (Values q
(- a
(* s q b
)) s
)))
141 ;; Internal routines.
143 (defun pair-with-newsyms (oldforms)
144 (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms
)))
145 (Values (mapcar* 'list newsyms oldforms
) newsyms
)))
147 (defun zip-lists (evens odds
)
148 (mapcan 'list evens odds
))
150 (defun unzip-lists (list)
151 (let ((e nil
) (o nil
))
153 (setq e
(cons (car list
) e
) o
(cons (cadr list
) o
) list
(cddr list
)))
154 (Values (nreverse e
) (nreverse o
))))
156 (defun reassemble-argslists (list)
157 (let ((n (apply 'min
(mapcar 'length list
))) (res nil
))
158 (while (>= (setq n
(1- n
)) 0)
159 (setq res
(cons (mapcar (function (lambda (x) (elt x n
))) list
) res
)))
162 (defun duplicate-symbols-p (list)
165 (if (memq (car list
) (cdr list
)) (setq res
(cons (car list
) res
)))
166 (setq list
(cdr list
)))
172 (defun setnth (n list x
)
173 (setcar (nthcdr n list
) x
))
175 (defun setnthcdr (n list x
)
176 (setcdr (nthcdr (1- n
) list
) x
))
178 (defun setelt (seq n x
)
179 (if (consp seq
) (setcar (nthcdr n seq
) x
) (aset seq n x
)))
182 ;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
183 ;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
184 ;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
185 ;;; all names with embedded `$'.
190 ;;; cl-compat.el ends here