annotate lisp/=cl.el @ 1117:878afcdce84e

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