src/util.lisp

   1 ;;; util.lisp --- General utilities
   2
   3 ;; Copyright (C) 2010 Didier Verna
   4
   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
   9
  10 ;; This file is part of Clon.
  11
  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.
  15
  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.
  20
  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.
  24
  25
  26 ;;; Commentary:
  27
  28 ;; Contents management by FCM version 0.1.
  29
  30
  31 ;;; Code:
  32
  33 (in-package :com.dvlsoft.clon)
  34 (in-readtable :com.dvlsoft.clon)
  35
  36
  37 ;; Preamble C code needed for ECL's FD-LINE-WIDTH function.
  38 #+ecl (ffi:clines "
  39 #include <stdio.h>
  40 #include <errno.h>
  41 #include <sys/ioctl.h>")
  42
  43
  44
  45 ;; ==========================================================================
  46 ;; Miscellaneous Auxiliary Routines
  47 ;; ==========================================================================
  48
  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."))))))
  53
  54 (defmacro endpush (object place)
  55   "Like push, but at the end."
  56   `(setf ,place (nconc ,place (list ,object))))
  57
  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)))))
  63
  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
  67 value is non-nil.
  68 If nothing to accumulate, then return nil instead of the list of
  69 INITIAL-VALUE."
  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))
  76                 body)
  77       (when (not (eq ,initial-place ,place))
  78         (nreverse ,place)))))
  79
  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))))
  87
  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)
  94         closest-match)
  95     (dolist (elt list)
  96       (let ((elt-string (funcall key elt))
  97             distance)
  98         (when (and (beginning-of-string-p match elt-string ignore-case)
  99                    (< (setq distance (- (length elt-string) match-length))
 100                       shortest-distance))
 101           (setq shortest-distance distance)
 102           (setq closest-match elt))))
 103     closest-match))
 104
 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)) ")"))
 111
 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))
 117           list
 118           :key key))
 119
 120
 121
 122 ;; ==========================================================================
 123 ;; Key-Value Pairs Manipulation
 124 ;; ==========================================================================
 125
 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)))
 132
 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)))
 139
 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)
 147     :append ,form
 148     :else
 149     :nconc (list ,key ,val)))
 150
 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
 154 ;; failure.
 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:
 160 - :KEY
 161   The effect is to remove :KEY from KEYS, as per REMOVE-KEYS.
 162 - (:KEY :NEW-KEY)
 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
 188               (list new-key
 189                     (let ((match
 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))))))
 206                 (if match
 207                     (cdr match)
 208                     (list key val))))))))
 209
 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)))
 216     new-keys))
 217
 218
 219
 220 ;; ==========================================================================
 221 ;; CLOS Utility Routines
 222 ;; ==========================================================================
 223
 224 ;; --------------------
 225 ;; Portability wrappers
 226 ;; --------------------
 227
 228 (defmacro validate-superclass (class superclass)
 229   "Validate SUPERCLASS classes for CLASS classes."
 230   ;; #### PORTME.
 231   #+abcl '(progn)
 232   #-abcl
 233   `(defmethod #+sbcl  sb-mop:validate-superclass
 234               #+cmu   mop:validate-superclass
 235               #+ccl   ccl:validate-superclass
 236               #+ecl   clos:validate-superclass
 237               #+clisp clos:validate-superclass
 238     ((class ,class) (superclass ,superclass))
 239     #+ecl (declare (ignore class superclass))
 240     t))
 241
 242 (defun class-slots (class)
 243   "Return CLASS slots."
 244   ;; #### PORTME.
 245   (#+sbcl  sb-mop:class-slots
 246    #+cmu   mop:class-slots
 247    #+ccl   ccl:class-slots
 248    #+ecl   clos:class-slots
 249    #+clisp clos:class-slots
 250    #+abcl  mop:class-slots
 251    class))
 252
 253 (defun slot-definition-name (slot)
 254   "Return SLOT's definition name."
 255   ;; #### PORTME.
 256   (#+sbcl  sb-mop:slot-definition-name
 257    #+cmu   mop:slot-definition-name
 258    #+ccl   ccl:slot-definition-name
 259    #+ecl   clos:slot-definition-name
 260    #+clisp clos:slot-definition-name
 261    #+abcl  mop:slot-definition-name
 262    slot))
 263
 264
 265 ;; ----------------
 266 ;; Abstract classes
 267 ;; ----------------
 268
 269 (defclass abstract-class (standard-class)
 270   ()
 271   (:documentation "The ABSTRACT-CLASS class.
 272 This is the meta-class for abstract classes."))
 273
 274 (defmacro defabstract (class super-classes slots &rest options)
 275   "Like DEFCLASS, but define an abstract class."
 276   (when (assoc :metaclass options)
 277     (error "Defining abstract class ~S: explicit meta-class option." class))
 278   `(defclass ,class ,super-classes ,slots ,@options
 279     (:metaclass abstract-class)))
 280
 281 (defmethod make-instance ((class abstract-class) &rest initargs)
 282   (declare (ignore initargs))
 283   (error "Instanciating class ~S: is abstract." (class-name class)))
 284
 285 (validate-superclass abstract-class standard-class)
 286 (validate-superclass standard-class abstract-class)
 287
 288
 289 ;; ----------------
 290 ;; Instance copying
 291 ;; ----------------
 292
 293 (defgeneric copy-instance (instance &optional subclass)
 294   (:documentation "Return a copy of INSTANCE.
 295 Copy is either an object of INSTANCE's class, or INSTANCE's SUBCLASS if given.")
 296   (:method (instance &optional subclass)
 297     "Return a copy of INSTANCE.
 298 Both instances share the same slot values."
 299     (let* ((class (class-of instance))
 300            (slots (class-slots class))
 301            (new-instance (make-instance (or subclass class))))
 302       (loop :for slot :in slots
 303             :when (slot-boundp instance (slot-definition-name slot))
 304             :do (setf (slot-value new-instance (slot-definition-name slot))
 305                       (slot-value instance (slot-definition-name slot))))
 306       new-instance)))
 307
 308
 309
 310 ;; ==========================================================================
 311 ;; System-related utilities
 312 ;; ==========================================================================
 313
 314 (defun home-directory ()
 315   "Return user's home directory in canonical form."
 316   (truename (user-homedir-pathname)))
 317
 318 (defun macosp ()
 319   "Return t if running on Mac OS."
 320   (string= (software-type) "Darwin"))
 321
 322
 323
 324 ;; ==========================================================================
 325 ;; Wrappers around non ANSI features
 326 ;; ==========================================================================
 327
 328 ;; Thanks Nikodemus!
 329 (defgeneric stream-file-stream (stream &optional direction)
 330   (:documentation "Convert STREAM to a file-stream.")
 331   (:method ((stream file-stream) &optional direction)
 332     (declare (ignore direction))
 333     stream)
 334   (:method ((stream synonym-stream) &optional direction)
 335     (declare (ignore direction))
 336     (stream-file-stream (symbol-value (synonym-stream-symbol stream))))
 337   (:method ((stream two-way-stream) &optional direction)
 338     (stream-file-stream
 339         (case direction
 340           (:input (two-way-stream-input-stream stream))
 341           (:output (two-way-stream-output-stream stream))
 342           (otherwise
 343            (error "Cannot extract file-stream from TWO-WAY-STREAM ~A:
 344 invalid direction: ~S"
 345                   stream direction)))
 346         direction)))
 347
 348 #+ecl
 349 (defun fd-line-width (fd)
 350   "Get the line width for FD (file descriptor).
 351 Return two values:
 352 - the line width, or -1 if it can't be computed
 353   (typically when FD does not denote a tty),
 354 - an error message if the operation failed."
 355   (ffi:c-inline (fd) (:int) (values :int :cstring) "{
 356     int fd = #0;
 357
 358     int cols = -1;
 359     char *msg = NULL;
 360
 361     struct winsize window;
 362     if (ioctl (fd, TIOCGWINSZ, &window) == -1)
 363       {
 364         if (errno != ENOTTY)
 365           msg = strerror (errno);
 366       }
 367     else
 368       cols = (int) window.ws_col;
 369
 370     @(return 0) = cols;
 371     @(return 1) = msg;
 372 }"))
 373
 374 (defun stream-line-width (stream)
 375   "Get STREAM's line width.
 376 Return two values:
 377 - the stream's line width, or nil if it can't be computed
 378   (typically when the stream does not denote a tty),
 379 - an error message if the operation failed."
 380   ;; #### NOTE: doing a TIOCGWINSZ ioctl here is a convenient way to both know
 381   ;; whether we're connected to a tty, and getting the terminal width at the
 382   ;; same time. In case the ioctl fails, we need to distinguish between and
 383   ;; ENOTTY error, which simply means that we're not connected to a terminal,
 384   ;; and the other which are real errors and need to be reported.
 385   ;; #### PORTME.
 386   #+sbcl
 387   (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
 388     (handler-case
 389         (with-winsize winsize ()
 390           (sb-posix:ioctl (stream-file-stream stream :output)
 391                           +tiocgwinsz+
 392                           winsize)
 393           (winsize-ws-col winsize))
 394       (sb-posix:syscall-error (error)
 395         (unless (= (sb-posix:syscall-errno error) sb-posix:enotty)
 396           (values nil error)))))
 397   #+cmu
 398   (locally (declare (optimize (ext:inhibit-warnings 3)))
 399     (alien:with-alien ((winsize (alien:struct unix:winsize)))
 400       (multiple-value-bind (success error-number)
 401           (unix:unix-ioctl
 402            (system:fd-stream-fd (stream-file-stream stream :output))
 403            unix:tiocgwinsz
 404            winsize)
 405         (if success
 406             (alien:slot winsize 'unix:ws-col)
 407           (unless (= error-number unix:enotty)
 408             (values nil (unix:get-unix-error-msg error-number)))))))
 409   #+ccl
 410   (ccl:rlet ((winsize :winsize))
 411     (let ((result
 412            (ccl::int-errno-call
 413             (#_ioctl (ccl::stream-device stream :output)
 414                      #$TIOCGWINSZ
 415                      :address winsize))))
 416       (if (zerop result)
 417           (ccl:pref winsize :winsize.ws_col)
 418         (unless (= result (- #$ENOTTY))
 419           (values nil (ccl::%strerror (- result)))))))
 420   #+ecl
 421   (multiple-value-bind (cols msg)
 422       (fd-line-width (ext:file-stream-fd stream))
 423     (values (unless (= cols -1) cols) msg))
 424   #+clisp
 425   (multiple-value-bind (input-fd output-fd)
 426       (ext:stream-handles stream)
 427     (when output-fd
 428       (cffi:with-foreign-object (winsize 'winsize)
 429         (let ((result (cffi:foreign-funcall "ioctl"
 430                                             :int output-fd
 431                                             :int +tiocgwinsz+
 432                                             :pointer winsize
 433                                             :int)))
 434           (if (= result -1)
 435               (unless (= +errno+ +enotty+)
 436                 (values nil
 437                         (cffi:foreign-funcall "strerror"
 438                                               :int +errno+ :string)))
 439             (cffi:with-foreign-slots ((ws-col) winsize winsize)
 440               ws-col)))))))
 441
 442 (defun exit (&optional (status 0))
 443   "Quit the current application with STATUS."
 444   ;; #### PORTME.
 445   #+sbcl  (sb-ext:quit :unix-status status)
 446   #+cmu   (unix:unix-exit status)
 447   #+ccl   (ccl:quit status)
 448   #+ecl   (ext:quit status)
 449   #+clisp (ext:exit status)
 450   #+abcl  (extensions:exit :status status))
 451
 452 (defun cmdline ()
 453   "Get the current application's command-line."
 454   ;; #### PORTME.
 455   #+sbcl  sb-ext:*posix-argv*
 456   #+cmu   lisp::lisp-command-line-list
 457   #+ccl   ccl::*command-line-argument-list*
 458   #+ecl   (ext:command-args)
 459   #+clisp (cons (aref (ext:argv) 0) ext:*args*))
 460
 461 (defun getenv (variable)
 462   "Get environment VARIABLE's value. VARIABLE may be null."
 463   ;; #### PORTME.
 464   (when variable
 465     (#+sbcl  sb-posix:getenv
 466      #+cmu   unix:unix-getenv
 467      #+ccl   ccl:getenv
 468      #+ecl   ext:getenv
 469      #+clisp ext:getenv
 470      #+abcl  extensions:getenv
 471      variable)))
 472
 473 ;; #### NOTE: JAVA doesn't provide a way to set an environment variable. I've
 474 ;; seen tricks around to modify the startup environment memory mapping instead
 475 ;; of doing a real putenv, but I'll just disable the "modify-environment"
 476 ;; restart in environ.lisp for now.
 477 #-abcl
 478 (defun putenv (variable value)
 479   "Set environment VARIABLE to VALUE."
 480   ;; #### PORTME.
 481   #+sbcl  (sb-posix:putenv  (concatenate 'string variable "=" value))
 482   #+cmu   (unix:unix-putenv (concatenate 'string variable "=" value))
 483   #+ccl   (ccl:setenv variable value)
 484   #+ecl   (ext:setenv variable value)
 485   #+clisp (setf (ext:getenv variable) value))
 486
 487 (defmacro dump (name function)
 488   "Dump a standalone executable named NAME starting with FUNCTION.
 489 ECL doesn't create executables by dumping a Lisp image, but relies on having
 490 toplevel code to execute instead, so this macro simply expands to a call to
 491 FUNCTION for ECL."
 492   ;; #### PORTME.
 493   #+ecl (declare (ignore name))
 494   #+sbcl  `(sb-ext:save-lisp-and-die ,name
 495             :toplevel #',function
 496             :executable t
 497             :save-runtime-options t)
 498   #+cmu   `(ext:save-lisp ,name
 499             :init-function #',function
 500             :executable t
 501             :load-init-file nil
 502             :site-init nil
 503             :print-herald nil
 504             :process-command-line nil)
 505   #+ccl   `(ccl:save-application ,name
 506             :toplevel-function #',function
 507             :init-file nil
 508             :error-handler :quit
 509             :prepend-kernel t)
 510   ;; #### NOTE: ECL works differently: it needs an entry point (i.e. actual
 511   ;; code to execute) instead of a main function. So we expand DUMP to just
 512   ;; call that function.
 513   #+ecl   (list function)
 514   ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
 515   #+clisp `(progn
 516             (ext:saveinitmem ,name
 517              :init-function #',function
 518              :executable 0
 519              :quiet t
 520              :norc t)
 521             (exit)))
 522
 523
 524 ;;; util.lisp ends here