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