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 (declare (ignore class superclass))
 232   #+abcl '(progn)
 233   #-abcl
 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))
 241     t))
 242
 243 (defun class-slots (class)
 244   "Return CLASS slots."
 245   ;; #### PORTME.
 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
 252    class))
 253
 254 (defun slot-definition-name (slot)
 255   "Return SLOT's definition name."
 256   ;; #### PORTME.
 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
 263    slot))
 264
 265
 266 ;; ----------------
 267 ;; Abstract classes
 268 ;; ----------------
 269
 270 (defclass abstract-class (standard-class)
 271   ()
 272   (:documentation "The ABSTRACT-CLASS class.
 273 This is the meta-class for abstract classes."))
 274
 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)))
 281
 282 (defmethod make-instance ((class abstract-class) &rest initargs)
 283   (declare (ignore initargs))
 284   (error "Instanciating class ~S: is abstract." (class-name class)))
 285
 286 (validate-superclass abstract-class standard-class)
 287 (validate-superclass standard-class abstract-class)
 288
 289
 290 ;; ----------------
 291 ;; Instance copying
 292 ;; ----------------
 293
 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))))
 307       new-instance)))
 308
 309
 310
 311 ;; ==========================================================================
 312 ;; System-related utilities
 313 ;; ==========================================================================
 314
 315 (defun home-directory ()
 316   "Return user's home directory in canonical form."
 317   (truename (user-homedir-pathname)))
 318
 319 (defun macosp ()
 320   "Return t if running on Mac OS."
 321   (string= (software-type) "Darwin"))
 322
 323
 324
 325 ;; ==========================================================================
 326 ;; Wrappers around non ANSI features
 327 ;; ==========================================================================
 328
 329 ;; Thanks Nikodemus!
 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))
 334     stream)
 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)
 339     (stream-file-stream
 340         (case direction
 341           (:input (two-way-stream-input-stream stream))
 342           (:output (two-way-stream-output-stream stream))
 343           (otherwise
 344            (error "Cannot extract file-stream from TWO-WAY-STREAM ~A:
 345 invalid direction: ~S"
 346                   stream direction)))
 347         direction)))
 348
 349 #+ecl
 350 (defun fd-line-width (fd)
 351   "Get the line width for FD (file descriptor).
 352 Return two values:
 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) "{
 357     int fd = #0;
 358
 359     int cols = -1;
 360     char *msg = NULL;
 361
 362     struct winsize window;
 363     if (ioctl (fd, TIOCGWINSZ, &window) == -1)
 364       {
 365         if (errno != ENOTTY)
 366           msg = strerror (errno);
 367       }
 368     else
 369       cols = (int) window.ws_col;
 370
 371     @(return 0) = cols;
 372     @(return 1) = msg;
 373 }"))
 374
 375 (defun stream-line-width (stream)
 376   "Get STREAM's line width.
 377 Return two values:
 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.
 386   ;; #### PORTME.
 387   #+sbcl
 388   (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
 389     (handler-case
 390         (with-winsize winsize ()
 391           (sb-posix:ioctl (stream-file-stream stream :output)
 392                           +tiocgwinsz+
 393                           winsize)
 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)))))
 398   #+cmu
 399   (locally (declare (optimize (ext:inhibit-warnings 3)))
 400     (alien:with-alien ((winsize (alien:struct unix:winsize)))
 401       (multiple-value-bind (success error-number)
 402           (unix:unix-ioctl
 403            (system:fd-stream-fd (stream-file-stream stream :output))
 404            unix:tiocgwinsz
 405            winsize)
 406         (if success
 407             (alien:slot winsize 'unix:ws-col)
 408           (unless (= error-number unix:enotty)
 409             (values nil (unix:get-unix-error-msg error-number)))))))
 410   #+ccl
 411   (ccl:rlet ((winsize :winsize))
 412     (let ((result
 413            (ccl::int-errno-call
 414             (#_ioctl (ccl::stream-device stream :output)
 415                      #$TIOCGWINSZ
 416                      :address winsize))))
 417       (if (zerop result)
 418           (ccl:pref winsize :winsize.ws_col)
 419         (unless (= result (- #$ENOTTY))
 420           (values nil (ccl::%strerror (- result)))))))
 421   #+ecl
 422   (multiple-value-bind (cols msg)
 423       (fd-line-width (ext:file-stream-fd stream))
 424     (values (unless (= cols -1) cols) msg))
 425   #+clisp
 426   (multiple-value-bind (input-fd output-fd)
 427       (ext:stream-handles stream)
 428     (when output-fd
 429       (cffi:with-foreign-object (winsize 'winsize)
 430         (let ((result (cffi:foreign-funcall "ioctl"
 431                                             :int output-fd
 432                                             :int +tiocgwinsz+
 433                                             :pointer winsize
 434                                             :int)))
 435           (if (= result -1)
 436               (unless (= +errno+ +enotty+)
 437                 (values nil
 438                         (cffi:foreign-funcall "strerror"
 439                                               :int +errno+ :string)))
 440             (cffi:with-foreign-slots ((ws-col) winsize winsize)
 441               ws-col)))))))
 442
 443 (defun exit (&optional (status 0))
 444   "Quit the current application with STATUS."
 445   ;; #### PORTME.
 446   #+sbcl  (sb-ext:quit :unix-status status)
 447   #+cmu   (unix:unix-exit status)
 448   #+ccl   (ccl:quit status)
 449   #+ecl   (ext:quit status)
 450   #+clisp (ext:exit status)
 451   #+abcl  (extensions:exit :status status))
 452
 453 (defun cmdline ()
 454   "Get the current application's command-line."
 455   ;; #### PORTME.
 456   #+sbcl  sb-ext:*posix-argv*
 457   #+cmu   lisp::lisp-command-line-list
 458   #+ccl   ccl::*command-line-argument-list*
 459   #+ecl   (ext:command-args)
 460   #+clisp (cons (aref (ext:argv) 0) ext:*args*))
 461
 462 (defun getenv (variable)
 463   "Get environment VARIABLE's value. VARIABLE may be null."
 464   ;; #### PORTME.
 465   (when variable
 466     (#+sbcl  sb-posix:getenv
 467      #+cmu   unix:unix-getenv
 468      #+ccl   ccl:getenv
 469      #+ecl   ext:getenv
 470      #+clisp ext:getenv
 471      #+abcl  extensions:getenv
 472      variable)))
 473
 474 ;; #### NOTE: JAVA doesn't provide a way to set an environment variable. I've
 475 ;; seen tricks around to modify the startup environment memory mapping instead
 476 ;; of doing a real putenv, but I'll just disable the "modify-environment"
 477 ;; restart in environ.lisp for now.
 478 #-abcl
 479 (defun putenv (variable value)
 480   "Set environment VARIABLE to VALUE."
 481   ;; #### PORTME.
 482   #+sbcl  (sb-posix:putenv  (concatenate 'string variable "=" value))
 483   #+cmu   (unix:unix-putenv (concatenate 'string variable "=" value))
 484   #+ccl   (ccl:setenv variable value)
 485   #+ecl   (ext:setenv variable value)
 486   #+clisp (setf (ext:getenv variable) value))
 487
 488 (defmacro dump (name function)
 489   "Dump a standalone executable named NAME starting with FUNCTION.
 490 ECL doesn't create executables by dumping a Lisp image, but relies on having
 491 toplevel code to execute instead, so this macro simply expands to a call to
 492 FUNCTION for ECL."
 493   ;; #### PORTME.
 494   #+ecl (declare (ignore name))
 495   #+sbcl  `(sb-ext:save-lisp-and-die ,name
 496             :toplevel #',function
 497             :executable t
 498             :save-runtime-options t)
 499   #+cmu   `(ext:save-lisp ,name
 500             :init-function #',function
 501             :executable t
 502             :load-init-file nil
 503             :site-init nil
 504             :print-herald nil
 505             :process-command-line nil)
 506   #+ccl   `(ccl:save-application ,name
 507             :toplevel-function #',function
 508             :init-file nil
 509             :error-handler :quit
 510             :prepend-kernel t)
 511   ;; #### NOTE: ECL works differently: it needs an entry point (i.e. actual
 512   ;; code to execute) instead of a main function. So we expand DUMP to just
 513   ;; call that function.
 514   #+ecl   (list function)
 515   ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
 516   #+clisp `(progn
 517             (ext:saveinitmem ,name
 518              :init-function #',function
 519              :executable 0
 520              :quiet t
 521              :norc t)
 522             (exit)))
 523
 524
 525 ;;; util.lisp ends here