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 ;; ==========================================================================
  38 ;; Miscellaneous Auxiliary Routines
  39 ;; ==========================================================================
  40
  41 (defmacro econd (&body clauses)
  42   "Like COND, but signal an error if no clause evaluates to t."
  43   `(cond ,@(append clauses
  44                    '((t (error "Fell out of ECOND clauses."))))))
  45
  46 (defmacro endpush (object place)
  47   "Like push, but at the end."
  48   `(setf ,place (nconc ,place (list ,object))))
  49
  50 (defmacro maybe-push (object place)
  51   "Like push, but only if OBJECT is non-nil."
  52   (let ((the-object (gensym "object")))
  53     `(let ((,the-object ,object))
  54       (when ,the-object (push ,the-object ,place)))))
  55
  56 (defmacro accumulate ((initial-value) &body body)
  57   "Accumulate BODY forms in a list beginning with INITIAL-VALUE.
  58 INITIAL-VALUE is not evaluated. BODY forms are accumulated only when their
  59 value is non-nil.
  60 If nothing to accumulate, then return nil instead of the list of
  61 INITIAL-VALUE."
  62   (let ((place (gensym "place"))
  63         (initial-place (gensym "initial-place")))
  64     `(let* ((,place (list ',initial-value))
  65             (,initial-place ,place))
  66       ,@(mapcar (lambda (body-form)
  67                   `(maybe-push ,body-form ,place))
  68                 body)
  69       (when (not (eq ,initial-place ,place))
  70         (nreverse ,place)))))
  71
  72 (defun beginning-of-string-p (beginning string &optional ignore-case)
  73   "Check that STRING starts with BEGINNING.
  74 If IGNORE-CASE, well, ignore case."
  75   (let ((length (length beginning)))
  76     (and (>= (length string) length)
  77          (funcall (if ignore-case #'string-equal #'string=)
  78                   beginning string :end2 length))))
  79
  80 (defun closest-match (match list &key ignore-case (key #'identity))
  81   "Return the LIST element closest to MATCH, or nil.
  82 If IGNORE-CASE, well, ignore case.
  83 KEY should provide a way to get a string from each LIST element."
  84   (let ((match-length (length match))
  85         (shortest-distance most-positive-fixnum)
  86         closest-match)
  87     (dolist (elt list)
  88       (let ((elt-string (funcall key elt))
  89             distance)
  90         (when (and (beginning-of-string-p match elt-string ignore-case)
  91                    (< (setq distance (- (length elt-string) match-length))
  92                       shortest-distance))
  93           (setq shortest-distance distance)
  94           (setq closest-match elt))))
  95     closest-match))
  96
  97 (defun complete-string (beginning complete)
  98   "Complete BEGINNING with the rest of COMPLETE in parentheses.
  99 For instance, completing 'he' with 'help' will produce 'he(lp)'."
 100   (assert (beginning-of-string-p beginning complete))
 101   (assert (not (string= beginning complete)))
 102   (concatenate 'string beginning "(" (subseq complete (length beginning)) ")"))
 103
 104 (defun list-to-string (list &key (key #'identity) (separator ", "))
 105   "Return a SEPARATOR-separated string of all LIST elements.
 106 - KEY should provide a way to get a string from each LIST element.
 107 - SEPARATOR is the string to insert between elements."
 108   (reduce (lambda (str1 str2) (concatenate 'string str1 separator str2))
 109           list
 110           :key key))
 111
 112
 113
 114 ;; ==========================================================================
 115 ;; Key-Value Pairs Manipulation
 116 ;; ==========================================================================
 117
 118 (defun select-keys (keys &rest selected)
 119   "Return a new property list from KEYS with only SELECTED ones."
 120   (loop :for key :in keys :by #'cddr
 121         :for val :in (cdr keys) :by #'cddr
 122         :when (member key selected)
 123         :nconc (list key val)))
 124
 125 (defun remove-keys (keys &rest removed)
 126   "Return a new property list from KEYS without REMOVED ones."
 127   (loop :for key :in keys :by #'cddr
 128         :for val :in (cdr keys) :by #'cddr
 129         :unless (member key removed)
 130         :nconc (list key val)))
 131
 132 (defmacro replace-in-keys ((key val) keys the-key form)
 133   "Replace every occurrence of THE-KEY in KEYS with FORM.
 134 At every KEYS round, KEY and VAL are bound to the current key-value pair.
 135 FORM is evaluated each time and should return a key-value list."
 136   `(loop :for ,key :in ,keys :by #'cddr
 137     :for ,val :in (cdr ,keys) :by #'cddr
 138     :if (eql ,key ,the-key)
 139     :append ,form
 140     :else
 141     :nconc (list ,key ,val)))
 142
 143 ;; #### NOTE: that's the typical situation where I would like a
 144 ;; destructuring-cond, but it seems difficult to do so because of the
 145 ;; standard imprecision of the reported error in case of a pattern matching
 146 ;; failure.
 147 ;; #### NOTE: I could extend this utility by supporting a global :test, or
 148 ;; even a per-replacement local one.
 149 (defun replace-key (replacement keys)
 150   "Return a new property list from KEYS with REPLACEMENT.
 151 REPLACEMENT can take the following forms:
 152 - :KEY
 153   The effect is to remove :KEY from KEYS, as per REMOVE-KEYS.
 154 - (:KEY :NEW-KEY)
 155   The effect is to replace :KEY with :NEW-KEY, leaving the values unchanged.
 156 - (:KEY :NEW-KEY (VAL-OR-VALS NEW-VAL)*), with VAL-OR-VALS being
 157   either a value or a list of values. The effect is to replace :KEY with
 158   :NEW-KEY and a value matching one of the VAL-OR-VALS with the
 159   corresponding NEW-VAL. Values not matching any VAL-OR-VALS remain unchanged.
 160 - (:KEY (VAL-OR-VALS :NEW-KEY NEW-VAL...)*), with VAL-OR-VALS as above. The
 161   effect is the same as above, but :NEW-KEY additionally depends on the
 162   matched value. If multiple :NEW-KEY NEW-VAL couples are provided, that many
 163   new keys are inserted along with their values. For values not matching any
 164   VAL-OR-VALS, :KEY and its value remain unchanged."
 165   (econd ((symbolp replacement)
 166           (remove-keys keys replacement))
 167          ((and (consp replacement)
 168                (= (length replacement) 2)
 169                (symbolp (car replacement))
 170                (symbolp (cadr replacement)))
 171           (destructuring-bind (old-key new-key) replacement
 172             (replace-in-keys (key val) keys old-key
 173               (list new-key val))))
 174          ((and (consp replacement)
 175                (> (length replacement) 2)
 176                (symbolp (car replacement))
 177                (symbolp (cadr replacement)))
 178           (destructuring-bind (old-key new-key &rest replacements) replacement
 179             (replace-in-keys (key val) keys old-key
 180               (list new-key
 181                     (let ((match
 182                            (assoc val replacements
 183                                   :test (lambda (val val-or-vals)
 184                                           (if (consp val-or-vals)
 185                                               (member val val-or-vals)
 186                                               (eql val val-or-vals))))))
 187                       (if match (cadr match) val))))))
 188          ((and (consp replacement)
 189                (> (length replacement) 1)
 190                (symbolp (car replacement)))
 191           (destructuring-bind (old-key &rest replacements) replacement
 192             (replace-in-keys (key val) keys old-key
 193               (let ((match (assoc val replacements
 194                                   :test (lambda (val val-or-vals)
 195                                           (if (consp val-or-vals)
 196                                               (member val val-or-vals)
 197                                               (eql val val-or-vals))))))
 198                 (if match
 199                     (cdr match)
 200                     (list key val))))))))
 201
 202 (defun replace-keys (keys &rest replacements)
 203   "Return a new property list from KEYS with REPLACEMENTS.
 204 See REPLACE-KEY for more information on the replacement syntax."
 205   (let ((new-keys keys))
 206     (dolist (replacement replacements)
 207       (setq new-keys (replace-key replacement new-keys)))
 208     new-keys))
 209
 210
 211
 212 ;; ==========================================================================
 213 ;; CLOS Utility Routines
 214 ;; ==========================================================================
 215
 216 ;; --------------------
 217 ;; Portability wrappers
 218 ;; --------------------
 219
 220 (defmacro validate-superclass (class superclass)
 221   "Validate SUPERCLASS classes for CLASS classes."
 222   ;; #### PORTME.
 223   `(defmethod #+sbcl  sb-mop:validate-superclass
 224               #+cmu   mop:validate-superclass
 225               #+clisp clos:validate-superclass
 226               #+ccl   ccl:validate-superclass
 227     ((class ,class) (superclass ,superclass))
 228     t))
 229
 230 (defun class-slots (class)
 231   "Return CLASS slots."
 232   ;; #### PORTME.
 233   (#+sbcl  sb-mop:class-slots
 234    #+cmu   mop:class-slots
 235    #+clisp clos:class-slots
 236    #+ccl   ccl:class-slots
 237    class))
 238
 239 (defun slot-definition-name (slot)
 240   "Return SLOT's definition name."
 241   ;; #### PORTME.
 242   (#+sbcl  sb-mop:slot-definition-name
 243    #+cmu   mop:slot-definition-name
 244    #+clisp clos:slot-definition-name
 245    #+ccl   ccl:slot-definition-name
 246    slot))
 247
 248
 249 ;; ----------------
 250 ;; Abstract classes
 251 ;; ----------------
 252
 253 (defclass abstract-class (standard-class)
 254   ()
 255   (:documentation "The ABSTRACT-CLASS class.
 256 This is the meta-class for abstract classes."))
 257
 258 (defmacro defabstract (class super-classes slots &rest options)
 259   "Like DEFCLASS, but define an abstract class."
 260   (when (assoc :metaclass options)
 261     (error "Defining abstract class ~S: explicit meta-class option." class))
 262   `(defclass ,class ,super-classes ,slots ,@options
 263     (:metaclass abstract-class)))
 264
 265 (defmethod make-instance ((class abstract-class) &rest initargs)
 266   (declare (ignore initargs))
 267   (error "Instanciating class ~S: is abstract." (class-name class)))
 268
 269 (validate-superclass abstract-class standard-class)
 270 (validate-superclass standard-class abstract-class)
 271
 272
 273 ;; ----------------
 274 ;; Instance copying
 275 ;; ----------------
 276
 277 (defgeneric copy-instance (instance &optional subclass)
 278   (:documentation "Return a copy of INSTANCE.
 279 Copy is either an object of INSTANCE's class, or INSTANCE's SUBCLASS if given.")
 280   (:method (instance &optional subclass)
 281     "Return a copy of INSTANCE.
 282 Both instances share the same slot values."
 283     (let* ((class (class-of instance))
 284            (slots (class-slots class))
 285            (new-instance (make-instance (or subclass class))))
 286       (loop :for slot :in slots
 287             :when (slot-boundp instance (slot-definition-name slot))
 288             :do (setf (slot-value new-instance (slot-definition-name slot))
 289                       (slot-value instance (slot-definition-name slot))))
 290       new-instance)))
 291
 292
 293
 294 ;; ==========================================================================
 295 ;; Stream to file-stream conversion (thanks Nikodemus !)
 296 ;; ==========================================================================
 297
 298 (defgeneric stream-file-stream (stream &optional direction)
 299   (:documentation "Convert STREAM to a file-stream.")
 300   (:method ((stream file-stream) &optional direction)
 301     (declare (ignore direction))
 302     stream)
 303   (:method ((stream synonym-stream) &optional direction)
 304     (declare (ignore direction))
 305     (stream-file-stream (symbol-value (synonym-stream-symbol stream))))
 306   (:method ((stream two-way-stream) &optional direction)
 307     (stream-file-stream
 308         (case direction
 309           (:input (two-way-stream-input-stream stream))
 310           (:output (two-way-stream-output-stream stream))
 311           (otherwise
 312            (error "Cannot extract file-stream from TWO-WAY-STREAM ~A:
 313 invalid direction: ~S"
 314                   stream direction)))
 315         direction)))
 316
 317
 318
 319 ;; ==========================================================================
 320 ;; Wrappers around non ANSI features and operating system stuff
 321 ;; ==========================================================================
 322
 323 (defun home-directory ()
 324   "Return user's home directory in canonical form."
 325   (truename (user-homedir-pathname)))
 326
 327 (defun macosp ()
 328   "Return t if running on Mac OS."
 329   (string= (software-type) "Darwin"))
 330
 331 (defun exit (&optional (status 0))
 332   "Quit the current application with STATUS."
 333   ;; #### PORTME.
 334   #+sbcl  (sb-ext:quit :unix-status status)
 335   #+cmu   (unix:unix-exit status)
 336   #+clisp (ext:exit status)
 337   #+ccl   (ccl:quit status))
 338
 339 (defun cmdline ()
 340   "Get the current application's command-line."
 341   ;; #### PORTME.
 342   #+sbcl  sb-ext:*posix-argv*
 343   #+cmu   lisp::lisp-command-line-list
 344   #+clisp (cons (aref (ext:argv) 0) ext:*args*)
 345   #+ccl   ccl::*command-line-argument-list*)
 346
 347 (defun getenv (variable)
 348   "Get environment VARIABLE's value. VARIABLE may be null."
 349   ;; #### PORTME.
 350   (when variable
 351     (#+sbcl  sb-posix:getenv
 352      #+cmu   unix:unix-getenv
 353      #+clisp ext:getenv
 354      #+ccl   ccl:getenv
 355      variable)))
 356
 357 (defun putenv (variable value)
 358   "Set environment VARIABLE to VALUE."
 359   ;; #### PORTME.
 360   #+sbcl  (sb-posix:putenv  (concatenate 'string variable "=" value))
 361   #+cmu   (unix:unix-putenv (concatenate 'string variable "=" value))
 362   #+clisp (setf (ext:getenv variable) value)
 363   #+ccl   (ccl:setenv variable value))
 364
 365 (defun dump (name function)
 366   "Dump a standalone executable named NAME starting with FUNCTION."
 367   ;; #### PORTME.
 368   #+sbcl  (sb-ext:save-lisp-and-die name :toplevel function :executable t
 369                                     :save-runtime-options t)
 370   #+cmu   (ext:save-lisp name :init-function function :executable t
 371                          :load-init-file nil :site-init nil
 372                          :print-herald nil :process-command-line nil)
 373   ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
 374   #+clisp (progn
 375             (ext:saveinitmem name
 376               :init-function function :executable 0 :quiet t :norc t)
 377             (exit))
 378   #+ccl   (ccl:save-application name :toplevel-function function
 379                                 :init-file nil :prepend-kernel t))
 380
 381
 382 ;;; util.lisp ends here