src/util.lisp

   1 ;;; util.lisp --- General utilities
   2
   3 ;; Copyright (C) 2010, 2011, 2012 Didier Verna.
   4
   5 ;; Author:     Didier Verna <didier@lrde.epita.fr>
   6 ;; Maintainer: Didier Verna <didier@lrde.epita.fr>
   7
   8 ;; This file is part of Clon.
   9
  10 ;; Permission to use, copy, modify, and distribute this software for any
  11 ;; purpose with or without fee is hereby granted, provided that the above
  12 ;; copyright notice and this permission notice appear in all copies.
  13
  14 ;; THIS SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  15 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  16 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  17 ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  18 ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  19 ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21
  22
  23 ;;; Commentary:
  24
  25 ;; Contents management by FCM version 0.1.
  26
  27
  28 ;;; Code:
  29
  30 (in-package :com.dvlsoft.clon)
  31 (in-readtable :com.dvlsoft.clon)
  32
  33
  34 ;; ==========================================================================
  35 ;; Miscellaneous Auxiliary Routines
  36 ;; ==========================================================================
  37
  38 #i(econd cond)
  39 (defmacro econd (&body clauses)
  40   "Like COND, but signal an error if no clause evaluates to t."
  41   `(cond ,@(append clauses
  42             '((t (error "Fell out of ECOND clauses."))))))
  43
  44 (defmacro endpush (object place)
  45   "Like push, but at the end."
  46   `(setf ,place (nconc ,place (list ,object))))
  47
  48 (defmacro maybe-push (object place &aux (the-object (gensym "object")))
  49   "Like push, but only if OBJECT is non-nil."
  50   `(let ((,the-object ,object))
  51      (when ,the-object (push ,the-object ,place))))
  52
  53 (defmacro accumulate
  54     ((initial-value) &body body
  55                      &aux (place (gensym "place"))
  56                           (initial-place (gensym "initial-place")))
  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 (list ',initial-value))
  63           (,initial-place ,place))
  64      ,@(mapcar (lambda (body-form)
  65                  `(maybe-push ,body-form ,place))
  66                body)
  67      (when (not (eq ,initial-place ,place))
  68        (nreverse ,place))))
  69
  70 (defun beginning-of-string-p
  71     (beginning string &optional ignore-case &aux (length (length beginning)))
  72   "Check that STRING starts with BEGINNING.
  73 If IGNORE-CASE, well, ignore case."
  74   (and (>= (length string) length)
  75        (funcall (if ignore-case #'string-equal #'string=)
  76                 beginning string :end2 length)))
  77
  78 #i(closest-match 2)
  79 (defun closest-match
  80     (match list &key ignore-case (key #'identity)
  81                 &aux (match-length (length match))
  82                      (shortest-distance most-positive-fixnum)
  83                      closest-match)
  84   "Return the LIST element closest to MATCH, or nil.
  85 If IGNORE-CASE, well, ignore case.
  86 KEY should provide a way to get a string from each LIST element."
  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 #i(select-keys 1)
 119 (defun select-keys (keys &rest selected)
 120   "Return a new property list from KEYS with only SELECTED ones."
 121   (loop :for key :in keys :by #'cddr
 122         :for val :in (cdr keys) :by #'cddr
 123         :when (member key selected)
 124           :nconc (list key val)))
 125
 126 #i(remove-keys 1)
 127 (defun remove-keys (keys &rest removed)
 128   "Return a new property list from KEYS without REMOVED ones."
 129   (loop :for key :in keys :by #'cddr
 130         :for val :in (cdr keys) :by #'cddr
 131         :unless (member key removed)
 132           :nconc (list key val)))
 133
 134 #i(replace-in-keys 3)
 135 (defmacro replace-in-keys ((key val) keys the-key form)
 136   "Replace every occurrence of THE-KEY in KEYS with FORM.
 137 At every KEYS round, KEY and VAL are bound to the current key-value pair.
 138 FORM is evaluated each time and should return a key-value list."
 139   `(loop :for ,key :in ,keys :by #'cddr
 140          :for ,val :in (cdr ,keys) :by #'cddr
 141          :if (eql ,key ,the-key)
 142            :append ,form
 143          :else
 144            :nconc (list ,key ,val)))
 145
 146 ;; #### NOTE: that's the typical situation where I would like a
 147 ;; destructuring-cond, but it seems difficult to do so because of the
 148 ;; standard imprecision of the reported error in case of a pattern matching
 149 ;; failure.
 150 ;; #### NOTE: I could extend this utility by supporting a global :test, or
 151 ;; even a per-replacement local one.
 152 (defun replace-key (replacement keys)
 153   "Return a new property list from KEYS with REPLACEMENT.
 154 REPLACEMENT can take the following forms:
 155 - :KEY
 156   The effect is to remove :KEY from KEYS, as per REMOVE-KEYS.
 157 - (:KEY :NEW-KEY)
 158   The effect is to replace :KEY with :NEW-KEY, leaving the values unchanged.
 159 - (:KEY :NEW-KEY (VAL-OR-VALS NEW-VAL)*), with VAL-OR-VALS being
 160   either a value or a list of values. The effect is to replace :KEY with
 161   :NEW-KEY and a value matching one of the VAL-OR-VALS with the
 162   corresponding NEW-VAL. Values not matching any VAL-OR-VALS remain unchanged.
 163 - (:KEY (VAL-OR-VALS :NEW-KEY NEW-VAL...)*), with VAL-OR-VALS as above. The
 164   effect is the same as above, but :NEW-KEY additionally depends on the
 165   matched value. If multiple :NEW-KEY NEW-VAL couples are provided, that many
 166   new keys are inserted along with their values. For values not matching any
 167   VAL-OR-VALS, :KEY and its value remain unchanged."
 168   (econd ((symbolp replacement)
 169           (remove-keys keys replacement))
 170          ((and (consp replacement)
 171                (= (length replacement) 2)
 172                (symbolp (car replacement))
 173                (symbolp (cadr replacement)))
 174           (destructuring-bind (old-key new-key) replacement
 175             (replace-in-keys (key val) keys old-key
 176               (list new-key val))))
 177          ((and (consp replacement)
 178                (> (length replacement) 2)
 179                (symbolp (car replacement))
 180                (symbolp (cadr replacement)))
 181           (destructuring-bind (old-key new-key &rest replacements) replacement
 182             (replace-in-keys (key val) keys old-key
 183               (list new-key
 184                     (let ((match
 185                               (assoc val replacements
 186                                      :test (lambda (val val-or-vals)
 187                                              (if (consp val-or-vals)
 188                                                  (member val val-or-vals)
 189                                                (eql val val-or-vals))))))
 190                       (if match (cadr match) val))))))
 191          ((and (consp replacement)
 192                (> (length replacement) 1)
 193                (symbolp (car replacement)))
 194           (destructuring-bind (old-key &rest replacements) replacement
 195             (replace-in-keys (key val) keys old-key
 196               (let ((match (assoc val replacements
 197                                   :test (lambda (val val-or-vals)
 198                                           (if (consp val-or-vals)
 199                                               (member val val-or-vals)
 200                                             (eql val val-or-vals))))))
 201                 (if match
 202                     (cdr match)
 203                   (list key val))))))))
 204
 205 #i(replace-keys 1)
 206 (defun replace-keys (keys &rest replacements &aux (new-keys keys))
 207   "Return a new property list from KEYS with REPLACEMENTS.
 208 See REPLACE-KEY for more information on the replacement syntax."
 209   (dolist (replacement replacements)
 210     (setq new-keys (replace-key replacement new-keys)))
 211   new-keys)
 212
 213
 214
 215 ;; ==========================================================================
 216 ;; CLOS Utility Routines
 217 ;; ==========================================================================
 218
 219 ;; --------------------
 220 ;; Portability wrappers
 221 ;; --------------------
 222
 223 (defmacro declare-valid-superclass (class superclass)
 224   "Validate SUPERCLASS classes for CLASS classes."
 225   ;; #### PORTME.
 226   #+abcl (declare (ignore class superclass))
 227   #+abcl '(progn)
 228   #-abcl
 229   `(defmethod validate-superclass((class ,class) (superclass ,superclass))
 230      #+ecl (declare (ignore class superclass))
 231      t))
 232
 233
 234 ;; ----------------
 235 ;; Abstract classes
 236 ;; ----------------
 237
 238 (defclass abstract-class (standard-class)
 239   ()
 240   (:documentation "The ABSTRACT-CLASS class.
 241 This is the meta-class for abstract classes."))
 242
 243 (defmacro defabstract (class super-classes slots &rest options)
 244   "Like DEFCLASS, but define an abstract class."
 245   (when (assoc :metaclass options)
 246     (error "Defining abstract class ~S: explicit meta-class option." class))
 247   `(defclass ,class ,super-classes ,slots ,@options
 248              (:metaclass abstract-class)))
 249
 250 (defmethod make-instance ((class abstract-class) &rest initargs)
 251   (declare (ignore initargs))
 252   (error "Instanciating class ~S: is abstract." (class-name class)))
 253
 254 (declare-valid-superclass abstract-class standard-class)
 255 (declare-valid-superclass standard-class abstract-class)
 256
 257
 258 ;; ----------------
 259 ;; Instance copying
 260 ;; ----------------
 261
 262 (defgeneric copy-instance (instance &optional subclass)
 263   (:documentation "Return a copy of INSTANCE.
 264 Copy is either an object of INSTANCE's class, or INSTANCE's SUBCLASS if given.")
 265   (:method (instance &optional subclass)
 266     "Return a copy of INSTANCE.
 267 Both instances share the same slot values."
 268     (let* ((class (class-of instance))
 269            (slots (class-slots class))
 270            (new-instance (make-instance (or subclass class))))
 271       (loop :for slot :in slots
 272             :when (slot-boundp instance (slot-definition-name slot))
 273               :do (setf (slot-value new-instance (slot-definition-name slot))
 274                         (slot-value instance (slot-definition-name slot))))
 275       new-instance)))
 276
 277
 278
 279 ;; ==========================================================================
 280 ;; System-related utilities
 281 ;; ==========================================================================
 282
 283 (defun home-directory ()
 284   "Return user's home directory in canonical form."
 285   (truename (user-homedir-pathname)))
 286
 287 (defun macosp ()
 288   "Return t if running on Mac OS."
 289   (string= (software-type) "Darwin"))
 290
 291
 292
 293 ;; ==========================================================================
 294 ;; Wrappers around non ANSI features
 295 ;; ==========================================================================
 296
 297 (defun exit (&optional (status 0))
 298   "Quit the current application with STATUS."
 299   ;; #### PORTME.
 300   #+sbcl  (sb-ext:quit :unix-status status)
 301   #+cmu   (unix:unix-exit status)
 302   #+ccl   (ccl:quit status)
 303   #+ecl   (ext:quit status)
 304   #+clisp (ext:exit status)
 305   #+abcl  (extensions:exit :status status))
 306
 307 (defvar *executablep* nil
 308   "Whether the current Lisp image is a standalone executable dumped by Clon.
 309 This information is needed in some implementations that treat their
 310 command-line differently in dumped images.")
 311
 312 (defun cmdline ()
 313   "Get the current application's command-line.
 314 This command-line is not supposed to contain any Lisp implementation specific
 315 option; only user-level ones. When a standalone executable is dumped, this is
 316 always the case. When used interactively, this depends on the underlying Lisp
 317 implementation. See appendix A.5 of the user manual for more information."
 318   ;; #### PORTME.
 319   #+sbcl  sb-ext:*posix-argv*
 320   #+cmu   (if *executablep*
 321               lisp::lisp-command-line-list
 322             (cons (car lisp::lisp-command-line-list)
 323                   ext:*command-line-application-arguments*))
 324   #+ccl   (if *executablep*
 325               ccl:*command-line-argument-list*
 326             (cons (car ccl:*command-line-argument-list*)
 327                   ccl:*unprocessed-command-line-arguments*))
 328   #+ecl   (if *executablep*
 329               (ext:command-args)
 330             (cons (car (ext:command-args))
 331                   (cdr (member "--" (ext:command-args) :test #'string=))))
 332   #+clisp (cons (aref (ext:argv) 0) ext:*args*)
 333   ;; #### NOTE: the trickery below is here to make CMDLINE work even when Clon
 334   ;; is loaded into ABCL without dumping the Clon way (see
 335   ;; +ABCL-MAIN-CLASS-TEMPLATE+).
 336   #+abcl  (cons (or (let ((symbol (find-symbol "*ARGV0*" 'extensions)))
 337                       (when symbol
 338                         (symbol-value symbol)))
 339                     "abcl")
 340                 extensions:*command-line-argument-list*))
 341
 342 (defun getenv (variable)
 343   "Get environment VARIABLE's value. VARIABLE may be null."
 344   ;; #### PORTME.
 345   (when variable
 346     (#+sbcl  sb-posix:getenv
 347      #+cmu   unix:unix-getenv
 348      #+ccl   ccl:getenv
 349      #+ecl   ext:getenv
 350      #+clisp ext:getenv
 351      #+abcl  extensions:getenv
 352      variable)))
 353
 354 ;; #### NOTE: JAVA doesn't provide a way to set an environment variable. I've
 355 ;; seen tricks around to modify the startup environment memory mapping instead
 356 ;; of doing a real putenv, but I'll just disable the "modify-environment"
 357 ;; restart in environ.lisp for now.
 358 #-abcl
 359 (defun putenv (variable value)
 360   "Set environment VARIABLE to VALUE."
 361   ;; #### PORTME.
 362   #+sbcl  (sb-posix:putenv  (concatenate 'string variable "=" value))
 363   #+cmu   (unix:unix-putenv (concatenate 'string variable "=" value))
 364   #+ccl   (ccl:setenv variable value)
 365   #+ecl   (ext:setenv variable value)
 366   #+clisp (setf (ext:getenv variable) value))
 367
 368 #+abcl
 369 (defconstant +abcl-main-class-template+
 370   "import org.armedbear.lisp.*;
 371
 372 public class ~A
 373 {
 374     public static void main (final String[] argv)
 375     {
 376         Runnable r = new Runnable ()
 377             {
 378                 public void run()
 379                 {
 380                     try
 381                         {
 382                             LispObject cmdline = Lisp.NIL;
 383                             for (String arg : argv)
 384                                 cmdline = new Cons (arg, cmdline);
 385                             cmdline.nreverse ();
 386                             Lisp._COMMAND_LINE_ARGUMENT_LIST_.setSymbolValue
 387                                 (cmdline);
 388
 389                             Interpreter interpreter =
 390                               Interpreter.createInstance ();
 391                             interpreter.eval
 392                               (\"(defvar extensions::*argv0* \\\"~A\\\")\");
 393                             interpreter.eval
 394                               (\"(export 'extensions::*argv0* 'extensions)\");
 395
 396                             Load.loadSystemFile (\"/~A\", false, false, false);
 397                         }
 398                     catch (ProcessingTerminated e)
 399                         {
 400                             System.exit (e.getStatus ());
 401                         }
 402                 }
 403             };
 404
 405         new Thread (null, r, \"interpreter\", 4194304L).start();
 406     }
 407 }~%"
 408   "Main class template for ABCL.")
 409
 410 (defmacro dump (name function)
 411   "Dump a standalone executable named NAME starting with FUNCTION.
 412
 413 Since executable dumping is not available in all supported implementations,
 414 this function behaves differently in some cases, as described below.
 415
 416 - ECL doesn't create executables by dumping a Lisp image, but relies on having
 417   toplevel code to execute instead, so this macro simply expands to a call to
 418   FUNCTION.
 419 - ABCL can't dump executables at all because of the underlying Java
 420   implementation, so this macro expands to just (PROGN) but creates a Java
 421   class file with a main function that creates an interpreter, loads
 422   the file in which this macro call appears and calls FUNCTION."
 423   ;; #### PORTME.
 424   #+ecl (declare (ignore name))
 425   #+sbcl  `(progn
 426              (setq *executablep* t) ; not used but here for correctness
 427              (sb-ext:save-lisp-and-die ,name
 428                :toplevel #',function
 429                :executable t
 430                :save-runtime-options t))
 431   #+cmu   `(progn
 432              (setq *executablep* t)
 433              (ext:save-lisp ,name
 434                :init-function #',function
 435                :executable t
 436                :load-init-file nil
 437                :site-init nil
 438                :print-herald nil
 439                :process-command-line nil))
 440   #+ccl   `(progn
 441              (setq *executablep* t)
 442              (ccl:save-application ,name
 443                :toplevel-function #',function
 444                :init-file nil
 445                :error-handler :quit
 446                :prepend-kernel t))
 447   ;; #### NOTE: ECL works differently: it needs an entry point (i.e. actual
 448   ;; code to execute) instead of a main function. So we expand DUMP to just
 449   ;; call that function.
 450   #+ecl   `(progn
 451              (setq *executablep* t)
 452              (,function))
 453   ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
 454   #+clisp `(progn
 455              (setq *executablep* t) ; not used but here for correctness
 456              (ext:saveinitmem ,name
 457                :init-function #',function
 458                :executable 0
 459                :quiet t
 460                :norc t)
 461              (exit))
 462   #+abcl (if (configuration :dump)
 463              (let ((source-pathname (or *compile-file-pathname*
 464                                         *load-pathname*))
 465                    (class-name (copy-seq name)))
 466                (setf (aref class-name 0) (char-upcase (aref class-name 0)))
 467                (with-open-file
 468                    (*standard-output*
 469                     (merge-pathnames
 470                      (make-pathname :name class-name :type "java")
 471                      source-pathname)
 472                     :direction :output :if-exists :supersede)
 473                  (format t +abcl-main-class-template+
 474                    class-name name (namestring source-pathname)))
 475                '(progn))
 476            `(progn
 477               (setq *executablep* t) ; not used but here for correctness
 478               (,function))))
 479
 480
 481 ;;; util.lisp ends here