1 ;;; util.lisp --- General utilities
3 ;; Copyright (C) 2010 Didier Verna
5 ;; Author: Didier Verna <didier@lrde.epita.fr>
6 ;; Maintainer: Didier Verna <didier@lrde.epita.fr>
7 ;; Created: Mon Jun 30 17:23:36 2008
8 ;; Last Revision: Sat Jun 12 18:21:45 2010
10 ;; This file is part of Clon.
12 ;; Clon is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License version 3,
14 ;; as published by the Free Software Foundation.
16 ;; Clon is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program; if not, write to the Free Software
23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
28 ;; Contents management by FCM version 0.1.
33 (in-package :com.dvlsoft.clon
)
34 (in-readtable :com.dvlsoft.clon
)
37 ;; Preamble C code needed for ECL's FD-LINE-WIDTH function.
41 #include <sys/ioctl.h>")
45 ;; ==========================================================================
46 ;; Miscellaneous Auxiliary Routines
47 ;; ==========================================================================
49 (defmacro econd
(&body clauses
)
50 "Like COND, but signal an error if no clause evaluates to t."
51 `(cond ,@(append clauses
52 '((t (error "Fell out of ECOND clauses."))))))
54 (defmacro endpush
(object place
)
55 "Like push, but at the end."
56 `(setf ,place
(nconc ,place
(list ,object
))))
58 (defmacro maybe-push
(object place
)
59 "Like push, but only if OBJECT is non-nil."
60 (let ((the-object (gensym "object")))
61 `(let ((,the-object
,object
))
62 (when ,the-object
(push ,the-object
,place
)))))
64 (defmacro accumulate
((initial-value) &body body
)
65 "Accumulate BODY forms in a list beginning with INITIAL-VALUE.
66 INITIAL-VALUE is not evaluated. BODY forms are accumulated only when their
68 If nothing to accumulate, then return nil instead of the list of
70 (let ((place (gensym "place"))
71 (initial-place (gensym "initial-place")))
72 `(let* ((,place
(list ',initial-value
))
73 (,initial-place
,place
))
74 ,@(mapcar (lambda (body-form)
75 `(maybe-push ,body-form
,place
))
77 (when (not (eq ,initial-place
,place
))
80 (defun beginning-of-string-p (beginning string
&optional ignore-case
)
81 "Check that STRING starts with BEGINNING.
82 If IGNORE-CASE, well, ignore case."
83 (let ((length (length beginning
)))
84 (and (>= (length string
) length
)
85 (funcall (if ignore-case
#'string-equal
#'string
=)
86 beginning string
:end2 length
))))
88 (defun closest-match (match list
&key ignore-case
(key #'identity
))
89 "Return the LIST element closest to MATCH, or nil.
90 If IGNORE-CASE, well, ignore case.
91 KEY should provide a way to get a string from each LIST element."
92 (let ((match-length (length match
))
93 (shortest-distance most-positive-fixnum
)
96 (let ((elt-string (funcall key elt
))
98 (when (and (beginning-of-string-p match elt-string ignore-case
)
99 (< (setq distance
(- (length elt-string
) match-length
))
101 (setq shortest-distance distance
)
102 (setq closest-match elt
))))
105 (defun complete-string (beginning complete
)
106 "Complete BEGINNING with the rest of COMPLETE in parentheses.
107 For instance, completing 'he' with 'help' will produce 'he(lp)'."
108 (assert (beginning-of-string-p beginning complete
))
109 (assert (not (string= beginning complete
)))
110 (concatenate 'string beginning
"(" (subseq complete
(length beginning
)) ")"))
112 (defun list-to-string (list &key
(key #'identity
) (separator ", "))
113 "Return a SEPARATOR-separated string of all LIST elements.
114 - KEY should provide a way to get a string from each LIST element.
115 - SEPARATOR is the string to insert between elements."
116 (reduce (lambda (str1 str2
) (concatenate 'string str1 separator str2
))
122 ;; ==========================================================================
123 ;; Key-Value Pairs Manipulation
124 ;; ==========================================================================
126 (defun select-keys (keys &rest selected
)
127 "Return a new property list from KEYS with only SELECTED ones."
128 (loop :for key
:in keys
:by
#'cddr
129 :for val
:in
(cdr keys
) :by
#'cddr
130 :when
(member key selected
)
131 :nconc
(list key val
)))
133 (defun remove-keys (keys &rest removed
)
134 "Return a new property list from KEYS without REMOVED ones."
135 (loop :for key
:in keys
:by
#'cddr
136 :for val
:in
(cdr keys
) :by
#'cddr
137 :unless
(member key removed
)
138 :nconc
(list key val
)))
140 (defmacro replace-in-keys
((key val
) keys the-key form
)
141 "Replace every occurrence of THE-KEY in KEYS with FORM.
142 At every KEYS round, KEY and VAL are bound to the current key-value pair.
143 FORM is evaluated each time and should return a key-value list."
144 `(loop :for
,key
:in
,keys
:by
#'cddr
145 :for
,val
:in
(cdr ,keys
) :by
#'cddr
146 :if
(eql ,key
,the-key
)
149 :nconc
(list ,key
,val
)))
151 ;; #### NOTE: that's the typical situation where I would like a
152 ;; destructuring-cond, but it seems difficult to do so because of the
153 ;; standard imprecision of the reported error in case of a pattern matching
155 ;; #### NOTE: I could extend this utility by supporting a global :test, or
156 ;; even a per-replacement local one.
157 (defun replace-key (replacement keys
)
158 "Return a new property list from KEYS with REPLACEMENT.
159 REPLACEMENT can take the following forms:
161 The effect is to remove :KEY from KEYS, as per REMOVE-KEYS.
163 The effect is to replace :KEY with :NEW-KEY, leaving the values unchanged.
164 - (:KEY :NEW-KEY (VAL-OR-VALS NEW-VAL)*), with VAL-OR-VALS being
165 either a value or a list of values. The effect is to replace :KEY with
166 :NEW-KEY and a value matching one of the VAL-OR-VALS with the
167 corresponding NEW-VAL. Values not matching any VAL-OR-VALS remain unchanged.
168 - (:KEY (VAL-OR-VALS :NEW-KEY NEW-VAL...)*), with VAL-OR-VALS as above. The
169 effect is the same as above, but :NEW-KEY additionally depends on the
170 matched value. If multiple :NEW-KEY NEW-VAL couples are provided, that many
171 new keys are inserted along with their values. For values not matching any
172 VAL-OR-VALS, :KEY and its value remain unchanged."
173 (econd ((symbolp replacement
)
174 (remove-keys keys replacement
))
175 ((and (consp replacement
)
176 (= (length replacement
) 2)
177 (symbolp (car replacement
))
178 (symbolp (cadr replacement
)))
179 (destructuring-bind (old-key new-key
) replacement
180 (replace-in-keys (key val
) keys old-key
181 (list new-key val
))))
182 ((and (consp replacement
)
183 (> (length replacement
) 2)
184 (symbolp (car replacement
))
185 (symbolp (cadr replacement
)))
186 (destructuring-bind (old-key new-key
&rest replacements
) replacement
187 (replace-in-keys (key val
) keys old-key
190 (assoc val replacements
191 :test
(lambda (val val-or-vals
)
192 (if (consp val-or-vals
)
193 (member val val-or-vals
)
194 (eql val val-or-vals
))))))
195 (if match
(cadr match
) val
))))))
196 ((and (consp replacement
)
197 (> (length replacement
) 1)
198 (symbolp (car replacement
)))
199 (destructuring-bind (old-key &rest replacements
) replacement
200 (replace-in-keys (key val
) keys old-key
201 (let ((match (assoc val replacements
202 :test
(lambda (val val-or-vals
)
203 (if (consp val-or-vals
)
204 (member val val-or-vals
)
205 (eql val val-or-vals
))))))
208 (list key val
))))))))
210 (defun replace-keys (keys &rest replacements
)
211 "Return a new property list from KEYS with REPLACEMENTS.
212 See REPLACE-KEY for more information on the replacement syntax."
213 (let ((new-keys keys
))
214 (dolist (replacement replacements
)
215 (setq new-keys
(replace-key replacement new-keys
)))
220 ;; ==========================================================================
221 ;; CLOS Utility Routines
222 ;; ==========================================================================
224 ;; --------------------
225 ;; Portability wrappers
226 ;; --------------------
228 (defmacro validate-superclass
(class superclass
)
229 "Validate SUPERCLASS classes for CLASS classes."
231 #+abcl
(declare (ignore class superclass
))
234 `(defmethod #+sbcl sb-mop
:validate-superclass
235 #+cmu mop
:validate-superclass
236 #+ccl ccl
:validate-superclass
237 #+ecl clos
:validate-superclass
238 #+clisp clos
:validate-superclass
239 ((class ,class
) (superclass ,superclass
))
240 #+ecl
(declare (ignore class superclass
))
243 (defun class-slots (class)
244 "Return CLASS slots."
246 (#+sbcl sb-mop
:class-slots
247 #+cmu mop
:class-slots
248 #+ccl ccl
:class-slots
249 #+ecl clos
:class-slots
250 #+clisp clos
:class-slots
251 #+abcl mop
:class-slots
254 (defun slot-definition-name (slot)
255 "Return SLOT's definition name."
257 (#+sbcl sb-mop
:slot-definition-name
258 #+cmu mop
:slot-definition-name
259 #+ccl ccl
:slot-definition-name
260 #+ecl clos
:slot-definition-name
261 #+clisp clos
:slot-definition-name
262 #+abcl mop
:slot-definition-name
270 (defclass abstract-class
(standard-class)
272 (:documentation
"The ABSTRACT-CLASS class.
273 This is the meta-class for abstract classes."))
275 (defmacro defabstract
(class super-classes slots
&rest options
)
276 "Like DEFCLASS, but define an abstract class."
277 (when (assoc :metaclass options
)
278 (error "Defining abstract class ~S: explicit meta-class option." class
))
279 `(defclass ,class
,super-classes
,slots
,@options
280 (:metaclass abstract-class
)))
282 (defmethod make-instance ((class abstract-class
) &rest initargs
)
283 (declare (ignore initargs
))
284 (error "Instanciating class ~S: is abstract." (class-name class
)))
286 (validate-superclass abstract-class standard-class
)
287 (validate-superclass standard-class abstract-class
)
294 (defgeneric copy-instance
(instance &optional subclass
)
295 (:documentation
"Return a copy of INSTANCE.
296 Copy is either an object of INSTANCE's class, or INSTANCE's SUBCLASS if given.")
297 (:method
(instance &optional subclass
)
298 "Return a copy of INSTANCE.
299 Both instances share the same slot values."
300 (let* ((class (class-of instance
))
301 (slots (class-slots class
))
302 (new-instance (make-instance (or subclass class
))))
303 (loop :for slot
:in slots
304 :when
(slot-boundp instance
(slot-definition-name slot
))
305 :do
(setf (slot-value new-instance
(slot-definition-name slot
))
306 (slot-value instance
(slot-definition-name slot
))))
311 ;; ==========================================================================
312 ;; System-related utilities
313 ;; ==========================================================================
315 (defun home-directory ()
316 "Return user's home directory in canonical form."
317 (truename (user-homedir-pathname)))
320 "Return t if running on Mac OS."
321 (string= (software-type) "Darwin"))
325 ;; ==========================================================================
326 ;; Wrappers around non ANSI features
327 ;; ==========================================================================
330 (defgeneric stream-file-stream
(stream &optional direction
)
331 (:documentation
"Convert STREAM to a file-stream.")
332 (:method
((stream file-stream
) &optional direction
)
333 (declare (ignore direction
))
335 (:method
((stream synonym-stream
) &optional direction
)
336 (declare (ignore direction
))
337 (stream-file-stream (symbol-value (synonym-stream-symbol stream
))))
338 (:method
((stream two-way-stream
) &optional direction
)
341 (:input
(two-way-stream-input-stream stream
))
342 (:output
(two-way-stream-output-stream stream
))
344 (error "Cannot extract file-stream from TWO-WAY-STREAM ~A:
345 invalid direction: ~S"
350 (defun fd-line-width (fd)
351 "Get the line width for FD (file descriptor).
353 - the line width, or -1 if it can't be computed
354 (typically when FD does not denote a tty),
355 - an error message if the operation failed."
356 (ffi:c-inline
(fd) (:int
) (values :int
:cstring
) "{
362 struct winsize window;
363 if (ioctl (fd, TIOCGWINSZ, &window) == -1)
366 msg = strerror (errno);
369 cols = (int) window.ws_col;
375 (defun stream-line-width (stream)
376 "Get STREAM's line width.
378 - the stream's line width, or nil if it can't be computed
379 (typically when the stream does not denote a tty),
380 - an error message if the operation failed."
381 ;; #### NOTE: doing a TIOCGWINSZ ioctl here is a convenient way to both know
382 ;; whether we're connected to a tty, and getting the terminal width at the
383 ;; same time. In case the ioctl fails, we need to distinguish between and
384 ;; ENOTTY error, which simply means that we're not connected to a terminal,
385 ;; and the other which are real errors and need to be reported.
388 (locally (declare (sb-ext:muffle-conditions sb-ext
:compiler-note
))
390 (with-winsize winsize
()
391 (sb-posix:ioctl
(stream-file-stream stream
:output
)
394 (winsize-ws-col winsize
))
395 (sb-posix:syscall-error
(error)
396 (unless (= (sb-posix:syscall-errno error
) sb-posix
:enotty
)
397 (values nil error
)))))
399 (locally (declare (optimize (ext:inhibit-warnings
3)))
400 (alien:with-alien
((winsize (alien:struct unix
:winsize
)))
401 (multiple-value-bind (success error-number
)
403 (system:fd-stream-fd
(stream-file-stream stream
:output
))
407 (alien:slot winsize
'unix
:ws-col
)
408 (unless (= error-number unix
:enotty
)
409 (values nil
(unix:get-unix-error-msg error-number
)))))))
411 (ccl:rlet
((winsize :winsize
))
414 (#_ioctl
(ccl::stream-device stream
:output
)
418 (ccl:pref winsize
:winsize.ws_col
)
419 (unless (= result
(- #$ENOTTY
))
420 (values nil
(ccl::%strerror
(- result
)))))))
422 (multiple-value-bind (cols msg
)
423 (fd-line-width (ext:file-stream-fd stream
))
424 (values (unless (= cols -
1) cols
) msg
))
426 (multiple-value-bind (input-fd output-fd
)
427 (ext:stream-handles stream
)
429 (cffi:with-foreign-object
(winsize 'winsize
)
430 (let ((result (cffi:foreign-funcall
"ioctl"
436 (unless (= +errno
+ +enotty
+)
438 (cffi:foreign-funcall
"strerror"
439 :int
+errno
+ :string
)))
440 (cffi:with-foreign-slots
((ws-col) winsize winsize
)
445 (defun exit (&optional
(status 0))
446 "Quit the current application with STATUS."
448 #+sbcl
(sb-ext:quit
:unix-status status
)
449 #+cmu
(unix:unix-exit status
)
450 #+ccl
(ccl:quit status
)
451 #+ecl
(ext:quit status
)
452 #+clisp
(ext:exit status
)
453 #+abcl
(extensions:exit
:status status
))
456 "Get the current application's command-line."
458 #+sbcl sb-ext
:*posix-argv
*
459 #+cmu lisp
::lisp-command-line-list
460 #+ccl ccl
::*command-line-argument-list
*
461 #+ecl
(ext:command-args
)
462 #+clisp
(cons (aref (ext:argv
) 0) ext
:*args
*)
463 #+abcl
(cons "abcl" extensions
:*command-line-argument-list
*))
465 (defun getenv (variable)
466 "Get environment VARIABLE's value. VARIABLE may be null."
469 (#+sbcl sb-posix
:getenv
470 #+cmu unix
:unix-getenv
474 #+abcl extensions
:getenv
477 ;; #### NOTE: JAVA doesn't provide a way to set an environment variable. I've
478 ;; seen tricks around to modify the startup environment memory mapping instead
479 ;; of doing a real putenv, but I'll just disable the "modify-environment"
480 ;; restart in environ.lisp for now.
482 (defun putenv (variable value
)
483 "Set environment VARIABLE to VALUE."
485 #+sbcl
(sb-posix:putenv
(concatenate 'string variable
"=" value
))
486 #+cmu
(unix:unix-putenv
(concatenate 'string variable
"=" value
))
487 #+ccl
(ccl:setenv variable value
)
488 #+ecl
(ext:setenv variable value
)
489 #+clisp
(setf (ext:getenv variable
) value
))
491 (defmacro dump
(name function
)
492 "Dump a standalone executable named NAME starting with FUNCTION.
493 ECL doesn't create executables by dumping a Lisp image, but relies on having
494 toplevel code to execute instead, so this macro simply expands to a call to
497 #+ecl
(declare (ignore name
))
498 #+sbcl
`(sb-ext:save-lisp-and-die
,name
499 :toplevel
#',function
501 :save-runtime-options t
)
502 #+cmu
`(ext:save-lisp
,name
503 :init-function
#',function
508 :process-command-line nil
)
509 #+ccl
`(ccl:save-application
,name
510 :toplevel-function
#',function
514 ;; #### NOTE: ECL works differently: it needs an entry point (i.e. actual
515 ;; code to execute) instead of a main function. So we expand DUMP to just
516 ;; call that function.
517 #+ecl
(list function
)
518 ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
520 (ext:saveinitmem
,name
521 :init-function
#',function
528 ;;; util.lisp ends here