| 1 | ;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp. |
| 2 | |
| 3 | ;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Cesar Quiroz <quiroz@cs.rochester.edu> |
| 6 | ;; Keywords: extensions |
| 7 | |
| 8 | (defvar cl-version "3.0 07-February-1993") |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 13 | ;; but WITHOUT ANY WARRANTY. No author or distributor |
| 14 | ;; accepts responsibility to anyone for the consequences of using it |
| 15 | ;; or for whether it serves any particular purpose or works at all, |
| 16 | ;; unless he says so in writing. Refer to the GNU Emacs General Public |
| 17 | ;; License for full details. |
| 18 | |
| 19 | ;; Everyone is granted permission to copy, modify and redistribute |
| 20 | ;; GNU Emacs, but only under the conditions described in the |
| 21 | ;; GNU Emacs General Public License. A copy of this license is |
| 22 | ;; supposed to have been given to you along with GNU Emacs so you |
| 23 | ;; can know your rights and responsibilities. It should be in a |
| 24 | ;; file named COPYING. Among other things, the copyright notice |
| 25 | ;; and this notice must be preserved on all copies. |
| 26 | |
| 27 | ;;; Commentary: |
| 28 | |
| 29 | ;;; Notes from Rob Austein on his mods |
| 30 | ;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra |
| 31 | ;; |
| 32 | ;; Slightly hacked copy of cl.el 2.0 beta 27. |
| 33 | ;; |
| 34 | ;; Various minor performance improvements: |
| 35 | ;; a) Don't use MAPCAR when we're going to discard its results. |
| 36 | ;; b) Make various macros a little more clever about optimizing |
| 37 | ;; generated code in common cases. |
| 38 | ;; c) Fix DEFSETF to expand to the right code at compile-time. |
| 39 | ;; d) Make various macros cleverer about generating reasonable |
| 40 | ;; code when compiled, particularly forms like DEFSTRUCT which |
| 41 | ;; are usually used at top-level and thus are only compiled if |
| 42 | ;; you use Hallvard Furuseth's hacked bytecomp.el. |
| 43 | ;; |
| 44 | ;; New features: GETF, REMF, and REMPROP. |
| 45 | ;; |
| 46 | ;; Notes: |
| 47 | ;; 1) I'm sceptical about the FBOUNDP checks in SETF. Why should |
| 48 | ;; the SETF expansion fail because the SETF method isn't defined |
| 49 | ;; at compile time? Lisp is going to check for a binding at run-time |
| 50 | ;; anyway, so maybe we should just assume the user's right here. |
| 51 | |
| 52 | ;;;; These are extensions to Emacs Lisp that provide some form of |
| 53 | ;;;; Common Lisp compatibility, beyond what is already built-in |
| 54 | ;;;; in Emacs Lisp. |
| 55 | ;;;; |
| 56 | ;;;; When developing them, I had the code spread among several files. |
| 57 | ;;;; This file 'cl.el' is a concatenation of those original files, |
| 58 | ;;;; minus some declarations that became redundant. The marks between |
| 59 | ;;;; the original files can be found easily, as they are lines that |
| 60 | ;;;; begin with four semicolons (as this does). The names of the |
| 61 | ;;;; original parts follow the four semicolons in uppercase, those |
| 62 | ;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS, |
| 63 | ;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you |
| 64 | ;;;; add functions to this file, you might want to put them in a place |
| 65 | ;;;; that is compatible with the division above (or invent your own |
| 66 | ;;;; categories). |
| 67 | ;;;; |
| 68 | ;;;; To compile this file, make sure you load it first. This is |
| 69 | ;;;; because many things are implemented as macros and now that all |
| 70 | ;;;; the files are concatenated together one cannot ensure that |
| 71 | ;;;; declaration always precedes use. |
| 72 | ;;;; |
| 73 | ;;;; Bug reports, suggestions and comments, |
| 74 | ;;;; to quiroz@cs.rochester.edu |
| 75 | |
| 76 | \f |
| 77 | ;;;; GLOBAL |
| 78 | ;;;; This file provides utilities and declarations that are global |
| 79 | ;;;; to Common Lisp and so might be used by more than one of the |
| 80 | ;;;; other libraries. Especially, I intend to keep here some |
| 81 | ;;;; utilities that help parsing/destructuring some difficult calls. |
| 82 | ;;;; |
| 83 | ;;;; |
| 84 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 85 | ;;;; (quiroz@cs.rochester.edu) |
| 86 | |
| 87 | ;;; Too many pieces of the rest of this package use psetq. So it is unwise to |
| 88 | ;;; use here anything but plain Emacs Lisp! There is a neater recursive form |
| 89 | ;;; for the algorithm that deals with the bodies. |
| 90 | |
| 91 | ;;; Code: |
| 92 | |
| 93 | ;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91) |
| 94 | (defmacro psetq (&rest args) |
| 95 | "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE. |
| 96 | All the VALUEs are evaluated, and then all the VARIABLEs are set. |
| 97 | Aside from order of evaluation, this is the same as `setq'." |
| 98 | ;; check there is a reasonable number of forms |
| 99 | (if (/= (% (length args) 2) 0) |
| 100 | (error "Odd number of arguments to `psetq'")) |
| 101 | (setq args (copy-sequence args)) ;for safety below |
| 102 | (prog1 (cons 'setq args) |
| 103 | (while (progn (if (not (symbolp (car args))) |
| 104 | (error "`psetq' expected a symbol, found '%s'." |
| 105 | (prin1-to-string (car args)))) |
| 106 | (cdr (cdr args))) |
| 107 | (setcdr args (list (list 'prog1 (nth 1 args) |
| 108 | (cons 'setq |
| 109 | (setq args (cdr (cdr args)))))))))) |
| 110 | \f |
| 111 | ;;; utilities |
| 112 | ;;; |
| 113 | ;;; pair-with-newsyms takes a list and returns a list of lists of the |
| 114 | ;;; form (newsym form), such that a let* can then bind the evaluation |
| 115 | ;;; of the forms to the newsyms. The idea is to guarantee correct |
| 116 | ;;; order of evaluation of the subforms of a setf. It also returns a |
| 117 | ;;; list of the newsyms generated, in the corresponding order. |
| 118 | |
| 119 | (defun pair-with-newsyms (oldforms) |
| 120 | "PAIR-WITH-NEWSYMS OLDFORMS |
| 121 | The top-level components of the list oldforms are paired with fresh |
| 122 | symbols, the pairings list and the newsyms list are returned." |
| 123 | (do ((ptr oldforms (cdr ptr)) |
| 124 | (bindings '()) |
| 125 | (newsyms '())) |
| 126 | ((endp ptr) (values (nreverse bindings) (nreverse newsyms))) |
| 127 | (let ((newsym (gentemp))) |
| 128 | (setq bindings (cons (list newsym (car ptr)) bindings)) |
| 129 | (setq newsyms (cons newsym newsyms))))) |
| 130 | |
| 131 | (defun zip-lists (evens odds) |
| 132 | "Merge two lists EVENS and ODDS, taking elts from each list alternatingly. |
| 133 | EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose |
| 134 | even numbered elements (0,2,...) come from EVENS and whose odd |
| 135 | numbered elements (1,3,...) come from ODDS. |
| 136 | The construction stops when the shorter list is exhausted." |
| 137 | (do* ((p0 evens (cdr p0)) |
| 138 | (p1 odds (cdr p1)) |
| 139 | (even (car p0) (car p0)) |
| 140 | (odd (car p1) (car p1)) |
| 141 | (result '())) |
| 142 | ((or (endp p0) (endp p1)) |
| 143 | (nreverse result)) |
| 144 | (setq result |
| 145 | (cons odd (cons even result))))) |
| 146 | |
| 147 | (defun unzip-list (list) |
| 148 | "Extract even and odd elements of LIST into two separate lists. |
| 149 | The argument LIST is separated in two strands, the even and the odd |
| 150 | numbered elements. Numbering starts with 0, so the first element |
| 151 | belongs in EVENS. No check is made that there is an even number of |
| 152 | elements to start with." |
| 153 | (do* ((ptr list (cddr ptr)) |
| 154 | (this (car ptr) (car ptr)) |
| 155 | (next (cadr ptr) (cadr ptr)) |
| 156 | (evens '()) |
| 157 | (odds '())) |
| 158 | ((endp ptr) |
| 159 | (values (nreverse evens) (nreverse odds))) |
| 160 | (setq evens (cons this evens)) |
| 161 | (setq odds (cons next odds)))) |
| 162 | \f |
| 163 | (defun reassemble-argslists (argslists) |
| 164 | "(reassemble-argslists ARGSLISTS) => a list of lists |
| 165 | ARGSLISTS is a list of sequences. Return a list of lists, the first |
| 166 | sublist being all the entries coming from ELT 0 of the original |
| 167 | sublists, the next those coming from ELT 1 and so on, until the |
| 168 | shortest list is exhausted." |
| 169 | (let* ((minlen (apply 'min (mapcar 'length argslists))) |
| 170 | (result '())) |
| 171 | (dotimes (i minlen (nreverse result)) |
| 172 | ;; capture all the elements at index i |
| 173 | (setq result |
| 174 | (cons (mapcar (function (lambda (sublist) (elt sublist i))) |
| 175 | argslists) |
| 176 | result))))) |
| 177 | |
| 178 | \f |
| 179 | ;;; Checking that a list of symbols contains no duplicates is a common |
| 180 | ;;; task when checking the legality of some macros. The check for 'eq |
| 181 | ;;; pairs can be too expensive, as it is quadratic on the length of |
| 182 | ;;; the list. I use a 4-pass, linear, counting approach. It surely |
| 183 | ;;; loses on small lists (less than 5 elements?), but should win for |
| 184 | ;;; larger lists. The fourth pass could be eliminated. |
| 185 | ;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the |
| 186 | ;;; 4th pass. |
| 187 | ;;; |
| 188 | ;;; [22 April 1991, sra] REMPROP now in library, so restored 4th pass. |
| 189 | (defun duplicate-symbols-p (list) |
| 190 | "Find all symbols appearing more than once in LIST. |
| 191 | Return a list of all such duplicates; `nil' if there are no duplicates." |
| 192 | (let ((duplicates '()) ;result built here |
| 193 | (propname (gensym)) ;we use a fresh property |
| 194 | ) |
| 195 | ;; check validity |
| 196 | (unless (and (listp list) |
| 197 | (every 'symbolp list)) |
| 198 | (error "a list of symbols is needed")) |
| 199 | ;; pass 1: mark |
| 200 | (dolist (x list) |
| 201 | (put x propname 0)) |
| 202 | ;; pass 2: count |
| 203 | (dolist (x list) |
| 204 | (put x propname (1+ (get x propname)))) |
| 205 | ;; pass 3: collect |
| 206 | (dolist (x list) |
| 207 | (if (> (get x propname) 1) |
| 208 | (setq duplicates (cons x duplicates)))) |
| 209 | ;; pass 4: unmark. |
| 210 | (dolist (x list) |
| 211 | (remprop x propname)) |
| 212 | ;; return result |
| 213 | duplicates)) |
| 214 | |
| 215 | ;;;; end of cl-global.el |
| 216 | \f |
| 217 | ;;;; SYMBOLS |
| 218 | ;;;; This file provides the gentemp function, which generates fresh |
| 219 | ;;;; symbols, plus some other minor Common Lisp symbol tools. |
| 220 | ;;;; |
| 221 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 222 | ;;;; (quiroz@cs.rochester.edu) |
| 223 | |
| 224 | ;;; Keywords. There are no packages in Emacs Lisp, so this is only a |
| 225 | ;;; kludge around to let things be "as if" a keyword package was around. |
| 226 | |
| 227 | (defmacro defkeyword (x &optional docstring) |
| 228 | "Make symbol X a keyword (symbol whose value is itself). |
| 229 | Optional second argument is a documentation string for it." |
| 230 | (cond ((symbolp x) |
| 231 | (list 'defconst x (list 'quote x) docstring)) |
| 232 | (t |
| 233 | (error "`%s' is not a symbol" (prin1-to-string x))))) |
| 234 | |
| 235 | (defun keywordp (sym) |
| 236 | "t if SYM is a keyword." |
| 237 | (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:)) |
| 238 | ;; looks like one, make sure value is right |
| 239 | (set sym sym) |
| 240 | nil)) |
| 241 | |
| 242 | (defun keyword-of (sym) |
| 243 | "Return a keyword that is naturally associated with symbol SYM. |
| 244 | If SYM is keyword, the value is SYM. |
| 245 | Otherwise it is a keyword whose name is `:' followed by SYM's name." |
| 246 | (cond ((keywordp sym) |
| 247 | sym) |
| 248 | ((symbolp sym) |
| 249 | (let ((newsym (intern (concat ":" (symbol-name sym))))) |
| 250 | (set newsym newsym))) |
| 251 | (t |
| 252 | (error "expected a symbol, not `%s'" (prin1-to-string sym))))) |
| 253 | \f |
| 254 | ;;; Temporary symbols. |
| 255 | ;;; |
| 256 | |
| 257 | (defvar *gentemp-index* 0 |
| 258 | "Integer used by gentemp to produce new names.") |
| 259 | |
| 260 | (defvar *gentemp-prefix* "T$$_" |
| 261 | "Names generated by gentemp begin with this string by default.") |
| 262 | |
| 263 | (defun gentemp (&optional prefix oblist) |
| 264 | "Generate a fresh interned symbol. |
| 265 | There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the |
| 266 | string that begins the new name, OBLIST is the obarray used to search for |
| 267 | old names. The defaults are just right, YOU SHOULD NEVER NEED THESE |
| 268 | ARGUMENTS IN YOUR OWN CODE." |
| 269 | (if (null prefix) |
| 270 | (setq prefix *gentemp-prefix*)) |
| 271 | (if (null oblist) |
| 272 | (setq oblist obarray)) ;default for the intern functions |
| 273 | (let ((newsymbol nil) |
| 274 | (newname)) |
| 275 | (while (not newsymbol) |
| 276 | (setq newname (concat prefix *gentemp-index*)) |
| 277 | (setq *gentemp-index* (+ *gentemp-index* 1)) |
| 278 | (if (not (intern-soft newname oblist)) |
| 279 | (setq newsymbol (intern newname oblist)))) |
| 280 | newsymbol)) |
| 281 | \f |
| 282 | (defvar *gensym-index* 0 |
| 283 | "Integer used by gensym to produce new names.") |
| 284 | |
| 285 | (defvar *gensym-prefix* "G$$_" |
| 286 | "Names generated by gensym begin with this string by default.") |
| 287 | |
| 288 | (defun gensym (&optional prefix) |
| 289 | "Generate a fresh uninterned symbol. |
| 290 | There is an optional argument, PREFIX. PREFIX is the |
| 291 | string that begins the new name. Most people take just the default, |
| 292 | except when debugging needs suggest otherwise." |
| 293 | (if (null prefix) |
| 294 | (setq prefix *gensym-prefix*)) |
| 295 | (let ((newsymbol nil) |
| 296 | (newname "")) |
| 297 | (while (not newsymbol) |
| 298 | (setq newname (concat prefix *gensym-index*)) |
| 299 | (setq *gensym-index* (+ *gensym-index* 1)) |
| 300 | (if (not (intern-soft newname)) |
| 301 | (setq newsymbol (make-symbol newname)))) |
| 302 | newsymbol)) |
| 303 | |
| 304 | ;;;; end of cl-symbols.el |
| 305 | \f |
| 306 | ;;;; CONDITIONALS |
| 307 | ;;;; This file provides some of the conditional constructs of |
| 308 | ;;;; Common Lisp. Total compatibility is again impossible, as the |
| 309 | ;;;; 'if' form is different in both languages, so only a good |
| 310 | ;;;; approximation is desired. |
| 311 | ;;;; |
| 312 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 313 | ;;;; (quiroz@cs.rochester.edu) |
| 314 | |
| 315 | ;;; indentation info |
| 316 | (put 'case 'lisp-indent-hook 1) |
| 317 | (put 'ecase 'lisp-indent-hook 1) |
| 318 | (put 'when 'lisp-indent-hook 1) |
| 319 | (put 'unless 'lisp-indent-hook 1) |
| 320 | |
| 321 | ;;; WHEN and UNLESS |
| 322 | ;;; These two forms are simplified ifs, with a single branch. |
| 323 | |
| 324 | (defmacro when (condition &rest body) |
| 325 | "(when CONDITION . BODY) => evaluate BODY if CONDITION is true." |
| 326 | (list* 'if (list 'not condition) '() body)) |
| 327 | |
| 328 | (defmacro unless (condition &rest body) |
| 329 | "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false." |
| 330 | (list* 'if condition '() body)) |
| 331 | \f |
| 332 | ;;; CASE and ECASE |
| 333 | ;;; CASE selects among several clauses, based on the value (evaluated) |
| 334 | ;;; of a expression and a list of (unevaluated) key values. ECASE is |
| 335 | ;;; the same, but signals an error if no clause is activated. |
| 336 | |
| 337 | (defmacro case (expr &rest cases) |
| 338 | "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value. |
| 339 | EXPR -> any form |
| 340 | CASES -> list of clauses, non empty |
| 341 | CLAUSE -> HEAD . BODY |
| 342 | HEAD -> t = catch all, must be last clause |
| 343 | -> otherwise = same as t |
| 344 | -> nil = illegal |
| 345 | -> atom = activated if (eql EXPR HEAD) |
| 346 | -> list of atoms = activated if (memq EXPR HEAD) |
| 347 | BODY -> list of forms, implicit PROGN is built around it. |
| 348 | EXPR is evaluated only once." |
| 349 | (let* ((newsym (gentemp)) |
| 350 | (clauses (case-clausify cases newsym))) |
| 351 | ;; convert case into a cond inside a let |
| 352 | (list 'let |
| 353 | (list (list newsym expr)) |
| 354 | (list* 'cond (nreverse clauses))))) |
| 355 | |
| 356 | (defmacro ecase (expr &rest cases) |
| 357 | "(ecase EXPR . CASES) => like `case', but error if no case fits. |
| 358 | `t'-clauses are not allowed." |
| 359 | (let* ((newsym (gentemp)) |
| 360 | (clauses (case-clausify cases newsym))) |
| 361 | ;; check that no 't clause is present. |
| 362 | ;; case-clausify would put one such at the beginning of clauses |
| 363 | (if (eq (caar clauses) t) |
| 364 | (error "no clause-head should be `t' or `otherwise' for `ecase'")) |
| 365 | ;; insert error-catching clause |
| 366 | (setq clauses |
| 367 | (cons |
| 368 | (list 't (list 'error |
| 369 | "ecase on %s = %s failed to take any branch" |
| 370 | (list 'quote expr) |
| 371 | (list 'prin1-to-string newsym))) |
| 372 | clauses)) |
| 373 | ;; generate code as usual |
| 374 | (list 'let |
| 375 | (list (list newsym expr)) |
| 376 | (list* 'cond (nreverse clauses))))) |
| 377 | |
| 378 | \f |
| 379 | (defun case-clausify (cases newsym) |
| 380 | "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond' |
| 381 | Converts the CASES of a [e]case macro into cond clauses to be |
| 382 | evaluated inside a let that binds NEWSYM. Returns the clauses in |
| 383 | reverse order." |
| 384 | (do* ((currentpos cases (cdr currentpos)) |
| 385 | (nextpos (cdr cases) (cdr nextpos)) |
| 386 | (curclause (car cases) (car currentpos)) |
| 387 | (result '())) |
| 388 | ((endp currentpos) result) |
| 389 | (let ((head (car curclause)) |
| 390 | (body (cdr curclause))) |
| 391 | ;; construct a cond-clause according to the head |
| 392 | (cond ((null head) |
| 393 | (error "case clauses cannot have null heads: `%s'" |
| 394 | (prin1-to-string curclause))) |
| 395 | ((or (eq head 't) |
| 396 | (eq head 'otherwise)) |
| 397 | ;; check it is the last clause |
| 398 | (if (not (endp nextpos)) |
| 399 | (error "clause with `t' or `otherwise' head must be last")) |
| 400 | ;; accept this clause as a 't' for cond |
| 401 | (setq result (cons (cons 't body) result))) |
| 402 | ((atom head) |
| 403 | (setq result |
| 404 | (cons (cons (list 'eql newsym (list 'quote head)) body) |
| 405 | result))) |
| 406 | ((listp head) |
| 407 | (setq result |
| 408 | (cons (cons (list 'memq newsym (list 'quote head)) body) |
| 409 | result))) |
| 410 | (t |
| 411 | ;; catch-all for this parser |
| 412 | (error "don't know how to parse case clause `%s'" |
| 413 | (prin1-to-string head))))))) |
| 414 | |
| 415 | ;;;; end of cl-conditionals.el |
| 416 | \f |
| 417 | ;;;; ITERATIONS |
| 418 | ;;;; This file provides simple iterative macros (a la Common Lisp) |
| 419 | ;;;; constructed on the basis of let, let* and while, which are the |
| 420 | ;;;; primitive binding/iteration constructs of Emacs Lisp |
| 421 | ;;;; |
| 422 | ;;;; The Common Lisp iterations use to have a block named nil |
| 423 | ;;;; wrapped around them, and allow declarations at the beginning |
| 424 | ;;;; of their bodies and you can return a value using (return ...). |
| 425 | ;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried |
| 426 | ;;;; to imitate these behaviors. |
| 427 | ;;;; |
| 428 | ;;;; Other than the above, the semantics of Common Lisp are |
| 429 | ;;;; correctly reproduced to the extent this was reasonable. |
| 430 | ;;;; |
| 431 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 432 | ;;;; (quiroz@cs.rochester.edu) |
| 433 | |
| 434 | ;;; some lisp-indentation information |
| 435 | (put 'do 'lisp-indent-hook 2) |
| 436 | (put 'do* 'lisp-indent-hook 2) |
| 437 | (put 'dolist 'lisp-indent-hook 1) |
| 438 | (put 'dotimes 'lisp-indent-hook 1) |
| 439 | (put 'do-symbols 'lisp-indent-hook 1) |
| 440 | (put 'do-all-symbols 'lisp-indent-hook 1) |
| 441 | |
| 442 | \f |
| 443 | (defmacro do (stepforms endforms &rest body) |
| 444 | "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables. |
| 445 | STEPFORMS must be a list of symbols or lists. In the second case, the |
| 446 | lists must start with a symbol and contain up to two more forms. In |
| 447 | the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms |
| 448 | are the initial value (def. NIL) and the form to step (def. itself). |
| 449 | The values used by initialization and stepping are computed in parallel. |
| 450 | The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION |
| 451 | evaluates to true in any iteration, ENDBODY is evaluated and the last |
| 452 | form in it is returned. |
| 453 | The BODY (which may be empty) is evaluated at every iteration, with |
| 454 | the symbols of the STEPFORMS bound to the initial or stepped values." |
| 455 | ;; check the syntax of the macro |
| 456 | (and (check-do-stepforms stepforms) |
| 457 | (check-do-endforms endforms)) |
| 458 | ;; construct emacs-lisp equivalent |
| 459 | (let ((initlist (extract-do-inits stepforms)) |
| 460 | (steplist (extract-do-steps stepforms)) |
| 461 | (endcond (car endforms)) |
| 462 | (endbody (cdr endforms))) |
| 463 | (cons 'let (cons initlist |
| 464 | (cons (cons 'while (cons (list 'not endcond) |
| 465 | (append body steplist))) |
| 466 | (append endbody)))))) |
| 467 | |
| 468 | \f |
| 469 | (defmacro do* (stepforms endforms &rest body) |
| 470 | "`do*' is to `do' as `let*' is to `let'. |
| 471 | STEPFORMS must be a list of symbols or lists. In the second case, the |
| 472 | lists must start with a symbol and contain up to two more forms. In |
| 473 | the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms |
| 474 | are the initial value (def. NIL) and the form to step (def. itself). |
| 475 | Initializations and steppings are done in the sequence they are written. |
| 476 | The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION |
| 477 | evaluates to true in any iteration, ENDBODY is evaluated and the last |
| 478 | form in it is returned. |
| 479 | The BODY (which may be empty) is evaluated at every iteration, with |
| 480 | the symbols of the STEPFORMS bound to the initial or stepped values." |
| 481 | ;; check the syntax of the macro |
| 482 | (and (check-do-stepforms stepforms) |
| 483 | (check-do-endforms endforms)) |
| 484 | ;; construct emacs-lisp equivalent |
| 485 | (let ((initlist (extract-do-inits stepforms)) |
| 486 | (steplist (extract-do*-steps stepforms)) |
| 487 | (endcond (car endforms)) |
| 488 | (endbody (cdr endforms))) |
| 489 | (cons 'let* (cons initlist |
| 490 | (cons (cons 'while (cons (list 'not endcond) |
| 491 | (append body steplist))) |
| 492 | (append endbody)))))) |
| 493 | |
| 494 | \f |
| 495 | ;;; DO and DO* share the syntax checking functions that follow. |
| 496 | |
| 497 | (defun check-do-stepforms (forms) |
| 498 | "True if FORMS is a valid stepforms for the do[*] macro (q.v.)" |
| 499 | (if (nlistp forms) |
| 500 | (error "init/step form for do[*] should be a list, not `%s'" |
| 501 | (prin1-to-string forms)) |
| 502 | (mapcar |
| 503 | (function |
| 504 | (lambda (entry) |
| 505 | (if (not (or (symbolp entry) |
| 506 | (and (listp entry) |
| 507 | (symbolp (car entry)) |
| 508 | (< (length entry) 4)))) |
| 509 | (error "init/step must be %s, not `%s'" |
| 510 | "symbol or (symbol [init [step]])" |
| 511 | (prin1-to-string entry))))) |
| 512 | forms))) |
| 513 | |
| 514 | (defun check-do-endforms (forms) |
| 515 | "True if FORMS is a valid endforms for the do[*] macro (q.v.)" |
| 516 | (if (nlistp forms) |
| 517 | (error "termination form for do macro should be a list, not `%s'" |
| 518 | (prin1-to-string forms)))) |
| 519 | |
| 520 | (defun extract-do-inits (forms) |
| 521 | "Returns a list of the initializations (for do) in FORMS |
| 522 | --a stepforms, see the do macro--. FORMS is assumed syntactically valid." |
| 523 | (mapcar |
| 524 | (function |
| 525 | (lambda (entry) |
| 526 | (cond ((symbolp entry) |
| 527 | (list entry nil)) |
| 528 | ((listp entry) |
| 529 | (list (car entry) (cadr entry)))))) |
| 530 | forms)) |
| 531 | |
| 532 | ;;; There used to be a reason to deal with DO differently than with |
| 533 | ;;; DO*. The writing of PSETQ has made it largely unnecessary. |
| 534 | |
| 535 | (defun extract-do-steps (forms) |
| 536 | "EXTRACT-DO-STEPS FORMS => an s-expr |
| 537 | FORMS is the stepforms part of a DO macro (q.v.). This function |
| 538 | constructs an s-expression that does the stepping at the end of an |
| 539 | iteration." |
| 540 | (list (cons 'psetq (select-stepping-forms forms)))) |
| 541 | |
| 542 | (defun extract-do*-steps (forms) |
| 543 | "EXTRACT-DO*-STEPS FORMS => an s-expr |
| 544 | FORMS is the stepforms part of a DO* macro (q.v.). This function |
| 545 | constructs an s-expression that does the stepping at the end of an |
| 546 | iteration." |
| 547 | (list (cons 'setq (select-stepping-forms forms)))) |
| 548 | |
| 549 | (defun select-stepping-forms (forms) |
| 550 | "Separate only the forms that cause stepping." |
| 551 | (let ((result '()) ;ends up being (... var form ...) |
| 552 | (ptr forms) ;to traverse the forms |
| 553 | entry ;to explore each form in turn |
| 554 | ) |
| 555 | (while ptr ;(not (endp entry)) might be safer |
| 556 | (setq entry (car ptr)) |
| 557 | (cond ((and (listp entry) (= (length entry) 3)) |
| 558 | (setq result (append ;append in reverse order! |
| 559 | (list (caddr entry) (car entry)) |
| 560 | result)))) |
| 561 | (setq ptr (cdr ptr))) ;step in the list of forms |
| 562 | (nreverse result))) |
| 563 | \f |
| 564 | ;;; Other iterative constructs |
| 565 | |
| 566 | (defmacro dolist (stepform &rest body) |
| 567 | "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST. |
| 568 | The RESULTFORM defaults to nil. The VAR is bound to successive |
| 569 | elements of the value of LIST and remains bound (to the nil value) when the |
| 570 | RESULTFORM is evaluated." |
| 571 | ;; check sanity |
| 572 | (cond |
| 573 | ((nlistp stepform) |
| 574 | (error "stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'" |
| 575 | (prin1-to-string stepform))) |
| 576 | ((not (symbolp (car stepform))) |
| 577 | (error "first component of stepform should be a symbol, not `%s'" |
| 578 | (prin1-to-string (car stepform)))) |
| 579 | ((> (length stepform) 3) |
| 580 | (error "too many components in stepform `%s'" |
| 581 | (prin1-to-string stepform)))) |
| 582 | ;; generate code |
| 583 | (let* ((var (car stepform)) |
| 584 | (listform (cadr stepform)) |
| 585 | (resultform (caddr stepform)) |
| 586 | (listsym (gentemp))) |
| 587 | (nconc |
| 588 | (list 'let (list var (list listsym listform)) |
| 589 | (nconc |
| 590 | (list 'while listsym |
| 591 | (list 'setq |
| 592 | var (list 'car listsym) |
| 593 | listsym (list 'cdr listsym))) |
| 594 | body)) |
| 595 | (and resultform |
| 596 | (cons (list 'setq var nil) |
| 597 | (list resultform)))))) |
| 598 | |
| 599 | (defmacro dotimes (stepform &rest body) |
| 600 | "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR. |
| 601 | The COUNTFORM should return a positive integer. The VAR is bound to |
| 602 | successive integers from 0 to COUNTFORM-1 and the BODY is repeated for |
| 603 | each of them. At the end, the RESULTFORM is evaluated and its value |
| 604 | returned. During this last evaluation, the VAR is still bound, and its |
| 605 | value is the number of times the iteration occurred. An omitted RESULTFORM |
| 606 | defaults to nil." |
| 607 | ;; check sanity |
| 608 | (cond |
| 609 | ((nlistp stepform) |
| 610 | (error "stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'" |
| 611 | (prin1-to-string stepform))) |
| 612 | ((not (symbolp (car stepform))) |
| 613 | (error "first component of stepform should be a symbol, not `%s'" |
| 614 | (prin1-to-string (car stepform)))) |
| 615 | ((> (length stepform) 3) |
| 616 | (error "too many components in stepform `%s'" |
| 617 | (prin1-to-string stepform)))) |
| 618 | ;; generate code |
| 619 | (let* ((var (car stepform)) |
| 620 | (countform (cadr stepform)) |
| 621 | (resultform (caddr stepform)) |
| 622 | (testsym (if (consp countform) (gentemp) countform))) |
| 623 | (nconc |
| 624 | (list |
| 625 | 'let (cons (list var -1) |
| 626 | (and (not (eq countform testsym)) |
| 627 | (list (list testsym countform)))) |
| 628 | (nconc |
| 629 | (list 'while (list '< (list 'setq var (list '1+ var)) testsym)) |
| 630 | body)) |
| 631 | (and resultform (list resultform))))) |
| 632 | \f |
| 633 | (defmacro do-symbols (stepform &rest body) |
| 634 | "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY) |
| 635 | The VAR is bound to each of the symbols in OBARRAY (def. obarray) and |
| 636 | the BODY is repeatedly performed for each of those bindings. At the |
| 637 | end, RESULTFORM (def. nil) is evaluated and its value returned. |
| 638 | During this last evaluation, the VAR is still bound and its value is nil. |
| 639 | See also the function `mapatoms'." |
| 640 | ;; check sanity |
| 641 | (cond |
| 642 | ((nlistp stepform) |
| 643 | (error "stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'" |
| 644 | (prin1-to-string stepform))) |
| 645 | ((not (symbolp (car stepform))) |
| 646 | (error "first component of stepform should be a symbol, not `%s'" |
| 647 | (prin1-to-string (car stepform)))) |
| 648 | ((> (length stepform) 3) |
| 649 | (error "too many components in stepform `%s'" |
| 650 | (prin1-to-string stepform)))) |
| 651 | ;; generate code |
| 652 | (let* ((var (car stepform)) |
| 653 | (oblist (cadr stepform)) |
| 654 | (resultform (caddr stepform))) |
| 655 | (list 'progn |
| 656 | (list 'mapatoms |
| 657 | (list 'function |
| 658 | (cons 'lambda (cons (list var) body))) |
| 659 | oblist) |
| 660 | (list 'let |
| 661 | (list (list var nil)) |
| 662 | resultform)))) |
| 663 | |
| 664 | |
| 665 | (defmacro do-all-symbols (stepform &rest body) |
| 666 | "(do-all-symbols (VAR [RESULTFORM]) . BODY) |
| 667 | Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)." |
| 668 | (list* |
| 669 | 'do-symbols |
| 670 | (list (car stepform) 'obarray (cadr stepform)) |
| 671 | body)) |
| 672 | \f |
| 673 | (defmacro loop (&rest body) |
| 674 | "(loop . BODY) repeats BODY indefinitely and does not return. |
| 675 | Normally BODY uses `throw' or `signal' to cause an exit. |
| 676 | The forms in BODY should be lists, as non-lists are reserved for new features." |
| 677 | ;; check that the body doesn't have atomic forms |
| 678 | (if (nlistp body) |
| 679 | (error "body of `loop' should be a list of lists or nil") |
| 680 | ;; ok, it is a list, check for atomic components |
| 681 | (mapcar |
| 682 | (function (lambda (component) |
| 683 | (if (nlistp component) |
| 684 | (error "components of `loop' should be lists")))) |
| 685 | body) |
| 686 | ;; build the infinite loop |
| 687 | (cons 'while (cons 't body)))) |
| 688 | |
| 689 | ;;;; end of cl-iterations.el |
| 690 | \f |
| 691 | ;;;; LISTS |
| 692 | ;;;; This file provides some of the lists machinery of Common-Lisp |
| 693 | ;;;; in a way compatible with Emacs Lisp. Especially, see the the |
| 694 | ;;;; typical c[ad]*r functions. |
| 695 | ;;;; |
| 696 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 697 | ;;;; (quiroz@cs.rochester.edu) |
| 698 | |
| 699 | ;;; Synonyms for list functions |
| 700 | (defsubst first (x) |
| 701 | "Synonym for `car'" |
| 702 | (car x)) |
| 703 | |
| 704 | (defsubst second (x) |
| 705 | "Return the second element of the list LIST." |
| 706 | (nth 1 x)) |
| 707 | |
| 708 | (defsubst third (x) |
| 709 | "Return the third element of the list LIST." |
| 710 | (nth 2 x)) |
| 711 | |
| 712 | (defsubst fourth (x) |
| 713 | "Return the fourth element of the list LIST." |
| 714 | (nth 3 x)) |
| 715 | |
| 716 | (defsubst fifth (x) |
| 717 | "Return the fifth element of the list LIST." |
| 718 | (nth 4 x)) |
| 719 | |
| 720 | (defsubst sixth (x) |
| 721 | "Return the sixth element of the list LIST." |
| 722 | (nth 5 x)) |
| 723 | |
| 724 | (defsubst seventh (x) |
| 725 | "Return the seventh element of the list LIST." |
| 726 | (nth 6 x)) |
| 727 | |
| 728 | (defsubst eighth (x) |
| 729 | "Return the eighth element of the list LIST." |
| 730 | (nth 7 x)) |
| 731 | |
| 732 | (defsubst ninth (x) |
| 733 | "Return the ninth element of the list LIST." |
| 734 | (nth 8 x)) |
| 735 | |
| 736 | (defsubst tenth (x) |
| 737 | "Return the tenth element of the list LIST." |
| 738 | (nth 9 x)) |
| 739 | |
| 740 | (defsubst rest (x) |
| 741 | "Synonym for `cdr'" |
| 742 | (cdr x)) |
| 743 | \f |
| 744 | (defsubst endp (x) |
| 745 | "t if X is nil, nil if X is a cons; error otherwise." |
| 746 | (if (listp x) |
| 747 | (null x) |
| 748 | (error "endp received a non-cons, non-null argument `%s'" |
| 749 | (prin1-to-string x)))) |
| 750 | |
| 751 | (defun last (x) |
| 752 | "Returns the last link in the list LIST." |
| 753 | (if (nlistp x) |
| 754 | (error "arg to `last' must be a list")) |
| 755 | (do ((current-cons x (cdr current-cons)) |
| 756 | (next-cons (cdr x) (cdr next-cons))) |
| 757 | ((endp next-cons) current-cons))) |
| 758 | |
| 759 | (defun list-length (x) ;taken from CLtL sect. 15.2 |
| 760 | "Returns the length of a non-circular list, or `nil' for a circular one." |
| 761 | (do ((n 0) ;counter |
| 762 | (fast x (cddr fast)) ;fast pointer, leaps by 2 |
| 763 | (slow x (cdr slow)) ;slow pointer, leaps by 1 |
| 764 | (ready nil)) ;indicates termination |
| 765 | (ready n) |
| 766 | (cond ((endp fast) |
| 767 | (setq ready t)) ;return n |
| 768 | ((endp (cdr fast)) |
| 769 | (setq n (+ n 1)) |
| 770 | (setq ready t)) ;return n+1 |
| 771 | ((and (eq fast slow) (> n 0)) |
| 772 | (setq n nil) |
| 773 | (setq ready t)) ;return nil |
| 774 | (t |
| 775 | (setq n (+ n 2)))))) ;just advance counter |
| 776 | \f |
| 777 | (defun butlast (list &optional n) |
| 778 | "Return a new list like LIST but sans the last N elements. |
| 779 | N defaults to 1. If the list doesn't have N elements, nil is returned." |
| 780 | (if (null n) (setq n 1)) |
| 781 | (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org |
| 782 | |
| 783 | ;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) |
| 784 | (defun list* (arg &rest others) |
| 785 | "Return a new list containing the first arguments consed onto the last arg. |
| 786 | Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)." |
| 787 | (if (null others) |
| 788 | arg |
| 789 | (let* ((others (cons arg (copy-sequence others))) |
| 790 | (a others)) |
| 791 | (while (cdr (cdr a)) |
| 792 | (setq a (cdr a))) |
| 793 | (setcdr a (car (cdr a))) |
| 794 | others))) |
| 795 | |
| 796 | (defun adjoin (item list) |
| 797 | "Return a list which contains ITEM but is otherwise like LIST. |
| 798 | If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST). |
| 799 | When comparing ITEM against elements, `eql' is used." |
| 800 | (if (memq item list) |
| 801 | list |
| 802 | (cons item list))) |
| 803 | |
| 804 | (defun ldiff (list sublist) |
| 805 | "Return a new list like LIST but sans SUBLIST. |
| 806 | SUBLIST must be one of the links in LIST; otherwise the value is LIST itself." |
| 807 | (do ((result '()) |
| 808 | (curcons list (cdr curcons))) |
| 809 | ((or (endp curcons) (eq curcons sublist)) |
| 810 | (reverse result)) |
| 811 | (setq result (cons (car curcons) result)))) |
| 812 | \f |
| 813 | ;;; The popular c[ad]*r functions and other list accessors. |
| 814 | |
| 815 | ;;; To implement this efficiently, a new byte compile handler is used to |
| 816 | ;;; generate the minimal code, saving one function call. |
| 817 | |
| 818 | (defsubst caar (X) |
| 819 | "Return the car of the car of X." |
| 820 | (car (car X))) |
| 821 | |
| 822 | (defsubst cadr (X) |
| 823 | "Return the car of the cdr of X." |
| 824 | (car (cdr X))) |
| 825 | |
| 826 | (defsubst cdar (X) |
| 827 | "Return the cdr of the car of X." |
| 828 | (cdr (car X))) |
| 829 | |
| 830 | (defsubst cddr (X) |
| 831 | "Return the cdr of the cdr of X." |
| 832 | (cdr (cdr X))) |
| 833 | |
| 834 | (defsubst caaar (X) |
| 835 | "Return the car of the car of the car of X." |
| 836 | (car (car (car X)))) |
| 837 | |
| 838 | (defsubst caadr (X) |
| 839 | "Return the car of the car of the cdr of X." |
| 840 | (car (car (cdr X)))) |
| 841 | |
| 842 | (defsubst cadar (X) |
| 843 | "Return the car of the cdr of the car of X." |
| 844 | (car (cdr (car X)))) |
| 845 | |
| 846 | (defsubst cdaar (X) |
| 847 | "Return the cdr of the car of the car of X." |
| 848 | (cdr (car (car X)))) |
| 849 | |
| 850 | (defsubst caddr (X) |
| 851 | "Return the car of the cdr of the cdr of X." |
| 852 | (car (cdr (cdr X)))) |
| 853 | |
| 854 | (defsubst cdadr (X) |
| 855 | "Return the cdr of the car of the cdr of X." |
| 856 | (cdr (car (cdr X)))) |
| 857 | |
| 858 | (defsubst cddar (X) |
| 859 | "Return the cdr of the cdr of the car of X." |
| 860 | (cdr (cdr (car X)))) |
| 861 | |
| 862 | (defsubst cdddr (X) |
| 863 | "Return the cdr of the cdr of the cdr of X." |
| 864 | (cdr (cdr (cdr X)))) |
| 865 | |
| 866 | (defsubst caaaar (X) |
| 867 | "Return the car of the car of the car of the car of X." |
| 868 | (car (car (car (car X))))) |
| 869 | |
| 870 | (defsubst caaadr (X) |
| 871 | "Return the car of the car of the car of the cdr of X." |
| 872 | (car (car (car (cdr X))))) |
| 873 | |
| 874 | (defsubst caadar (X) |
| 875 | "Return the car of the car of the cdr of the car of X." |
| 876 | (car (car (cdr (car X))))) |
| 877 | |
| 878 | (defsubst cadaar (X) |
| 879 | "Return the car of the cdr of the car of the car of X." |
| 880 | (car (cdr (car (car X))))) |
| 881 | |
| 882 | (defsubst cdaaar (X) |
| 883 | "Return the cdr of the car of the car of the car of X." |
| 884 | (cdr (car (car (car X))))) |
| 885 | |
| 886 | (defsubst caaddr (X) |
| 887 | "Return the car of the car of the cdr of the cdr of X." |
| 888 | (car (car (cdr (cdr X))))) |
| 889 | |
| 890 | (defsubst cadadr (X) |
| 891 | "Return the car of the cdr of the car of the cdr of X." |
| 892 | (car (cdr (car (cdr X))))) |
| 893 | |
| 894 | (defsubst cdaadr (X) |
| 895 | "Return the cdr of the car of the car of the cdr of X." |
| 896 | (cdr (car (car (cdr X))))) |
| 897 | |
| 898 | (defsubst caddar (X) |
| 899 | "Return the car of the cdr of the cdr of the car of X." |
| 900 | (car (cdr (cdr (car X))))) |
| 901 | |
| 902 | (defsubst cdadar (X) |
| 903 | "Return the cdr of the car of the cdr of the car of X." |
| 904 | (cdr (car (cdr (car X))))) |
| 905 | |
| 906 | (defsubst cddaar (X) |
| 907 | "Return the cdr of the cdr of the car of the car of X." |
| 908 | (cdr (cdr (car (car X))))) |
| 909 | |
| 910 | (defsubst cadddr (X) |
| 911 | "Return the car of the cdr of the cdr of the cdr of X." |
| 912 | (car (cdr (cdr (cdr X))))) |
| 913 | |
| 914 | (defsubst cddadr (X) |
| 915 | "Return the cdr of the cdr of the car of the cdr of X." |
| 916 | (cdr (cdr (car (cdr X))))) |
| 917 | |
| 918 | (defsubst cdaddr (X) |
| 919 | "Return the cdr of the car of the cdr of the cdr of X." |
| 920 | (cdr (car (cdr (cdr X))))) |
| 921 | |
| 922 | (defsubst cdddar (X) |
| 923 | "Return the cdr of the cdr of the cdr of the car of X." |
| 924 | (cdr (cdr (cdr (car X))))) |
| 925 | |
| 926 | (defsubst cddddr (X) |
| 927 | "Return the cdr of the cdr of the cdr of the cdr of X." |
| 928 | (cdr (cdr (cdr (cdr X))))) |
| 929 | \f |
| 930 | ;;; some inverses of the accessors are needed for setf purposes |
| 931 | |
| 932 | (defsubst setnth (n list newval) |
| 933 | "Set (nth N LIST) to NEWVAL. Returns NEWVAL." |
| 934 | (rplaca (nthcdr n list) newval)) |
| 935 | |
| 936 | (defun setnthcdr (n list newval) |
| 937 | "(setnthcdr N LIST NEWVAL) => NEWVAL |
| 938 | As a side effect, sets the Nth cdr of LIST to NEWVAL." |
| 939 | (when (< n 0) |
| 940 | (error "N must be 0 or greater, not %d" n)) |
| 941 | (while (> n 0) |
| 942 | (setq list (cdr list) |
| 943 | n (- n 1))) |
| 944 | ;; here only if (zerop n) |
| 945 | (rplaca list (car newval)) |
| 946 | (rplacd list (cdr newval)) |
| 947 | newval) |
| 948 | \f |
| 949 | ;;; A-lists machinery |
| 950 | |
| 951 | (defsubst acons (key item alist) |
| 952 | "Return a new alist with KEY paired with ITEM; otherwise like ALIST. |
| 953 | Does not copy ALIST." |
| 954 | (cons (cons key item) alist)) |
| 955 | |
| 956 | (defun pairlis (keys data &optional alist) |
| 957 | "Return a new alist with each elt of KEYS paired with an elt of DATA; |
| 958 | optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must |
| 959 | have the same length." |
| 960 | (unless (= (length keys) (length data)) |
| 961 | (error "keys and data should be the same length")) |
| 962 | (do* ;;collect keys and data in front of alist |
| 963 | ((kptr keys (cdr kptr)) ;traverses the keys |
| 964 | (dptr data (cdr dptr)) ;traverses the data |
| 965 | (key (car kptr) (car kptr)) ;current key |
| 966 | (item (car dptr) (car dptr)) ;current data item |
| 967 | (result alist)) |
| 968 | ((endp kptr) result) |
| 969 | (setq result (acons key item result)))) |
| 970 | |
| 971 | ;;;; end of cl-lists.el |
| 972 | \f |
| 973 | ;;;; SEQUENCES |
| 974 | ;;;; Emacs Lisp provides many of the 'sequences' functionality of |
| 975 | ;;;; Common Lisp. This file provides a few things that were left out. |
| 976 | ;;;; |
| 977 | |
| 978 | |
| 979 | (defkeyword :test "Used to designate positive (selection) tests.") |
| 980 | (defkeyword :test-not "Used to designate negative (rejection) tests.") |
| 981 | (defkeyword :key "Used to designate component extractions.") |
| 982 | (defkeyword :predicate "Used to define matching of sequence components.") |
| 983 | (defkeyword :start "Inclusive low index in sequence") |
| 984 | (defkeyword :end "Exclusive high index in sequence") |
| 985 | (defkeyword :start1 "Inclusive low index in first of two sequences.") |
| 986 | (defkeyword :start2 "Inclusive low index in second of two sequences.") |
| 987 | (defkeyword :end1 "Exclusive high index in first of two sequences.") |
| 988 | (defkeyword :end2 "Exclusive high index in second of two sequences.") |
| 989 | (defkeyword :count "Number of elements to affect.") |
| 990 | (defkeyword :from-end "T when counting backwards.") |
| 991 | (defkeyword :initial-value "For the syntax of #'reduce") |
| 992 | \f |
| 993 | (defun some (pred seq &rest moreseqs) |
| 994 | "Test PREDICATE on each element of SEQUENCE; is it ever non-nil? |
| 995 | Extra args are additional sequences; PREDICATE gets one arg from each |
| 996 | sequence and we advance down all the sequences together in lock-step. |
| 997 | A sequence means either a list or a vector." |
| 998 | (let ((args (reassemble-argslists (list* seq moreseqs)))) |
| 999 | (do* ((ready nil) ;flag: return when t |
| 1000 | (result nil) ;resulting value |
| 1001 | (applyval nil) ;result of applying pred once |
| 1002 | (remaining args |
| 1003 | (cdr remaining)) ;remaining argument sets |
| 1004 | (current (car remaining) ;current argument set |
| 1005 | (car remaining))) |
| 1006 | ((or ready (endp remaining)) result) |
| 1007 | (setq applyval (apply pred current)) |
| 1008 | (when applyval |
| 1009 | (setq ready t) |
| 1010 | (setq result applyval))))) |
| 1011 | |
| 1012 | (defun every (pred seq &rest moreseqs) |
| 1013 | "Test PREDICATE on each element of SEQUENCE; is it always non-nil? |
| 1014 | Extra args are additional sequences; PREDICATE gets one arg from each |
| 1015 | sequence and we advance down all the sequences together in lock-step. |
| 1016 | A sequence means either a list or a vector." |
| 1017 | (let ((args (reassemble-argslists (list* seq moreseqs)))) |
| 1018 | (do* ((ready nil) ;flag: return when t |
| 1019 | (result t) ;resulting value |
| 1020 | (applyval nil) ;result of applying pred once |
| 1021 | (remaining args |
| 1022 | (cdr remaining)) ;remaining argument sets |
| 1023 | (current (car remaining) ;current argument set |
| 1024 | (car remaining))) |
| 1025 | ((or ready (endp remaining)) result) |
| 1026 | (setq applyval (apply pred current)) |
| 1027 | (unless applyval |
| 1028 | (setq ready t) |
| 1029 | (setq result nil))))) |
| 1030 | \f |
| 1031 | (defun notany (pred seq &rest moreseqs) |
| 1032 | "Test PREDICATE on each element of SEQUENCE; is it always nil? |
| 1033 | Extra args are additional sequences; PREDICATE gets one arg from each |
| 1034 | sequence and we advance down all the sequences together in lock-step. |
| 1035 | A sequence means either a list or a vector." |
| 1036 | (let ((args (reassemble-argslists (list* seq moreseqs)))) |
| 1037 | (do* ((ready nil) ;flag: return when t |
| 1038 | (result t) ;resulting value |
| 1039 | (applyval nil) ;result of applying pred once |
| 1040 | (remaining args |
| 1041 | (cdr remaining)) ;remaining argument sets |
| 1042 | (current (car remaining) ;current argument set |
| 1043 | (car remaining))) |
| 1044 | ((or ready (endp remaining)) result) |
| 1045 | (setq applyval (apply pred current)) |
| 1046 | (when applyval |
| 1047 | (setq ready t) |
| 1048 | (setq result nil))))) |
| 1049 | |
| 1050 | (defun notevery (pred seq &rest moreseqs) |
| 1051 | "Test PREDICATE on each element of SEQUENCE; is it sometimes nil? |
| 1052 | Extra args are additional sequences; PREDICATE gets one arg from each |
| 1053 | sequence and we advance down all the sequences together in lock-step. |
| 1054 | A sequence means either a list or a vector." |
| 1055 | (let ((args (reassemble-argslists (list* seq moreseqs)))) |
| 1056 | (do* ((ready nil) ;flag: return when t |
| 1057 | (result nil) ;resulting value |
| 1058 | (applyval nil) ;result of applying pred once |
| 1059 | (remaining args |
| 1060 | (cdr remaining)) ;remaining argument sets |
| 1061 | (current (car remaining) ;current argument set |
| 1062 | (car remaining))) |
| 1063 | ((or ready (endp remaining)) result) |
| 1064 | (setq applyval (apply pred current)) |
| 1065 | (unless applyval |
| 1066 | (setq ready t) |
| 1067 | (setq result t))))) |
| 1068 | \f |
| 1069 | ;;; More sequence functions that don't need keyword arguments |
| 1070 | |
| 1071 | (defun concatenate (type &rest sequences) |
| 1072 | "(concatenate TYPE &rest SEQUENCES) => a sequence |
| 1073 | The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and |
| 1074 | contains the concatenation of the elements of all the arguments, in the order |
| 1075 | given." |
| 1076 | (let ((sequences (append sequences '(())))) |
| 1077 | (case type |
| 1078 | (list |
| 1079 | (apply (function append) sequences)) |
| 1080 | (string |
| 1081 | (apply (function concat) sequences)) |
| 1082 | (vector |
| 1083 | (apply (function vector) (apply (function append) sequences))) |
| 1084 | (t |
| 1085 | (error "type for concatenate `%s' not 'list, 'string or 'vector" |
| 1086 | (prin1-to-string type)))))) |
| 1087 | |
| 1088 | (defun map (type function &rest sequences) |
| 1089 | "(map TYPE FUNCTION &rest SEQUENCES) => a sequence |
| 1090 | The FUNCTION is called on each set of elements from the SEQUENCES \(stopping |
| 1091 | when the shortest sequence is terminated\) and the results are possibly |
| 1092 | returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\) |
| 1093 | giving NIL for TYPE gets rid of the values." |
| 1094 | (if (not (memq type (list 'list 'string 'vector nil))) |
| 1095 | (error "type for map `%s' not 'list, 'string, 'vector or nil" |
| 1096 | (prin1-to-string type))) |
| 1097 | (let ((argslists (reassemble-argslists sequences)) |
| 1098 | results) |
| 1099 | (if (null type) |
| 1100 | (while argslists ;don't bother accumulating |
| 1101 | (apply function (car argslists)) |
| 1102 | (setq argslists (cdr argslists))) |
| 1103 | (setq results (mapcar (function (lambda (args) (apply function args))) |
| 1104 | argslists)) |
| 1105 | (case type |
| 1106 | (list |
| 1107 | results) |
| 1108 | (string |
| 1109 | (funcall (function concat) results)) |
| 1110 | (vector |
| 1111 | (apply (function vector) results)))))) |
| 1112 | \f |
| 1113 | ;;; an inverse of elt is needed for setf purposes |
| 1114 | |
| 1115 | (defun setelt (seq n newval) |
| 1116 | "In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL. |
| 1117 | A sequence means either a list or a vector." |
| 1118 | (let ((l (length seq))) |
| 1119 | (if (or (< n 0) (>= n l)) |
| 1120 | (error "N(%d) should be between 0 and %d" n l) |
| 1121 | ;; only two cases need be considered valid, as strings are arrays |
| 1122 | (cond ((listp seq) |
| 1123 | (setnth n seq newval)) |
| 1124 | ((arrayp seq) |
| 1125 | (aset seq n newval)) |
| 1126 | (t |
| 1127 | (error "SEQ should be a sequence, not `%s'" |
| 1128 | (prin1-to-string seq))))))) |
| 1129 | \f |
| 1130 | ;;; Testing with keyword arguments. |
| 1131 | ;;; |
| 1132 | ;;; Many of the sequence functions use keywords to denote some stylized |
| 1133 | ;;; form of selecting entries in a sequence. The involved arguments |
| 1134 | ;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key |
| 1135 | ;;; marker), then they are passed to build-klist, who |
| 1136 | ;;; constructs an association list. That association list is used to |
| 1137 | ;;; test for satisfaction and matching. |
| 1138 | |
| 1139 | ;;; DON'T USE MEMBER, NOR ANY FUNCTION THAT COULD TAKE KEYWORDS HERE!!! |
| 1140 | |
| 1141 | (defun build-klist (argslist acceptable &optional allow-other-keys) |
| 1142 | "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE. |
| 1143 | ARGSLIST is a list, presumably the &rest argument of a call, whose |
| 1144 | even numbered elements must be keywords. |
| 1145 | ACCEPTABLE is a list of keywords, the only ones that are truly acceptable. |
| 1146 | The result is an alist containing the arguments named by the keywords |
| 1147 | in ACCEPTABLE, or an error is signalled, if something failed. |
| 1148 | If the third argument (an optional) is non-nil, other keys are acceptable." |
| 1149 | ;; check legality of the arguments, then destructure them |
| 1150 | (unless (and (listp argslist) |
| 1151 | (evenp (length argslist))) |
| 1152 | (error "build-klist: odd number of keyword-args")) |
| 1153 | (unless (and (listp acceptable) |
| 1154 | (every 'keywordp acceptable)) |
| 1155 | (error "build-klist: second arg should be a list of keywords")) |
| 1156 | (multiple-value-bind |
| 1157 | (keywords forms) |
| 1158 | (unzip-list argslist) |
| 1159 | (unless (every 'keywordp keywords) |
| 1160 | (error "build-klist: expected keywords, found `%s'" |
| 1161 | (prin1-to-string keywords))) |
| 1162 | (unless (or allow-other-keys |
| 1163 | (every (function (lambda (keyword) |
| 1164 | (memq keyword acceptable))) |
| 1165 | keywords)) |
| 1166 | (error "bad keyword[s]: %s not in %s" |
| 1167 | (prin1-to-string (mapcan (function (lambda (keyword) |
| 1168 | (if (memq keyword acceptable) |
| 1169 | nil |
| 1170 | (list keyword)))) |
| 1171 | keywords)) |
| 1172 | (prin1-to-string acceptable))) |
| 1173 | (do* ;;pick up the pieces |
| 1174 | ((auxlist ;auxiliary a-list, may |
| 1175 | (pairlis keywords forms)) ;contain repetitions and junk |
| 1176 | (ptr acceptable (cdr ptr)) ;pointer in acceptable |
| 1177 | (this (car ptr) (car ptr)) ;current acceptable keyword |
| 1178 | (auxval nil) ;used to move values around |
| 1179 | (alist '())) ;used to build the result |
| 1180 | ((endp ptr) alist) |
| 1181 | ;; if THIS appears in auxlist, use its value |
| 1182 | (when (setq auxval (assq this auxlist)) |
| 1183 | (setq alist (cons auxval alist)))))) |
| 1184 | |
| 1185 | |
| 1186 | (defun extract-from-klist (klist key &optional default) |
| 1187 | "(extract-from-klist KLIST KEY [DEFAULT]) => value of KEY or DEFAULT |
| 1188 | Extract value associated with KEY in KLIST (return DEFAULT if nil)." |
| 1189 | (let ((retrieved (cdr (assq key klist)))) |
| 1190 | (or retrieved default))) |
| 1191 | |
| 1192 | (defun keyword-argument-supplied-p (klist key) |
| 1193 | "(keyword-argument-supplied-p KLIST KEY) => nil or something |
| 1194 | NIL if KEY (a keyword) does not appear in the KLIST." |
| 1195 | (assq key klist)) |
| 1196 | |
| 1197 | (defun add-to-klist (key item klist) |
| 1198 | "(ADD-TO-KLIST KEY ITEM KLIST) => new KLIST |
| 1199 | Add association (KEY . ITEM) to KLIST." |
| 1200 | (setq klist (acons key item klist))) |
| 1201 | |
| 1202 | (defun elt-satisfies-test-p (item elt klist) |
| 1203 | "(elt-satisfies-test-p ITEM ELT KLIST) => t or nil |
| 1204 | KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. |
| 1205 | True if the given ITEM and ELT satisfy the test." |
| 1206 | (let ((test (extract-from-klist klist :test)) |
| 1207 | (test-not (extract-from-klist klist :test-not)) |
| 1208 | (keyfn (extract-from-klist klist :key 'identity))) |
| 1209 | (cond (test |
| 1210 | (funcall test item (funcall keyfn elt))) |
| 1211 | (test-not |
| 1212 | (not (funcall test-not item (funcall keyfn elt)))) |
| 1213 | (t ;should never happen |
| 1214 | (error "neither :test nor :test-not in `%s'" |
| 1215 | (prin1-to-string klist)))))) |
| 1216 | |
| 1217 | (defun elt-satisfies-if-p (item klist) |
| 1218 | "(elt-satisfies-if-p ITEM KLIST) => t or nil |
| 1219 | True if an -if style function was called and ITEM satisfies the |
| 1220 | predicate under :predicate in KLIST." |
| 1221 | (let ((predicate (extract-from-klist klist :predicate)) |
| 1222 | (keyfn (extract-from-klist klist :key 'identity))) |
| 1223 | (funcall predicate (funcall keyfn item)))) |
| 1224 | |
| 1225 | (defun elt-satisfies-if-not-p (item klist) |
| 1226 | "(elt-satisfies-if-not-p ITEM KLIST) => t or nil |
| 1227 | KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. |
| 1228 | True if an -if-not style function was called and ITEM does not satisfy |
| 1229 | the predicate under :predicate in KLIST." |
| 1230 | (let ((predicate (extract-from-klist klist :predicate)) |
| 1231 | (keyfn (extract-from-klist klist :key 'identity))) |
| 1232 | (not (funcall predicate (funcall keyfn item))))) |
| 1233 | |
| 1234 | (defun elts-match-under-klist-p (e1 e2 klist) |
| 1235 | "(elts-match-under-klist-p E1 E2 KLIST) => t or nil |
| 1236 | KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. |
| 1237 | True if elements E1 and E2 match under the tests encoded in KLIST." |
| 1238 | (let ((test (extract-from-klist klist :test)) |
| 1239 | (test-not (extract-from-klist klist :test-not)) |
| 1240 | (keyfn (extract-from-klist klist :key 'identity))) |
| 1241 | (if (and test test-not) |
| 1242 | (error "both :test and :test-not in `%s'" |
| 1243 | (prin1-to-string klist))) |
| 1244 | (cond (test |
| 1245 | (funcall test (funcall keyfn e1) (funcall keyfn e2))) |
| 1246 | (test-not |
| 1247 | (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2)))) |
| 1248 | (t ;should never happen |
| 1249 | (error "neither :test nor :test-not in `%s'" |
| 1250 | (prin1-to-string klist)))))) |
| 1251 | \f |
| 1252 | ;;; This macro simplifies using keyword args. It is less clumsy than using |
| 1253 | ;;; the primitives build-klist, etc... For instance, member could be written |
| 1254 | ;;; this way: |
| 1255 | |
| 1256 | ;;; (defun member (item list &rest kargs) |
| 1257 | ;;; (with-keyword-args kargs (test test-not (key 'identity)) |
| 1258 | ;;; ...)) |
| 1259 | |
| 1260 | ;;; Suggested by Robert Potter (potter@cs.rochester.edu, 15 Nov 1989) |
| 1261 | |
| 1262 | (defmacro with-keyword-args (keyargslist vardefs &rest body) |
| 1263 | "(WITH-KEYWORD-ARGS KEYARGSLIST VARDEFS . BODY) |
| 1264 | KEYARGSLIST can be either a symbol or a list of one or two symbols. |
| 1265 | In the second case, the second symbol is either T or NIL, indicating whether |
| 1266 | keywords other than the mentioned ones are tolerable. |
| 1267 | |
| 1268 | VARDEFS is a list. Each entry is either a VAR (symbol) or matches |
| 1269 | \(VAR [DEFAULT [KEYWORD]]). Just giving VAR is the same as giving |
| 1270 | \(VAR nil :VAR). |
| 1271 | |
| 1272 | The BODY is executed in an environment where each VAR (a symbol) is bound to |
| 1273 | the value present in the KEYARGSLIST provided, or to the DEFAULT. The value |
| 1274 | is searched by using the keyword form of VAR (i.e., :VAR) or the optional |
| 1275 | keyword if provided. |
| 1276 | |
| 1277 | Notice that this macro doesn't distinguish between a default value given |
| 1278 | explicitly by the user and one provided by default. See also the more |
| 1279 | primitive functions build-klist, add-to-klist, extract-from-klist, |
| 1280 | keyword-argument-supplied-p, elt-satisfies-test-p, elt-satisfies-if-p, |
| 1281 | elt-satisfies-if-not-p, elts-match-under-klist-p. They provide more complete, |
| 1282 | if clumsier, control over this feature." |
| 1283 | (let (allow-other-keys) |
| 1284 | (if (listp keyargslist) |
| 1285 | (if (> (length keyargslist) 2) |
| 1286 | (error |
| 1287 | "`%s' should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" |
| 1288 | (prin1-to-string keyargslist)) |
| 1289 | (setq allow-other-keys (cadr keyargslist) |
| 1290 | keyargslist (car keyargslist)) |
| 1291 | (if (not (and |
| 1292 | (symbolp keyargslist) |
| 1293 | (memq allow-other-keys '(t nil)))) |
| 1294 | (error |
| 1295 | "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" |
| 1296 | ))) |
| 1297 | (if (symbolp keyargslist) |
| 1298 | (setq allow-other-keys nil) |
| 1299 | (error |
| 1300 | "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"))) |
| 1301 | (let (vars defaults keywords forms |
| 1302 | (klistname (gensym "KLIST_"))) |
| 1303 | (mapcar (function (lambda (entry) |
| 1304 | (if (symbolp entry) ;defaulty case |
| 1305 | (setq entry (list entry nil (keyword-of entry)))) |
| 1306 | (let* ((l (length entry)) |
| 1307 | (v (car entry)) |
| 1308 | (d (cadr entry)) |
| 1309 | (k (caddr entry))) |
| 1310 | (if (or (< l 1) (> l 3)) |
| 1311 | (error |
| 1312 | "`%s' must match (VAR [DEFAULT [KEYWORD]])" |
| 1313 | (prin1-to-string entry))) |
| 1314 | (if (or (null v) (not (symbolp v))) |
| 1315 | (error |
| 1316 | "bad variable `%s': must be non-null symbol" |
| 1317 | (prin1-to-string v))) |
| 1318 | (setq vars (cons v vars)) |
| 1319 | (setq defaults (cons d defaults)) |
| 1320 | (if (< l 3) |
| 1321 | (setq k (keyword-of v))) |
| 1322 | (if (and (= l 3) |
| 1323 | (or (null k) |
| 1324 | (not (keywordp k)))) |
| 1325 | (error |
| 1326 | "bad keyword `%s'" (prin1-to-string k))) |
| 1327 | (setq keywords (cons k keywords)) |
| 1328 | (setq forms (cons (list v (list 'extract-from-klist |
| 1329 | klistname |
| 1330 | k |
| 1331 | d)) |
| 1332 | forms))))) |
| 1333 | vardefs) |
| 1334 | (append |
| 1335 | (list 'let* (nconc (list (list klistname |
| 1336 | (list 'build-klist keyargslist |
| 1337 | (list 'quote keywords) |
| 1338 | allow-other-keys))) |
| 1339 | (nreverse forms))) |
| 1340 | body)))) |
| 1341 | (put 'with-keyword-args 'lisp-indent-hook 1) |
| 1342 | |
| 1343 | \f |
| 1344 | ;;; REDUCE |
| 1345 | ;;; It is here mostly as an example of how to use KLISTs. |
| 1346 | ;;; |
| 1347 | ;;; First of all, you need to declare the keywords (done elsewhere in this |
| 1348 | ;;; file): |
| 1349 | ;;; (defkeyword :from-end "syntax of sequence functions") |
| 1350 | ;;; (defkeyword :start "syntax of sequence functions") |
| 1351 | ;;; etc... |
| 1352 | ;;; |
| 1353 | ;;; Then, you capture all the possible keyword arguments with a &rest |
| 1354 | ;;; argument. You can pass that list downward again, of course, but |
| 1355 | ;;; internally you need to parse it into a KLIST (an alist, really). One uses |
| 1356 | ;;; (build-klist REST-ARGS ACCEPTABLE-KEYWORDS [ALLOW-OTHER]). You can then |
| 1357 | ;;; test for presence by using (keyword-argument-supplied-p KLIST KEY) and |
| 1358 | ;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]). |
| 1359 | |
| 1360 | (defun reduce (function sequence &rest kargs) |
| 1361 | "Apply FUNCTION (a function of two arguments) to successive pairs of elements |
| 1362 | from SEQUENCE. Some keyword arguments are valid after FUNCTION and SEQUENCE: |
| 1363 | :from-end If non-nil, process the values backwards |
| 1364 | :initial-value If given, prefix it to the SEQUENCE. Suffix, if :from-end |
| 1365 | :start Restrict reduction to the subsequence from this index |
| 1366 | :end Restrict reduction to the subsequence BEFORE this index. |
| 1367 | If the sequence is empty and no :initial-value is given, the FUNCTION is |
| 1368 | called on zero (not two) arguments. Otherwise, if there is exactly one |
| 1369 | element in the combination of SEQUENCE and the initial value, that element is |
| 1370 | returned." |
| 1371 | (let* ((klist (build-klist kargs '(:from-end :start :end :initial-value))) |
| 1372 | (length (length sequence)) |
| 1373 | (from-end (extract-from-klist klist :from-end)) |
| 1374 | (initial-value-given (keyword-argument-supplied-p |
| 1375 | klist :initial-value)) |
| 1376 | (start (extract-from-klist kargs :start 0)) |
| 1377 | (end (extract-from-klist kargs :end length))) |
| 1378 | (setq sequence (cl$subseq-as-list sequence start end)) |
| 1379 | (if from-end |
| 1380 | (setq sequence (reverse sequence))) |
| 1381 | (if initial-value-given |
| 1382 | (setq sequence (cons (extract-from-klist klist :initial-value) |
| 1383 | sequence))) |
| 1384 | (if (null sequence) |
| 1385 | (funcall function) ;only use of 0 arguments |
| 1386 | (let* ((result (car sequence)) |
| 1387 | (sequence (cdr sequence))) |
| 1388 | (while sequence |
| 1389 | (setq result (if from-end |
| 1390 | (funcall function (car sequence) result) |
| 1391 | (funcall function result (car sequence))) |
| 1392 | sequence (cdr sequence))) |
| 1393 | result)))) |
| 1394 | |
| 1395 | (defun cl$subseq-as-list (sequence start end) |
| 1396 | "(cl$subseq-as-list SEQUENCE START END) => a list" |
| 1397 | (let ((list (append sequence nil)) |
| 1398 | (length (length sequence)) |
| 1399 | result) |
| 1400 | (if (< start 0) |
| 1401 | (error "start should be >= 0, not %d" start)) |
| 1402 | (if (> end length) |
| 1403 | (error "end should be <= %d, not %d" length end)) |
| 1404 | (if (and (zerop start) (= end length)) |
| 1405 | list |
| 1406 | (let ((i start) |
| 1407 | (vector (apply 'vector list))) |
| 1408 | (while (/= i end) |
| 1409 | (setq result (cons (elt vector i) result)) |
| 1410 | (setq i (+ i 1))) |
| 1411 | (nreverse result))))) |
| 1412 | |
| 1413 | ;;;; end of cl-sequences.el |
| 1414 | \f |
| 1415 | ;;;; Some functions with keyword arguments |
| 1416 | ;;;; |
| 1417 | ;;;; Both list and sequence functions are considered here together. This |
| 1418 | ;;;; doesn't fit any more with the original split of functions in files. |
| 1419 | |
| 1420 | (defun cl-member (item list &rest kargs) |
| 1421 | "Look for ITEM in LIST; return first tail of LIST the car of whose first |
| 1422 | cons cell tests the same as ITEM. Admits arguments :key, :test, and |
| 1423 | :test-not." |
| 1424 | (if (null kargs) ;treat this fast for efficiency |
| 1425 | (memq item list) |
| 1426 | (let* ((klist (build-klist kargs '(:test :test-not :key))) |
| 1427 | (test (extract-from-klist klist :test)) |
| 1428 | (testnot (extract-from-klist klist :test-not)) |
| 1429 | (key (extract-from-klist klist :key 'identity))) |
| 1430 | ;; another workaround allegedly for speed, BLAH |
| 1431 | (if (and (or (eq test 'eq) (eq test 'eql) |
| 1432 | (eq test (symbol-function 'eq)) |
| 1433 | (eq test (symbol-function 'eql))) |
| 1434 | (null testnot) |
| 1435 | (or (eq key 'identity) ;either by default or so given |
| 1436 | (eq key (function identity)) ;could this happen? |
| 1437 | (eq key (symbol-function 'identity)) ;sheer paranoia |
| 1438 | )) |
| 1439 | (memq item list) |
| 1440 | (if (and test testnot) |
| 1441 | (error ":test and :test-not both specified for member")) |
| 1442 | (if (not (or test testnot)) |
| 1443 | (setq test 'eql)) |
| 1444 | ;; final hack: remove the indirection through the function names |
| 1445 | (if testnot |
| 1446 | (if (symbolp testnot) |
| 1447 | (setq testnot (symbol-function testnot))) |
| 1448 | (if (symbolp test) |
| 1449 | (setq test (symbol-function test)))) |
| 1450 | (if (symbolp key) |
| 1451 | (setq key (symbol-function key))) |
| 1452 | ;; ok, go for it |
| 1453 | (let ((ptr list) |
| 1454 | (done nil) |
| 1455 | (result '())) |
| 1456 | (if testnot |
| 1457 | (while (not (or done (endp ptr))) |
| 1458 | (cond ((not (funcall testnot item (funcall key (car ptr)))) |
| 1459 | (setq done t) |
| 1460 | (setq result ptr))) |
| 1461 | (setq ptr (cdr ptr))) |
| 1462 | (while (not (or done (endp ptr))) |
| 1463 | (cond ((funcall test item (funcall key (car ptr))) |
| 1464 | (setq done t) |
| 1465 | (setq result ptr))) |
| 1466 | (setq ptr (cdr ptr)))) |
| 1467 | result))))) |
| 1468 | \f |
| 1469 | ;;;; MULTIPLE VALUES |
| 1470 | ;;;; This package approximates the behavior of the multiple-values |
| 1471 | ;;;; forms of Common Lisp. |
| 1472 | ;;;; |
| 1473 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 1474 | ;;;; (quiroz@cs.rochester.edu) |
| 1475 | |
| 1476 | ;;; Lisp indentation information |
| 1477 | (put 'multiple-value-bind 'lisp-indent-hook 2) |
| 1478 | (put 'multiple-value-setq 'lisp-indent-hook 2) |
| 1479 | (put 'multiple-value-list 'lisp-indent-hook nil) |
| 1480 | (put 'multiple-value-call 'lisp-indent-hook 1) |
| 1481 | (put 'multiple-value-prog1 'lisp-indent-hook 1) |
| 1482 | |
| 1483 | ;;; Global state of the package is kept here |
| 1484 | (defvar *mvalues-values* nil |
| 1485 | "Most recently returned multiple-values") |
| 1486 | (defvar *mvalues-count* nil |
| 1487 | "Count of multiple-values returned, or nil if the mechanism was not used") |
| 1488 | \f |
| 1489 | ;;; values is the standard multiple-value-return form. Must be the |
| 1490 | ;;; last thing evaluated inside a function. If the caller is not |
| 1491 | ;;; expecting multiple values, only the first one is passed. (values) |
| 1492 | ;;; is the same as no-values returned (unaware callers see nil). The |
| 1493 | ;;; alternative (values-list <list>) is just a convenient shorthand |
| 1494 | ;;; and complements multiple-value-list. |
| 1495 | |
| 1496 | (defun values (&rest val-forms) |
| 1497 | "Produce multiple values (zero or more). Each arg is one value. |
| 1498 | See also `multiple-value-bind', which is one way to examine the |
| 1499 | multiple values produced by a form. If the containing form or caller |
| 1500 | does not check specially to see multiple values, it will see only |
| 1501 | the first value." |
| 1502 | (setq *mvalues-values* val-forms) |
| 1503 | (setq *mvalues-count* (length *mvalues-values*)) |
| 1504 | (car *mvalues-values*)) |
| 1505 | |
| 1506 | (defun values-list (&optional val-forms) |
| 1507 | "Produce multiple values (zero or more). Each element of LIST is one value. |
| 1508 | This is equivalent to (apply 'values LIST)." |
| 1509 | (cond ((nlistp val-forms) |
| 1510 | (error "Argument to values-list must be a list, not `%s'" |
| 1511 | (prin1-to-string val-forms)))) |
| 1512 | (setq *mvalues-values* val-forms) |
| 1513 | (setq *mvalues-count* (length *mvalues-values*)) |
| 1514 | (car *mvalues-values*)) |
| 1515 | \f |
| 1516 | ;;; Callers that want to see the multiple values use these macros. |
| 1517 | |
| 1518 | (defmacro multiple-value-list (form) |
| 1519 | "Execute FORM and return a list of all the (multiple) values FORM produces. |
| 1520 | See `values' and `multiple-value-bind'." |
| 1521 | (list 'progn |
| 1522 | (list 'setq '*mvalues-count* nil) |
| 1523 | (list 'let (list (list 'it '(gensym))) |
| 1524 | (list 'set 'it form) |
| 1525 | (list 'if '*mvalues-count* |
| 1526 | (list 'copy-sequence '*mvalues-values*) |
| 1527 | (list 'progn |
| 1528 | (list 'setq '*mvalues-count* 1) |
| 1529 | (list 'setq '*mvalues-values* |
| 1530 | (list 'list (list 'symbol-value 'it))) |
| 1531 | (list 'copy-sequence '*mvalues-values*)))))) |
| 1532 | |
| 1533 | (defmacro multiple-value-call (function &rest args) |
| 1534 | "Call FUNCTION on all the values produced by the remaining arguments. |
| 1535 | (multiple-value-call '+ (values 1 2) (values 3 4)) is 10." |
| 1536 | (let* ((result (gentemp)) |
| 1537 | (arg (gentemp))) |
| 1538 | (list 'apply (list 'function (eval function)) |
| 1539 | (list 'let* (list (list result '())) |
| 1540 | (list 'dolist (list arg (list 'quote args) result) |
| 1541 | (list 'setq result |
| 1542 | (list 'append |
| 1543 | result |
| 1544 | (list 'multiple-value-list |
| 1545 | (list 'eval arg))))))))) |
| 1546 | |
| 1547 | (defmacro multiple-value-bind (vars form &rest body) |
| 1548 | "Bind VARS to the (multiple) values produced by FORM, then do BODY. |
| 1549 | VARS is a list of variables; each is bound to one of FORM's values. |
| 1550 | If FORM doesn't make enough values, the extra variables are bound to nil. |
| 1551 | (Ordinary forms produce only one value; to produce more, use `values'.) |
| 1552 | Extra values are ignored. |
| 1553 | BODY (zero or more forms) is executed with the variables bound, |
| 1554 | then the bindings are unwound." |
| 1555 | (let* ((vals (gentemp)) ;name for intermediate values |
| 1556 | (clauses (mv-bind-clausify ;convert into clauses usable |
| 1557 | vars vals))) ; in a let form |
| 1558 | (list* 'let* |
| 1559 | (cons (list vals (list 'multiple-value-list form)) |
| 1560 | clauses) |
| 1561 | body))) |
| 1562 | \f |
| 1563 | (defmacro multiple-value-setq (vars form) |
| 1564 | "Set VARS to the (multiple) values produced by FORM. |
| 1565 | VARS is a list of variables; each is set to one of FORM's values. |
| 1566 | If FORM doesn't make enough values, the extra variables are set to nil. |
| 1567 | (Ordinary forms produce only one value; to produce more, use `values'.) |
| 1568 | Extra values are ignored." |
| 1569 | (let* ((vals (gentemp)) ;name for intermediate values |
| 1570 | (clauses (mv-bind-clausify ;convert into clauses usable |
| 1571 | vars vals))) ; in a setq (after append). |
| 1572 | (list 'let* |
| 1573 | (list (list vals (list 'multiple-value-list form))) |
| 1574 | (cons 'setq (apply (function append) clauses))))) |
| 1575 | |
| 1576 | (defmacro multiple-value-prog1 (form &rest body) |
| 1577 | "Evaluate FORM, then BODY, then produce the same values FORM produced. |
| 1578 | Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2. |
| 1579 | This is like `prog1' except that `prog1' would produce only one value, |
| 1580 | which would be the first of FORM's values." |
| 1581 | (let* ((heldvalues (gentemp))) |
| 1582 | (cons 'let* |
| 1583 | (cons (list (list heldvalues (list 'multiple-value-list form))) |
| 1584 | (append body (list (list 'values-list heldvalues))))))) |
| 1585 | |
| 1586 | ;;; utility functions |
| 1587 | ;;; |
| 1588 | ;;; mv-bind-clausify makes the pairs needed to have the variables in |
| 1589 | ;;; the variable list correspond with the values returned by the form. |
| 1590 | ;;; vals is a fresh symbol that intervenes in all the bindings. |
| 1591 | |
| 1592 | (defun mv-bind-clausify (vars vals) |
| 1593 | "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list |
| 1594 | Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to |
| 1595 | the length of VARS (a list of symbols). VALS is just a fresh symbol." |
| 1596 | (if (or (nlistp vars) |
| 1597 | (notevery 'symbolp vars)) |
| 1598 | (error "expected a list of symbols, not `%s'" |
| 1599 | (prin1-to-string vars))) |
| 1600 | (let* ((nvars (length vars)) |
| 1601 | (clauses '())) |
| 1602 | (dotimes (n nvars clauses) |
| 1603 | (setq clauses (cons (list (nth n vars) |
| 1604 | (list 'nth n vals)) clauses))))) |
| 1605 | |
| 1606 | ;;;; end of cl-multiple-values.el |
| 1607 | \f |
| 1608 | ;;;; ARITH |
| 1609 | ;;;; This file provides integer arithmetic extensions. Although |
| 1610 | ;;;; Emacs Lisp doesn't really support anything but integers, that |
| 1611 | ;;;; has still to be made to look more or less standard. |
| 1612 | ;;;; |
| 1613 | ;;;; |
| 1614 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 1615 | ;;;; (quiroz@cs.rochester.edu) |
| 1616 | |
| 1617 | |
| 1618 | (defsubst plusp (number) |
| 1619 | "True if NUMBER is strictly greater than zero." |
| 1620 | (> number 0)) |
| 1621 | |
| 1622 | (defsubst minusp (number) |
| 1623 | "True if NUMBER is strictly less than zero." |
| 1624 | (< number 0)) |
| 1625 | |
| 1626 | (defsubst oddp (number) |
| 1627 | "True if INTEGER is not divisible by 2." |
| 1628 | (/= (% number 2) 0)) |
| 1629 | |
| 1630 | (defsubst evenp (number) |
| 1631 | "True if INTEGER is divisible by 2." |
| 1632 | (= (% number 2) 0)) |
| 1633 | |
| 1634 | (defsubst abs (number) |
| 1635 | "Return the absolute value of NUMBER." |
| 1636 | (if (< number 0) |
| 1637 | (- number) |
| 1638 | number)) |
| 1639 | |
| 1640 | (defsubst signum (number) |
| 1641 | "Return -1, 0 or 1 according to the sign of NUMBER." |
| 1642 | (cond ((< number 0) |
| 1643 | -1) |
| 1644 | ((> number 0) |
| 1645 | 1) |
| 1646 | (t ;exactly zero |
| 1647 | 0))) |
| 1648 | \f |
| 1649 | (defun gcd (&rest integers) |
| 1650 | "Return the greatest common divisor of all the arguments. |
| 1651 | The arguments must be integers. With no arguments, value is zero." |
| 1652 | (let ((howmany (length integers))) |
| 1653 | (cond ((= howmany 0) |
| 1654 | 0) |
| 1655 | ((= howmany 1) |
| 1656 | (abs (car integers))) |
| 1657 | ((> howmany 2) |
| 1658 | (apply (function gcd) |
| 1659 | (cons (gcd (nth 0 integers) (nth 1 integers)) |
| 1660 | (nthcdr 2 integers)))) |
| 1661 | (t ;howmany=2 |
| 1662 | ;; essentially the euclidean algorithm |
| 1663 | (when (zerop (* (nth 0 integers) (nth 1 integers))) |
| 1664 | (error "a zero argument is invalid for `gcd'")) |
| 1665 | (do* ((absa (abs (nth 0 integers))) ; better to operate only |
| 1666 | (absb (abs (nth 1 integers))) ;on positives. |
| 1667 | (dd (max absa absb)) ; setup correct order for the |
| 1668 | (ds (min absa absb)) ;successive divisions. |
| 1669 | ;; intermediate results |
| 1670 | (q 0) |
| 1671 | (r 0) |
| 1672 | ;; final results |
| 1673 | (done nil) ; flag: end of iterations |
| 1674 | (result 0)) ; final value |
| 1675 | (done result) |
| 1676 | (setq q (/ dd ds)) |
| 1677 | (setq r (% dd ds)) |
| 1678 | (cond ((zerop r) (setq done t) (setq result ds)) |
| 1679 | (t (setq dd ds) (setq ds r)))))))) |
| 1680 | |
| 1681 | (defun lcm (integer &rest more) |
| 1682 | "Return the least common multiple of all the arguments. |
| 1683 | The arguments must be integers and there must be at least one of them." |
| 1684 | (let ((howmany (length more)) |
| 1685 | (a integer) |
| 1686 | (b (nth 0 more)) |
| 1687 | prod ; intermediate product |
| 1688 | (yetmore (nthcdr 1 more))) |
| 1689 | (cond ((zerop howmany) |
| 1690 | (abs a)) |
| 1691 | ((> howmany 1) ; recursive case |
| 1692 | (apply (function lcm) |
| 1693 | (cons (lcm a b) yetmore))) |
| 1694 | (t ; base case, just 2 args |
| 1695 | (setq prod (* a b)) |
| 1696 | (cond |
| 1697 | ((zerop prod) |
| 1698 | 0) |
| 1699 | (t |
| 1700 | (/ (abs prod) (gcd a b)))))))) |
| 1701 | \f |
| 1702 | (defun isqrt (number) |
| 1703 | "Return the integer square root of NUMBER. |
| 1704 | NUMBER must not be negative. Result is largest integer less than or |
| 1705 | equal to the real square root of the argument." |
| 1706 | ;; The method used here is essentially the Newtonian iteration |
| 1707 | ;; x[n+1] <- (x[n] + Number/x[n]) / 2 |
| 1708 | ;; suitably adapted to integer arithmetic. |
| 1709 | ;; Thanks to Philippe Schnoebelen <phs@lifia.imag.fr> for suggesting the |
| 1710 | ;; termination condition. |
| 1711 | (cond ((minusp number) |
| 1712 | (error "argument to `isqrt' (%d) must not be negative" |
| 1713 | number)) |
| 1714 | ((zerop number) |
| 1715 | 0) |
| 1716 | (t ;so (>= number 0) |
| 1717 | (do* ((approx 1) ;any positive integer will do |
| 1718 | (new 0) ;init value irrelevant |
| 1719 | (done nil)) |
| 1720 | (done (if (> (* approx approx) number) |
| 1721 | (- approx 1) |
| 1722 | approx)) |
| 1723 | (setq new (/ (+ approx (/ number approx)) 2) |
| 1724 | done (or (= new approx) (= new (+ approx 1))) |
| 1725 | approx new))))) |
| 1726 | \f |
| 1727 | (defun cl-floor (number &optional divisor) |
| 1728 | "Divide DIVIDEND by DIVISOR, rounding toward minus infinity. |
| 1729 | DIVISOR defaults to 1. The remainder is produced as a second value." |
| 1730 | (cond ((and (null divisor) ; trivial case |
| 1731 | (numberp number)) |
| 1732 | (values number 0)) |
| 1733 | (t ; do the division |
| 1734 | (multiple-value-bind |
| 1735 | (q r s) |
| 1736 | (safe-idiv number divisor) |
| 1737 | (cond ((zerop s) |
| 1738 | (values 0 0)) |
| 1739 | ((plusp s) |
| 1740 | (values q r)) |
| 1741 | (t ;opposite-signs case |
| 1742 | (if (zerop r) |
| 1743 | (values (- q) 0) |
| 1744 | (let ((q (- (+ q 1)))) |
| 1745 | (values q (- number (* q divisor))))))))))) |
| 1746 | |
| 1747 | (defun cl-ceiling (number &optional divisor) |
| 1748 | "Divide DIVIDEND by DIVISOR, rounding toward plus infinity. |
| 1749 | DIVISOR defaults to 1. The remainder is produced as a second value." |
| 1750 | (cond ((and (null divisor) ; trivial case |
| 1751 | (numberp number)) |
| 1752 | (values number 0)) |
| 1753 | (t ; do the division |
| 1754 | (multiple-value-bind |
| 1755 | (q r s) |
| 1756 | (safe-idiv number divisor) |
| 1757 | (cond ((zerop s) |
| 1758 | (values 0 0)) |
| 1759 | ((plusp s) |
| 1760 | (values (+ q 1) (- r divisor))) |
| 1761 | (t |
| 1762 | (values (- q) (+ number (* q divisor))))))))) |
| 1763 | \f |
| 1764 | (defun cl-truncate (number &optional divisor) |
| 1765 | "Divide DIVIDEND by DIVISOR, rounding toward zero. |
| 1766 | DIVISOR defaults to 1. The remainder is produced as a second value." |
| 1767 | (cond ((and (null divisor) ; trivial case |
| 1768 | (numberp number)) |
| 1769 | (values number 0)) |
| 1770 | (t ; do the division |
| 1771 | (multiple-value-bind |
| 1772 | (q r s) |
| 1773 | (safe-idiv number divisor) |
| 1774 | (cond ((zerop s) |
| 1775 | (values 0 0)) |
| 1776 | ((plusp s) ;same as floor |
| 1777 | (values q r)) |
| 1778 | (t ;same as ceiling |
| 1779 | (values (- q) (+ number (* q divisor))))))))) |
| 1780 | |
| 1781 | (defun cl-round (number &optional divisor) |
| 1782 | "Divide DIVIDEND by DIVISOR, rounding to nearest integer. |
| 1783 | DIVISOR defaults to 1. The remainder is produced as a second value." |
| 1784 | (cond ((and (null divisor) ; trivial case |
| 1785 | (numberp number)) |
| 1786 | (values number 0)) |
| 1787 | (t ; do the division |
| 1788 | (multiple-value-bind |
| 1789 | (q r s) |
| 1790 | (safe-idiv number divisor) |
| 1791 | (setq r (abs r)) |
| 1792 | ;; adjust magnitudes first, and then signs |
| 1793 | (let ((other-r (- (abs divisor) r))) |
| 1794 | (cond ((> r other-r) |
| 1795 | (setq q (+ q 1))) |
| 1796 | ((and (= r other-r) |
| 1797 | (oddp q)) |
| 1798 | ;; round to even is mandatory |
| 1799 | (setq q (+ q 1)))) |
| 1800 | (setq q (* s q)) |
| 1801 | (setq r (- number (* q divisor))) |
| 1802 | (values q r)))))) |
| 1803 | \f |
| 1804 | ;;; These two functions access the implementation-dependent representation of |
| 1805 | ;;; the multiple value returns. |
| 1806 | |
| 1807 | (defun cl-mod (number divisor) |
| 1808 | "Return remainder of X by Y (rounding quotient toward minus infinity). |
| 1809 | That is, the remainder goes with the quotient produced by `cl-floor'. |
| 1810 | Emacs Lisp hint: |
| 1811 | If you know that both arguments are positive, use `%' instead for speed." |
| 1812 | (cl-floor number divisor) |
| 1813 | (cadr *mvalues-values*)) |
| 1814 | |
| 1815 | (defun rem (number divisor) |
| 1816 | "Return remainder of X by Y (rounding quotient toward zero). |
| 1817 | That is, the remainder goes with the quotient produced by `cl-truncate'. |
| 1818 | Emacs Lisp hint: |
| 1819 | If you know that both arguments are positive, use `%' instead for speed." |
| 1820 | (cl-truncate number divisor) |
| 1821 | (cadr *mvalues-values*)) |
| 1822 | \f |
| 1823 | ;;; internal utilities |
| 1824 | ;;; |
| 1825 | ;;; safe-idiv performs an integer division with positive numbers only. |
| 1826 | ;;; It is known that some machines/compilers implement weird remainder |
| 1827 | ;;; computations when working with negatives, so the idea here is to |
| 1828 | ;;; make sure we know what is coming back to the caller in all cases. |
| 1829 | |
| 1830 | ;;; Signum computation fixed by mad@math.keio.JUNET (MAEDA Atusi) |
| 1831 | |
| 1832 | (defun safe-idiv (a b) |
| 1833 | "SAFE-IDIV A B => Q R S |
| 1834 | Q=|A|/|B|, S is the sign of A/B, R is the rest A - S*Q*B." |
| 1835 | ;; (unless (and (numberp a) (numberp b)) |
| 1836 | ;; (error "arguments to `safe-idiv' must be numbers")) |
| 1837 | ;; (when (zerop b) |
| 1838 | ;; (error "cannot divide %d by zero" a)) |
| 1839 | (let* ((q (/ (abs a) (abs b))) |
| 1840 | (s (* (signum a) (signum b))) |
| 1841 | (r (- a (* s q b)))) |
| 1842 | (values q r s))) |
| 1843 | |
| 1844 | ;;;; end of cl-arith.el |
| 1845 | \f |
| 1846 | ;;;; SETF |
| 1847 | ;;;; This file provides the setf macro and friends. The purpose has |
| 1848 | ;;;; been modest, only the simplest defsetf forms are accepted. |
| 1849 | ;;;; Use it and enjoy. |
| 1850 | ;;;; |
| 1851 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 1852 | ;;;; (quiroz@cs.rochester.edu) |
| 1853 | |
| 1854 | |
| 1855 | (defkeyword :setf-update-fn |
| 1856 | "Property, its value is the function setf must invoke to update a |
| 1857 | generalized variable whose access form is a function call of the |
| 1858 | symbol that has this property.") |
| 1859 | |
| 1860 | (defkeyword :setf-update-doc |
| 1861 | "Property of symbols that have a `defsetf' update function on them, |
| 1862 | installed by the `defsetf' from its optional third argument.") |
| 1863 | \f |
| 1864 | (defmacro setf (&rest pairs) |
| 1865 | "Generalized `setq' that can set things other than variable values. |
| 1866 | A use of `setf' looks like (setf {PLACE VALUE}...). |
| 1867 | The behavior of (setf PLACE VALUE) is to access the generalized variable |
| 1868 | at PLACE and store VALUE there. It returns VALUE. If there is more |
| 1869 | than one PLACE and VALUE, each PLACE is set from its VALUE before |
| 1870 | the next PLACE is evaluated." |
| 1871 | (let ((nforms (length pairs))) |
| 1872 | ;; check the number of subforms |
| 1873 | (cond ((/= (% nforms 2) 0) |
| 1874 | (error "odd number of arguments to `setf'")) |
| 1875 | ((= nforms 0) |
| 1876 | nil) |
| 1877 | ((> nforms 2) |
| 1878 | ;; this is the recursive case |
| 1879 | (cons 'progn |
| 1880 | (do* ;collect the place-value pairs |
| 1881 | ((args pairs (cddr args)) |
| 1882 | (place (car args) (car args)) |
| 1883 | (value (cadr args) (cadr args)) |
| 1884 | (result '())) |
| 1885 | ((endp args) (nreverse result)) |
| 1886 | (setq result |
| 1887 | (cons (list 'setf place value) |
| 1888 | result))))) |
| 1889 | (t ;i.e., nforms=2 |
| 1890 | ;; this is the base case (SETF PLACE VALUE) |
| 1891 | (let* ((place (car pairs)) |
| 1892 | (value (cadr pairs)) |
| 1893 | (head nil) |
| 1894 | (updatefn nil)) |
| 1895 | ;; dispatch on the type of the PLACE |
| 1896 | (cond ((symbolp place) |
| 1897 | (list 'setq place value)) |
| 1898 | ((and (listp place) |
| 1899 | (setq head (car place)) |
| 1900 | (symbolp head) |
| 1901 | (setq updatefn (get head :setf-update-fn))) |
| 1902 | ;; dispatch on the type of update function |
| 1903 | (cond ((and (consp updatefn) (eq (car updatefn) 'lambda)) |
| 1904 | (cons 'funcall |
| 1905 | (cons (list 'function updatefn) |
| 1906 | (append (cdr place) (list value))))) |
| 1907 | ((and (symbolp updatefn) |
| 1908 | (fboundp updatefn) |
| 1909 | (let ((defn (symbol-function updatefn))) |
| 1910 | (or (subrp defn) |
| 1911 | (and (consp defn) |
| 1912 | (or (eq (car defn) 'lambda) |
| 1913 | (eq (car defn) 'macro)))))) |
| 1914 | (cons updatefn (append (cdr place) (list value)))) |
| 1915 | (t |
| 1916 | (multiple-value-bind |
| 1917 | (bindings newsyms) |
| 1918 | (pair-with-newsyms |
| 1919 | (append (cdr place) (list value))) |
| 1920 | ;; this let gets new symbols to ensure adequate |
| 1921 | ;; order of evaluation of the subforms. |
| 1922 | (list 'let |
| 1923 | bindings |
| 1924 | (cons updatefn newsyms)))))) |
| 1925 | (t |
| 1926 | (error "no `setf' update-function for `%s'" |
| 1927 | (prin1-to-string place))))))))) |
| 1928 | \f |
| 1929 | (defmacro defsetf (accessfn updatefn &optional docstring) |
| 1930 | "Define how `setf' works on a certain kind of generalized variable. |
| 1931 | A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]). |
| 1932 | ACCESSFN is a symbol. UPDATEFN is a function or macro which takes |
| 1933 | one more argument than ACCESSFN does. DEFSETF defines the translation |
| 1934 | of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL). |
| 1935 | The function UPDATEFN must return its last arg, after performing the |
| 1936 | updating called for." |
| 1937 | ;; reject ill-formed requests. too bad one can't test for functionp |
| 1938 | ;; or macrop. |
| 1939 | (when (not (symbolp accessfn)) |
| 1940 | (error "first argument of `defsetf' must be a symbol, not `%s'" |
| 1941 | (prin1-to-string accessfn))) |
| 1942 | ;; update properties |
| 1943 | (list 'progn |
| 1944 | (list 'eval-and-compile |
| 1945 | (list 'put (list 'quote accessfn) |
| 1946 | :setf-update-fn (list 'function updatefn))) |
| 1947 | (list 'put (list 'quote accessfn) :setf-update-doc docstring) |
| 1948 | ;; any better thing to return? |
| 1949 | (list 'quote accessfn))) |
| 1950 | \f |
| 1951 | ;;; This section provides the "default" setfs for Common-Emacs-Lisp |
| 1952 | ;;; The user will not normally add anything to this, although |
| 1953 | ;;; defstruct will introduce new ones as a matter of fact. |
| 1954 | ;;; |
| 1955 | ;;; Apply is a special case. The Common Lisp |
| 1956 | ;;; standard makes the case of apply be useful when the user writes |
| 1957 | ;;; something like (apply #'name ...), Emacs Lisp doesn't have the # |
| 1958 | ;;; stuff, but it has (function ...). Notice that V18 includes a new |
| 1959 | ;;; apply: this file is compatible with V18 and pre-V18 Emacses. |
| 1960 | |
| 1961 | ;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the |
| 1962 | ;;; (correct) left to right sequence *before* checking for apply |
| 1963 | ;;; methods (which should really be an special case inside setf). Due |
| 1964 | ;;; to this, the lambda expression defsetf'd to apply will succeed in |
| 1965 | ;;; applying the right function even if the name was not quoted, but |
| 1966 | ;;; computed! That extension is not Common Lisp (nor is particularly |
| 1967 | ;;; useful, I think). |
| 1968 | |
| 1969 | (defsetf apply |
| 1970 | (lambda (&rest args) |
| 1971 | ;; disassemble the calling form |
| 1972 | ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too) |
| 1973 | (let* ((fnform (car args)) ;functional form |
| 1974 | (applyargs (append ;arguments "to apply fnform" |
| 1975 | (apply 'list* (butlast (cdr args))) |
| 1976 | (last args))) |
| 1977 | (newupdater nil)) ; its update-fn, if any |
| 1978 | (if (and (symbolp fnform) |
| 1979 | (setq newupdater (get fnform :setf-update-fn))) |
| 1980 | (apply newupdater applyargs) |
| 1981 | (error "can't `setf' to `%s'" |
| 1982 | (prin1-to-string fnform))))) |
| 1983 | "`apply' is a special case for `setf'") |
| 1984 | |
| 1985 | \f |
| 1986 | (defsetf aref |
| 1987 | aset |
| 1988 | "`setf' inversion for `aref'") |
| 1989 | |
| 1990 | (defsetf nth |
| 1991 | setnth |
| 1992 | "`setf' inversion for `nth'") |
| 1993 | |
| 1994 | (defsetf nthcdr |
| 1995 | setnthcdr |
| 1996 | "`setf' inversion for `nthcdr'") |
| 1997 | |
| 1998 | (defsetf elt |
| 1999 | setelt |
| 2000 | "`setf' inversion for `elt'") |
| 2001 | |
| 2002 | (defsetf first |
| 2003 | (lambda (list val) (setnth 0 list val)) |
| 2004 | "`setf' inversion for `first'") |
| 2005 | |
| 2006 | (defsetf second |
| 2007 | (lambda (list val) (setnth 1 list val)) |
| 2008 | "`setf' inversion for `second'") |
| 2009 | |
| 2010 | (defsetf third |
| 2011 | (lambda (list val) (setnth 2 list val)) |
| 2012 | "`setf' inversion for `third'") |
| 2013 | |
| 2014 | (defsetf fourth |
| 2015 | (lambda (list val) (setnth 3 list val)) |
| 2016 | "`setf' inversion for `fourth'") |
| 2017 | |
| 2018 | (defsetf fifth |
| 2019 | (lambda (list val) (setnth 4 list val)) |
| 2020 | "`setf' inversion for `fifth'") |
| 2021 | |
| 2022 | (defsetf sixth |
| 2023 | (lambda (list val) (setnth 5 list val)) |
| 2024 | "`setf' inversion for `sixth'") |
| 2025 | |
| 2026 | (defsetf seventh |
| 2027 | (lambda (list val) (setnth 6 list val)) |
| 2028 | "`setf' inversion for `seventh'") |
| 2029 | \f |
| 2030 | (defsetf eighth |
| 2031 | (lambda (list val) (setnth 7 list val)) |
| 2032 | "`setf' inversion for `eighth'") |
| 2033 | |
| 2034 | (defsetf ninth |
| 2035 | (lambda (list val) (setnth 8 list val)) |
| 2036 | "`setf' inversion for `ninth'") |
| 2037 | |
| 2038 | (defsetf tenth |
| 2039 | (lambda (list val) (setnth 9 list val)) |
| 2040 | "`setf' inversion for `tenth'") |
| 2041 | |
| 2042 | (defsetf rest |
| 2043 | (lambda (list val) (setcdr list val)) |
| 2044 | "`setf' inversion for `rest'") |
| 2045 | |
| 2046 | (defsetf car setcar "Replace the car of a cons") |
| 2047 | |
| 2048 | (defsetf cdr setcdr "Replace the cdr of a cons") |
| 2049 | |
| 2050 | (defsetf caar |
| 2051 | (lambda (list val) (setcar (nth 0 list) val)) |
| 2052 | "`setf' inversion for `caar'") |
| 2053 | |
| 2054 | (defsetf cadr |
| 2055 | (lambda (list val) (setcar (cdr list) val)) |
| 2056 | "`setf' inversion for `cadr'") |
| 2057 | |
| 2058 | (defsetf cdar |
| 2059 | (lambda (list val) (setcdr (car list) val)) |
| 2060 | "`setf' inversion for `cdar'") |
| 2061 | |
| 2062 | (defsetf cddr |
| 2063 | (lambda (list val) (setcdr (cdr list) val)) |
| 2064 | "`setf' inversion for `cddr'") |
| 2065 | |
| 2066 | (defsetf caaar |
| 2067 | (lambda (list val) (setcar (caar list) val)) |
| 2068 | "`setf' inversion for `caaar'") |
| 2069 | |
| 2070 | (defsetf caadr |
| 2071 | (lambda (list val) (setcar (cadr list) val)) |
| 2072 | "`setf' inversion for `caadr'") |
| 2073 | |
| 2074 | (defsetf cadar |
| 2075 | (lambda (list val) (setcar (cdar list) val)) |
| 2076 | "`setf' inversion for `cadar'") |
| 2077 | \f |
| 2078 | (defsetf cdaar |
| 2079 | (lambda (list val) (setcdr (caar list) val)) |
| 2080 | "`setf' inversion for `cdaar'") |
| 2081 | |
| 2082 | (defsetf caddr |
| 2083 | (lambda (list val) (setcar (cddr list) val)) |
| 2084 | "`setf' inversion for `caddr'") |
| 2085 | |
| 2086 | (defsetf cdadr |
| 2087 | (lambda (list val) (setcdr (cadr list) val)) |
| 2088 | "`setf' inversion for `cdadr'") |
| 2089 | |
| 2090 | (defsetf cddar |
| 2091 | (lambda (list val) (setcdr (cdar list) val)) |
| 2092 | "`setf' inversion for `cddar'") |
| 2093 | |
| 2094 | (defsetf cdddr |
| 2095 | (lambda (list val) (setcdr (cddr list) val)) |
| 2096 | "`setf' inversion for `cdddr'") |
| 2097 | |
| 2098 | (defsetf caaaar |
| 2099 | (lambda (list val) (setcar (caaar list) val)) |
| 2100 | "`setf' inversion for `caaaar'") |
| 2101 | |
| 2102 | (defsetf caaadr |
| 2103 | (lambda (list val) (setcar (caadr list) val)) |
| 2104 | "`setf' inversion for `caaadr'") |
| 2105 | |
| 2106 | (defsetf caadar |
| 2107 | (lambda (list val) (setcar (cadar list) val)) |
| 2108 | "`setf' inversion for `caadar'") |
| 2109 | |
| 2110 | (defsetf cadaar |
| 2111 | (lambda (list val) (setcar (cdaar list) val)) |
| 2112 | "`setf' inversion for `cadaar'") |
| 2113 | |
| 2114 | (defsetf cdaaar |
| 2115 | (lambda (list val) (setcdr (caar list) val)) |
| 2116 | "`setf' inversion for `cdaaar'") |
| 2117 | |
| 2118 | (defsetf caaddr |
| 2119 | (lambda (list val) (setcar (caddr list) val)) |
| 2120 | "`setf' inversion for `caaddr'") |
| 2121 | \f |
| 2122 | (defsetf cadadr |
| 2123 | (lambda (list val) (setcar (cdadr list) val)) |
| 2124 | "`setf' inversion for `cadadr'") |
| 2125 | |
| 2126 | (defsetf cdaadr |
| 2127 | (lambda (list val) (setcdr (caadr list) val)) |
| 2128 | "`setf' inversion for `cdaadr'") |
| 2129 | |
| 2130 | (defsetf caddar |
| 2131 | (lambda (list val) (setcar (cddar list) val)) |
| 2132 | "`setf' inversion for `caddar'") |
| 2133 | |
| 2134 | (defsetf cdadar |
| 2135 | (lambda (list val) (setcdr (cadar list) val)) |
| 2136 | "`setf' inversion for `cdadar'") |
| 2137 | |
| 2138 | (defsetf cddaar |
| 2139 | (lambda (list val) (setcdr (cdaar list) val)) |
| 2140 | "`setf' inversion for `cddaar'") |
| 2141 | |
| 2142 | (defsetf cadddr |
| 2143 | (lambda (list val) (setcar (cdddr list) val)) |
| 2144 | "`setf' inversion for `cadddr'") |
| 2145 | |
| 2146 | (defsetf cddadr |
| 2147 | (lambda (list val) (setcdr (cdadr list) val)) |
| 2148 | "`setf' inversion for `cddadr'") |
| 2149 | |
| 2150 | (defsetf cdaddr |
| 2151 | (lambda (list val) (setcdr (caddr list) val)) |
| 2152 | "`setf' inversion for `cdaddr'") |
| 2153 | |
| 2154 | (defsetf cdddar |
| 2155 | (lambda (list val) (setcdr (cddar list) val)) |
| 2156 | "`setf' inversion for `cdddar'") |
| 2157 | |
| 2158 | (defsetf cddddr |
| 2159 | (lambda (list val) (setcdr (cddr list) val)) |
| 2160 | "`setf' inversion for `cddddr'") |
| 2161 | |
| 2162 | (defsetf get put "`setf' inversion for `get' is `put'") |
| 2163 | |
| 2164 | (defsetf symbol-function fset |
| 2165 | "`setf' inversion for `symbol-function' is `fset'") |
| 2166 | |
| 2167 | (defsetf symbol-plist setplist |
| 2168 | "`setf' inversion for `symbol-plist' is `setplist'") |
| 2169 | |
| 2170 | (defsetf symbol-value set |
| 2171 | "`setf' inversion for `symbol-value' is `set'") |
| 2172 | |
| 2173 | (defsetf point goto-char |
| 2174 | "To set (point) to N, use (goto-char N)") |
| 2175 | |
| 2176 | ;; how about defsetfing other Emacs forms? |
| 2177 | \f |
| 2178 | ;;; Modify macros |
| 2179 | ;;; |
| 2180 | ;;; It could be nice to implement define-modify-macro, but I don't |
| 2181 | ;;; think it really pays. |
| 2182 | |
| 2183 | (defmacro incf (ref &optional delta) |
| 2184 | "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)" |
| 2185 | (if (null delta) |
| 2186 | (setq delta 1)) |
| 2187 | (list 'setf ref (list '+ ref delta))) |
| 2188 | |
| 2189 | (defmacro decf (ref &optional delta) |
| 2190 | "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)" |
| 2191 | (if (null delta) |
| 2192 | (setq delta 1)) |
| 2193 | (list 'setf ref (list '- ref delta))) |
| 2194 | |
| 2195 | (defmacro push (item ref) |
| 2196 | "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)" |
| 2197 | (list 'setf ref (list 'cons item ref))) |
| 2198 | |
| 2199 | (defmacro pushnew (item ref) |
| 2200 | "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)" |
| 2201 | (list 'setf ref (list 'adjoin item ref))) |
| 2202 | |
| 2203 | (defmacro pop (ref) |
| 2204 | "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))" |
| 2205 | (let ((listname (gensym))) |
| 2206 | (list 'let (list (list listname ref)) |
| 2207 | (list 'prog1 |
| 2208 | (list 'car listname) |
| 2209 | (list 'setf ref (list 'cdr listname)))))) |
| 2210 | \f |
| 2211 | ;;; PSETF |
| 2212 | ;;; |
| 2213 | ;;; Psetf is the generalized variable equivalent of psetq. The right |
| 2214 | ;;; hand sides are evaluated and assigned (via setf) to the left hand |
| 2215 | ;;; sides. The evaluations are done in an environment where they |
| 2216 | ;;; appear to occur in parallel. |
| 2217 | |
| 2218 | (defmacro psetf (&rest body) |
| 2219 | "(psetf {var value }...) => nil |
| 2220 | Like setf, but all the values are computed before any assignment is made." |
| 2221 | (let ((length (length body))) |
| 2222 | (cond ((/= (% length 2) 0) |
| 2223 | (error "psetf needs an even number of arguments, %d given" |
| 2224 | length)) |
| 2225 | ((null body) |
| 2226 | '()) |
| 2227 | (t |
| 2228 | (list 'prog1 nil |
| 2229 | (let ((setfs '()) |
| 2230 | (bodyforms (reverse body))) |
| 2231 | (while bodyforms |
| 2232 | (let* ((value (car bodyforms)) |
| 2233 | (place (cadr bodyforms))) |
| 2234 | (setq bodyforms (cddr bodyforms)) |
| 2235 | (if (null setfs) |
| 2236 | (setq setfs (list 'setf place value)) |
| 2237 | (setq setfs (list 'setf place |
| 2238 | (list 'prog1 value |
| 2239 | setfs)))))) |
| 2240 | setfs)))))) |
| 2241 | \f |
| 2242 | ;;; SHIFTF and ROTATEF |
| 2243 | ;;; |
| 2244 | |
| 2245 | (defmacro shiftf (&rest forms) |
| 2246 | "(shiftf PLACE1 PLACE2... NEWVALUE) |
| 2247 | Set PLACE1 to PLACE2, PLACE2 to PLACE3... |
| 2248 | Each PLACE is set to the old value of the following PLACE, |
| 2249 | and the last PLACE is set to the value NEWVALUE. |
| 2250 | Returns the old value of PLACE1." |
| 2251 | (unless (> (length forms) 1) |
| 2252 | (error "`shiftf' needs more than one argument")) |
| 2253 | (let ((places (butlast forms)) |
| 2254 | (newvalue (car (last forms)))) |
| 2255 | ;; the places are accessed to fresh symbols |
| 2256 | (multiple-value-bind |
| 2257 | (bindings newsyms) |
| 2258 | (pair-with-newsyms places) |
| 2259 | (list 'let bindings |
| 2260 | (cons 'setf |
| 2261 | (zip-lists places |
| 2262 | (append (cdr newsyms) (list newvalue)))) |
| 2263 | (car newsyms))))) |
| 2264 | |
| 2265 | (defmacro rotatef (&rest places) |
| 2266 | "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE. |
| 2267 | The last PLACE is set to the old value of the first PLACE. |
| 2268 | Thus, the values rotate through the PLACEs. Returns nil." |
| 2269 | (if (null places) |
| 2270 | nil |
| 2271 | (multiple-value-bind |
| 2272 | (bindings newsyms) |
| 2273 | (pair-with-newsyms places) |
| 2274 | (list |
| 2275 | 'let bindings |
| 2276 | (cons 'setf |
| 2277 | (zip-lists places |
| 2278 | (append (cdr newsyms) (list (car newsyms))))) |
| 2279 | nil)))) |
| 2280 | \f |
| 2281 | ;;; GETF, REMF, and REMPROP |
| 2282 | ;;; |
| 2283 | |
| 2284 | (defun getf (place indicator &optional default) |
| 2285 | "Return PLACE's PROPNAME property, or DEFAULT if not present." |
| 2286 | (while (and place (not (eq (car place) indicator))) |
| 2287 | (setq place (cdr (cdr place)))) |
| 2288 | (if place |
| 2289 | (car (cdr place)) |
| 2290 | default)) |
| 2291 | |
| 2292 | (defmacro getf$setf$method (place indicator default &rest newval) |
| 2293 | "SETF method for GETF. Not for public use." |
| 2294 | (case (length newval) |
| 2295 | (0 (setq newval default default nil)) |
| 2296 | (1 (setq newval (car newval))) |
| 2297 | (t (error "Wrong number of arguments to (setf (getf ...)) form"))) |
| 2298 | (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp))) |
| 2299 | (list 'let (list (list psym place) |
| 2300 | (list isym indicator) |
| 2301 | (list vsym newval)) |
| 2302 | (list 'while |
| 2303 | (list 'and psym |
| 2304 | (list 'not |
| 2305 | (list 'eq (list 'car psym) isym))) |
| 2306 | (list 'setq psym (list 'cdr (list 'cdr psym)))) |
| 2307 | (list 'if psym |
| 2308 | (list 'setcar (list 'cdr psym) vsym) |
| 2309 | (list 'setf place |
| 2310 | (list 'nconc place (list 'list isym newval)))) |
| 2311 | vsym))) |
| 2312 | |
| 2313 | (defsetf getf |
| 2314 | getf$setf$method) |
| 2315 | |
| 2316 | (defmacro remf (place indicator) |
| 2317 | "Remove from the property list at PLACE its PROPNAME property. |
| 2318 | Returns non-nil if and only if the property existed." |
| 2319 | (let ((psym (gentemp)) (isym (gentemp))) |
| 2320 | (list 'let (list (list psym place) (list isym indicator)) |
| 2321 | (list 'cond |
| 2322 | (list (list 'eq isym (list 'car psym)) |
| 2323 | (list 'setf place (list 'cdr (list 'cdr psym))) |
| 2324 | t) |
| 2325 | (list t |
| 2326 | (list 'setq psym (list 'cdr psym)) |
| 2327 | (list 'while |
| 2328 | (list 'and (list 'cdr psym) |
| 2329 | (list 'not |
| 2330 | (list 'eq (list 'car (list 'cdr psym)) |
| 2331 | isym))) |
| 2332 | (list 'setq psym (list 'cdr (list 'cdr psym)))) |
| 2333 | (list 'cond |
| 2334 | (list (list 'cdr psym) |
| 2335 | (list 'setcdr psym |
| 2336 | (list 'cdr |
| 2337 | (list 'cdr (list 'cdr psym)))) |
| 2338 | t))))))) |
| 2339 | |
| 2340 | (defun remprop (symbol indicator) |
| 2341 | "Remove SYMBOL's PROPNAME property, returning non-nil if it was present." |
| 2342 | (remf (symbol-plist symbol) indicator)) |
| 2343 | |
| 2344 | \f |
| 2345 | ;;;; STRUCTS |
| 2346 | ;;;; This file provides the structures mechanism. See the |
| 2347 | ;;;; documentation for Common-Lisp's defstruct. Mine doesn't |
| 2348 | ;;;; implement all the functionality of the standard, although some |
| 2349 | ;;;; more could be grafted if so desired. More details along with |
| 2350 | ;;;; the code. |
| 2351 | ;;;; |
| 2352 | ;;;; |
| 2353 | ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 |
| 2354 | ;;;; (quiroz@cs.rochester.edu) |
| 2355 | |
| 2356 | |
| 2357 | (defkeyword :include "Syntax of `defstruct'") |
| 2358 | (defkeyword :named "Syntax of `defstruct'") |
| 2359 | (defkeyword :conc-name "Syntax of `defstruct'") |
| 2360 | (defkeyword :copier "Syntax of `defstruct'") |
| 2361 | (defkeyword :predicate "Syntax of `defstruct'") |
| 2362 | (defkeyword :print-function "Syntax of `defstruct'") |
| 2363 | (defkeyword :type "Syntax of `defstruct'") |
| 2364 | (defkeyword :initial-offset "Syntax of `defstruct'") |
| 2365 | |
| 2366 | (defkeyword :structure-doc "Documentation string for a structure.") |
| 2367 | (defkeyword :structure-slotsn "Number of slots in structure") |
| 2368 | (defkeyword :structure-slots "List of the slot's names") |
| 2369 | (defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)") |
| 2370 | (defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)") |
| 2371 | (defkeyword :structure-includes |
| 2372 | "() or list of a symbol, that this struct includes") |
| 2373 | (defkeyword :structure-included-in |
| 2374 | "List of the structs that include this") |
| 2375 | |
| 2376 | \f |
| 2377 | (defmacro defstruct (&rest args) |
| 2378 | "(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type. |
| 2379 | NAME must be a symbol, the name of the new structure. It could also |
| 2380 | be a list (NAME . OPTIONS). |
| 2381 | |
| 2382 | Each option is either a symbol, or a list of a keyword symbol taken from the |
| 2383 | list \{:conc-name, :copier, :constructor, :predicate, :include, |
| 2384 | :print-function, :type, :initial-offset\}. The meanings of these are as in |
| 2385 | CLtL, except that no BOA-constructors are provided, and the options |
| 2386 | \{:print-function, :type, :initial-offset\} are ignored quietly. All these |
| 2387 | structs are named, in the sense that their names can be used for type |
| 2388 | discrimination. |
| 2389 | |
| 2390 | The DOC-STRING is established as the `structure-doc' property of NAME. |
| 2391 | |
| 2392 | The SLOTS are one or more of the following: |
| 2393 | SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME |
| 2394 | list of SYMBOL and VALUE -- meaning that VALUE is the initial value of |
| 2395 | the slot. |
| 2396 | `defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the |
| 2397 | structure, and functions with the same name as the slots to access |
| 2398 | them. `setf' of the accessors sets their values." |
| 2399 | (multiple-value-bind |
| 2400 | (name options docstring slotsn slots initlist) |
| 2401 | (parse$defstruct$args args) |
| 2402 | ;; Names for the member functions come from the options. The |
| 2403 | ;; slots* stuff collects info about the slots declared explicitly. |
| 2404 | (multiple-value-bind |
| 2405 | (conc-name constructor copier predicate |
| 2406 | moreslotsn moreslots moreinits included) |
| 2407 | (parse$defstruct$options name options slots) |
| 2408 | ;; The moreslots* stuff refers to slots gained as a consequence |
| 2409 | ;; of (:include clauses). -- Oct 89: Only one :include tolerated |
| 2410 | (when (and (numberp moreslotsn) |
| 2411 | (> moreslotsn 0)) |
| 2412 | (setf slotsn (+ slotsn moreslotsn)) |
| 2413 | (setf slots (append moreslots slots)) |
| 2414 | (setf initlist (append moreinits initlist))) |
| 2415 | (unless (> slotsn 0) |
| 2416 | (error "%s needs at least one slot" |
| 2417 | (prin1-to-string name))) |
| 2418 | (let ((dups (duplicate-symbols-p slots))) |
| 2419 | (when dups |
| 2420 | (error "`%s' are duplicates" |
| 2421 | (prin1-to-string dups)))) |
| 2422 | (setq initlist (simplify$inits slots initlist)) |
| 2423 | (let (properties functions keywords accessors alterators returned) |
| 2424 | ;; compute properties of NAME |
| 2425 | (setq properties |
| 2426 | (append |
| 2427 | (list |
| 2428 | (list 'put (list 'quote name) :structure-doc |
| 2429 | docstring) |
| 2430 | (list 'put (list 'quote name) :structure-slotsn |
| 2431 | slotsn) |
| 2432 | (list 'put (list 'quote name) :structure-slots |
| 2433 | (list 'quote slots)) |
| 2434 | (list 'put (list 'quote name) :structure-initforms |
| 2435 | (list 'quote initlist)) |
| 2436 | (list 'put (list 'quote name) :structure-indices |
| 2437 | (list 'quote (extract$indices initlist)))) |
| 2438 | ;; If this definition :includes another defstruct, |
| 2439 | ;; modify both property lists. |
| 2440 | (cond (included |
| 2441 | (list |
| 2442 | (list 'put |
| 2443 | (list 'quote name) |
| 2444 | :structure-includes |
| 2445 | (list 'quote included)) |
| 2446 | (list 'pushnew |
| 2447 | (list 'quote name) |
| 2448 | (list 'get (list 'quote (car included)) |
| 2449 | :structure-included-in)))) |
| 2450 | (t |
| 2451 | (list |
| 2452 | (let ((old (gensym))) |
| 2453 | (list 'let |
| 2454 | (list (list old |
| 2455 | (list 'car |
| 2456 | (list 'get |
| 2457 | (list 'quote name) |
| 2458 | :structure-includes)))) |
| 2459 | (list 'when old |
| 2460 | (list 'put |
| 2461 | old |
| 2462 | :structure-included-in |
| 2463 | (list 'delq |
| 2464 | (list 'quote name) |
| 2465 | ;; careful with destructive |
| 2466 | ;;manipulation! |
| 2467 | (list |
| 2468 | 'append |
| 2469 | (list |
| 2470 | 'get |
| 2471 | old |
| 2472 | :structure-included-in) |
| 2473 | '()) |
| 2474 | ))))) |
| 2475 | (list 'put |
| 2476 | (list 'quote name) |
| 2477 | :structure-includes |
| 2478 | '())))) |
| 2479 | ;; If this definition used to be :included in another, warn |
| 2480 | ;; that things make break. On the other hand, the redefinition |
| 2481 | ;; may be trivial, so don't call it an error. |
| 2482 | (let ((old (gensym))) |
| 2483 | (list |
| 2484 | (list 'let |
| 2485 | (list (list old (list 'get |
| 2486 | (list 'quote name) |
| 2487 | :structure-included-in))) |
| 2488 | (list 'when old |
| 2489 | (list 'message |
| 2490 | "`%s' redefined. Should redefine `%s'?" |
| 2491 | (list 'quote name) |
| 2492 | (list 'prin1-to-string old)))))))) |
| 2493 | |
| 2494 | ;; Compute functions associated with NAME. This is not |
| 2495 | ;; handling BOA constructors yet, but here would be the place. |
| 2496 | (setq functions |
| 2497 | (list |
| 2498 | (list 'fset (list 'quote constructor) |
| 2499 | (list 'function |
| 2500 | (list 'lambda (list '&rest 'args) |
| 2501 | (list 'make$structure$instance |
| 2502 | (list 'quote name) |
| 2503 | 'args)))) |
| 2504 | (list 'fset (list 'quote copier) |
| 2505 | (list 'function 'copy-sequence)) |
| 2506 | (let ((typetag (gensym))) |
| 2507 | (list 'fset (list 'quote predicate) |
| 2508 | (list |
| 2509 | 'function |
| 2510 | (list |
| 2511 | 'lambda (list 'thing) |
| 2512 | (list 'and |
| 2513 | (list 'vectorp 'thing) |
| 2514 | (list 'let |
| 2515 | (list (list typetag |
| 2516 | (list 'elt 'thing 0))) |
| 2517 | (list 'or |
| 2518 | (list |
| 2519 | 'and |
| 2520 | (list 'eq |
| 2521 | typetag |
| 2522 | (list 'quote name)) |
| 2523 | (list '= |
| 2524 | (list 'length 'thing) |
| 2525 | (1+ slotsn))) |
| 2526 | (list |
| 2527 | 'memq |
| 2528 | typetag |
| 2529 | (list 'get |
| 2530 | (list 'quote name) |
| 2531 | :structure-included-in)))))) |
| 2532 | ))))) |
| 2533 | ;; compute accessors for NAME's slots |
| 2534 | (multiple-value-setq |
| 2535 | (accessors alterators keywords) |
| 2536 | (build$accessors$for name conc-name predicate slots slotsn)) |
| 2537 | ;; generate returned value -- not defined by the standard |
| 2538 | (setq returned |
| 2539 | (list |
| 2540 | (cons 'vector |
| 2541 | (mapcar |
| 2542 | (function (lambda (x) (list 'quote x))) |
| 2543 | (cons name slots))))) |
| 2544 | ;; generate code |
| 2545 | (cons 'progn |
| 2546 | (nconc properties functions keywords |
| 2547 | accessors alterators returned)))))) |
| 2548 | \f |
| 2549 | (defun parse$defstruct$args (args) |
| 2550 | "(parse$defstruct$args ARGS) => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST |
| 2551 | NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots, |
| 2552 | SLOTS=list of their names, INITLIST=alist (keyword . initform)." |
| 2553 | (let (name ;args=(symbol...) or ((symbol...)...) |
| 2554 | options ;args=((symbol . options) ...) |
| 2555 | (docstring "") ;args=(head docstring . slotargs) |
| 2556 | slotargs ;second or third cdr of args |
| 2557 | (slotsn 0) ;number of slots |
| 2558 | (slots '()) ;list of slot names |
| 2559 | (initlist '())) ;list of (slot keyword . initform) |
| 2560 | ;; extract name and options |
| 2561 | (cond ((symbolp (car args)) ;simple name |
| 2562 | (setq name (car args) |
| 2563 | options '())) |
| 2564 | ((and (listp (car args)) ;(name . options) |
| 2565 | (symbolp (caar args))) |
| 2566 | (setq name (caar args) |
| 2567 | options (cdar args))) |
| 2568 | (t |
| 2569 | (error "first arg to `defstruct' must be symbol or (symbol ...)"))) |
| 2570 | (setq slotargs (cdr args)) |
| 2571 | ;; is there a docstring? |
| 2572 | (when (stringp (car slotargs)) |
| 2573 | (setq docstring (car slotargs) |
| 2574 | slotargs (cdr slotargs))) |
| 2575 | ;; now for the slots |
| 2576 | (multiple-value-bind |
| 2577 | (slotsn slots initlist) |
| 2578 | (process$slots slotargs) |
| 2579 | (values name options docstring slotsn slots initlist)))) |
| 2580 | \f |
| 2581 | (defun process$slots (slots) |
| 2582 | "(process$slots SLOTS) => SLOTSN SLOTSLIST INITLIST |
| 2583 | Converts a list of symbols or lists of symbol and form into the last 3 |
| 2584 | values returned by PARSE$DEFSTRUCT$ARGS." |
| 2585 | (let ((slotsn (length slots)) ;number of slots |
| 2586 | slotslist ;(slot1 slot2 ...) |
| 2587 | initlist) ;((:slot1 . init1) ...) |
| 2588 | (do* |
| 2589 | ((ptr slots (cdr ptr)) |
| 2590 | (this (car ptr) (car ptr))) |
| 2591 | ((endp ptr)) |
| 2592 | (cond ((symbolp this) |
| 2593 | (setq slotslist (cons this slotslist)) |
| 2594 | (setq initlist (acons (keyword-of this) nil initlist))) |
| 2595 | ((and (listp this) |
| 2596 | (symbolp (car this))) |
| 2597 | (let ((name (car this)) |
| 2598 | (form (cadr this))) |
| 2599 | ;; this silently ignores any slot options. bad... |
| 2600 | (setq slotslist (cons name slotslist)) |
| 2601 | (setq initlist (acons (keyword-of name) form initlist)))) |
| 2602 | (t |
| 2603 | (error "slot should be symbol or (symbol ...), not `%s'" |
| 2604 | (prin1-to-string this))))) |
| 2605 | (values slotsn (nreverse slotslist) (nreverse initlist)))) |
| 2606 | \f |
| 2607 | (defun parse$defstruct$options (name options slots) |
| 2608 | "(parse$defstruct$options name OPTIONS SLOTS) => many values |
| 2609 | A defstruct named NAME, with options list OPTIONS, has already slots SLOTS. |
| 2610 | Parse the OPTIONS and return the updated form of the struct's slots and other |
| 2611 | information. The values returned are: |
| 2612 | |
| 2613 | CONC-NAME is the string to use as prefix/suffix in the methods, |
| 2614 | CONST is the name of the official constructor, |
| 2615 | COPIER is the name of the structure copier, |
| 2616 | PRED is the name of the type predicate, |
| 2617 | MORESLOTSN is the number of slots added by :include, |
| 2618 | MORESLOTS is the list of slots added by :include, |
| 2619 | MOREINITS is the list of initialization forms added by :include, |
| 2620 | INCLUDED is nil, or the list of the symbol added by :include" |
| 2621 | (let* ((namestring (symbol-name name)) |
| 2622 | ;; to build the return values |
| 2623 | (conc-name (concat namestring "-")) |
| 2624 | (const (intern (concat "make-" namestring))) |
| 2625 | (copier (intern (concat "copy-" namestring))) |
| 2626 | (pred (intern (concat namestring "-p"))) |
| 2627 | (moreslotsn 0) |
| 2628 | (moreslots '()) |
| 2629 | (moreinits '()) |
| 2630 | ;; auxiliaries |
| 2631 | option-head ;When an option is not a plain |
| 2632 | option-second ; keyword, it must be a list of |
| 2633 | option-rest ; the form (head second . rest) |
| 2634 | these-slotsn ;When :include is found, the |
| 2635 | these-slots ; info about the included |
| 2636 | these-inits ; structure is added here. |
| 2637 | included ;NIL or (list INCLUDED) |
| 2638 | ) |
| 2639 | ;; Values above are the defaults. Now we read the options themselves |
| 2640 | (dolist (option options) |
| 2641 | ;; 2 cases arise, as options must be a keyword or a list |
| 2642 | (cond |
| 2643 | ((keywordp option) |
| 2644 | (case option |
| 2645 | (:named |
| 2646 | ) ;ignore silently |
| 2647 | (t |
| 2648 | (error "can't recognize option `%s'" |
| 2649 | (prin1-to-string option))))) |
| 2650 | ((and (listp option) |
| 2651 | (keywordp (setq option-head (car option)))) |
| 2652 | (setq option-second (second option)) |
| 2653 | (setq option-rest (nthcdr 2 option)) |
| 2654 | (case option-head |
| 2655 | (:conc-name |
| 2656 | (setq conc-name |
| 2657 | (cond |
| 2658 | ((stringp option-second) |
| 2659 | option-second) |
| 2660 | ((null option-second) |
| 2661 | "") |
| 2662 | (t |
| 2663 | (error "`%s' is invalid as `conc-name'" |
| 2664 | (prin1-to-string option-second)))))) |
| 2665 | (:copier |
| 2666 | (setq copier |
| 2667 | (cond |
| 2668 | ((and (symbolp option-second) |
| 2669 | (null option-rest)) |
| 2670 | option-second) |
| 2671 | (t |
| 2672 | (error "can't recognize option `%s'" |
| 2673 | (prin1-to-string option)))))) |
| 2674 | \f |
| 2675 | (:constructor ;no BOA-constructors allowed |
| 2676 | (setq const |
| 2677 | (cond |
| 2678 | ((and (symbolp option-second) |
| 2679 | (null option-rest)) |
| 2680 | option-second) |
| 2681 | (t |
| 2682 | (error "can't recognize option `%s'" |
| 2683 | (prin1-to-string option)))))) |
| 2684 | (:predicate |
| 2685 | (setq pred |
| 2686 | (cond |
| 2687 | ((and (symbolp option-second) |
| 2688 | (null option-rest)) |
| 2689 | option-second) |
| 2690 | (t |
| 2691 | (error "can't recognize option `%s'" |
| 2692 | (prin1-to-string option)))))) |
| 2693 | (:include |
| 2694 | (unless (symbolp option-second) |
| 2695 | (error "arg to `:include' should be a symbol, not `%s'" |
| 2696 | (prin1-to-string option-second))) |
| 2697 | (setq these-slotsn (get option-second :structure-slotsn) |
| 2698 | these-slots (get option-second :structure-slots) |
| 2699 | these-inits (get option-second :structure-initforms)) |
| 2700 | (unless (and (numberp these-slotsn) |
| 2701 | (> these-slotsn 0)) |
| 2702 | (error "`%s' is not a valid structure" |
| 2703 | (prin1-to-string option-second))) |
| 2704 | (if included |
| 2705 | (error "`%s' already includes `%s', can't include `%s' too" |
| 2706 | name (car included) option-second) |
| 2707 | (push option-second included)) |
| 2708 | (multiple-value-bind |
| 2709 | (xtra-slotsn xtra-slots xtra-inits) |
| 2710 | (process$slots option-rest) |
| 2711 | (when (> xtra-slotsn 0) |
| 2712 | (dolist (xslot xtra-slots) |
| 2713 | (unless (memq xslot these-slots) |
| 2714 | (error "`%s' is not a slot of `%s'" |
| 2715 | (prin1-to-string xslot) |
| 2716 | (prin1-to-string option-second)))) |
| 2717 | (setq these-inits (append xtra-inits these-inits))) |
| 2718 | (setq moreslotsn (+ moreslotsn these-slotsn)) |
| 2719 | (setq moreslots (append these-slots moreslots)) |
| 2720 | (setq moreinits (append these-inits moreinits)))) |
| 2721 | ((:print-function :type :initial-offset) |
| 2722 | ) ;ignore silently |
| 2723 | (t |
| 2724 | (error "can't recognize option `%s'" |
| 2725 | (prin1-to-string option))))) |
| 2726 | (t |
| 2727 | (error "can't recognize option `%s'" |
| 2728 | (prin1-to-string option))))) |
| 2729 | ;; Return values found |
| 2730 | (values conc-name const copier pred |
| 2731 | moreslotsn moreslots moreinits |
| 2732 | included))) |
| 2733 | \f |
| 2734 | (defun simplify$inits (slots initlist) |
| 2735 | "(simplify$inits SLOTS INITLIST) => new INITLIST |
| 2736 | Removes from INITLIST - an ALIST - any shadowed bindings." |
| 2737 | (let ((result '()) ;built here |
| 2738 | key ;from the slot |
| 2739 | ) |
| 2740 | (dolist (slot slots) |
| 2741 | (setq key (keyword-of slot)) |
| 2742 | (setq result (acons key (cdr (assoc key initlist)) result))) |
| 2743 | (nreverse result))) |
| 2744 | |
| 2745 | (defun extract$indices (initlist) |
| 2746 | "(extract$indices INITLIST) => indices list |
| 2747 | Kludge. From a list of pairs (keyword . form) build a list of pairs |
| 2748 | of the form (keyword . position in list from 0). Useful to precompute |
| 2749 | some of the work of MAKE$STRUCTURE$INSTANCE." |
| 2750 | (let ((result '()) |
| 2751 | (index 0)) |
| 2752 | (dolist (entry initlist (nreverse result)) |
| 2753 | (setq result (acons (car entry) index result) |
| 2754 | index (+ index 1))))) |
| 2755 | \f |
| 2756 | (defun build$accessors$for (name conc-name predicate slots slotsn) |
| 2757 | "(build$accessors$for NAME PREDICATE SLOTS SLOTSN) => FSETS DEFSETFS KWDS |
| 2758 | Generate the code for accesors and defsetfs of a structure called |
| 2759 | NAME, whose slots are SLOTS. Also, establishes the keywords for the |
| 2760 | slots names." |
| 2761 | (do ((i 0 (1+ i)) |
| 2762 | (accessors '()) |
| 2763 | (alterators '()) |
| 2764 | (keywords '()) |
| 2765 | (canonic "")) ;slot name with conc-name prepended |
| 2766 | ((>= i slotsn) |
| 2767 | (values |
| 2768 | (nreverse accessors) (nreverse alterators) (nreverse keywords))) |
| 2769 | (setq canonic (intern (concat conc-name (symbol-name (nth i slots))))) |
| 2770 | (setq accessors |
| 2771 | (cons |
| 2772 | (list 'fset (list 'quote canonic) |
| 2773 | (list 'function |
| 2774 | (list 'lambda (list 'object) |
| 2775 | (list 'cond |
| 2776 | (list (list predicate 'object) |
| 2777 | (list 'aref 'object (1+ i))) |
| 2778 | (list 't |
| 2779 | (list 'error |
| 2780 | "`%s' is not a struct %s" |
| 2781 | (list 'prin1-to-string |
| 2782 | 'object) |
| 2783 | (list 'prin1-to-string |
| 2784 | (list 'quote |
| 2785 | name)))))))) |
| 2786 | accessors)) |
| 2787 | (setq alterators |
| 2788 | (cons |
| 2789 | (list 'defsetf canonic |
| 2790 | (list 'lambda (list 'object 'newval) |
| 2791 | (list 'cond |
| 2792 | (list (list predicate 'object) |
| 2793 | (list 'aset 'object (1+ i) 'newval)) |
| 2794 | (list 't |
| 2795 | (list 'error |
| 2796 | "`%s' not a `%s'" |
| 2797 | (list 'prin1-to-string |
| 2798 | 'object) |
| 2799 | (list 'prin1-to-string |
| 2800 | (list 'quote |
| 2801 | name))))))) |
| 2802 | alterators)) |
| 2803 | (setq keywords |
| 2804 | (cons (list 'defkeyword (keyword-of (nth i slots))) |
| 2805 | keywords)))) |
| 2806 | \f |
| 2807 | (defun make$structure$instance (name args) |
| 2808 | "(make$structure$instance NAME ARGS) => new struct NAME |
| 2809 | A struct of type NAME is created, some slots might be initialized |
| 2810 | according to ARGS (the &rest argument of MAKE-name)." |
| 2811 | (unless (symbolp name) |
| 2812 | (error "`%s' is not a possible name for a structure" |
| 2813 | (prin1-to-string name))) |
| 2814 | (let ((initforms (get name :structure-initforms)) |
| 2815 | (slotsn (get name :structure-slotsn)) |
| 2816 | (indices (get name :structure-indices)) |
| 2817 | initalist ;pairlis'd on initforms |
| 2818 | initializers ;definitive initializers |
| 2819 | ) |
| 2820 | ;; check sanity of the request |
| 2821 | (unless (and (numberp slotsn) |
| 2822 | (> slotsn 0)) |
| 2823 | (error "`%s' is not a defined structure" |
| 2824 | (prin1-to-string name))) |
| 2825 | (unless (evenp (length args)) |
| 2826 | (error "slot initializers `%s' not of even length" |
| 2827 | (prin1-to-string args))) |
| 2828 | ;; analyze the initializers provided by the call |
| 2829 | (multiple-value-bind |
| 2830 | (speckwds specvals) ;keywords and values given |
| 2831 | (unzip-list args) ; by the user |
| 2832 | ;; check that all the arguments are introduced by keywords |
| 2833 | (unless (every (function keywordp) speckwds) |
| 2834 | (error "all of the names in `%s' should be keywords" |
| 2835 | (prin1-to-string speckwds))) |
| 2836 | ;; check that all the keywords are known |
| 2837 | (dolist (kwd speckwds) |
| 2838 | (unless (numberp (cdr (assoc kwd indices))) |
| 2839 | (error "`%s' is not a valid slot name for %s" |
| 2840 | (prin1-to-string kwd) (prin1-to-string name)))) |
| 2841 | ;; update initforms |
| 2842 | (setq initalist |
| 2843 | (pairlis speckwds |
| 2844 | (do* ;;protect values from further evaluation |
| 2845 | ((ptr specvals (cdr ptr)) |
| 2846 | (val (car ptr) (car ptr)) |
| 2847 | (result '())) |
| 2848 | ((endp ptr) (nreverse result)) |
| 2849 | (setq result |
| 2850 | (cons (list 'quote val) |
| 2851 | result))) |
| 2852 | (copy-sequence initforms))) |
| 2853 | ;; compute definitive initializers |
| 2854 | (setq initializers |
| 2855 | (do* ;;gather the values of the most definitive forms |
| 2856 | ((ptr indices (cdr ptr)) |
| 2857 | (key (caar ptr) (caar ptr)) |
| 2858 | (result '())) |
| 2859 | ((endp ptr) (nreverse result)) |
| 2860 | (setq result |
| 2861 | (cons (eval (cdr (assoc key initalist))) result)))) |
| 2862 | ;; do real initialization |
| 2863 | (apply (function vector) |
| 2864 | (cons name initializers))))) |
| 2865 | |
| 2866 | ;;;; end of cl-structs.el |
| 2867 | \f |
| 2868 | ;;; For lisp-interaction mode, so that multiple values can be seen when passed |
| 2869 | ;;; back. Lies every now and then... |
| 2870 | |
| 2871 | (defvar - nil "form currently under evaluation") |
| 2872 | (defvar + nil "previous -") |
| 2873 | (defvar ++ nil "previous +") |
| 2874 | (defvar +++ nil "previous ++") |
| 2875 | (defvar / nil "list of values returned by +") |
| 2876 | (defvar // nil "list of values returned by ++") |
| 2877 | (defvar /// nil "list of values returned by +++") |
| 2878 | (defvar * nil "(first) value of +") |
| 2879 | (defvar ** nil "(first) value of ++") |
| 2880 | (defvar *** nil "(first) value of +++") |
| 2881 | |
| 2882 | (defun cl-eval-print-last-sexp () |
| 2883 | "Evaluate sexp before point; print value\(s\) into current buffer. |
| 2884 | If the evaled form returns multiple values, they are shown one to a line. |
| 2885 | The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning. |
| 2886 | |
| 2887 | It clears the multiple-value passing mechanism, and does not pass back |
| 2888 | multiple values. Use this only if you are debugging cl.el and understand well |
| 2889 | how the multiple-value stuff works, because it can be fooled into believing |
| 2890 | that multiple values have been returned when they actually haven't, for |
| 2891 | instance |
| 2892 | \(identity \(values nil 1\)\) |
| 2893 | However, even when this fails, you can trust the first printed value to be |
| 2894 | \(one of\) the returned value\(s\)." |
| 2895 | (interactive) |
| 2896 | ;; top level call, can reset mvalues |
| 2897 | (setq *mvalues-count* nil |
| 2898 | *mvalues-values* nil) |
| 2899 | (setq - (car (read-from-string |
| 2900 | (buffer-substring |
| 2901 | (let ((stab (syntax-table))) |
| 2902 | (unwind-protect |
| 2903 | (save-excursion |
| 2904 | (set-syntax-table emacs-lisp-mode-syntax-table) |
| 2905 | (forward-sexp -1) |
| 2906 | (point)) |
| 2907 | (set-syntax-table stab))) |
| 2908 | (point))))) |
| 2909 | (setq *** ** |
| 2910 | ** * |
| 2911 | * (eval -)) |
| 2912 | (setq /// // |
| 2913 | // / |
| 2914 | / *mvalues-values*) |
| 2915 | (setq +++ ++ |
| 2916 | ++ + |
| 2917 | + -) |
| 2918 | (cond ((or (null *mvalues-count*) ;mvalues mechanism not used |
| 2919 | (not (eq * (car *mvalues-values*)))) |
| 2920 | (print * (current-buffer))) |
| 2921 | ((null /) ;no values returned |
| 2922 | (terpri (current-buffer))) |
| 2923 | (t ;more than zero mvalues |
| 2924 | (terpri (current-buffer)) |
| 2925 | (mapcar (function (lambda (value) |
| 2926 | (prin1 value (current-buffer)) |
| 2927 | (terpri (current-buffer)))) |
| 2928 | /))) |
| 2929 | (setq *mvalues-count* nil ;make sure |
| 2930 | *mvalues-values* nil)) |
| 2931 | \f |
| 2932 | ;;;; More LISTS functions |
| 2933 | ;;;; |
| 2934 | |
| 2935 | ;;; Some mapping functions on lists, commonly useful. |
| 2936 | ;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR. |
| 2937 | |
| 2938 | (defun mapc (function list) |
| 2939 | "(MAPC FUNCTION LIST) => LIST |
| 2940 | Apply FUNCTION to each element of LIST, return LIST. |
| 2941 | Like mapcar, but called only for effect." |
| 2942 | (let ((args list)) |
| 2943 | (while args |
| 2944 | (funcall function (car args)) |
| 2945 | (setq args (cdr args)))) |
| 2946 | list) |
| 2947 | |
| 2948 | (defun maplist (function list) |
| 2949 | "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST |
| 2950 | Apply FUNCTION to successive sublists of LIST, return the list of the results" |
| 2951 | (let ((args list) |
| 2952 | results '()) |
| 2953 | (while args |
| 2954 | (setq results (cons (funcall function args) results) |
| 2955 | args (cdr args))) |
| 2956 | (nreverse results))) |
| 2957 | |
| 2958 | (defun mapl (function list) |
| 2959 | "(MAPL FUNCTION LIST) => LIST |
| 2960 | Apply FUNCTION to successive cdrs of LIST, return LIST. |
| 2961 | Like maplist, but called only for effect." |
| 2962 | (let ((args list)) |
| 2963 | (while args |
| 2964 | (funcall function args) |
| 2965 | (setq args (cdr args))) |
| 2966 | list)) |
| 2967 | |
| 2968 | (defun mapcan (function list) |
| 2969 | "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST |
| 2970 | Apply FUNCTION to each element of LIST, nconc the results. |
| 2971 | Beware: nconc destroys its first argument! See copy-list." |
| 2972 | (let ((args list) |
| 2973 | (results '())) |
| 2974 | (while args |
| 2975 | (setq results (nconc (funcall function (car args)) results) |
| 2976 | args (cdr args))) |
| 2977 | (nreverse results))) |
| 2978 | |
| 2979 | (defun mapcon (function list) |
| 2980 | "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST |
| 2981 | Apply FUNCTION to successive sublists of LIST, nconc the results. |
| 2982 | Beware: nconc destroys its first argument! See copy-list." |
| 2983 | (let ((args list) |
| 2984 | (results '())) |
| 2985 | (while args |
| 2986 | (setq results (nconc (funcall function args) results) |
| 2987 | args (cdr args))) |
| 2988 | (nreverse results))) |
| 2989 | |
| 2990 | ;;; Copiers |
| 2991 | |
| 2992 | (defsubst copy-list (list) |
| 2993 | "Build a copy of LIST" |
| 2994 | (append list '())) |
| 2995 | |
| 2996 | (defun copy-tree (tree) |
| 2997 | "Build a copy of the tree of conses TREE |
| 2998 | The argument is a tree of conses, it is recursively copied down to |
| 2999 | non conses. Circularity and sharing of substructure are not |
| 3000 | necessarily preserved." |
| 3001 | (if (consp tree) |
| 3002 | (cons (copy-tree (car tree)) |
| 3003 | (copy-tree (cdr tree))) |
| 3004 | tree)) |
| 3005 | |
| 3006 | ;;; reversals, and destructive manipulations of a list's spine |
| 3007 | |
| 3008 | (defun revappend (x y) |
| 3009 | "does what (append (reverse X) Y) would, only faster" |
| 3010 | (if (endp x) |
| 3011 | y |
| 3012 | (revappend (cdr x) (cons (car x) y)))) |
| 3013 | |
| 3014 | (defun nreconc (x y) |
| 3015 | "does (nconc (nreverse X) Y) would, only faster |
| 3016 | Destructive on X, be careful." |
| 3017 | (if (endp x) |
| 3018 | y |
| 3019 | ;; reuse the first cons of x, making it point to y |
| 3020 | (nreconc (cdr x) (prog1 x (rplacd x y))))) |
| 3021 | |
| 3022 | (defun nbutlast (list &optional n) |
| 3023 | "Side-effected LIST truncated N+1 conses from the end. |
| 3024 | This is the destructive version of BUTLAST. Returns () and does not |
| 3025 | modify the LIST argument if the length of the list is not at least N." |
| 3026 | (when (null n) (setf n 1)) |
| 3027 | (let ((length (list-length list))) |
| 3028 | (cond ((null length) |
| 3029 | list) |
| 3030 | ((< length n) |
| 3031 | '()) |
| 3032 | (t |
| 3033 | (setnthcdr (- length n) list nil) |
| 3034 | list)))) |
| 3035 | \f |
| 3036 | ;;; Substitutions |
| 3037 | |
| 3038 | (defun subst (new old tree) |
| 3039 | "NEW replaces OLD in a copy of TREE |
| 3040 | Uses eql for the test." |
| 3041 | (subst-if new (function (lambda (x) (eql x old))) tree)) |
| 3042 | |
| 3043 | (defun subst-if-not (new test tree) |
| 3044 | "NEW replaces any subtree or leaf that fails TEST in a copy of TREE" |
| 3045 | ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree) |
| 3046 | (cond ((not (funcall test tree)) |
| 3047 | new) |
| 3048 | ((atom tree) |
| 3049 | tree) |
| 3050 | (t ;no match so far |
| 3051 | (let ((head (subst-if-not new test (car tree))) |
| 3052 | (tail (subst-if-not new test (cdr tree)))) |
| 3053 | ;; If nothing changed, return originals. Else use the new |
| 3054 | ;; components to assemble a new tree. |
| 3055 | (if (and (eql head (car tree)) |
| 3056 | (eql tail (cdr tree))) |
| 3057 | tree |
| 3058 | (cons head tail)))))) |
| 3059 | |
| 3060 | (defun subst-if (new test tree) |
| 3061 | "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE" |
| 3062 | (cond ((funcall test tree) |
| 3063 | new) |
| 3064 | ((atom tree) |
| 3065 | tree) |
| 3066 | (t ;no match so far |
| 3067 | (let ((head (subst-if new test (car tree))) |
| 3068 | (tail (subst-if new test (cdr tree)))) |
| 3069 | ;; If nothing changed, return originals. Else use the new |
| 3070 | ;; components to assemble a new tree. |
| 3071 | (if (and (eql head (car tree)) |
| 3072 | (eql tail (cdr tree))) |
| 3073 | tree |
| 3074 | (cons head tail)))))) |
| 3075 | |
| 3076 | (defun sublis (alist tree) |
| 3077 | "Use association list ALIST to modify a copy of TREE |
| 3078 | If a subtree or leaf of TREE is a key in ALIST, it is replaced by the |
| 3079 | associated value. Not exactly Common Lisp, but close in spirit and |
| 3080 | compatible with the native Emacs Lisp ASSOC, which uses EQUAL." |
| 3081 | (let ((toplevel (assoc tree alist))) |
| 3082 | (cond (toplevel ;Bingo at top |
| 3083 | (cdr toplevel)) |
| 3084 | ((atom tree) ;Give up on this |
| 3085 | tree) |
| 3086 | (t |
| 3087 | (let ((head (sublis alist (car tree))) |
| 3088 | (tail (sublis alist (cdr tree)))) |
| 3089 | (if (and (eql head (car tree)) |
| 3090 | (eql tail (cdr tree))) |
| 3091 | tree |
| 3092 | (cons head tail))))))) |
| 3093 | |
| 3094 | (defun member-if (predicate list) |
| 3095 | "PREDICATE is applied to the members of LIST. As soon as one of them |
| 3096 | returns true, that tail of the list if returned. Else NIL." |
| 3097 | (catch 'found-member-if |
| 3098 | (while (not (endp list)) |
| 3099 | (if (funcall predicate (car list)) |
| 3100 | (throw 'found-member-if list) |
| 3101 | (setq list (cdr list)))) |
| 3102 | nil)) |
| 3103 | |
| 3104 | (defun member-if-not (predicate list) |
| 3105 | "PREDICATE is applied to the members of LIST. As soon as one of them |
| 3106 | returns false, that tail of the list if returned. Else NIL." |
| 3107 | (catch 'found-member-if-not |
| 3108 | (while (not (endp list)) |
| 3109 | (if (funcall predicate (car list)) |
| 3110 | (setq list (cdr list)) |
| 3111 | (throw 'found-member-if-not list))) |
| 3112 | nil)) |
| 3113 | |
| 3114 | (defun tailp (sublist list) |
| 3115 | "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST." |
| 3116 | (catch 'tailp-found |
| 3117 | (while (not (endp list)) |
| 3118 | (if (eq sublist list) |
| 3119 | (throw 'tailp-found t) |
| 3120 | (setq list (cdr list)))) |
| 3121 | nil)) |
| 3122 | \f |
| 3123 | ;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu |
| 3124 | |
| 3125 | (defmacro declare (&rest decls) |
| 3126 | "Ignore a Common-Lisp declaration." |
| 3127 | "declarations are ignored in this implementation") |
| 3128 | |
| 3129 | (defun proclaim (&rest decls) |
| 3130 | "Ignore a Common-Lisp proclamation." |
| 3131 | "declarations are ignored in this implementation") |
| 3132 | |
| 3133 | (defmacro the (type form) |
| 3134 | "(the TYPE FORM) macroexpands to FORM |
| 3135 | No checking is even attempted. This is just for compatibility with |
| 3136 | Common-Lisp codes." |
| 3137 | form) |
| 3138 | \f |
| 3139 | ;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) |
| 3140 | (put 'progv 'common-lisp-indent-hook '(4 4 &body)) |
| 3141 | (defmacro progv (vars vals &rest body) |
| 3142 | "progv vars vals &body forms |
| 3143 | bind vars to vals then execute forms. |
| 3144 | If there are more vars than vals, the extra vars are unbound, if |
| 3145 | there are more vals than vars, the extra vals are just ignored." |
| 3146 | (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body)))))) |
| 3147 | |
| 3148 | ;;; To do this efficiently, it really needs to be a special form... |
| 3149 | (defun progv$runtime (vars vals body) |
| 3150 | (eval (let ((vars-n-vals nil) |
| 3151 | (unbind-forms nil)) |
| 3152 | (do ((r vars (cdr r)) |
| 3153 | (l vals (cdr l))) |
| 3154 | ((endp r)) |
| 3155 | (push (list (car r) (list 'quote (car l))) vars-n-vals) |
| 3156 | (if (null l) |
| 3157 | (push (` (makunbound '(, (car r)))) unbind-forms))) |
| 3158 | (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body))))))) |
| 3159 | |
| 3160 | (provide 'cl) |
| 3161 | |
| 3162 | ;;;; end of cl.el |