![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cl.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to cl.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; Common-Lisp extensions for GNU Emacs Lisp.
2: ;; Copyright (C) 1987, 1988 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is free software; you can redistribute it and/or modify
7: ;; it under the terms of the GNU General Public License as published by
8: ;; the Free Software Foundation; either version 1, or (at your option)
9: ;; any later version.
10:
11: ;; GNU Emacs is distributed in the hope that it will be useful,
12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: ;; GNU General Public License for more details.
15:
16: ;; You should have received a copy of the GNU General Public License
17: ;; along with GNU Emacs; see the file COPYING. If not, write to
18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19:
20: ;;;;
21: ;;;; These are extensions to Emacs Lisp that provide some form of
22: ;;;; Common Lisp compatibility, beyond what is already built-in
23: ;;;; in Emacs Lisp.
24: ;;;;
25: ;;;; When developing them, I had the code spread among several files.
26: ;;;; This file 'cl.el' is a concatenation of those original files,
27: ;;;; minus some declarations that became redundant. The marks between
28: ;;;; the original files can be found easily, as they are lines that
29: ;;;; begin with four semicolons (as this does). The names of the
30: ;;;; original parts follow the four semicolons in uppercase, those
31: ;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS,
32: ;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you
33: ;;;; add functions to this file, you might want to put them in a place
34: ;;;; that is compatible with the division above (or invent your own
35: ;;;; categories).
36: ;;;;
37: ;;;; To compile this file, make sure you load it first. This is
38: ;;;; because many things are implemented as macros and now that all
39: ;;;; the files are concatenated together one cannot ensure that
40: ;;;; declaration always precedes use.
41: ;;;;
42: ;;;; Bug reports, suggestions and comments,
43: ;;;; to [email protected]
44:
45: (provide 'cl)
46:
47:
48: ;;;; GLOBAL
49: ;;;; This file provides utilities and declarations that are global
50: ;;;; to Common Lisp and so might be used by more than one of the
51: ;;;; other libraries. Especially, I intend to keep here some
52: ;;;; utilities that help parsing/destructuring some difficult calls.
53: ;;;;
54: ;;;;
55: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
56: ;;;; ([email protected])
57:
58: (defmacro psetq (&rest pairs)
59: "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE.
60: All the VALUEs are evaluated, and then all the VARIABLEs are set.
61: Aside from order of evaluation, this is the same as `setq'."
62: (let ((nforms (length pairs)) ;count of args
63: ;; next are used to destructure the call
64: symbols ;even numbered args
65: forms ;odd numbered args
66: ;; these are used to generate code
67: bindings ;for the let
68: newsyms ;list of gensyms
69: assignments ;for the setq
70: ;; auxiliary indices
71: i)
72: ;; check there is a reasonable number of forms
73: (if (/= (% nforms 2) 0)
74: (error "Odd number of arguments to `psetq'"))
75:
76: ;; destructure the args
77: (let ((ptr pairs) ;traverses the args
78: var ;visits each symbol position
79: )
80: (while ptr
81: (setq var (car ptr)) ;next variable
82: (if (not (symbolp var))
83: (error "`psetq' expected a symbol, found '%s'."
84: (prin1-to-string var)))
85: (setq symbols (cons var symbols))
86: (setq forms (cons (car (cdr ptr)) forms))
87: (setq ptr (cdr (cdr ptr)))))
88:
89: ;; assign new symbols to the bindings
90: (let ((ptr forms) ;traverses the forms
91: form ;each form goes here
92: newsym ;gensym for current value of form
93: )
94: (while ptr
95: (setq form (car ptr))
96: (setq newsym (gensym))
97: (setq bindings (cons (list newsym form) bindings))
98: (setq newsyms (cons newsym newsyms))
99: (setq ptr (cdr ptr))))
100: (setq newsyms (nreverse newsyms)) ;to sync with symbols
101:
102: ;; pair symbols with newsyms for assignment
103: (let ((ptr1 symbols) ;traverses original names
104: (ptr2 newsyms) ;traverses new symbols
105: )
106: (while ptr1
107: (setq assignments
108: (cons (car ptr1) (cons (car ptr2) assignments)))
109: (setq ptr1 (cdr ptr1))
110: (setq ptr2 (cdr ptr2))))
111:
112: ;; generate code
113: (list 'let
114: bindings
115: (cons 'setq assignments)
116: nil)))
117:
118: ;;; utilities
119: ;;;
120: ;;; pair-with-newsyms takes a list and returns a list of lists of the
121: ;;; form (newsym form), such that a let* can then bind the evaluation
122: ;;; of the forms to the newsyms. The idea is to guarantee correct
123: ;;; order of evaluation of the subforms of a setf. It also returns a
124: ;;; list of the newsyms generated, in the corresponding order.
125:
126: (defun pair-with-newsyms (oldforms)
127: "PAIR-WITH-NEWSYMS OLDFORMS
128: The top-level components of the list oldforms are paired with fresh
129: symbols, the pairings list and the newsyms list are returned."
130: (do ((ptr oldforms (cdr ptr))
131: (bindings '())
132: (newsyms '()))
133: ((endp ptr) (values (nreverse bindings) (nreverse newsyms)))
134: (let ((newsym (gentemp)))
135: (setq bindings (cons (list newsym (car ptr)) bindings))
136: (setq newsyms (cons newsym newsyms)))))
137:
138: (defun zip-lists (evens odds)
139: "Merge two lists EVENS and ODDS, taking elts from each list alternatingly.
140: EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose
141: even numbered elements (0,2,...) come from EVENS and whose odd
142: numbered elements (1,3,...) come from ODDS.
143: The construction stops when the shorter list is exhausted."
144: (do* ((p0 evens (cdr p0))
145: (p1 odds (cdr p1))
146: (even (car p0) (car p0))
147: (odd (car p1) (car p1))
148: (result '()))
149: ((or (endp p0) (endp p1))
150: (nreverse result))
151: (setq result
152: (cons odd (cons even result)))))
153:
154: (defun unzip-list (list)
155: "Extract even and odd elements of LIST into two separate lists.
156: The argument LIST is separated in two strands, the even and the odd
157: numbered elements. Numbering starts with 0, so the first element
158: belongs in EVENS. No check is made that there is an even number of
159: elements to start with."
160: (do* ((ptr list (cddr ptr))
161: (this (car ptr) (car ptr))
162: (next (cadr ptr) (cadr ptr))
163: (evens '())
164: (odds '()))
165: ((endp ptr)
166: (values (nreverse evens) (nreverse odds)))
167: (setq evens (cons this evens))
168: (setq odds (cons next odds))))
169:
170: (defun reassemble-argslists (argslists)
171: "(reassemble-argslists ARGSLISTS).
172: ARGSLISTS is a list of sequences. Return a list of lists, the first
173: sublist being all the entries coming from ELT 0 of the original
174: sublists, the next those coming from ELT 1 and so on, until the
175: shortest list is exhausted."
176: (let* ((minlen (apply 'min (mapcar 'length argslists)))
177: (result '()))
178: (dotimes (i minlen (nreverse result))
179: ;; capture all the elements at index i
180: (setq result
181: (cons (mapcar
182: (function (lambda (sublist) (elt sublist i)))
183: argslists)
184: result)))))
185:
186: ;;; to help parsing keyword arguments
187:
188: (defun build-klist (argslist acceptable)
189: "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
190: ARGSLIST is a list, presumably the &rest argument of a call, whose
191: even numbered elements must be keywords.
192: ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
193: The result is an alist containing the arguments named by the keywords
194: in ACCEPTABLE, or nil if something failed."
195:
196: ;; check legality of the arguments, then destructure them
197: (unless (and (listp argslist)
198: (evenp (length argslist)))
199: (error "Odd number of keyword-args"))
200: (unless (and (listp acceptable)
201: (every 'keywordp acceptable))
202: (error "Second arg should be a list of keywords"))
203: (multiple-value-bind
204: (keywords forms)
205: (unzip-list argslist)
206: (unless (every 'keywordp keywords)
207: (error "Expected keywords, found `%s'"
208: (prin1-to-string keywords)))
209: (do* ;pick up the pieces
210: ((auxlist ;auxiliary a-list, may
211: (pairlis keywords forms)) ;contain repetitions and junk
212: (ptr acceptable (cdr ptr)) ;pointer in acceptable
213: (this (car ptr) (car ptr)) ;current acceptable keyword
214: (auxval nil) ;used to move values around
215: (alist '())) ;used to build the result
216: ((endp ptr) alist)
217: ;; if THIS appears in auxlist, use its value
218: (when (setq auxval (assoc this auxlist))
219: (setq alist (cons auxval alist))))))
220:
221:
222: ;;; Checking that a list of symbols contains no duplicates is a common
223: ;;; task when checking the legality of some macros. The check for 'eq
224: ;;; pairs can be too expensive, as it is quadratic on the length of
225: ;;; the list. I use a 4-pass, linear, counting approach. It surely
226: ;;; loses on small lists (less than 5 elements?), but should win for
227: ;;; larger lists. The fourth pass could be eliminated.
228: ;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the
229: ;;; 4th pass.
230: (defun duplicate-symbols-p (list)
231: "Find all symbols appearing more than once in LIST.
232: Return a list of all such duplicates; `nil' if there are no duplicates."
233: (let ((duplicates '()) ;result built here
234: (propname (gensym)) ;we use a fresh property
235: )
236: ;; check validity
237: (unless (and (listp list)
238: (every 'symbolp list))
239: (error "A list of symbols is needed"))
240: ;; pass 1: mark
241: (dolist (x list)
242: (put x propname 0))
243: ;; pass 2: count
244: (dolist (x list)
245: (put x propname (1+ (get x propname))))
246: ;; pass 3: collect
247: (dolist (x list)
248: (if (> (get x propname) 1)
249: (setq duplicates (cons x duplicates))))
250: ;; pass 4: unmark. eliminated.
251: ;; (dolist (x list) (remprop x propname))
252: ;; return result
253: duplicates))
254:
255: ;;;; end of cl-global.el
256:
257: ;;;; SYMBOLS
258: ;;;; This file provides the gentemp function, which generates fresh
259: ;;;; symbols, plus some other minor Common Lisp symbol tools.
260: ;;;;
261: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
262: ;;;; ([email protected])
263:
264: ;;; Keywords. There are no packages in Emacs Lisp, so this is only a
265: ;;; kludge around to let things be "as if" a keyword package was around.
266:
267: (defmacro defkeyword (x &optional docstring)
268: "Make symbol X a keyword (symbol whose value is itself).
269: Optional second argument is a documentation string for it."
270: (cond
271: ((symbolp x)
272: (list 'defconst x (list 'quote x)))
273: (t
274: (error "`%s' is not a symbol" (prin1-to-string x)))))
275:
276: (defun keywordp (sym)
277: "Return `t' if SYM is a keyword."
278: (cond
279: ((and (symbolp sym)
280: (char-equal (aref (symbol-name sym) 0) ?\:))
281: ;; looks like one, make sure value is right
282: (set sym sym))
283: (t
284: nil)))
285:
286: (defun keyword-of (sym)
287: "Return a keyword that is naturally associated with symbol SYM.
288: If SYM is keyword, the value is SYM.
289: Otherwise it is a keyword whose name is `:' followed by SYM's name."
290: (cond
291: ((keywordp sym)
292: sym)
293: ((symbolp sym)
294: (let ((newsym (intern (concat ":" (symbol-name sym)))))
295: (set newsym newsym)))
296: (t
297: (error "Expected a symbol, not `%s'" (prin1-to-string sym)))))
298:
299: ;;; Temporary symbols.
300: ;;;
301:
302: (defvar *gentemp-index* 0
303: "Integer used by gentemp to produce new names.")
304:
305: (defvar *gentemp-prefix* "T$$_"
306: "Names generated by gentemp begin with this string by default.")
307:
308: (defun gentemp (&optional prefix oblist)
309: "Generate a fresh interned symbol.
310: There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the
311: string that begins the new name, OBLIST is the obarray used to search for
312: old names. The defaults are just right, YOU SHOULD NEVER NEED THESE
313: ARGUMENTS IN YOUR OWN CODE."
314: (if (null prefix)
315: (setq prefix *gentemp-prefix*))
316: (if (null oblist)
317: (setq oblist obarray)) ;default for the intern functions
318: (let ((newsymbol nil)
319: (newname))
320: (while (not newsymbol)
321: (setq newname (concat prefix *gentemp-index*))
322: (setq *gentemp-index* (+ *gentemp-index* 1))
323: (if (not (intern-soft newname oblist))
324: (setq newsymbol (intern newname oblist))))
325: newsymbol))
326:
327: (defvar *gensym-index* 0
328: "Integer used by gensym to produce new names.")
329:
330: (defvar *gensym-prefix* "G$$_"
331: "Names generated by gensym begin with this string by default.")
332:
333: (defun gensym (&optional prefix)
334: "Generate a fresh uninterned symbol.
335: There is an optional argument, PREFIX. PREFIX is the
336: string that begins the new name. Most people take just the default,
337: except when debugging needs suggest otherwise."
338: (if (null prefix)
339: (setq prefix *gensym-prefix*))
340: (let ((newsymbol nil)
341: (newname ""))
342: (while (not newsymbol)
343: (setq newname (concat prefix *gensym-index*))
344: (setq *gensym-index* (+ *gensym-index* 1))
345: (if (not (intern-soft newname))
346: (setq newsymbol (make-symbol newname))))
347: newsymbol))
348:
349: ;;;; end of cl-symbols.el
350:
351: ;;;; CONDITIONALS
352: ;;;; This file provides some of the conditional constructs of
353: ;;;; Common Lisp. Total compatibility is again impossible, as the
354: ;;;; 'if' form is different in both languages, so only a good
355: ;;;; approximation is desired.
356: ;;;;
357: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
358: ;;;; ([email protected])
359:
360: ;;; indentation info
361: (put 'case 'lisp-indent-hook 1)
362: (put 'ecase 'lisp-indent-hook 1)
363: (put 'when 'lisp-indent-hook 1)
364: (put 'unless 'lisp-indent-hook 1)
365:
366: ;;; WHEN and UNLESS
367: ;;; These two forms are simplified ifs, with a single branch.
368:
369: (defmacro when (condition &rest body)
370: "(when CONDITION . BODY) => evaluate BODY if CONDITION is true."
371: (list* 'if (list 'not condition) '() body))
372:
373: (defmacro unless (condition &rest body)
374: "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false."
375: (list* 'if condition '() body))
376:
377: ;;; CASE and ECASE
378: ;;; CASE selects among several clauses, based on the value (evaluated)
379: ;;; of a expression and a list of (unevaluated) key values. ECASE is
380: ;;; the same, but signals an error if no clause is activated.
381:
382: (defmacro case (expr &rest cases)
383: "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value.
384: EXPR -> any form
385: CASES -> list of clauses, non empty
386: CLAUSE -> HEAD . BODY
387: HEAD -> t = catch all, must be last clause
388: -> otherwise = same as t
389: -> nil = illegal
390: -> atom = activated if (eql EXPR HEAD)
391: -> list of atoms = activated if (member EXPR HEAD)
392: BODY -> list of forms, implicit PROGN is built around it.
393: EXPR is evaluated only once."
394: (let* ((newsym (gentemp))
395: (clauses (case-clausify cases newsym)))
396: ;; convert case into a cond inside a let
397: (list 'let
398: (list (list newsym expr))
399: (list* 'cond (nreverse clauses)))))
400:
401: (defmacro ecase (expr &rest cases)
402: "(ecase EXPR . CASES) => like `case', but error if no case fits.
403: `t'-clauses are not allowed."
404: (let* ((newsym (gentemp))
405: (clauses (case-clausify cases newsym)))
406: ;; check that no 't clause is present.
407: ;; case-clausify would put one such at the beginning of clauses
408: (if (eq (caar clauses) t)
409: (error "No clause-head should be `t' or `otherwise' for `ecase'"))
410: ;; insert error-catching clause
411: (setq clauses
412: (cons
413: (list 't (list 'error
414: "ecase on %s = %s failed to take any branch."
415: (list 'quote expr)
416: (list 'prin1-to-string newsym)))
417: clauses))
418: ;; generate code as usual
419: (list 'let
420: (list (list newsym expr))
421: (list* 'cond (nreverse clauses)))))
422:
423:
424: (defun case-clausify (cases newsym)
425: "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond'
426: Converts the CASES of a [e]case macro into cond clauses to be
427: evaluated inside a let that binds NEWSYM. Returns the clauses in
428: reverse order."
429: (do* ((currentpos cases (cdr currentpos))
430: (nextpos (cdr cases) (cdr nextpos))
431: (curclause (car cases) (car currentpos))
432: (result '()))
433: ((endp currentpos) result)
434: (let ((head (car curclause))
435: (body (cdr curclause)))
436: ;; construct a cond-clause according to the head
437: (cond
438: ((null head)
439: (error "Case clauses cannot have null heads: `%s'"
440: (prin1-to-string curclause)))
441: ((or (eq head 't)
442: (eq head 'otherwise))
443: ;; check it is the last clause
444: (if (not (endp nextpos))
445: (error "Clause with `t' or `otherwise' head must be last"))
446: ;; accept this clause as a 't' for cond
447: (setq result (cons (cons 't body) result)))
448: ((atom head)
449: (setq result
450: (cons (cons (list 'eql newsym (list 'quote head)) body)
451: result)))
452: ((listp head)
453: (setq result
454: (cons (cons (list 'member newsym (list 'quote head)) body)
455: result)))
456: (t
457: ;; catch-all for this parser
458: (error "Don't know how to parse case clause `%s'."
459: (prin1-to-string head)))))))
460:
461: ;;;; end of cl-conditionals.el
462:
463: ;;;; ITERATIONS
464: ;;;; This file provides simple iterative macros (a la Common Lisp)
465: ;;;; constructed on the basis of let, let* and while, which are the
466: ;;;; primitive binding/iteration constructs of Emacs Lisp
467: ;;;;
468: ;;;; The Common Lisp iterations use to have a block named nil
469: ;;;; wrapped around them, and allow declarations at the beginning
470: ;;;; of their bodies and you can return a value using (return ...).
471: ;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried
472: ;;;; to imitate these behaviors.
473: ;;;;
474: ;;;; Other than the above, the semantics of Common Lisp are
475: ;;;; correctly reproduced to the extent this was reasonable.
476: ;;;;
477: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
478: ;;;; ([email protected])
479:
480: ;;; some lisp-indentation information
481: (put 'do 'lisp-indent-hook 2)
482: (put 'do* 'lisp-indent-hook 2)
483: (put 'dolist 'lisp-indent-hook 1)
484: (put 'dotimes 'lisp-indent-hook 1)
485: (put 'do-symbols 'lisp-indent-hook 1)
486: (put 'do-all-symbols 'lisp-indent-hook 1)
487:
488:
489: (defmacro do (stepforms endforms &rest body)
490: "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables.
491: STEPFORMS must be a list of symbols or lists. In the second case, the
492: lists must start with a symbol and contain up to two more forms. In
493: the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
494: are the initial value (def. NIL) and the form to step (def. itself).
495: The values used by initialization and stepping are computed in parallel.
496: The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
497: evaluates to true in any iteration, ENDBODY is evaluated and the last
498: form in it is returned.
499: The BODY (which may be empty) is evaluated at every iteration, with
500: the symbols of the STEPFORMS bound to the initial or stepped values."
501: ;; check the syntax of the macro
502: (and (check-do-stepforms stepforms)
503: (check-do-endforms endforms))
504: ;; construct emacs-lisp equivalent
505: (let ((initlist (extract-do-inits stepforms))
506: (steplist (extract-do-steps stepforms))
507: (endcond (car endforms))
508: (endbody (cdr endforms)))
509: (cons 'let (cons initlist
510: (cons (cons 'while (cons (list 'not endcond)
511: (append body steplist)))
512: (append endbody))))))
513:
514:
515: (defmacro do* (stepforms endforms &rest body)
516: "`do*' is to `do' as `let*' is to `let'.
517: STEPFORMS must be a list of symbols or lists. In the second case, the
518: lists must start with a symbol and contain up to two more forms. In
519: the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
520: are the initial value (def. NIL) and the form to step (def. itself).
521: Initializations and steppings are done in the sequence they are written.
522: The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
523: evaluates to true in any iteration, ENDBODY is evaluated and the last
524: form in it is returned.
525: The BODY (which may be empty) is evaluated at every iteration, with
526: the symbols of the STEPFORMS bound to the initial or stepped values."
527: ;; check the syntax of the macro
528: (and (check-do-stepforms stepforms)
529: (check-do-endforms endforms))
530: ;; construct emacs-lisp equivalent
531: (let ((initlist (extract-do-inits stepforms))
532: (steplist (extract-do*-steps stepforms))
533: (endcond (car endforms))
534: (endbody (cdr endforms)))
535: (cons 'let* (cons initlist
536: (cons (cons 'while (cons (list 'not endcond)
537: (append body steplist)))
538: (append endbody))))))
539:
540:
541: ;;; DO and DO* share the syntax checking functions that follow.
542:
543: (defun check-do-stepforms (forms)
544: "True if FORMS is a valid stepforms for the do[*] macro (q.v.)"
545: (cond
546: ((nlistp forms)
547: (error "Init/Step form for do[*] should be a list, not `%s'"
548: (prin1-to-string forms)))
549: (t ;valid list
550: ;; each entry must be a symbol, or a list whose car is a symbol
551: ;; and whose length is no more than three
552: (mapcar
553: (function
554: (lambda (entry)
555: (cond
556: ((or (symbolp entry)
557: (and (listp entry)
558: (symbolp (car entry))
559: (< (length entry) 4)))
560: t)
561: (t
562: (error
563: "Init/Step must be symbol or (symbol [init [step]]), not `%s'"
564: (prin1-to-string entry))))))
565: forms))))
566:
567: (defun check-do-endforms (forms)
568: "True if FORMS is a valid endforms for the do[*] macro (q.v.)"
569: (cond
570: ((listp forms)
571: t)
572: (t
573: (error "Termination form for do macro should be a list, not `%s'"
574: (prin1-to-string forms)))))
575:
576: (defun extract-do-inits (forms)
577: "Returns a list of the initializations (for do) in FORMS
578: -a stepforms, see the do macro-. Forms is assumed syntactically valid."
579: (mapcar
580: (function
581: (lambda (entry)
582: (cond
583: ((symbolp entry)
584: (list entry nil))
585: ((listp entry)
586: (list (car entry) (cadr entry))))))
587: forms))
588:
589: ;;; There used to be a reason to deal with DO differently than with
590: ;;; DO*. The writing of PSETQ has made it largely unnecessary.
591:
592: (defun extract-do-steps (forms)
593: "EXTRACT-DO-STEPS FORMS => an s-expr
594: FORMS is the stepforms part of a DO macro (q.v.). This function
595: constructs an s-expression that does the stepping at the end of an
596: iteration."
597: (list (cons 'psetq (select-stepping-forms forms))))
598:
599: (defun extract-do*-steps (forms)
600: "EXTRACT-DO*-STEPS FORMS => an s-expr
601: FORMS is the stepforms part of a DO* macro (q.v.). This function
602: constructs an s-expression that does the stepping at the end of an
603: iteration."
604: (list (cons 'setq (select-stepping-forms forms))))
605:
606: (defun select-stepping-forms (forms)
607: "Separate only the forms that cause stepping."
608: (let ((result '()) ;ends up being (... var form ...)
609: (ptr forms) ;to traverse the forms
610: entry ;to explore each form in turn
611: )
612: (while ptr ;(not (endp entry)) might be safer
613: (setq entry (car ptr))
614: (cond
615: ((and (listp entry)
616: (= (length entry) 3))
617: (setq result (append ;append in reverse order!
618: (list (caddr entry) (car entry))
619: result))))
620: (setq ptr (cdr ptr))) ;step in the list of forms
621: ;;put things back in the
622: ;;correct order before return
623: (nreverse result)))
624:
625: ;;; Other iterative constructs
626:
627: (defmacro dolist (stepform &rest body)
628: "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
629: The RESULTFORM defaults to nil. The VAR is bound to successive
630: elements of the value of LIST and remains bound (to the nil value) when the
631: RESULTFORM is evaluated."
632: ;; check sanity
633: (cond
634: ((nlistp stepform)
635: (error "Stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
636: (prin1-to-string stepform)))
637: ((not (symbolp (car stepform)))
638: (error "First component of stepform should be a symbol, not `%s'"
639: (prin1-to-string (car stepform))))
640: ((> (length stepform) 3)
641: (error "Too many components in stepform `%s'"
642: (prin1-to-string stepform))))
643: ;; generate code
644: (let* ((var (car stepform))
645: (listform (cadr stepform))
646: (resultform (caddr stepform)))
647: (list 'progn
648: (list 'mapcar
649: (list 'function
650: (cons 'lambda (cons (list var) body)))
651: listform)
652: (list 'let
653: (list (list var nil))
654: resultform))))
655:
656: (defmacro dotimes (stepform &rest body)
657: "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR.
658: The COUNTFORM should return a positive integer. The VAR is bound to
659: successive integers from 0 to COUNTFORM-1 and the BODY is repeated for
660: each of them. At the end, the RESULTFORM is evaluated and its value
661: returned. During this last evaluation, the VAR is still bound, and its
662: value is the number of times the iteration occurred. An omitted RESULTFORM
663: defaults to nil."
664: ;; check sanity
665: (cond
666: ((nlistp stepform)
667: (error "Stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
668: (prin1-to-string stepform)))
669: ((not (symbolp (car stepform)))
670: (error "First component of stepform should be a symbol, not `%s'"
671: (prin1-to-string (car stepform))))
672: ((> (length stepform) 3)
673: (error "Too many components in stepform `%s'"
674: (prin1-to-string stepform))))
675: ;; generate code
676: (let* ((var (car stepform))
677: (countform (cadr stepform))
678: (resultform (caddr stepform))
679: (newsym (gentemp)))
680: (list
681: 'let* (list (list newsym countform))
682: (list*
683: 'do*
684: (list (list var 0 (list '+ var 1)))
685: (list (list '>= var newsym) resultform)
686: body))))
687:
688: (defmacro do-symbols (stepform &rest body)
689: "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
690: The VAR is bound to each of the symbols in OBARRAY (def. obarray) and
691: the BODY is repeatedly performed for each of those bindings. At the
692: end, RESULTFORM (def. nil) is evaluated and its value returned.
693: During this last evaluation, the VAR is still bound and its value is nil.
694: See also the function `mapatoms'."
695: ;; check sanity
696: (cond
697: ((nlistp stepform)
698: (error "Stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
699: (prin1-to-string stepform)))
700: ((not (symbolp (car stepform)))
701: (error "First component of stepform should be a symbol, not `%s'"
702: (prin1-to-string (car stepform))))
703: ((> (length stepform) 3)
704: (error "Too many components in stepform `%s'"
705: (prin1-to-string stepform))))
706: ;; generate code
707: (let* ((var (car stepform))
708: (oblist (cadr stepform))
709: (resultform (caddr stepform)))
710: (list 'progn
711: (list 'mapatoms
712: (list 'function
713: (cons 'lambda (cons (list var) body)))
714: oblist)
715: (list 'let
716: (list (list var nil))
717: resultform))))
718:
719:
720: (defmacro do-all-symbols (stepform &rest body)
721: "(do-all-symbols (VAR [RESULTFORM]) . BODY)
722: Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)."
723: (list*
724: 'do-symbols
725: (list (car stepform) 'obarray (cadr stepform))
726: body))
727:
728: (defmacro loop (&rest body)
729: "(loop . BODY) repeats BODY indefinitely and does not return.
730: Normally BODY uses `throw' or `signal' to cause an exit.
731: The forms in BODY should be lists, as non-lists are reserved for new features."
732: ;; check that the body doesn't have atomic forms
733: (if (nlistp body)
734: (error "Body of `loop' should be a list of lists or nil")
735: ;; ok, it is a list, check for atomic components
736: (mapcar
737: (function (lambda (component)
738: (if (nlistp component)
739: (error "Components of `loop' should be lists"))))
740: body)
741: ;; build the infinite loop
742: (cons 'while (cons 't body))))
743:
744: ;;;; end of cl-iterations.el
745:
746: ;;;; LISTS
747: ;;;; This file provides some of the lists machinery of Common-Lisp
748: ;;;; in a way compatible with Emacs Lisp. Especially, see the the
749: ;;;; typical c[ad]*r functions.
750: ;;;;
751: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
752: ;;;; ([email protected])
753:
754:
755:
756: ;;; Synonyms for list functions
757: (defun first (x)
758: "Synonym for `car'"
759: (car x))
760:
761: (defun second (x)
762: "Return the second element of the list LIST."
763: (nth 1 x))
764:
765: (defun third (x)
766: "Return the third element of the list LIST."
767: (nth 2 x))
768:
769: (defun fourth (x)
770: "Return the fourth element of the list LIST."
771: (nth 3 x))
772:
773: (defun fifth (x)
774: "Return the fifth element of the list LIST."
775: (nth 4 x))
776:
777: (defun sixth (x)
778: "Return the sixth element of the list LIST."
779: (nth 5 x))
780:
781: (defun seventh (x)
782: "Return the seventh element of the list LIST."
783: (nth 6 x))
784:
785: (defun eighth (x)
786: "Return the eighth element of the list LIST."
787: (nth 7 x))
788:
789: (defun ninth (x)
790: "Return the ninth element of the list LIST."
791: (nth 8 x))
792:
793: (defun tenth (x)
794: "Return the tenth element of the list LIST."
795: (nth 9 x))
796:
797: (defun rest (x)
798: "Synonym for `cdr'"
799: (cdr x))
800:
801: (defun endp (x)
802: "t if X is nil, nil if X is a cons; error otherwise."
803: (if (listp x)
804: (null x)
805: (error "endp received a non-cons, non-null argument `%s'"
806: (prin1-to-string x))))
807:
808: (defun last (x)
809: "Returns the last link in the list LIST."
810: (if (nlistp x)
811: (error "Arg to `last' must be a list"))
812: (do ((current-cons x (cdr current-cons))
813: (next-cons (cdr x) (cdr next-cons)))
814: ((endp next-cons) current-cons)))
815:
816: (defun list-length (x) ;taken from CLtL sect. 15.2
817: "Returns the length of a non-circular list, or `nil' for a circular one."
818: (do ((n 0) ;counter
819: (fast x (cddr fast)) ;fast pointer, leaps by 2
820: (slow x (cdr slow)) ;slow pointer, leaps by 1
821: (ready nil)) ;indicates termination
822: (ready n)
823: (cond
824: ((endp fast)
825: (setq ready t)) ;return n
826: ((endp (cdr fast))
827: (setq n (+ n 1))
828: (setq ready t)) ;return n+1
829: ((and (eq fast slow) (> n 0))
830: (setq n nil)
831: (setq ready t)) ;return nil
832: (t
833: (setq n (+ n 2)))))) ;just advance counter
834:
835: (defun member (item list)
836: "Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM."
837: (let ((ptr list)
838: (done nil)
839: (result '()))
840: (while (not (or done (endp ptr)))
841: (cond ((eql item (car ptr))
842: (setq done t)
843: (setq result ptr)))
844: (setq ptr (cdr ptr)))
845: result))
846:
847: (defun butlast (list &optional n)
848: "Return a new list like LIST but sans the last N elements.
849: N defaults to 1. If the list doesn't have N elements, nil is returned."
850: (if (null n) (setq n 1))
851: (reverse (nthcdr n (reverse list))))
852:
853: (defun list* (arg &rest others)
854: "Return a new list containing the first arguments consed onto the last arg.
855: Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
856: (if (null others)
857: arg
858: (let* ((allargs (cons arg others))
859: (front (butlast allargs))
860: (back (last allargs)))
861: (rplacd (last front) (car back))
862: front)))
863:
864: (defun adjoin (item list)
865: "Return a list which contains ITEM but is otherwise like LIST.
866: If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST).
867: When comparing ITEM against elements, `eql' is used."
868: (cond
869: ((member item list)
870: list)
871: (t
872: (cons item list))))
873:
874: (defun ldiff (list sublist)
875: "Return a new list like LIST but sans SUBLIST.
876: SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
877: (do ((result '())
878: (curcons list (cdr curcons)))
879: ((or (endp curcons) (eq curcons sublist))
880: (reverse result))
881: (setq result (cons (car curcons) result))))
882:
883: ;;; The popular c[ad]*r functions.
884:
885: (defun caar (X)
886: "Return the car of the car of X."
887: (car (car X)))
888:
889: (defun cadr (X)
890: "Return the car of the cdr of X."
891: (car (cdr X)))
892:
893: (defun cdar (X)
894: "Return the cdr of the car of X."
895: (cdr (car X)))
896:
897: (defun cddr (X)
898: "Return the cdr of the cdr of X."
899: (cdr (cdr X)))
900:
901: (defun caaar (X)
902: "Return the car of the car of the car of X."
903: (car (car (car X))))
904:
905: (defun caadr (X)
906: "Return the car of the car of the cdr of X."
907: (car (car (cdr X))))
908:
909: (defun cadar (X)
910: "Return the car of the cdr of the car of X."
911: (car (cdr (car X))))
912:
913: (defun cdaar (X)
914: "Return the cdr of the car of the car of X."
915: (cdr (car (car X))))
916:
917: (defun caddr (X)
918: "Return the car of the cdr of the cdr of X."
919: (car (cdr (cdr X))))
920:
921: (defun cdadr (X)
922: "Return the cdr of the car of the cdr of X."
923: (cdr (car (cdr X))))
924:
925: (defun cddar (X)
926: "Return the cdr of the cdr of the car of X."
927: (cdr (cdr (car X))))
928:
929: (defun cdddr (X)
930: "Return the cdr of the cdr of the cdr of X."
931: (cdr (cdr (cdr X))))
932:
933: (defun caaaar (X)
934: "Return the car of the car of the car of the car of X."
935: (car (car (car (car X)))))
936:
937: (defun caaadr (X)
938: "Return the car of the car of the car of the cdr of X."
939: (car (car (car (cdr X)))))
940:
941: (defun caadar (X)
942: "Return the car of the car of the cdr of the car of X."
943: (car (car (cdr (car X)))))
944:
945: (defun cadaar (X)
946: "Return the car of the cdr of the car of the car of X."
947: (car (cdr (car (car X)))))
948:
949: (defun cdaaar (X)
950: "Return the cdr of the car of the car of the car of X."
951: (cdr (car (car (car X)))))
952:
953: (defun caaddr (X)
954: "Return the car of the car of the cdr of the cdr of X."
955: (car (car (cdr (cdr X)))))
956:
957: (defun cadadr (X)
958: "Return the car of the cdr of the car of the cdr of X."
959: (car (cdr (car (cdr X)))))
960:
961: (defun cdaadr (X)
962: "Return the cdr of the car of the car of the cdr of X."
963: (cdr (car (car (cdr X)))))
964:
965: (defun caddar (X)
966: "Return the car of the cdr of the cdr of the car of X."
967: (car (cdr (cdr (car X)))))
968:
969: (defun cdadar (X)
970: "Return the cdr of the car of the cdr of the car of X."
971: (cdr (car (cdr (car X)))))
972:
973: (defun cddaar (X)
974: "Return the cdr of the cdr of the car of the car of X."
975: (cdr (cdr (car (car X)))))
976:
977: (defun cadddr (X)
978: "Return the car of the cdr of the cdr of the cdr of X."
979: (car (cdr (cdr (cdr X)))))
980:
981: (defun cddadr (X)
982: "Return the cdr of the cdr of the car of the cdr of X."
983: (cdr (cdr (car (cdr X)))))
984:
985: (defun cdaddr (X)
986: "Return the cdr of the car of the cdr of the cdr of X."
987: (cdr (car (cdr (cdr X)))))
988:
989: (defun cdddar (X)
990: "Return the cdr of the cdr of the cdr of the car of X."
991: (cdr (cdr (cdr (car X)))))
992:
993: (defun cddddr (X)
994: "Return the cdr of the cdr of the cdr of the cdr of X."
995: (cdr (cdr (cdr (cdr X)))))
996:
997: ;;; some inverses of the accessors are needed for setf purposes
998:
999: (defun setnth (n list newval)
1000: "Set (nth N LIST) to NEWVAL. Returns NEWVAL."
1001: (rplaca (nthcdr n list) newval))
1002:
1003: (defun setnthcdr (n list newval)
1004: "SETNTHCDR N LIST NEWVAL => NEWVAL
1005: As a side effect, sets the Nth cdr of LIST to NEWVAL."
1006: (cond
1007: ((< n 0)
1008: (error "N must be 0 or greater, not %d" n))
1009: ((= n 0)
1010: (rplaca list (car newval))
1011: (rplacd list (cdr newval))
1012: newval)
1013: (t
1014: (rplacd (nthcdr (- n 1) list) newval))))
1015:
1016: ;;; A-lists machinery
1017:
1018: (defun acons (key item alist)
1019: "Return a new alist with KEY paired with ITEM; otherwise like ALIST.
1020: Does not copy ALIST."
1021: (cons (cons key item) alist))
1022:
1023: (defun pairlis (keys data &optional alist)
1024: "Return a new alist with each elt of KEYS paired with an elt of DATA;
1025: optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must
1026: have the same length."
1027: (unless (= (length keys) (length data))
1028: (error "Keys and data should be the same length"))
1029: (do* ;;collect keys and data in front of alist
1030: ((kptr keys (cdr kptr)) ;traverses the keys
1031: (dptr data (cdr dptr)) ;traverses the data
1032: (key (car kptr) (car kptr)) ;current key
1033: (item (car dptr) (car dptr)) ;current data item
1034: (result alist))
1035: ((endp kptr) result)
1036: (setq result (acons key item result))))
1037:
1038: ;;;; end of cl-lists.el
1039:
1040: ;;;; SEQUENCES
1041: ;;;; Emacs Lisp provides many of the 'sequences' functionality of
1042: ;;;; Common Lisp. This file provides a few things that were left out.
1043: ;;;;
1044:
1045:
1046: (defkeyword :test "Used to designate positive (selection) tests.")
1047: (defkeyword :test-not "Used to designate negative (rejection) tests.")
1048: (defkeyword :key "Used to designate component extractions.")
1049: (defkeyword :predicate "Used to define matching of sequence components.")
1050: (defkeyword :start "Inclusive low index in sequence")
1051: (defkeyword :end "Exclusive high index in sequence")
1052: (defkeyword :start1 "Inclusive low index in first of two sequences.")
1053: (defkeyword :start2 "Inclusive low index in second of two sequences.")
1054: (defkeyword :end1 "Exclusive high index in first of two sequences.")
1055: (defkeyword :end2 "Exclusive high index in second of two sequences.")
1056: (defkeyword :count "Number of elements to affect.")
1057: (defkeyword :from-end "T when counting backwards.")
1058:
1059: (defun some (pred seq &rest moreseqs)
1060: "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
1061: Extra args are additional sequences; PREDICATE gets one arg from each
1062: sequence and we advance down all the sequences together in lock-step.
1063: A sequence means either a list or a vector."
1064: (let ((args (reassemble-argslists (list* seq moreseqs))))
1065: (do* ((ready nil) ;flag: return when t
1066: (result nil) ;resulting value
1067: (applyval nil) ;result of applying pred once
1068: (remaining args
1069: (cdr remaining)) ;remaining argument sets
1070: (current (car remaining) ;current argument set
1071: (car remaining)))
1072: ((or ready (endp remaining)) result)
1073: (setq applyval (apply pred current))
1074: (when applyval
1075: (setq ready t)
1076: (setq result applyval)))))
1077:
1078: (defun every (pred seq &rest moreseqs)
1079: "Test PREDICATE on each element of SEQUENCE; is it always non-nil?
1080: Extra args are additional sequences; PREDICATE gets one arg from each
1081: sequence and we advance down all the sequences together in lock-step.
1082: A sequence means either a list or a vector."
1083: (let ((args (reassemble-argslists (list* seq moreseqs))))
1084: (do* ((ready nil) ;flag: return when t
1085: (result t) ;resulting value
1086: (applyval nil) ;result of applying pred once
1087: (remaining args
1088: (cdr remaining)) ;remaining argument sets
1089: (current (car remaining) ;current argument set
1090: (car remaining)))
1091: ((or ready (endp remaining)) result)
1092: (setq applyval (apply pred current))
1093: (unless applyval
1094: (setq ready t)
1095: (setq result nil)))))
1096:
1097: (defun notany (pred seq &rest moreseqs)
1098: "Test PREDICATE on each element of SEQUENCE; is it always nil?
1099: Extra args are additional sequences; PREDICATE gets one arg from each
1100: sequence and we advance down all the sequences together in lock-step.
1101: A sequence means either a list or a vector."
1102: (let ((args (reassemble-argslists (list* seq moreseqs))))
1103: (do* ((ready nil) ;flag: return when t
1104: (result t) ;resulting value
1105: (applyval nil) ;result of applying pred once
1106: (remaining args
1107: (cdr remaining)) ;remaining argument sets
1108: (current (car remaining) ;current argument set
1109: (car remaining)))
1110: ((or ready (endp remaining)) result)
1111: (setq applyval (apply pred current))
1112: (when applyval
1113: (setq ready t)
1114: (setq result nil)))))
1115:
1116: (defun notevery (pred seq &rest moreseqs)
1117: "Test PREDICATE on each element of SEQUENCE; is it sometimes nil?
1118: Extra args are additional sequences; PREDICATE gets one arg from each
1119: sequence and we advance down all the sequences together in lock-step.
1120: A sequence means either a list or a vector."
1121: (let ((args (reassemble-argslists (list* seq moreseqs))))
1122: (do* ((ready nil) ;flag: return when t
1123: (result nil) ;resulting value
1124: (applyval nil) ;result of applying pred once
1125: (remaining args
1126: (cdr remaining)) ;remaining argument sets
1127: (current (car remaining) ;current argument set
1128: (car remaining)))
1129: ((or ready (endp remaining)) result)
1130: (setq applyval (apply pred current))
1131: (unless applyval
1132: (setq ready t)
1133: (setq result t)))))
1134:
1135:
1136:
1137: ;;; an inverse of elt is needed for setf purposes
1138:
1139: (defun setelt (seq n newval)
1140: "In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL.
1141: A sequence means either a list or a vector."
1142: (let ((l (length seq)))
1143: (cond
1144: ((or (< n 0)
1145: (>= n l))
1146: (error "N(%d) should be between 0 and %d" n l))
1147: (t
1148: ;; only two cases need be considered
1149: (cond
1150: ((listp seq)
1151: (setnth n seq newval))
1152: ((arrayp seq)
1153: (aset seq n newval))
1154: (t
1155: (error "SEQ should be a sequence, not `%s'"
1156: (prin1-to-string seq))))))))
1157:
1158: ;;; Testing with keyword arguments.
1159: ;;;
1160: ;;; Many of the sequence functions use keywords to denote some stylized
1161: ;;; form of selecting entries in a sequence. The involved arguments
1162: ;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key
1163: ;;; marker), then they are passed to build-klist, who
1164: ;;; constructs an association list. That association list is used to
1165: ;;; test for satisfaction and matching.
1166:
1167: (defun extract-from-klist (key klist &optional default)
1168: "EXTRACT-FROM-KLIST KEY KLIST [DEFAULT] => value of KEY or DEFAULT
1169: Extract value associated with KEY in KLIST (return DEFAULT if nil)."
1170: (let ((retrieved (cdr (assoc key klist))))
1171: (or retrieved default)))
1172:
1173: (defun add-to-klist (key item klist)
1174: "ADD-TO-KLIST KEY ITEM KLIST => new KLIST
1175: Add association (KEY . ITEM) to KLIST."
1176: (setq klist (acons key item klist)))
1177:
1178: (defun elt-satisfies-test-p (item elt klist)
1179: "ELT-SATISFIES-TEST-P ITEM ELT KLIST => t or nil
1180: KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
1181: True if the given ITEM and ELT satisfy the test."
1182: (let ((test (extract-from-klist :test klist))
1183: (test-not (extract-from-klist :test-not klist))
1184: (keyfn (extract-from-klist :key klist 'identity)))
1185: (cond
1186: (test
1187: (funcall test item (funcall keyfn elt)))
1188: (test-not
1189: (not (funcall test-not item (funcall keyfn elt))))
1190: (t ;should never happen
1191: (error "Neither :test nor :test-not in `%s'"
1192: (prin1-to-string klist))))))
1193:
1194: (defun elt-satisfies-if-p (item klist)
1195: "ELT-SATISFIES-IF-P ITEM KLIST => t or nil
1196: True if an -if style function was called and ITEM satisfies the
1197: predicate under :predicate in KLIST."
1198: (let ((predicate (extract-from-klist :predicate klist))
1199: (keyfn (extract-from-klist :key 'identity)))
1200: (funcall predicate item (funcall keyfn elt))))
1201:
1202: (defun elt-satisfies-if-not-p (item klist)
1203: "ELT-SATISFIES-IF-NOT-P ITEM KLIST => t or nil
1204: KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
1205: True if an -if-not style function was called and ITEM does not satisfy
1206: the predicate under :predicate in KLIST."
1207: (let ((predicate (extract-from-klist :predicate klist))
1208: (keyfn (extract-from-klist :key 'identity)))
1209: (not (funcall predicate item (funcall keyfn elt)))))
1210:
1211: (defun elts-match-under-klist-p (e1 e2 klist)
1212: "ELTS-MATCH-UNDER-KLIST-P E1 E2 KLIST => t or nil
1213: KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
1214: True if elements E1 and E2 match under the tests encoded in KLIST."
1215: (let ((test (extract-from-klist :test klist))
1216: (test-not (extract-from-klist :test-not klist))
1217: (keyfn (extract-from-klist :key klist 'identity)))
1218: (cond
1219: (test
1220: (funcall test (funcall keyfn e1) (funcall keyfn e2)))
1221: (test-not
1222: (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
1223: (t ;should never happen
1224: (error "Neither :test nor :test-not in `%s'"
1225: (prin1-to-string klist))))))
1226:
1227: ;;;; end of cl-sequences.el
1228:
1229: ;;;; MULTIPLE VALUES
1230: ;;;; This package approximates the behavior of the multiple-values
1231: ;;;; forms of Common Lisp.
1232: ;;;;
1233: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
1234: ;;;; ([email protected])
1235:
1236:
1237:
1238: ;;; Lisp indentation information
1239: (put 'multiple-value-bind 'lisp-indent-hook 2)
1240: (put 'multiple-value-setq 'lisp-indent-hook 2)
1241: (put 'multiple-value-list 'lisp-indent-hook nil)
1242: (put 'multiple-value-call 'lisp-indent-hook 1)
1243: (put 'multiple-value-prog1 'lisp-indent-hook 1)
1244:
1245:
1246: ;;; Global state of the package is kept here
1247: (defvar *mvalues-values* nil
1248: "Most recently returned multiple-values")
1249: (defvar *mvalues-count* nil
1250: "Count of multiple-values returned, or nil if the mechanism was not used")
1251:
1252: ;;; values is the standard multiple-value-return form. Must be the
1253: ;;; last thing evaluated inside a function. If the caller is not
1254: ;;; expecting multiple values, only the first one is passed. (values)
1255: ;;; is the same as no-values returned (unaware callers see nil). The
1256: ;;; alternative (values-list <list>) is just a convenient shorthand
1257: ;;; and complements multiple-value-list.
1258:
1259: (defun values (&rest val-forms)
1260: "Produce multiple values (zero or more). Each arg is one value.
1261: See also `multiple-value-bind', which is one way to examine the
1262: multiple values produced by a form. If the containing form or caller
1263: does not check specially to see multiple values, it will see only
1264: the first value."
1265: (setq *mvalues-values* val-forms)
1266: (setq *mvalues-count* (length *mvalues-values*))
1267: (car *mvalues-values*))
1268:
1269:
1270: (defun values-list (&optional val-forms)
1271: "Produce multiple values (zero or mode). Each element of LIST is one value.
1272: This is equivalent to (apply 'values LIST)."
1273: (cond ((nlistp val-forms)
1274: (error "Argument to values-list must be a list, not `%s'"
1275: (prin1-to-string val-forms))))
1276: (setq *mvalues-values* val-forms)
1277: (setq *mvalues-count* (length *mvalues-values*))
1278: (car *mvalues-values*))
1279:
1280:
1281: ;;; Callers that want to see the multiple values use these macros.
1282:
1283: (defmacro multiple-value-list (form)
1284: "Execute FORM and return a list of all the (multiple) values FORM produces.
1285: See `values' and `multiple-value-bind'."
1286: (list 'progn
1287: (list 'setq '*mvalues-count* nil)
1288: (list 'let (list (list 'it '(gensym)))
1289: (list 'set 'it form)
1290: (list 'if '*mvalues-count*
1291: (list 'copy-sequence '*mvalues-values*)
1292: (list 'progn
1293: (list 'setq '*mvalues-count* 1)
1294: (list 'setq '*mvalues-values*
1295: (list 'list (list 'symbol-value 'it)))
1296: (list 'copy-sequence '*mvalues-values*))))))
1297:
1298: (defmacro multiple-value-call (function &rest args)
1299: "Call FUNCTION on all the values produced by the remaining arguments.
1300: (multiple-value-call '+ (values 1 2) (values 3 4)) is 10."
1301: (let* ((result (gentemp))
1302: (arg (gentemp)))
1303: (list 'apply (list 'function (eval function))
1304: (list 'let* (list (list result '()))
1305: (list 'dolist (list arg (list 'quote args) result)
1306: (list 'setq result
1307: (list 'append
1308: result
1309: (list 'multiple-value-list
1310: (list 'eval arg)))))))))
1311:
1312: (defmacro multiple-value-bind (vars form &rest body)
1313: "Bind VARS to the (multiple) values produced by FORM, then do BODY.
1314: VARS is a list of variables; each is bound to one of FORM's values.
1315: If FORM doesn't make enough values, the extra variables are bound to nil.
1316: (Ordinary forms produce only one value; to produce more, use `values'.)
1317: Extra values are ignored.
1318: BODY (zero or more forms) is executed with the variables bound,
1319: then the bindings are unwound."
1320: (let* ((vals (gentemp)) ;name for intermediate values
1321: (clauses (mv-bind-clausify ;convert into clauses usable
1322: vars vals))) ; in a let form
1323: (list* 'let*
1324: (cons (list vals (list 'multiple-value-list form))
1325: clauses)
1326: body)))
1327:
1328: (defmacro multiple-value-setq (vars form)
1329: "Set VARS to the (multiple) values produced by FORM.
1330: VARS is a list of variables; each is set to one of FORM's values.
1331: If FORM doesn't make enough values, the extra variables are set to nil.
1332: (Ordinary forms produce only one value; to produce more, use `values'.)
1333: Extra values are ignored."
1334: (let* ((vals (gentemp)) ;name for intermediate values
1335: (clauses (mv-bind-clausify ;convert into clauses usable
1336: vars vals))) ; in a setq (after append).
1337: (list 'let*
1338: (list (list vals (list 'multiple-value-list form)))
1339: (cons 'setq (apply (function append) clauses)))))
1340:
1341: (defmacro multiple-value-prog1 (form &rest body)
1342: "Evaluate FORM, then BODY, then produce the same values FORM produced.
1343: Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2.
1344: This is like `prog1' except that `prog1' would produce only one value,
1345: which would be the first of FORM's values."
1346: (let* ((heldvalues (gentemp)))
1347: (cons 'let*
1348: (cons (list (list heldvalues (list 'multiple-value-list form)))
1349: (append body (list (list 'values-list heldvalues)))))))
1350:
1351: ;;; utility functions
1352: ;;;
1353: ;;; mv-bind-clausify makes the pairs needed to have the variables in
1354: ;;; the variable list correspond with the values returned by the form.
1355: ;;; vals is a fresh symbol that intervenes in all the bindings.
1356:
1357: (defun mv-bind-clausify (vars vals)
1358: "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list
1359: Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to
1360: the length of VARS (a list of symbols). VALS is just a fresh symbol."
1361: (if (or (nlistp vars)
1362: (notevery 'symbolp vars))
1363: (error "Expected a list of symbols, not `%s'"
1364: (prin1-to-string vars)))
1365: (let* ((nvars (length vars))
1366: (clauses '()))
1367: (dotimes (n nvars clauses)
1368: (setq clauses (cons (list (nth n vars)
1369: (list 'nth n vals)) clauses)))))
1370:
1371: ;;;; end of cl-multiple-values.el
1372:
1373: ;;;; ARITH
1374: ;;;; This file provides integer arithmetic extensions. Although
1375: ;;;; Emacs Lisp doesn't really support anything but integers, that
1376: ;;;; has still to be made to look more or less standard.
1377: ;;;;
1378: ;;;;
1379: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
1380: ;;;; ([email protected])
1381:
1382:
1383: (defun plusp (number)
1384: "True if NUMBER is strictly greater than zero."
1385: (> number 0))
1386:
1387: (defun minusp (number)
1388: "True if NUMBER is strictly less than zero."
1389: (< number 0))
1390:
1391: (defun oddp (number)
1392: "True if INTEGER is not divisible by 2."
1393: (/= (% number 2) 0))
1394:
1395: (defun evenp (number)
1396: "True if INTEGER is divisible by 2."
1397: (= (% number 2) 0))
1398:
1399: (defun abs (number)
1400: "Return the absolute value of NUMBER."
1401: (cond
1402: ((< number 0)
1403: (- 0 number))
1404: (t ;number is >= 0
1405: number)))
1406:
1407: (defun signum (number)
1408: "Return -1, 0 or 1 according to the sign of NUMBER."
1409: (cond
1410: ((< number 0)
1411: -1)
1412: ((> number 0)
1413: 1)
1414: (t ;exactly zero
1415: 0)))
1416:
1417: (defun gcd (&rest integers)
1418: "Return the greatest common divisor of all the arguments.
1419: The arguments must be integers. With no arguments, value is zero."
1420: (let ((howmany (length integers)))
1421: (cond
1422: ((= howmany 0)
1423: 0)
1424: ((= howmany 1)
1425: (abs (car integers)))
1426: ((> howmany 2)
1427: (apply (function gcd)
1428: (cons (gcd (nth 0 integers) (nth 1 integers))
1429: (nthcdr 2 integers))))
1430: (t ;howmany=2
1431: ;; essentially the euclidean algorithm
1432: (when (zerop (* (nth 0 integers) (nth 1 integers)))
1433: (error "A zero argument is invalid for `gcd'"))
1434: (do* ((absa (abs (nth 0 integers))) ; better to operate only
1435: (absb (abs (nth 1 integers))) ;on positives.
1436: (dd (max absa absb)) ; setup correct order for the
1437: (ds (min absa absb)) ;succesive divisions.
1438: ;; intermediate results
1439: (q 0)
1440: (r 0)
1441: ;; final results
1442: (done nil) ; flag: end of iterations
1443: (result 0)) ; final value
1444: (done result)
1445: (setq q (/ dd ds))
1446: (setq r (% dd ds))
1447: (cond
1448: ((zerop r) (setq done t) (setq result ds))
1449: ( t (setq dd ds) (setq ds r))))))))
1450:
1451: (defun lcm (integer &rest more)
1452: "Return the least common multiple of all the arguments.
1453: The arguments must be integers and there must be at least one of them."
1454: (let ((howmany (length more))
1455: (a integer)
1456: (b (nth 0 more))
1457: prod ; intermediate product
1458: (yetmore (nthcdr 1 more)))
1459: (cond
1460: ((zerop howmany)
1461: (abs a))
1462: ((> howmany 1) ; recursive case
1463: (apply (function lcm)
1464: (cons (lcm a b) yetmore)))
1465: (t ; base case, just 2 args
1466: (setq prod (* a b))
1467: (cond
1468: ((zerop prod)
1469: 0)
1470: (t
1471: (/ (abs prod) (gcd a b))))))))
1472:
1473: (defun isqrt (number)
1474: "Return the integer square root of NUMBER.
1475: NUMBER must not be negative. Result is largest integer less than or
1476: equal to the real square root of the argument."
1477: (cond
1478: ((minusp number)
1479: (error "Argument to `isqrt' must not be negative"))
1480: ((zerop number)
1481: 0)
1482: ((<= number 3)
1483: 1)
1484: (t
1485: ;; This is some sort of newtonian iteration, trying not to get in
1486: ;; an infinite loop. That's why I catch 0, 1, 2 and 3 as special
1487: ;; cases, so then rounding won't make this iteration loop.
1488: (do* ((approx (/ number 2) iter)
1489: (done nil)
1490: (iter 0))
1491: (done (if (> (* approx approx) number)
1492: (- approx 1) ;reached from above
1493: approx))
1494: (setq iter
1495: (/ (+ approx
1496: (/ number approx)
1497: (if (>= (% number approx) (/ approx 2))
1498: 1 0))
1499: 2))
1500: (setq done (eql approx iter))))))
1501:
1502: (defun floor (number &optional divisor)
1503: "Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
1504: DIVISOR defaults to 1. The remainder is produced as a second value."
1505: (cond
1506: ((and (null divisor) ; trivial case
1507: (numberp number))
1508: (values number 0))
1509: (t ; do the division
1510: (multiple-value-bind
1511: (q r s)
1512: (safe-idiv number divisor)
1513: (cond
1514: ((zerop s)
1515: (values 0 0))
1516: ((plusp s)
1517: (values q r))
1518: (t
1519: (unless (zerop r)
1520: (setq q (- 0 (+ q 1)))
1521: (setq r (- number (* q divisor))))
1522: (values q r)))))))
1523:
1524: (defun ceiling (number &optional divisor)
1525: "Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
1526: DIVISOR defaults to 1. The remainder is produced as a second value."
1527: (cond
1528: ((and (null divisor) ; trivial case
1529: (numberp number))
1530: (values number 0))
1531: (t ; do the division
1532: (multiple-value-bind
1533: (q r s)
1534: (safe-idiv number divisor)
1535: (cond
1536: ((zerop s)
1537: (values 0 0))
1538: ((minusp s)
1539: (values q r))
1540: (t
1541: (unless (zerop r)
1542: (setq q (+ q 1))
1543: (setq r (- number (* q divisor))))
1544: (values q r)))))))
1545:
1546: (defun truncate (number &optional divisor)
1547: "Divide DIVIDEND by DIVISOR, rounding toward zero.
1548: DIVISOR defaults to 1. The remainder is produced as a second value."
1549: (cond
1550: ((and (null divisor) ; trivial case
1551: (numberp number))
1552: (values number 0))
1553: (t ; do the division
1554: (multiple-value-bind
1555: (q r s)
1556: (safe-idiv number divisor)
1557: (cond
1558: ((zerop s)
1559: (values 0 0))
1560: ((plusp s)
1561: (values q r))
1562: (t
1563: (unless (zerop r)
1564: (setq q (- 0 q))
1565: (setq r (- number (* q divisor))))
1566: (values q r)))))))
1567:
1568: (defun round (number &optional divisor)
1569: "Divide DIVIDEND by DIVISOR, rounding to nearest integer.
1570: DIVISOR defaults to 1. The remainder is produced as a second value."
1571: (cond
1572: ((and (null divisor) ; trivial case
1573: (numberp number))
1574: (values number 0))
1575: (t ; do the division
1576: (multiple-value-bind
1577: (q r s)
1578: (safe-idiv number divisor)
1579: (setq r (abs r))
1580: ;; adjust magnitudes first, and then signs
1581: (let ((other-r (- (abs divisor) r)))
1582: (cond
1583: ((> r other-r)
1584: (setq q (+ q 1)))
1585: ((and (= r other-r)
1586: (oddp q))
1587: ;; round to even is mandatory
1588: (setq q (+ q 1))))
1589: (setq q (* s q))
1590: (setq r (- number (* q divisor)))
1591: (values q r))))))
1592:
1593: (defun mod (number divisor)
1594: "Return remainder of X by Y (rounding quotient toward minus infinity).
1595: That is, the remainder goes with the quotient produced by `floor'."
1596: (multiple-value-bind (q r) (floor number divisor)
1597: r))
1598:
1599: (defun rem (number divisor)
1600: "Return remainder of X by Y (rounding quotient toward zero).
1601: That is, the remainder goes with the quotient produced by `truncate'."
1602: (multiple-value-bind (q r) (truncate number divisor)
1603: r))
1604:
1605: ;;; internal utilities
1606: ;;;
1607: ;;; safe-idiv performs an integer division with positive numbers only.
1608: ;;; It is known that some machines/compilers implement weird remainder
1609: ;;; computations when working with negatives, so the idea here is to
1610: ;;; make sure we know what is coming back to the caller in all cases.
1611:
1612: (defun safe-idiv (a b)
1613: "SAFE-IDIV A B => Q R S
1614: Q=|A|/|B|, R is the rest, S is the sign of A/B."
1615: (unless (and (numberp a) (numberp b))
1616: (error "Arguments to `safe-idiv' must be numbers"))
1617: (when (zerop b)
1618: (error "Cannot divide %d by zero" a))
1619: (let* ((absa (abs a))
1620: (absb (abs b))
1621: (q (/ absa absb))
1622: (s (* (signum a) (signum b)))
1623: (r (- a (* (* s q) b))))
1624: (values q r s)))
1625:
1626: ;;;; end of cl-arith.el
1627:
1628: ;;;; SETF
1629: ;;;; This file provides the setf macro and friends. The purpose has
1630: ;;;; been modest, only the simplest defsetf forms are accepted.
1631: ;;;; Use it and enjoy.
1632: ;;;;
1633: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
1634: ;;;; ([email protected])
1635:
1636:
1637: (defkeyword :setf-update-fn
1638: "Property, its value is the function setf must invoke to update a
1639: generalized variable whose access form is a function call of the
1640: symbol that has this property.")
1641:
1642: (defkeyword :setf-update-doc
1643: "Property of symbols that have a `defsetf' update function on them,
1644: installed by the `defsetf' from its optional third argument.")
1645:
1646: (defmacro setf (&rest pairs)
1647: "Generalized `setq' that can set things other than variable values.
1648: A use of `setf' looks like (setf {PLACE VALUE}...).
1649: The behavior of (setf PLACE VALUE) is to access the generalized variable
1650: at PLACE and store VALUE there. It returns VALUE. If there is more
1651: than one PLACE and VALUE, each PLACE is set from its VALUE before
1652: the next PLACE is evaluated."
1653: (let ((nforms (length pairs)))
1654: ;; check the number of subforms
1655: (cond
1656: ((/= (% nforms 2) 0)
1657: (error "Odd number of arguments to `setf'"))
1658: ((= nforms 0)
1659: nil)
1660: ((> nforms 2)
1661: ;; this is the recursive case
1662: (cons 'progn
1663: (do* ;collect the place-value pairs
1664: ((args pairs (cddr args))
1665: (place (car args) (car args))
1666: (value (cadr args) (cadr args))
1667: (result '()))
1668: ((endp args) (nreverse result))
1669: (setq result
1670: (cons (list 'setf place value)
1671: result)))))
1672: (t ;i.e., nforms=2
1673: ;; this is the base case (SETF PLACE VALUE)
1674: (let* ((place (car pairs))
1675: (value (cadr pairs))
1676: (head nil)
1677: (updatefn nil))
1678: ;; dispatch on the type of the PLACE
1679: (cond
1680: ((symbolp place)
1681: (list 'setq place value))
1682: ((and (listp place)
1683: (setq head (car place))
1684: (symbolp head)
1685: (setq updatefn (get head :setf-update-fn)))
1686: (if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
1687: (and (symbolp updatefn)
1688: (fboundp updatefn)
1689: (let ((defn (symbol-function updatefn)))
1690: (or (subrp defn)
1691: (and (consp defn) (eq (car defn) 'lambda))))))
1692: (cons updatefn (append (cdr place) (list value)))
1693: (multiple-value-bind
1694: (bindings newsyms)
1695: (pair-with-newsyms (append (cdr place) (list value)))
1696: ;; this let* gets new symbols to ensure adequate order of
1697: ;; evaluation of the subforms.
1698: (list 'let
1699: bindings
1700: (cons updatefn newsyms)))))
1701: (t
1702: (error "No `setf' update-function for `%s'"
1703: (prin1-to-string place)))))))))
1704:
1705: (defmacro defsetf (accessfn updatefn &optional docstring)
1706: "Define how `setf' works on a certain kind of generalized variable.
1707: A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]).
1708: ACCESSFN is a symbol. UPDATEFN is a function or macro which takes
1709: one more argument than ACCESSFN does. DEFSETF defines the translation
1710: of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL).
1711: The function UPDATEFN must return its last arg, after performing the
1712: updating called for."
1713: ;; reject ill-formed requests. too bad one can't test for functionp
1714: ;; or macrop.
1715: (when (not (symbolp accessfn))
1716: (error "First argument of `defsetf' must be a symbol, not `%s'"
1717: (prin1-to-string accessfn)))
1718: ;; update properties
1719: (put accessfn :setf-update-fn updatefn)
1720: (put accessfn :setf-update-doc docstring))
1721:
1722: ;;; This section provides the "default" setfs for Common-Emacs-Lisp
1723: ;;; The user will not normally add anything to this, although
1724: ;;; defstruct will introduce new ones as a matter of fact.
1725: ;;;
1726: ;;; Apply is a special case. The Common Lisp
1727: ;;; standard makes the case of apply be useful when the user writes
1728: ;;; something like (apply #'name ...), Emacs Lisp doesn't have the #
1729: ;;; stuff, but it has (function ...). Notice that V18 includes a new
1730: ;;; apply: this file is compatible with V18 and pre-V18 Emacses.
1731:
1732: ;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the
1733: ;;; (correct) left to right sequence *before* checking for apply
1734: ;;; methods (which should really be an special case inside setf). Due
1735: ;;; to this, the lambda expression defsetf'd to apply will succeed in
1736: ;;; applying the right function even if the name was not quoted, but
1737: ;;; computed! That extension is not Common Lisp (nor is particularly
1738: ;;; useful, I think).
1739:
1740: (defsetf apply
1741: (lambda (&rest args)
1742: ;; dissasemble the calling form
1743: ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
1744: (let* ((fnform (car args)) ;functional form
1745: (applyargs (append ;arguments "to apply fnform"
1746: (apply 'list* (butlast (cdr args)))
1747: (last args)))
1748: (newupdater nil)) ; its update-fn, if any
1749: (cond
1750: ((and (symbolp fnform)
1751: (setq newupdater (get fnform :setf-update-fn)))
1752: ;; just do it
1753: (apply newupdater applyargs))
1754: (t
1755: (error "Can't `setf' to `%s'"
1756: (prin1-to-string fnform))))))
1757: "`apply' is a special case for `setf'")
1758:
1759:
1760: (defsetf aref
1761: aset
1762: "`setf' inversion for `aref'")
1763:
1764: (defsetf nth
1765: setnth
1766: "`setf' inversion for `nth'")
1767:
1768: (defsetf nthcdr
1769: setnthcdr
1770: "`setf' inversion for `nthcdr'")
1771:
1772: (defsetf elt
1773: setelt
1774: "`setf' inversion for `elt'")
1775:
1776: (defsetf first
1777: (lambda (list val) (setnth 0 list val))
1778: "`setf' inversion for `first'")
1779:
1780: (defsetf second
1781: (lambda (list val) (setnth 1 list val))
1782: "`setf' inversion for `second'")
1783:
1784: (defsetf third
1785: (lambda (list val) (setnth 2 list val))
1786: "`setf' inversion for `third'")
1787:
1788: (defsetf fourth
1789: (lambda (list val) (setnth 3 list val))
1790: "`setf' inversion for `fourth'")
1791:
1792: (defsetf fifth
1793: (lambda (list val) (setnth 4 list val))
1794: "`setf' inversion for `fifth'")
1795:
1796: (defsetf sixth
1797: (lambda (list val) (setnth 5 list val))
1798: "`setf' inversion for `sixth'")
1799:
1800: (defsetf seventh
1801: (lambda (list val) (setnth 6 list val))
1802: "`setf' inversion for `seventh'")
1803:
1804: (defsetf eighth
1805: (lambda (list val) (setnth 7 list val))
1806: "`setf' inversion for `eighth'")
1807:
1808: (defsetf ninth
1809: (lambda (list val) (setnth 8 list val))
1810: "`setf' inversion for `ninth'")
1811:
1812: (defsetf tenth
1813: (lambda (list val) (setnth 9 list val))
1814: "`setf' inversion for `tenth'")
1815:
1816: (defsetf rest
1817: (lambda (list val) (setcdr list val))
1818: "`setf' inversion for `rest'")
1819:
1820: (defsetf car setcar "Replace the car of a cons")
1821:
1822: (defsetf cdr setcdr "Replace the cdr of a cons")
1823:
1824: (defsetf caar
1825: (lambda (list val) (setcar (nth 0 list) val))
1826: "`setf' inversion for `caar'")
1827:
1828: (defsetf cadr
1829: (lambda (list val) (setcar (cdr list) val))
1830: "`setf' inversion for `cadr'")
1831:
1832: (defsetf cdar
1833: (lambda (list val) (setcdr (car list) val))
1834: "`setf' inversion for `cdar'")
1835:
1836: (defsetf cddr
1837: (lambda (list val) (setcdr (cdr list) val))
1838: "`setf' inversion for `cddr'")
1839:
1840: (defsetf caaar
1841: (lambda (list val) (setcar (caar list) val))
1842: "`setf' inversion for `caaar'")
1843:
1844: (defsetf caadr
1845: (lambda (list val) (setcar (cadr list) val))
1846: "`setf' inversion for `caadr'")
1847:
1848: (defsetf cadar
1849: (lambda (list val) (setcar (cdar list) val))
1850: "`setf' inversion for `cadar'")
1851:
1852: (defsetf cdaar
1853: (lambda (list val) (setcdr (caar list) val))
1854: "`setf' inversion for `cdaar'")
1855:
1856: (defsetf caddr
1857: (lambda (list val) (setcar (cddr list) val))
1858: "`setf' inversion for `caddr'")
1859:
1860: (defsetf cdadr
1861: (lambda (list val) (setcdr (cadr list) val))
1862: "`setf' inversion for `cdadr'")
1863:
1864: (defsetf cddar
1865: (lambda (list val) (setcdr (cdar list) val))
1866: "`setf' inversion for `cddar'")
1867:
1868: (defsetf cdddr
1869: (lambda (list val) (setcdr (cddr list) val))
1870: "`setf' inversion for `cdddr'")
1871:
1872: (defsetf caaaar
1873: (lambda (list val) (setcar (caaar list) val))
1874: "`setf' inversion for `caaaar'")
1875:
1876: (defsetf caaadr
1877: (lambda (list val) (setcar (caadr list) val))
1878: "`setf' inversion for `caaadr'")
1879:
1880: (defsetf caadar
1881: (lambda (list val) (setcar (cadar list) val))
1882: "`setf' inversion for `caadar'")
1883:
1884: (defsetf cadaar
1885: (lambda (list val) (setcar (cdaar list) val))
1886: "`setf' inversion for `cadaar'")
1887:
1888: (defsetf cdaaar
1889: (lambda (list val) (setcdr (caar list) val))
1890: "`setf' inversion for `cdaaar'")
1891:
1892: (defsetf caaddr
1893: (lambda (list val) (setcar (caddr list) val))
1894: "`setf' inversion for `caaddr'")
1895:
1896: (defsetf cadadr
1897: (lambda (list val) (setcar (cdadr list) val))
1898: "`setf' inversion for `cadadr'")
1899:
1900: (defsetf cdaadr
1901: (lambda (list val) (setcdr (caadr list) val))
1902: "`setf' inversion for `cdaadr'")
1903:
1904: (defsetf caddar
1905: (lambda (list val) (setcar (cddar list) val))
1906: "`setf' inversion for `caddar'")
1907:
1908: (defsetf cdadar
1909: (lambda (list val) (setcdr (cadar list) val))
1910: "`setf' inversion for `cdadar'")
1911:
1912: (defsetf cddaar
1913: (lambda (list val) (setcdr (cdaar list) val))
1914: "`setf' inversion for `cddaar'")
1915:
1916: (defsetf cadddr
1917: (lambda (list val) (setcar (cdddr list) val))
1918: "`setf' inversion for `cadddr'")
1919:
1920: (defsetf cddadr
1921: (lambda (list val) (setcdr (cdadr list) val))
1922: "`setf' inversion for `cddadr'")
1923:
1924: (defsetf cdaddr
1925: (lambda (list val) (setcdr (caddr list) val))
1926: "`setf' inversion for `cdaddr'")
1927:
1928: (defsetf cdddar
1929: (lambda (list val) (setcdr (cddar list) val))
1930: "`setf' inversion for `cdddar'")
1931:
1932: (defsetf cddddr
1933: (lambda (list val) (setcdr (cddr list) val))
1934: "`setf' inversion for `cddddr'")
1935:
1936:
1937: (defsetf get
1938: put
1939: "`setf' inversion for `get' is `put'")
1940:
1941: (defsetf symbol-function
1942: fset
1943: "`setf' inversion for `symbol-function' is `fset'")
1944:
1945: (defsetf symbol-plist
1946: setplist
1947: "`setf' inversion for `symbol-plist' is `setplist'")
1948:
1949: (defsetf symbol-value
1950: set
1951: "`setf' inversion for `symbol-value' is `set'")
1952:
1953: ;;; Modify macros
1954: ;;;
1955: ;;; It could be nice to implement define-modify-macro, but I don't
1956: ;;; think it really pays.
1957:
1958: (defmacro incf (ref &optional delta)
1959: "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)"
1960: (if (null delta)
1961: (setq delta 1))
1962: (list 'setf ref (list '+ ref delta)))
1963:
1964: (defmacro decf (ref &optional delta)
1965: "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)"
1966: (if (null delta)
1967: (setq delta 1))
1968: (list 'setf ref (list '- ref delta)))
1969:
1970: (defmacro push (item ref)
1971: "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)"
1972: (list 'setf ref (list 'cons item ref)))
1973:
1974: (defmacro pushnew (item ref)
1975: "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)"
1976: (list 'setf ref (list 'adjoin item ref)))
1977:
1978: (defmacro pop (ref)
1979: "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))"
1980: (let ((listname (gensym)))
1981: (list 'let (list (list listname ref))
1982: (list 'prog1
1983: (list 'car listname)
1984: (list 'setf ref (list 'cdr listname))))))
1985:
1986: ;;; PSETF
1987: ;;;
1988: ;;; Psetf is the generalized variable equivalent of psetq. The right
1989: ;;; hand sides are evaluated and assigned (via setf) to the left hand
1990: ;;; sides. The evaluations are done in an environment where they
1991: ;;; appear to occur in parallel.
1992:
1993: (defmacro psetf (&rest pairs)
1994: "(psetf {PLACE VALUE}...): Set several generalized variables in parallel.
1995: All the VALUEs are computed, and then all the PLACEs are stored as in `setf'.
1996: See also `psetq', `shiftf' and `rotatef'."
1997: (unless (evenp (length pairs))
1998: (error "Odd number of arguments to `psetf'"))
1999: (multiple-value-bind
2000: (places forms)
2001: (unzip-list pairs)
2002: ;; obtain fresh symbols to simulate the parallelism
2003: (multiple-value-bind
2004: (bindings newsyms)
2005: (pair-with-newsyms forms)
2006: (list 'let
2007: bindings
2008: (cons 'setf (zip-lists places newsyms))
2009: nil))))
2010:
2011: ;;; SHIFTF and ROTATEF
2012: ;;;
2013:
2014: (defmacro shiftf (&rest forms)
2015: "(shiftf PLACE1 PLACE2... NEWVALUE): set PLACE1 to PLACE2, PLACE2 to PLACE3...
2016: Each PLACE is set to the old value of the following PLACE,
2017: and the last PLACE is set to the value NEWVALUE."
2018: (unless (> (length forms) 1)
2019: (error "`shiftf' needs more than one argument"))
2020: (let ((places (butlast forms))
2021: (newvalue (car (last forms))))
2022: ;; the places are accessed to fresh symbols
2023: (multiple-value-bind
2024: (bindings newsyms)
2025: (pair-with-newsyms places)
2026: (list 'let bindings
2027: (cons 'setf
2028: (zip-lists places
2029: (append (cdr newsyms) (list newvalue))))
2030: (car newsyms)))))
2031:
2032: (defmacro rotatef (&rest places)
2033: "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE.
2034: The last PLACE is set to the old value of the first PLACE.
2035: Thus, the values rotate through the PLACEs."
2036: (cond
2037: ((null places)
2038: nil)
2039: (t
2040: (multiple-value-bind
2041: (bindings newsyms)
2042: (pair-with-newsyms places)
2043: (list
2044: 'let bindings
2045: (cons 'setf
2046: (zip-lists places
2047: (append (cdr newsyms) (list (car newsyms)))))
2048: nil)))))
2049:
2050: ;;;; STRUCTS
2051: ;;;; This file provides the structures mechanism. See the
2052: ;;;; documentation for Common-Lisp's defstruct. Mine doesn't
2053: ;;;; implement all the functionality of the standard, although some
2054: ;;;; more could be grafted if so desired. More details along with
2055: ;;;; the code.
2056: ;;;;
2057: ;;;;
2058: ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
2059: ;;;; ([email protected])
2060:
2061:
2062: (defkeyword :include "Syntax of `defstruct'")
2063: (defkeyword :named "Syntax of `defstruct'")
2064: (defkeyword :conc-name "Syntax of `defstruct'")
2065: (defkeyword :copier "Syntax of `defstruct'")
2066: (defkeyword :predicate "Syntax of `defstruct'")
2067: (defkeyword :print-function "Syntax of `defstruct'")
2068: (defkeyword :type "Syntax of `defstruct'")
2069: (defkeyword :initial-offset "Syntax of `defstruct'")
2070:
2071: (defkeyword :structure-doc "Documentation string for a structure.")
2072: (defkeyword :structure-slotsn "Number of slots in structure")
2073: (defkeyword :structure-slots "List of the slot's names")
2074: (defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)")
2075: (defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)")
2076:
2077:
2078: (defmacro defstruct (&rest args)
2079: "(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type.
2080: NAME must be a symbol, the name of the new structure. It could also
2081: be a list (NAME . OPTIONS), but not all options are supported currently.
2082: As of Dec. 1986, this is supporting :conc-name, :copier and :predicate
2083: completely, :include arguably completely and :constructor only to
2084: change the name of the default constructor. No BOA constructors allowed.
2085: The DOC-STRING is established as the 'structure-doc' property of NAME.
2086: The SLOTS are one or more of the following:
2087: SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME
2088: list of SYMBOL and VALUE -- meaning that VALUE is the initial value of
2089: the slot.
2090: `defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the
2091: structure, and functions with the same name as the slots to access
2092: them. `setf' of the accessors sets their values."
2093: (multiple-value-bind
2094: (name options docstring slotsn slots initlist)
2095: (parse$defstruct$args args)
2096: ;; Names for the member functions come from the options. The
2097: ;; slots* stuff collects info about the slots declared explicitly.
2098: (multiple-value-bind
2099: (conc-name constructor copier predicate moreslotsn moreslots moreinits)
2100: (parse$defstruct$options name options slots)
2101: ;; The moreslots* stuff refers to slots gained as a consequence
2102: ;; of (:include clauses).
2103: (when (and (numberp moreslotsn)
2104: (> moreslotsn 0))
2105: (setf slotsn (+ slotsn moreslotsn))
2106: (setf slots (append moreslots slots))
2107: (setf initlist (append moreinits initlist)))
2108: (unless (> slotsn 0)
2109: (error "%s needs at least one slot"
2110: (prin1-to-string name)))
2111: (let ((dups (duplicate-symbols-p slots)))
2112: (when dups
2113: (error "`%s' are duplicates"
2114: (prin1-to-string dups))))
2115: (setq initlist (simplify$inits slots initlist))
2116: (let (properties functions keywords accessors alterators returned)
2117: ;; compute properties of NAME
2118: (setq properties
2119: (list
2120: (list 'put (list 'quote name) :structure-doc
2121: docstring)
2122: (list 'put (list 'quote name) :structure-slotsn
2123: slotsn)
2124: (list 'put (list 'quote name) :structure-slots
2125: (list 'quote slots))
2126: (list 'put (list 'quote name) :structure-initforms
2127: (list 'quote initlist))
2128: (list 'put (list 'quote name) :structure-indices
2129: (list 'quote (extract$indices initlist)))))
2130:
2131: ;; Compute functions associated with NAME. This is not
2132: ;; handling BOA constructors yet, but here would be the place.
2133: (setq functions
2134: (list
2135: (list 'fset (list 'quote constructor)
2136: (list 'function
2137: (list 'lambda (list '&rest 'args)
2138: (list 'make$structure$instance
2139: (list 'quote name)
2140: 'args))))
2141: (list 'fset (list 'quote copier)
2142: (list 'function
2143: (list 'lambda (list 'struct)
2144: (list 'copy-vector 'struct))))
2145: (list 'fset (list 'quote predicate)
2146: (list 'function
2147: (list 'lambda (list 'thing)
2148: (list 'and
2149: (list 'vectorp 'thing)
2150: (list 'eq
2151: (list 'elt 'thing 0)
2152: (list 'quote name))
2153: (list '=
2154: (list 'length 'thing)
2155: (1+ slotsn))))))))
2156: ;; compute accessors for NAME's slots
2157: (multiple-value-setq
2158: (accessors alterators keywords)
2159: (build$accessors$for name conc-name predicate slots slotsn))
2160: ;; generate returned value -- not defined by the standard
2161: (setq returned
2162: (list
2163: (cons 'vector
2164: (mapcar
2165: '(lambda (x) (list 'quote x))
2166: (cons name slots)))))
2167: ;; generate code
2168: (cons 'progn
2169: (nconc properties functions keywords
2170: accessors alterators returned))))))
2171:
2172: (defun parse$defstruct$args (args)
2173: "PARSE$DEFSTRUCT$ARGS ARGS => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST
2174: NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots,
2175: SLOTS=list of their names, INITLIST=alist (keyword . initform)."
2176: (let (name ;args=(symbol...) or ((symbol...)...)
2177: options ;args=((symbol . options) ...)
2178: (docstring "") ;args=(head docstring . slotargs)
2179: slotargs ;second or third cdr of args
2180: (slotsn 0) ;number of slots
2181: (slots '()) ;list of slot names
2182: (initlist '())) ;list of (slot keyword . initform)
2183: ;; extract name and options
2184: (cond
2185: ((symbolp (car args)) ;simple name
2186: (setq name (car args)
2187: options '()))
2188: ((and (listp (car args)) ;(name . options)
2189: (symbolp (caar args)))
2190: (setq name (caar args)
2191: options (cdar args)))
2192: (t
2193: (error "First arg to `defstruct' must be symbol or (symbol ...)")))
2194: (setq slotargs (cdr args))
2195: ;; is there a docstring?
2196: (when (stringp (car slotargs))
2197: (setq docstring (car slotargs)
2198: slotargs (cdr slotargs)))
2199: ;; now for the slots
2200: (multiple-value-bind
2201: (slotsn slots initlist)
2202: (process$slots slotargs)
2203: (values name options docstring slotsn slots initlist))))
2204:
2205: (defun process$slots (slots)
2206: "PROCESS$SLOTS SLOTS => SLOTSN SLOTSLIST INITLIST
2207: Converts a list of symbols or lists of symbol and form into the last 3
2208: values returned by PARSE$DEFSTRUCT$ARGS."
2209: (let ((slotsn (length slots)) ;number of slots
2210: slotslist ;(slot1 slot2 ...)
2211: initlist) ;((:slot1 . init1) ...)
2212: (do*
2213: ((ptr slots (cdr ptr))
2214: (this (car ptr) (car ptr)))
2215: ((endp ptr))
2216: (cond
2217: ((symbolp this)
2218: (setq slotslist (cons this slotslist))
2219: (setq initlist (acons (keyword-of this) nil initlist)))
2220: ((and (listp this)
2221: (symbolp (car this)))
2222: (let ((name (car this))
2223: (form (cadr this)))
2224: ;; this silently ignores any slot options. bad...
2225: (setq slotslist (cons name slotslist))
2226: (setq initlist (acons (keyword-of name) form initlist))))
2227: (t
2228: (error "Slot should be symbol or (symbol ...), not `%s'"
2229: (prin1-to-string this)))))
2230: (values slotsn (nreverse slotslist) (nreverse initlist))))
2231:
2232: (defun parse$defstruct$options (name options slots)
2233: "PARSE$DEFSTRUCT$OPTIONS NAME OPTIONS SLOTS => CONC-NAME CONST COPIER PRED
2234: Returns at least those 4 values (a string and 3 symbols, to name the necessary
2235: functions), might return also things discovered by actually
2236: inspecting the options, namely MORESLOTSN MORESLOTS MOREINITS, as can
2237: be created by :include, and perhaps a list of BOACONSTRUCTORS."
2238: (let* ((namestring (symbol-name name))
2239: ;; to build the return values
2240: (conc-name (concat namestring "-"))
2241: (const (intern (concat "make-" namestring)))
2242: (copier (intern (concat "copy-" namestring)))
2243: (pred (intern (concat namestring "-p")))
2244: (moreslotsn 0)
2245: (moreslots '())
2246: (moreinits '())
2247: ;; auxiliaries
2248: option-head ;When an option is not a plain
2249: option-second ; keyword, it must be a list of
2250: option-rest ; the form (head second . rest)
2251: these-slotsn ;When :include is found, the
2252: these-slots ; info about the included
2253: these-inits ; structure is added here.
2254: )
2255: ;; Values above are the defaults. Now we read the options themselves
2256: (dolist (option options)
2257: ;; 2 cases arise, as options must be a keyword or a list
2258: (cond
2259: ((keywordp option)
2260: (case option
2261: (:named
2262: ) ;ignore silently
2263: (t
2264: (error "Can't recognize option `%s'"
2265: (prin1-to-string option)))))
2266: ((and (listp option)
2267: (keywordp (setq option-head (car option))))
2268: (setq option-second (second option))
2269: (setq option-rest (nthcdr 2 option))
2270: (case option-head
2271: (:conc-name
2272: (setq conc-name
2273: (cond
2274: ((stringp option-second)
2275: option-second)
2276: ((null option-second)
2277: "")
2278: (t
2279: (error "`%s' is invalid as `conc-name'"
2280: (prin1-to-string option-second))))))
2281: (:copier
2282: (setq copier
2283: (cond
2284: ((and (symbolp option-second)
2285: (null option-rest))
2286: option-second)
2287: (t
2288: (error "Can't recognize option `%s'"
2289: (prin1-to-string option))))))
2290:
2291: (:constructor ;no BOA-constructors allowed
2292: (setq const
2293: (cond
2294: ((and (symbolp option-second)
2295: (null option-rest))
2296: option-second)
2297: (t
2298: (error "Can't recognize option `%s'"
2299: (prin1-to-string option))))))
2300: (:predicate
2301: (setq pred
2302: (cond
2303: ((and (symbolp option-second)
2304: (null option-rest))
2305: option-second)
2306: (t
2307: (error "Can't recognize option `%s'"
2308: (prin1-to-string option))))))
2309: (:include
2310: (unless (symbolp option-second)
2311: (error "Arg to `:include' should be a symbol, not `%s'"
2312: (prin1-to-string option-second)))
2313: (setq these-slotsn (get option-second :structure-slotsn)
2314: these-slots (get option-second :structure-slots)
2315: these-inits (get option-second :structure-initforms))
2316: (unless (and (numberp these-slotsn)
2317: (> these-slotsn 0))
2318: (error "`%s' is not a valid structure"
2319: (prin1-to-string option-second)))
2320: (multiple-value-bind
2321: (xtra-slotsn xtra-slots xtra-inits)
2322: (process$slots option-rest)
2323: (when (> xtra-slotsn 0)
2324: (dolist (xslot xtra-slots)
2325: (unless (memq xslot these-slots)
2326: (error "`%s' is not a slot of `%s'"
2327: (prin1-to-string xslot)
2328: (prin1-to-string option-second))))
2329: (setq these-inits (append xtra-inits these-inits)))
2330: (setq moreslotsn (+ moreslotsn these-slotsn))
2331: (setq moreslots (append these-slots moreslots))
2332: (setq moreinits (append these-inits moreinits))))
2333: ((:print-function :type :initial-offset)
2334: ) ;ignore silently
2335: (t
2336: (error "Can't recognize option `%s'"
2337: (prin1-to-string option)))))
2338: (t
2339: (error "Can't recognize option `%s'"
2340: (prin1-to-string option)))))
2341: ;; Return values found
2342: (values conc-name const copier pred
2343: moreslotsn moreslots moreinits)))
2344:
2345: (defun simplify$inits (slots initlist)
2346: "SIMPLIFY$INITS SLOTS INITLIST => new INITLIST
2347: Removes from INITLIST - an ALIST - any shadowed bindings."
2348: (let ((result '()) ;built here
2349: key ;from the slot
2350: )
2351: (dolist (slot slots)
2352: (setq key (keyword-of slot))
2353: (setq result (acons key (cdr (assoc key initlist)) result)))
2354: (nreverse result)))
2355:
2356: (defun extract$indices (initlist)
2357: "EXTRACT$INDICES INITLIST => indices list
2358: Kludge. From a list of pairs (keyword . form) build a list of pairs
2359: of the form (keyword . position in list from 0). Useful to precompute
2360: some of the work of MAKE$STRUCTURE$INSTANCE."
2361: (let ((result '())
2362: (index 0))
2363: (dolist (entry initlist (nreverse result))
2364: (setq result (acons (car entry) index result)
2365: index (+ index 1)))))
2366:
2367: (defun build$accessors$for (name conc-name predicate slots slotsn)
2368: "BUILD$ACCESSORS$FOR NAME PREDICATE SLOTS SLOTSN => FSETS DEFSETFS KWDS
2369: Generate the code for accesors and defsetfs of a structure called
2370: NAME, whose slots are SLOTS. Also, establishes the keywords for the
2371: slots names."
2372: (do ((i 0 (1+ i))
2373: (accessors '())
2374: (alterators '())
2375: (keywords '())
2376: (canonic "")) ;slot name with conc-name prepended
2377: ((>= i slotsn)
2378: (values
2379: (nreverse accessors) (nreverse alterators) (nreverse keywords)))
2380: (setq canonic (intern (concat conc-name (symbol-name (nth i slots)))))
2381: (setq accessors
2382: (cons
2383: (list 'fset (list 'quote canonic)
2384: (list 'function
2385: (list 'lambda (list 'object)
2386: (list 'cond
2387: (list (list predicate 'object)
2388: (list 'aref 'object (1+ i)))
2389: (list 't
2390: (list 'error
2391: "`%s' not a %s."
2392: (list 'prin1-to-string
2393: 'object)
2394: (list 'prin1-to-string
2395: (list 'quote
2396: name))))))))
2397: accessors))
2398: (setq alterators
2399: (cons
2400: (list 'defsetf canonic
2401: (list 'lambda (list 'object 'newval)
2402: (list 'cond
2403: (list (list predicate 'object)
2404: (list 'aset 'object (1+ i) 'newval))
2405: (list 't
2406: (list 'error
2407: "`%s' not a `%s'"
2408: (list 'prin1-to-string
2409: 'object)
2410: (list 'prin1-to-string
2411: (list 'quote
2412: name)))))))
2413: alterators))
2414: (setq keywords
2415: (cons (list 'defkeyword (keyword-of (nth i slots)))
2416: keywords))))
2417:
2418: (defun make$structure$instance (name args)
2419: "MAKE$STRUCTURE$INSTANCE NAME ARGS => new struct NAME
2420: A struct of type NAME is created, some slots might be initialized
2421: according to ARGS (the &rest argument of MAKE-name)."
2422: (unless (symbolp name)
2423: (error "`%s' is not a possible name for a structure"
2424: (prin1-to-string name)))
2425: (let ((initforms (get name :structure-initforms))
2426: (slotsn (get name :structure-slotsn))
2427: (indices (get name :structure-indices))
2428: initalist ;pairlis'd on initforms
2429: initializers ;definitive initializers
2430: )
2431: ;; check sanity of the request
2432: (unless (and (numberp slotsn)
2433: (> slotsn 0))
2434: (error "`%s' is not a defined structure"
2435: (prin1-to-string name)))
2436: (unless (evenp (length args))
2437: (error "Slot initializers `%s' not of even length"
2438: (prin1-to-string args)))
2439: ;; analyze the initializers provided by the call
2440: (multiple-value-bind
2441: (speckwds specvals) ;keywords and values given
2442: (unzip-list args) ; by the user
2443: ;; check that all the arguments are introduced by keywords
2444: (unless (every (function keywordp) speckwds)
2445: (error "All of the names in `%s' should be keywords"
2446: (prin1-to-string speckwds)))
2447: ;; check that all the keywords are known
2448: (dolist (kwd speckwds)
2449: (unless (numberp (cdr (assoc kwd indices)))
2450: (error "`%s' is not a valid slot name for %s"
2451: (prin1-to-string kwd) (prin1-to-string name))))
2452: ;; update initforms
2453: (setq initalist
2454: (pairlis speckwds
2455: (do* ;;protect values from further evaluation
2456: ((ptr specvals (cdr ptr))
2457: (val (car ptr) (car ptr))
2458: (result '()))
2459: ((endp ptr) (nreverse result))
2460: (setq result
2461: (cons (list 'quote val)
2462: result)))
2463: (copy-sequence initforms)))
2464: ;; compute definitive initializers
2465: (setq initializers
2466: (do* ;;gather the values of the most definitive forms
2467: ((ptr indices (cdr ptr))
2468: (key (caar ptr) (caar ptr))
2469: (result '()))
2470: ((endp ptr) (nreverse result))
2471: (setq result
2472: (cons (eval (cdr (assoc key initalist))) result))))
2473: ;; do real initialization
2474: (apply (function vector)
2475: (cons name initializers)))))
2476:
2477: ;;;; end of cl-structs.el
2478:
2479: ;;;; end of cl.el
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.