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 the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
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.
48 ;; Require at load-time, but not when compiling cl-compat.
49 (or (featurep 'cl
) (require 'cl
))
52 ;;; Keyword routines not supported by new package.
54 (defmacro defkeyword
(x &optional doc
)
55 (list* 'defconst x
(list 'quote x
) (and doc
(list doc
))))
58 (and (symbolp sym
) (eq (aref (symbol-name sym
) 0) ?\
:) (set sym sym
)))
60 (defun keyword-of (sym)
61 (or (keywordp sym
) (keywordp (intern (format ":%s" sym
)))))
64 ;;; Multiple values. Note that the new package uses a different
65 ;;; convention for multiple values. The following definitions
66 ;;; emulate the old convention; all function names have been changed
67 ;;; by capitalizing the first letter: Values, Multiple-value-*,
68 ;;; to avoid conflict with the new-style definitions in cl-macs.
70 (put 'Multiple-value-bind
'lisp-indent-function
2)
71 (put 'Multiple-value-setq
'lisp-indent-function
2)
72 (put 'Multiple-value-call
'lisp-indent-function
1)
73 (put 'Multiple-value-prog1
'lisp-indent-function
1)
75 (defvar *mvalues-values
* nil
)
77 (defun Values (&rest val-forms
)
78 (setq *mvalues-values
* val-forms
)
81 (defun Values-list (val-forms)
82 (apply 'values val-forms
))
84 (defmacro Multiple-value-list
(form)
85 (list 'let
* (list '(*mvalues-values
* nil
) (list '*mvalues-temp
* form
))
86 '(or (and (eq *mvalues-temp
* (car *mvalues-values
*)) *mvalues-values
*)
87 (list *mvalues-temp
*))))
89 (defmacro Multiple-value-call
(function &rest args
)
92 (mapcar (function (lambda (x) (list 'Multiple-value-list x
)))
95 (defmacro Multiple-value-bind
(vars form
&rest body
)
96 (list* 'multiple-value-bind vars
(list 'Multiple-value-list form
) body
))
98 (defmacro Multiple-value-setq
(vars form
)
99 (list 'multiple-value-setq vars
(list 'Multiple-value-list form
)))
101 (defmacro Multiple-value-prog1
(form &rest body
)
102 (list 'prog1 form
(list* 'let
'((*mvalues-values
* nil
)) body
)))
105 ;;; Routines for parsing keyword arguments.
107 (defun build-klist (arglist keys
&optional allow-others
)
108 (let ((res (Multiple-value-call 'mapcar
* 'cons
(unzip-lists arglist
))))
110 (let ((bad (set-difference (mapcar 'car res
) keys
)))
111 (if bad
(error "Bad keywords: %s not in %s" bad keys
))))
114 (defun extract-from-klist (klist key
&optional def
)
115 (let ((res (assq key klist
))) (if res
(cdr res
) def
)))
117 (defun keyword-argument-supplied-p (klist key
)
120 (defun elt-satisfies-test-p (item elt klist
)
121 (let ((test-not (cdr (assq ':test-not klist
)))
122 (test (cdr (assq ':test klist
)))
123 (key (cdr (assq ':key klist
))))
124 (if key
(setq elt
(funcall key elt
)))
125 (if test-not
(not (funcall test-not item elt
))
126 (funcall (or test
'eql
) item elt
))))
129 ;;; Rounding functions with old-style multiple value returns.
131 (defun cl-floor (a &optional b
) (Values-list (floor* a b
)))
132 (defun cl-ceiling (a &optional b
) (Values-list (ceiling* a b
)))
133 (defun cl-round (a &optional b
) (Values-list (round* a b
)))
134 (defun cl-truncate (a &optional b
) (Values-list (truncate* a b
)))
136 (defun safe-idiv (a b
)
137 (let* ((q (/ (abs a
) (abs b
)))
138 (s (* (signum a
) (signum b
))))
139 (Values q
(- a
(* s q b
)) s
)))
142 ;; Internal routines.
144 (defun pair-with-newsyms (oldforms)
145 (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms
)))
146 (Values (mapcar* 'list newsyms oldforms
) newsyms
)))
148 (defun zip-lists (evens odds
)
149 (mapcan 'list evens odds
))
151 (defun unzip-lists (list)
152 (let ((e nil
) (o nil
))
154 (setq e
(cons (car list
) e
) o
(cons (cadr list
) o
) list
(cddr list
)))
155 (Values (nreverse e
) (nreverse o
))))
157 (defun reassemble-argslists (list)
158 (let ((n (apply 'min
(mapcar 'length list
))) (res nil
))
159 (while (>= (setq n
(1- n
)) 0)
160 (setq res
(cons (mapcar (function (lambda (x) (elt x n
))) list
) res
)))
163 (defun duplicate-symbols-p (list)
166 (if (memq (car list
) (cdr list
)) (setq res
(cons (car list
) res
)))
167 (setq list
(cdr list
)))
173 (defun setnth (n list x
)
174 (setcar (nthcdr n list
) x
))
176 (defun setnthcdr (n list x
)
177 (setcdr (nthcdr (1- n
) list
) x
))
179 (defun setelt (seq n x
)
180 (if (consp seq
) (setcar (nthcdr n seq
) x
) (aset seq n x
)))
183 ;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
184 ;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
185 ;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
186 ;;; all names with embedded `$'.
191 ;;; cl-compat.el ends here