1 | ;;;; |
---|
2 | ;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr@freebits.de> |
---|
3 | ;;;; |
---|
4 | ;;;; All rights reserved. |
---|
5 | ;;;; |
---|
6 | ;;;; See LICENSE for details. |
---|
7 | ;;;; |
---|
8 | |
---|
9 | (in-package :editor-hints.named-readtables) |
---|
10 | |
---|
11 | (defmacro without-package-lock ((&rest package-names) &body body) |
---|
12 | (declare (ignorable package-names)) |
---|
13 | #+clisp |
---|
14 | (return-from without-package-lock |
---|
15 | `(ext:without-package-lock (,@package-names) ,@body)) |
---|
16 | #+lispworks |
---|
17 | (return-from without-package-lock |
---|
18 | `(let ((hcl:*packages-for-warn-on-redefinition* |
---|
19 | (set-difference hcl:*packages-for-warn-on-redefinition* |
---|
20 | '(,@package-names) |
---|
21 | :key (lambda (package-designator) |
---|
22 | (if (packagep package-designator) |
---|
23 | (package-name package-designator) |
---|
24 | package-designator)) |
---|
25 | :test #'string=))) |
---|
26 | ,@body)) |
---|
27 | `(progn ,@body)) |
---|
28 | |
---|
29 | ;;; Taken from SWANK (which is Public Domain.) |
---|
30 | |
---|
31 | (defmacro destructure-case (value &body patterns) |
---|
32 | "Dispatch VALUE to one of PATTERNS. |
---|
33 | A cross between `case' and `destructuring-bind'. |
---|
34 | The pattern syntax is: |
---|
35 | ((HEAD . ARGS) . BODY) |
---|
36 | The list of patterns is searched for a HEAD `eq' to the car of |
---|
37 | VALUE. If one is found, the BODY is executed with ARGS bound to the |
---|
38 | corresponding values in the CDR of VALUE." |
---|
39 | (let ((operator (gensym "op-")) |
---|
40 | (operands (gensym "rand-")) |
---|
41 | (tmp (gensym "tmp-"))) |
---|
42 | `(let* ((,tmp ,value) |
---|
43 | (,operator (car ,tmp)) |
---|
44 | (,operands (cdr ,tmp))) |
---|
45 | (case ,operator |
---|
46 | ,@(loop for (pattern . body) in patterns collect |
---|
47 | (if (eq pattern t) |
---|
48 | `(t ,@body) |
---|
49 | (destructuring-bind (op &rest rands) pattern |
---|
50 | `(,op (destructuring-bind ,rands ,operands |
---|
51 | ,@body))))) |
---|
52 | ,@(if (eq (caar (last patterns)) t) |
---|
53 | '() |
---|
54 | `((t (error "destructure-case failed: ~S" ,tmp)))))))) |
---|
55 | |
---|
56 | ;;; Taken from Alexandria (which is Public Domain, or BSD.) |
---|
57 | |
---|
58 | (define-condition simple-style-warning (simple-warning style-warning) |
---|
59 | ()) |
---|
60 | |
---|
61 | (defun simple-style-warn (format-control &rest format-args) |
---|
62 | (warn 'simple-style-warning |
---|
63 | :format-control format-control |
---|
64 | :format-arguments format-args)) |
---|
65 | |
---|
66 | (define-condition simple-program-error (simple-error program-error) |
---|
67 | ()) |
---|
68 | |
---|
69 | (defun simple-program-error (message &rest args) |
---|
70 | (error 'simple-program-error |
---|
71 | :format-control message |
---|
72 | :format-arguments args)) |
---|
73 | |
---|
74 | (defun required-argument (&optional name) |
---|
75 | "Signals an error for a missing argument of NAME. Intended for |
---|
76 | use as an initialization form for structure and class-slots, and |
---|
77 | a default value for required keyword arguments." |
---|
78 | (error "Required argument ~@[~S ~]missing." name)) |
---|
79 | |
---|
80 | (defun ensure-list (list) |
---|
81 | "If LIST is a list, it is returned. Otherwise returns the list |
---|
82 | designated by LIST." |
---|
83 | (if (listp list) |
---|
84 | list |
---|
85 | (list list))) |
---|
86 | |
---|
87 | (declaim (inline ensure-function)) ; to propagate return type. |
---|
88 | (declaim (ftype (function (t) (values function &optional)) |
---|
89 | ensure-function)) |
---|
90 | (defun ensure-function (function-designator) |
---|
91 | "Returns the function designated by FUNCTION-DESIGNATOR: |
---|
92 | if FUNCTION-DESIGNATOR is a function, it is returned, otherwise |
---|
93 | it must be a function name and its FDEFINITION is returned." |
---|
94 | (if (functionp function-designator) |
---|
95 | function-designator |
---|
96 | (fdefinition function-designator))) |
---|
97 | |
---|
98 | (defun parse-body (body &key documentation whole) |
---|
99 | "Parses BODY into (values remaining-forms declarations doc-string). |
---|
100 | Documentation strings are recognized only if DOCUMENTATION is true. |
---|
101 | Syntax errors in body are signalled and WHOLE is used in the signal |
---|
102 | arguments when given." |
---|
103 | (let ((doc nil) |
---|
104 | (decls nil) |
---|
105 | (current nil)) |
---|
106 | (tagbody |
---|
107 | :declarations |
---|
108 | (setf current (car body)) |
---|
109 | (when (and documentation (stringp current) (cdr body)) |
---|
110 | (if doc |
---|
111 | (error "Too many documentation strings in ~S." (or whole body)) |
---|
112 | (setf doc (pop body))) |
---|
113 | (go :declarations)) |
---|
114 | (when (and (listp current) (eql (first current) 'declare)) |
---|
115 | (push (pop body) decls) |
---|
116 | (go :declarations))) |
---|
117 | (values body (nreverse decls) doc))) |
---|
118 | |
---|
119 | (defun parse-ordinary-lambda-list (lambda-list) |
---|
120 | "Parses an ordinary lambda-list, returning as multiple values: |
---|
121 | |
---|
122 | 1. Required parameters. |
---|
123 | 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP) |
---|
124 | where SUPPLIEDP is NIL if not present. |
---|
125 | 3. Name of the rest parameter, or NIL. |
---|
126 | 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP) |
---|
127 | where SUPPLIEDP is NIL if not present. |
---|
128 | 5. Boolean indicating &ALLOW-OTHER-KEYS presence. |
---|
129 | 6. &AUX parameter specifications, normalized into form (NAME INIT). |
---|
130 | |
---|
131 | Signals a PROGRAM-ERROR is the lambda-list is malformed." |
---|
132 | (let ((state :required) |
---|
133 | (allow-other-keys nil) |
---|
134 | (auxp nil) |
---|
135 | (required nil) |
---|
136 | (optional nil) |
---|
137 | (rest nil) |
---|
138 | (keys nil) |
---|
139 | (aux nil)) |
---|
140 | (labels ((simple-program-error (format-string &rest format-args) |
---|
141 | (error 'simple-program-error |
---|
142 | :format-control format-string |
---|
143 | :format-arguments format-args)) |
---|
144 | (fail (elt) |
---|
145 | (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" |
---|
146 | elt lambda-list)) |
---|
147 | (check-variable (elt what) |
---|
148 | (unless (and (symbolp elt) (not (constantp elt))) |
---|
149 | (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" |
---|
150 | what elt lambda-list))) |
---|
151 | (check-spec (spec what) |
---|
152 | (destructuring-bind (init suppliedp) spec |
---|
153 | (declare (ignore init)) |
---|
154 | (check-variable suppliedp what))) |
---|
155 | (make-keyword (name) |
---|
156 | "Interns the string designated by NAME in the KEYWORD package." |
---|
157 | (intern (string name) :keyword))) |
---|
158 | (dolist (elt lambda-list) |
---|
159 | (case elt |
---|
160 | (&optional |
---|
161 | (if (eq state :required) |
---|
162 | (setf state elt) |
---|
163 | (fail elt))) |
---|
164 | (&rest |
---|
165 | (if (member state '(:required &optional)) |
---|
166 | (setf state elt) |
---|
167 | (progn |
---|
168 | (break "state=~S" state) |
---|
169 | (fail elt)))) |
---|
170 | (&key |
---|
171 | (if (member state '(:required &optional :after-rest)) |
---|
172 | (setf state elt) |
---|
173 | (fail elt))) |
---|
174 | (&allow-other-keys |
---|
175 | (if (eq state '&key) |
---|
176 | (setf allow-other-keys t |
---|
177 | state elt) |
---|
178 | (fail elt))) |
---|
179 | (&aux |
---|
180 | (cond ((eq state '&rest) |
---|
181 | (fail elt)) |
---|
182 | (auxp |
---|
183 | (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" |
---|
184 | elt lambda-list)) |
---|
185 | (t |
---|
186 | (setf auxp t |
---|
187 | state elt)) |
---|
188 | )) |
---|
189 | (otherwise |
---|
190 | (when (member elt '#.(set-difference lambda-list-keywords |
---|
191 | '(&optional &rest &key &allow-other-keys &aux))) |
---|
192 | (simple-program-error |
---|
193 | "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" |
---|
194 | elt lambda-list)) |
---|
195 | (case state |
---|
196 | (:required |
---|
197 | (check-variable elt "required parameter") |
---|
198 | (push elt required)) |
---|
199 | (&optional |
---|
200 | (cond ((consp elt) |
---|
201 | (destructuring-bind (name &rest tail) elt |
---|
202 | (check-variable name "optional parameter") |
---|
203 | (if (cdr tail) |
---|
204 | (check-spec tail "optional-supplied-p parameter") |
---|
205 | (setf elt (append elt '(nil)))))) |
---|
206 | (t |
---|
207 | (check-variable elt "optional parameter") |
---|
208 | (setf elt (cons elt '(nil nil))))) |
---|
209 | (push elt optional)) |
---|
210 | (&rest |
---|
211 | (check-variable elt "rest parameter") |
---|
212 | (setf rest elt |
---|
213 | state :after-rest)) |
---|
214 | (&key |
---|
215 | (cond ((consp elt) |
---|
216 | (destructuring-bind (var-or-kv &rest tail) elt |
---|
217 | (cond ((consp var-or-kv) |
---|
218 | (destructuring-bind (keyword var) var-or-kv |
---|
219 | (unless (symbolp keyword) |
---|
220 | (simple-program-error "Invalid keyword name ~S in ordinary ~ |
---|
221 | lambda-list:~% ~S" |
---|
222 | keyword lambda-list)) |
---|
223 | (check-variable var "keyword parameter"))) |
---|
224 | (t |
---|
225 | (check-variable var-or-kv "keyword parameter") |
---|
226 | (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))) |
---|
227 | (if (cdr tail) |
---|
228 | (check-spec tail "keyword-supplied-p parameter") |
---|
229 | (setf tail (append tail '(nil)))) |
---|
230 | (setf elt (cons var-or-kv tail)))) |
---|
231 | (t |
---|
232 | (check-variable elt "keyword parameter") |
---|
233 | (setf elt (list (list (make-keyword elt) elt) nil nil)))) |
---|
234 | (push elt keys)) |
---|
235 | (&aux |
---|
236 | (if (consp elt) |
---|
237 | (destructuring-bind (var &optional init) elt |
---|
238 | (declare (ignore init)) |
---|
239 | (check-variable var "&aux parameter")) |
---|
240 | (check-variable elt "&aux parameter")) |
---|
241 | (push elt aux)) |
---|
242 | (t |
---|
243 | (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list))))))) |
---|
244 | (values (nreverse required) (nreverse optional) rest (nreverse keys) |
---|
245 | allow-other-keys (nreverse aux)))) |
---|