;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility);; Copyright (C) 1993 Free Software Foundation, Inc.;; Author: Dave Gillespie <daveg@synaptics.com>;; Version: 2.02;; Keywords: extensions;; This file is part of XEmacs.;; XEmacs is free software; you can redistribute it and/or modify it;; under the terms of the GNU General Public License as published by;; the Free Software Foundation; either version 2, or (at your option);; any later version.;; XEmacs is distributed in the hope that it will be useful, but;; WITHOUT ANY WARRANTY; without even the implied warranty of;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU;; General Public License for more details.;; You should have received a copy of the GNU General Public License;; along with XEmacs; see the file COPYING. If not, write to the Free;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA;; 02111-1307, USA.;;; Synched up with: FSF 19.34.;;; Commentary:;; These are extensions to Emacs Lisp that provide a degree of;; Common Lisp compatibility, beyond what is already built-in;; in Emacs Lisp.;;;; This package was written by Dave Gillespie; it is a complete;; rewrite of Cesar Quiroz's original cl.el package of December 1986.;;;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19.;;;; Bug reports, comments, and suggestions are welcome!;; This file contains emulations of internal routines of the older;; CL package which users may have called directly from their code.;; Use (require 'cl-compat) to get these routines.;; See cl.el for Change Log.;;; Code:;; Require at load-time, but not when compiling cl-compat.(or(featurep'cl)(require'cl));;; Keyword routines not supported by new package.(defmacrodefkeyword(x&optionaldoc)(list*'defconstx(list'quotex)(anddoc(listdoc))))(defunkeywordp(sym)(and(symbolpsym)(eq(aref(symbol-namesym)0)?\:)(setsymsym)))(defunkeyword-of(sym)(or(keywordpsym)(keywordp(intern(format":%s"sym)))));;; Multiple values. Note that the new package uses a different;;; convention for multiple values. The following definitions;;; emulate the old convention; all function names have been changed;;; by capitalizing the first letter: Values, Multiple-value-*,;;; to avoid conflict with the new-style definitions in cl-macs.(put'Multiple-value-bind'lisp-indent-function2)(put'Multiple-value-setq'lisp-indent-function2)(put'Multiple-value-call'lisp-indent-function1)(put'Multiple-value-prog1'lisp-indent-function1)(defvar*mvalues-values*nil)(defunValues(&restval-forms)(setq*mvalues-values*val-forms)(carval-forms))(defunValues-list(val-forms)(apply'valuesval-forms))(defmacroMultiple-value-list(form)(list'let*(list'(*mvalues-values*nil)(list'*mvalues-temp*form))'(or(and(eq*mvalues-temp*(car*mvalues-values*))*mvalues-values*)(list*mvalues-temp*))))(defmacroMultiple-value-call(function&restargs)(list'applyfunction(cons'append(mapcar(function(lambda(x)(list'Multiple-value-listx)))args))))(defmacroMultiple-value-bind(varsform&restbody)(list*'multiple-value-bindvars(list'Multiple-value-listform)body))(defmacroMultiple-value-setq(varsform)(list'multiple-value-setqvars(list'Multiple-value-listform)))(defmacroMultiple-value-prog1(form&restbody)(list'prog1form(list*'let'((*mvalues-values*nil))body)));;; Routines for parsing keyword arguments.(defunbuild-klist(arglistkeys&optionalallow-others)(let((res(Multiple-value-call'mapcar*'cons(unzip-listsarglist))))(orallow-others(let((bad(set-difference(mapcar'carres)keys)))(ifbad(error"Bad keywords: %s not in %s"badkeys))))res))(defunextract-from-klist(klistkey&optionaldef)(let((res(assqkeyklist)))(ifres(cdrres)def)))(defunkeyword-argument-supplied-p(klistkey)(assqkeyklist))(defunelt-satisfies-test-p(itemeltklist)(let((test-not(cdr(assq':test-notklist)))(test(cdr(assq':testklist)))(key(cdr(assq':keyklist))))(ifkey(setqelt(funcallkeyelt)))(iftest-not(not(funcalltest-notitemelt))(funcall(ortest'eql)itemelt))));;; Rounding functions with old-style multiple value returns.(defuncl-floor(a&optionalb)(Values-list(floor*ab)))(defuncl-ceiling(a&optionalb)(Values-list(ceiling*ab)))(defuncl-round(a&optionalb)(Values-list(round*ab)))(defuncl-truncate(a&optionalb)(Values-list(truncate*ab)))(defunsafe-idiv(ab)(let*((q(/(absa)(absb)))(s(*(signuma)(signumb))))(Valuesq(-a(*sqb))s)));; Internal routines.(defunpair-with-newsyms(oldforms)(let((newsyms(mapcar(function(lambda(x)(gensym)))oldforms)))(Values(mapcar*'listnewsymsoldforms)newsyms)))(defunzip-lists(evensodds)(mapcan'listevensodds))(defununzip-lists(list)(let((enil)(onil))(whilelist(setqe(cons(carlist)e)o(cons(cadrlist)o)list(cddrlist)))(Values(nreversee)(nreverseo))))(defunreassemble-argslists(list)(let((n(apply'min(mapcar'lengthlist)))(resnil))(while(>=(setqn(1-n))0)(setqres(cons(mapcar(function(lambda(x)(eltxn)))list)res)))res))(defunduplicate-symbols-p(list)(let((resnil))(whilelist(if(memq(carlist)(cdrlist))(setqres(cons(carlist)res)))(setqlist(cdrlist)))res));;; Setf internals.(defunsetnth(nlistx)(setcar(nthcdrnlist)x))(defunsetnthcdr(nlistx)(setcdr(nthcdr(1-n)list)x))(defunsetelt(seqnx)(if(conspseq)(setcar(nthcdrnseq)x)(asetseqnx)));;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,;;; all names with embedded `$'.(provide'cl-compat);;; cl-compat.el ends here