utility.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
utility.lisp (30467B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; General Purpose Utilities for ASDF | |
3 | |
4 (uiop/package:define-package :uiop/utility | |
5 (:use :uiop/common-lisp :uiop/package) | |
6 ;; import and reexport a few things defined in :uiop/common-lisp | |
7 (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings | |
8 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) | |
9 (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt | |
10 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) | |
11 (:export | |
12 ;; magic helper to define debugging functions: | |
13 #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* | |
14 #:with-upgradability ;; (un)defining functions in an upgrade-friendly… | |
15 #:defun* #:defgeneric* | |
16 #:nest #:if-let ;; basic flow control | |
17 #:parse-body ;; macro definition helper | |
18 #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists | |
19 #:remove-plist-keys #:remove-plist-key ;; plists | |
20 #:emptyp ;; sequences | |
21 #:+non-base-chars-exist-p+ ;; characters | |
22 #:+max-character-type-index+ #:character-type-index #:+character-type… | |
23 #:base-string-p #:strings-common-element-type #:reduce/strcat #:strca… | |
24 #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+cr… | |
25 #:string-prefix-p #:string-enclosed-p #:string-suffix-p | |
26 #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols | |
27 #:coerce-class ;; CLOS | |
28 #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps | |
29 #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp | |
30 #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-tim… | |
31 #:list-to-hash-set #:ensure-gethash ;; hash-table | |
32 #:ensure-function #:access-at #:access-at-count ;; functions | |
33 #:call-function #:call-functions #:register-hook-function | |
34 #:lexicographic< #:lexicographic<= ;; version | |
35 #:simple-style-warning #:style-warn ;; simple style warnings | |
36 #:match-condition-p #:match-any-condition-p ;; conditions | |
37 #:call-with-muffled-conditions #:with-muffled-conditions | |
38 #:not-implemented-error #:parameter-error | |
39 #:symbol-test-to-feature-expression | |
40 #:boolean-to-feature-expression)) | |
41 (in-package :uiop/utility) | |
42 | |
43 ;;;; Defining functions in a way compatible with hot-upgrade: | |
44 ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefini… | |
45 ;; thus replacing the function without warning or error | |
46 ;; even if the signature and/or generic-ness of the function has changed. | |
47 ;; For a generic function, this invalidates any previous DEFMETHOD. | |
48 (eval-when (:load-toplevel :compile-toplevel :execute) | |
49 (macrolet | |
50 ((defdef (def* def) | |
51 `(defmacro ,def* (name formals &rest rest) | |
52 (destructuring-bind (name &key (supersede t)) | |
53 (if (or (atom name) (eq (car name) 'setf)) | |
54 (list name :supersede nil) | |
55 name) | |
56 (declare (ignorable supersede)) | |
57 `(progn | |
58 ;; We usually try to do it only for the functions that … | |
59 ;; which happens in asdf/upgrade - however, for ECL, we… | |
60 ,@(when supersede | |
61 `((fmakunbound ',name))) | |
62 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails f… | |
63 `((declaim (notinline ,name)))) | |
64 (,',def ,name ,formals ,@rest)))))) | |
65 (defdef defgeneric* defgeneric) | |
66 (defdef defun* defun)) | |
67 (defmacro with-upgradability ((&optional) &body body) | |
68 "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFG… | |
69 to also declare the functions NOTINLINE and to accept a wrapping the fun… | |
70 specification into a list with keyword argument SUPERSEDE (which default… | |
71 is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UN… | |
72 to supersede any previous definition." | |
73 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
74 ,@(loop :for form :in body :collect | |
75 (if (consp form) | |
76 (destructuring-bind (car . cdr) form | |
77 (case car | |
78 ((defun) `(defun* ,@cdr)) | |
79 ((defgeneric) `(defgeneric* ,@cdr)) | |
80 (otherwise form))) | |
81 form))))) | |
82 | |
83 ;;; Magic debugging help. See contrib/debug.lisp | |
84 (with-upgradability () | |
85 (defvar *uiop-debug-utility* | |
86 '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory)… | |
87 "form that evaluates to the pathname to your favorite debugging util… | |
88 | |
89 (defmacro uiop-debug (&rest keys) | |
90 "Load the UIOP debug utility at compile-time as well as runtime" | |
91 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
92 (load-uiop-debug-utility ,@keys))) | |
93 | |
94 (defun load-uiop-debug-utility (&key package utility-file) | |
95 "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*). | |
96 Beware: The utility is located by EVAL'uating the UTILITY-FILE form (def… | |
97 (let* ((*package* (if package (find-package package) *package*)) | |
98 (keyword (read-from-string | |
99 (format nil ":DBG-~:@(~A~)" (package-name *package*… | |
100 (unless (member keyword *features*) | |
101 (let* ((utility-file (or utility-file *uiop-debug-utility*)) | |
102 (file (ignore-errors (probe-file (eval utility-file))))) | |
103 (if file (load file) | |
104 (error "Failed to locate debug utility file: ~S" utility-f… | |
105 | |
106 ;;; Flow control | |
107 (with-upgradability () | |
108 (defmacro nest (&rest things) | |
109 "Macro to keep code nesting and indentation under control." ;; Thank… | |
110 (reduce #'(lambda (outer inner) `(,@outer ,inner)) | |
111 things :from-end t)) | |
112 | |
113 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; f… | |
114 ;; bindings can be (var form) or ((var1 form1) ...) | |
115 (let* ((binding-list (if (and (consp bindings) (symbolp (car binding… | |
116 (list bindings) | |
117 bindings)) | |
118 (variables (mapcar #'car binding-list))) | |
119 `(let ,binding-list | |
120 (if (and ,@variables) | |
121 ,then-form | |
122 ,else-form))))) | |
123 | |
124 ;;; Macro definition helper | |
125 (with-upgradability () | |
126 (defun parse-body (body &key documentation whole) ;; from alexandria | |
127 "Parses BODY into (values remaining-forms declarations doc-string). | |
128 Documentation strings are recognized only if DOCUMENTATION is true. | |
129 Syntax errors in body are signalled and WHOLE is used in the signal | |
130 arguments when given." | |
131 (let ((doc nil) | |
132 (decls nil) | |
133 (current nil)) | |
134 (tagbody | |
135 :declarations | |
136 (setf current (car body)) | |
137 (when (and documentation (stringp current) (cdr body)) | |
138 (if doc | |
139 (error "Too many documentation strings in ~S." (or whole … | |
140 (setf doc (pop body))) | |
141 (go :declarations)) | |
142 (when (and (listp current) (eql (first current) 'declare)) | |
143 (push (pop body) decls) | |
144 (go :declarations))) | |
145 (values body (nreverse decls) doc)))) | |
146 | |
147 | |
148 ;;; List manipulation | |
149 (with-upgradability () | |
150 (defmacro while-collecting ((&rest collectors) &body body) | |
151 "COLLECTORS should be a list of names for collections. A collector | |
152 defines a function that, when applied to an argument inside BODY, will | |
153 add its argument to the corresponding collection. Returns multiple valu… | |
154 a list for each collection, in order. | |
155 E.g., | |
156 \(while-collecting \(foo bar\) | |
157 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) | |
158 \(foo \(first x\)\) | |
159 \(bar \(second x\)\)\)\) | |
160 Returns two values: \(A B C\) and \(1 2 3\)." | |
161 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collecto… | |
162 (initial-values (mapcar (constantly nil) collectors))) | |
163 `(let ,(mapcar #'list vars initial-values) | |
164 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) … | |
165 ,@body | |
166 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) | |
167 | |
168 (define-modify-macro appendf (&rest args) | |
169 append "Append onto list") ;; only to be used on short lists. | |
170 | |
171 (defun length=n-p (x n) ;is it that (= (length x) n) ? | |
172 (check-type n (integer 0 *)) | |
173 (loop | |
174 :for l = x :then (cdr l) | |
175 :for i :downfrom n :do | |
176 (cond | |
177 ((zerop i) (return (null l))) | |
178 ((not (consp l)) (return nil))))) | |
179 | |
180 (defun ensure-list (x) | |
181 (if (listp x) x (list x)))) | |
182 | |
183 | |
184 ;;; Remove a key from a plist, i.e. for keyword argument cleanup | |
185 (with-upgradability () | |
186 (defun remove-plist-key (key plist) | |
187 "Remove a single key from a plist" | |
188 (loop* :for (k v) :on plist :by #'cddr | |
189 :unless (eq k key) | |
190 :append (list k v))) | |
191 | |
192 (defun remove-plist-keys (keys plist) | |
193 "Remove a list of keys from a plist" | |
194 (loop* :for (k v) :on plist :by #'cddr | |
195 :unless (member k keys) | |
196 :append (list k v)))) | |
197 | |
198 | |
199 ;;; Sequences | |
200 (with-upgradability () | |
201 (defun emptyp (x) | |
202 "Predicate that is true for an empty sequence" | |
203 (or (null x) (and (vectorp x) (zerop (length x)))))) | |
204 | |
205 | |
206 ;;; Characters | |
207 (with-upgradability () | |
208 ;; base-char != character on ECL, LW, SBCL, Genera. | |
209 ;; NB: We assume a total order on character types. | |
210 ;; If that's not true... this code will need to be updated. | |
211 (defparameter +character-types+ ;; assuming a simple hierarchy | |
212 #.(coerce (loop* :for (type next) :on | |
213 '(;; In SCL, all characters seem to be 16-bit base-… | |
214 ;; Yet somehow character fails to be a subtype of… | |
215 #-scl base-char | |
216 ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER | |
217 ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = C… | |
218 #+lispworks7+ lw:bmp-char | |
219 #+lispworks lw:simple-char | |
220 character) | |
221 :unless (and next (subtypep next type)) | |
222 :collect type) 'vector)) | |
223 (defparameter +max-character-type-index+ (1- (length +character-types+… | |
224 (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index… | |
225 (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *featu… | |
226 | |
227 (with-upgradability () | |
228 (defun character-type-index (x) | |
229 (declare (ignorable x)) | |
230 #.(case +max-character-type-index+ | |
231 (0 0) | |
232 (1 '(etypecase x | |
233 (character (if (typep x 'base-char) 0 1)) | |
234 (symbol (if (subtypep x 'base-char) 0 1)))) | |
235 (otherwise | |
236 '(or (position-if (etypecase x | |
237 (character #'(lambda (type) (typep x type))) | |
238 (symbol #'(lambda (type) (subtypep x type))… | |
239 +character-types+) | |
240 (error "Not a character or character type: ~S" x)))))) | |
241 | |
242 | |
243 ;;; Strings | |
244 (with-upgradability () | |
245 (defun base-string-p (string) | |
246 "Does the STRING only contain BASE-CHARs?" | |
247 (declare (ignorable string)) | |
248 (and #+non-base-chars-exist-p (eq 'base-char (array-element-type str… | |
249 | |
250 (defun strings-common-element-type (strings) | |
251 "What least subtype of CHARACTER can contain all the elements of all… | |
252 (declare (ignorable strings)) | |
253 #.(if +non-base-chars-exist-p+ | |
254 `(aref +character-types+ | |
255 (loop :with index = 0 :for s :in strings :do | |
256 (flet ((consider (i) | |
257 (cond ((= i ,+max-character-type-index+) (return … | |
258 ,@(when (> +max-character-type-index+ 1) `(… | |
259 (cond | |
260 ((emptyp s)) ;; NIL or empty string | |
261 ((characterp s) (consider (character-type-index s))) | |
262 ((stringp s) (let ((string-type-index | |
263 (character-type-index (array-elem… | |
264 (unless (>= index string-type-index) | |
265 (loop :for c :across s :for i = (char… | |
266 :do (consider i) | |
267 ,@(when (> +max-character-type-… | |
268 `((when (= i string-type-in… | |
269 (t (error "Invalid string designator ~S for ~S" s 'str… | |
270 :finally (return index))) | |
271 ''character)) | |
272 | |
273 (defun reduce/strcat (strings &key key start end) | |
274 "Reduce a list as if by STRCAT, accepting KEY START and END keywords… | |
275 NIL is interpreted as an empty string. A character is interpreted as a s… | |
276 (when (or start end) (setf strings (subseq strings start end))) | |
277 (when key (setf strings (mapcar key strings))) | |
278 (loop :with output = (make-string (loop :for s :in strings | |
279 :sum (if (characterp s) 1 (l… | |
280 :element-type (strings-common-elem… | |
281 :with pos = 0 | |
282 :for input :in strings | |
283 :do (etypecase input | |
284 (null) | |
285 (character (setf (char output pos) input) (incf pos)) | |
286 (string (replace output input :start1 pos) (incf pos (le… | |
287 :finally (return output))) | |
288 | |
289 (defun strcat (&rest strings) | |
290 "Concatenate strings. | |
291 NIL is interpreted as an empty string, a character as a string of length… | |
292 (reduce/strcat strings)) | |
293 | |
294 (defun first-char (s) | |
295 "Return the first character of a non-empty string S, or NIL" | |
296 (and (stringp s) (plusp (length s)) (char s 0))) | |
297 | |
298 (defun last-char (s) | |
299 "Return the last character of a non-empty string S, or NIL" | |
300 (and (stringp s) (plusp (length s)) (char s (1- (length s))))) | |
301 | |
302 (defun split-string (string &key max (separator '(#\Space #\Tab))) | |
303 "Split STRING into a list of components separated by | |
304 any of the characters in the sequence SEPARATOR. | |
305 If MAX is specified, then no more than max(1,MAX) components will be ret… | |
306 starting the separation from the end, e.g. when called with arguments | |
307 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \… | |
308 (block () | |
309 (let ((list nil) (words 0) (end (length string))) | |
310 (when (zerop end) (return nil)) | |
311 (flet ((separatorp (char) (find char separator)) | |
312 (done () (return (cons (subseq string 0 end) list)))) | |
313 (loop | |
314 :for start = (if (and max (>= words (1- max))) | |
315 (done) | |
316 (position-if #'separatorp string :end end :… | |
317 :do (when (null start) (done)) | |
318 (push (subseq string (1+ start) end) list) | |
319 (incf words) | |
320 (setf end start)))))) | |
321 | |
322 (defun string-prefix-p (prefix string) | |
323 "Does STRING begin with PREFIX?" | |
324 (let* ((x (string prefix)) | |
325 (y (string string)) | |
326 (lx (length x)) | |
327 (ly (length y))) | |
328 (and (<= lx ly) (string= x y :end2 lx)))) | |
329 | |
330 (defun string-suffix-p (string suffix) | |
331 "Does STRING end with SUFFIX?" | |
332 (let* ((x (string string)) | |
333 (y (string suffix)) | |
334 (lx (length x)) | |
335 (ly (length y))) | |
336 (and (<= ly lx) (string= x y :start1 (- lx ly))))) | |
337 | |
338 (defun string-enclosed-p (prefix string suffix) | |
339 "Does STRING begin with PREFIX and end with SUFFIX?" | |
340 (and (string-prefix-p prefix string) | |
341 (string-suffix-p string suffix))) | |
342 | |
343 (defvar +cr+ (coerce #(#\Return) 'string)) | |
344 (defvar +lf+ (coerce #(#\Linefeed) 'string)) | |
345 (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string)) | |
346 | |
347 (defun stripln (x) | |
348 "Strip a string X from any ending CR, LF or CRLF. | |
349 Return two values, the stripped string and the ending that was stripped, | |
350 or the original value and NIL if no stripping took place. | |
351 Since our STRCAT accepts NIL as empty string designator, | |
352 the two results passed to STRCAT always reconstitute the original string" | |
353 (check-type x string) | |
354 (block nil | |
355 (flet ((c (end) (when (string-suffix-p x end) | |
356 (return (values (subseq x 0 (- (length x) (lengt… | |
357 (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) | |
358 | |
359 (defun standard-case-symbol-name (name-designator) | |
360 "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it… | |
361 if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING o… | |
362 platform such as Allegro with modern syntax." | |
363 (check-type name-designator (or string symbol)) | |
364 (cond | |
365 ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mo… | |
366 (string name-designator)) | |
367 ;; Should we be doing something on CLISP? | |
368 (t (string-upcase name-designator)))) | |
369 | |
370 (defun find-standard-case-symbol (name-designator package-designator &… | |
371 "Find a symbol designated by NAME-DESIGNATOR in a package designated… | |
372 where STANDARD-CASE-SYMBOL-NAME is used to transform them if these desig… | |
373 If optional ERROR argument is NIL, return NIL instead of an error when t… | |
374 (find-symbol* (standard-case-symbol-name name-designator) | |
375 (etypecase package-designator | |
376 ((or package symbol) package-designator) | |
377 (string (standard-case-symbol-name package-designato… | |
378 error))) | |
379 | |
380 ;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity | |
381 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) | |
382 (deftype timestamp () '(or real boolean))) | |
383 (with-upgradability () | |
384 (defun timestamp< (x y) | |
385 (etypecase x | |
386 ((eql t) (not (eql y t))) | |
387 (real (etypecase y | |
388 ((eql t) nil) | |
389 (real (< x y)) | |
390 (null t))) | |
391 (null nil))) | |
392 (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :… | |
393 (defun timestamp*< (&rest list) (timestamps< list)) | |
394 (defun timestamp<= (x y) (not (timestamp< y x))) | |
395 (defun earlier-timestamp (x y) (if (timestamp< x y) x y)) | |
396 (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :ini… | |
397 (defun earliest-timestamp (&rest list) (timestamps-earliest list)) | |
398 (defun later-timestamp (x y) (if (timestamp< x y) y x)) | |
399 (defun timestamps-latest (list) (reduce 'later-timestamp list :initial… | |
400 (defun latest-timestamp (&rest list) (timestamps-latest list)) | |
401 (define-modify-macro latest-timestamp-f (&rest timestamps) latest-time… | |
402 | |
403 | |
404 ;;; Function designators | |
405 (with-upgradability () | |
406 (defun ensure-function (fun &key (package :cl)) | |
407 "Coerce the object FUN into a function. | |
408 | |
409 If FUN is a FUNCTION, return it. | |
410 If the FUN is a non-sequence literal constant, return constantly that, | |
411 i.e. for a boolean keyword character number or pathname. | |
412 Otherwise if FUN is a non-literally constant symbol, return its FDEFINIT… | |
413 If FUN is a CONS, return the function that applies its CAR | |
414 to the appended list of the rest of its CDR and the arguments, | |
415 unless the CAR is LAMBDA, in which case the expression is evaluated. | |
416 If FUN is a string, READ a form from it in the specified PACKAGE (defaul… | |
417 and EVAL that in a (FUNCTION ...) context." | |
418 (etypecase fun | |
419 (function fun) | |
420 ((or boolean keyword character number pathname) (constantly fun)) | |
421 (hash-table #'(lambda (x) (gethash x fun))) | |
422 (symbol (fdefinition fun)) | |
423 (cons (if (eq 'lambda (car fun)) | |
424 (eval fun) | |
425 #'(lambda (&rest args) (apply (car fun) (append (cdr fun… | |
426 (string (eval `(function ,(with-standard-io-syntax | |
427 (let ((*package* (find-package package… | |
428 (read-from-string fun)))))))) | |
429 | |
430 (defun access-at (object at) | |
431 "Given an OBJECT and an AT specifier, list of successive accessors, | |
432 call each accessor on the result of the previous calls. | |
433 An accessor may be an integer, meaning a call to ELT, | |
434 a keyword, meaning a call to GETF, | |
435 NIL, meaning identity, | |
436 a function or other symbol, meaning itself, | |
437 or a list of a function designator and arguments, interpreted as per ENS… | |
438 As a degenerate case, the AT specifier may be an atom of a single such a… | |
439 instead of a list." | |
440 (flet ((access (object accessor) | |
441 (etypecase accessor | |
442 (function (funcall accessor object)) | |
443 (integer (elt object accessor)) | |
444 (keyword (getf object accessor)) | |
445 (null object) | |
446 (symbol (funcall accessor object)) | |
447 (cons (funcall (ensure-function accessor) object))))) | |
448 (if (listp at) | |
449 (dolist (accessor at object) | |
450 (setf object (access object accessor))) | |
451 (access object at)))) | |
452 | |
453 (defun access-at-count (at) | |
454 "From an AT specification, extract a COUNT of maximum number | |
455 of sub-objects to read as per ACCESS-AT" | |
456 (cond | |
457 ((integerp at) | |
458 (1+ at)) | |
459 ((and (consp at) (integerp (first at))) | |
460 (1+ (first at))))) | |
461 | |
462 (defun call-function (function-spec &rest arguments) | |
463 "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTIO… | |
464 with the given ARGUMENTS" | |
465 (apply (ensure-function function-spec) arguments)) | |
466 | |
467 (defun call-functions (function-specs) | |
468 "For each function in the list FUNCTION-SPECS, in order, call the fu… | |
469 (map () 'call-function function-specs)) | |
470 | |
471 (defun register-hook-function (variable hook &optional call-now-p) | |
472 "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto t… | |
473 When CALL-NOW-P is true, also call the function immediately." | |
474 (pushnew hook (symbol-value variable) :test 'equal) | |
475 (when call-now-p (call-function hook)))) | |
476 | |
477 | |
478 ;;; CLOS | |
479 (with-upgradability () | |
480 (defun coerce-class (class &key (package :cl) (super t) (error 'error)) | |
481 "Coerce CLASS to a class that is subclass of SUPER if specified, | |
482 or invoke ERROR handler as per CALL-FUNCTION. | |
483 | |
484 A keyword designates the name a symbol, which when found in either PACKA… | |
485 -- for backward compatibility, *PACKAGE* is also accepted for now, but t… | |
486 A string is read as a symbol while in PACKAGE, the symbol designates a c… | |
487 | |
488 A class object designates itself. | |
489 NIL designates itself (no class). | |
490 A symbol otherwise designates a class by name." | |
491 (let* ((normalized | |
492 (typecase class | |
493 (keyword (or (find-symbol* class package nil) | |
494 (find-symbol* class *package* nil))) | |
495 (string (symbol-call :uiop :safe-read-from-string class :p… | |
496 (t class))) | |
497 (found | |
498 (etypecase normalized | |
499 ((or standard-class built-in-class) normalized) | |
500 ((or null keyword) nil) | |
501 (symbol (find-class normalized nil nil)))) | |
502 (super-class | |
503 (etypecase super | |
504 ((or standard-class built-in-class) super) | |
505 ((or null keyword) nil) | |
506 (symbol (find-class super nil nil))))) | |
507 #+allegro (when found (mop:finalize-inheritance found)) | |
508 (or (and found | |
509 (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::… | |
510 found) | |
511 (call-function error "Can't coerce ~S to a ~:[class~;subclass … | |
512 | |
513 | |
514 ;;; Hash-tables | |
515 (with-upgradability () | |
516 (defun ensure-gethash (key table default) | |
517 "Lookup the TABLE for a KEY as by GETHASH, but if not present, | |
518 call the (possibly constant) function designated by DEFAULT as per CALL-… | |
519 set the corresponding entry to the result in the table. | |
520 Return two values: the entry after its optional computation, and whether… | |
521 (multiple-value-bind (value foundp) (gethash key table) | |
522 (values | |
523 (if foundp | |
524 value | |
525 (setf (gethash key table) (call-function default))) | |
526 foundp))) | |
527 | |
528 (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) | |
529 "Convert a LIST into hash-table that has the same elements when view… | |
530 up to the given equality TEST" | |
531 (dolist (x list h) (setf (gethash x h) t)))) | |
532 | |
533 | |
534 ;;; Lexicographic comparison of lists of numbers | |
535 (with-upgradability () | |
536 (defun lexicographic< (element< x y) | |
537 "Lexicographically compare two lists of using the function element< … | |
538 element< is a strict total order; the resulting order on X and Y will al… | |
539 (cond ((null y) nil) | |
540 ((null x) t) | |
541 ((funcall element< (car x) (car y)) t) | |
542 ((funcall element< (car y) (car x)) nil) | |
543 (t (lexicographic< element< (cdr x) (cdr y))))) | |
544 | |
545 (defun lexicographic<= (element< x y) | |
546 "Lexicographically compare two lists of using the function element< … | |
547 element< is a strict total order; the resulting order on X and Y will be… | |
548 (not (lexicographic< element< y x)))) | |
549 | |
550 | |
551 ;;; Simple style warnings | |
552 (with-upgradability () | |
553 (define-condition simple-style-warning | |
554 #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition styl… | |
555 ()) | |
556 | |
557 (defun style-warn (datum &rest arguments) | |
558 (etypecase datum | |
559 (string (warn (make-condition 'simple-style-warning :format-contro… | |
560 (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datu… | |
561 (style-warning (apply 'warn datum arguments))))) | |
562 | |
563 | |
564 ;;; Condition control | |
565 | |
566 (with-upgradability () | |
567 (defparameter +simple-condition-format-control-slot+ | |
568 #+abcl 'system::format-control | |
569 #+allegro 'excl::format-control | |
570 #+(or clasp ecl mkcl) 'si::format-control | |
571 #+clisp 'system::$format-control | |
572 #+clozure 'ccl::format-control | |
573 #+(or cmucl scl) 'conditions::format-control | |
574 #+(or gcl lispworks) 'conditions::format-string | |
575 #+sbcl 'sb-kernel:format-control | |
576 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl … | |
577 "Name of the slot for FORMAT-CONTROL in simple-condition") | |
578 | |
579 (defun match-condition-p (x condition) | |
580 "Compare received CONDITION to some pattern X: | |
581 a symbol naming a condition class, | |
582 a simple vector of length 2, arguments to find-symbol* with result as ab… | |
583 or a string describing the format-control of a simple-condition." | |
584 (etypecase x | |
585 (symbol (typep condition x)) | |
586 ((simple-vector 2) | |
587 (ignore-errors (typep condition (find-symbol* (svref x 0) (svref … | |
588 (function (funcall x condition)) | |
589 (string (and (typep condition 'simple-condition) | |
590 ;; On SBCL, it's always set and the check triggers a … | |
591 #+(or allegro clozure cmucl lispworks scl) | |
592 (slot-boundp condition +simple-condition-format-contr… | |
593 (ignore-errors (equal (simple-condition-format-contro… | |
594 | |
595 (defun match-any-condition-p (condition conditions) | |
596 "match CONDITION against any of the patterns of CONDITIONS supplied" | |
597 (loop :for x :in conditions :thereis (match-condition-p x condition)… | |
598 | |
599 (defun call-with-muffled-conditions (thunk conditions) | |
600 "calls the THUNK in a context where the CONDITIONS are muffled" | |
601 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c condi… | |
602 (muffle-warning c))))) | |
603 (funcall thunk))) | |
604 | |
605 (defmacro with-muffled-conditions ((conditions) &body body) | |
606 "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" | |
607 `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) | |
608 | |
609 ;;; Conditions | |
610 | |
611 (with-upgradability () | |
612 (define-condition not-implemented-error (error) | |
613 ((functionality :initarg :functionality) | |
614 (format-control :initarg :format-control) | |
615 (format-arguments :initarg :format-arguments)) | |
616 (:report (lambda (condition stream) | |
617 (format stream "Not (currently) implemented on ~A: ~S~@[ … | |
618 (nth-value 1 (symbol-call :uiop :implementation-t… | |
619 (slot-value condition 'functionality) | |
620 (slot-value condition 'format-control) | |
621 (slot-value condition 'format-arguments))))) | |
622 | |
623 (defun not-implemented-error (functionality &optional format-control &… | |
624 "Signal an error because some FUNCTIONALITY is not implemented in th… | |
625 of the software on the current platform; it may or may not be implemente… | |
626 of version of the software and of the underlying platform. Optionally, r… | |
627 message." | |
628 (error 'not-implemented-error | |
629 :functionality functionality | |
630 :format-control format-control | |
631 :format-arguments format-arguments)) | |
632 | |
633 (define-condition parameter-error (error) | |
634 ((functionality :initarg :functionality) | |
635 (format-control :initarg :format-control) | |
636 (format-arguments :initarg :format-arguments)) | |
637 (:report (lambda (condition stream) | |
638 (apply 'format stream | |
639 (slot-value condition 'format-control) | |
640 (slot-value condition 'functionality) | |
641 (slot-value condition 'format-arguments))))) | |
642 | |
643 ;; Note that functionality MUST be passed as the second argument to pa… | |
644 ;; the format-control. If you want it to not appear in first position … | |
645 ;; ~* and ~:* to adjust parameter order. | |
646 (defun parameter-error (format-control functionality &rest format-argu… | |
647 "Signal an error because some FUNCTIONALITY or its specific implemen… | |
648 platform does not accept a given parameter or combination of parameters.… | |
649 message, that takes the functionality as its first argument (that can be… | |
650 (error 'parameter-error | |
651 :functionality functionality | |
652 :format-control format-control | |
653 :format-arguments format-arguments))) | |
654 | |
655 (with-upgradability () | |
656 (defun boolean-to-feature-expression (value) | |
657 "Converts a boolean VALUE to a form suitable for testing with #+." | |
658 (if value | |
659 '(:and) | |
660 '(:or))) | |
661 | |
662 (defun symbol-test-to-feature-expression (name package) | |
663 "Check if a symbol with a given NAME exists in PACKAGE and returns a | |
664 form suitable for testing with #+." | |
665 (boolean-to-feature-expression | |
666 (find-symbol* name package nil)))) |