src/util.lisp

   1 ;;; util.lisp --- General utilities
   2
   3 ;; Copyright (C) 2010, 2011 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 ;; Preamble C code needed for ECL's FD-LINE-WIDTH function.
  35 #+ecl (ffi:clines "
  36 #include <stdio.h>
  37 #include <errno.h>
  38 #include <sys/ioctl.h>")
  39
  40
  41 ;; ==========================================================================
  42 ;; Miscellaneous Auxiliary Routines
  43 ;; ==========================================================================
  44
  45 #i(econd cond)
  46 (defmacro econd (&body clauses)
  47   "Like COND, but signal an error if no clause evaluates to t."
  48   `(cond ,@(append clauses
  49             '((t (error "Fell out of ECOND clauses."))))))
  50
  51 (defmacro endpush (object place)
  52   "Like push, but at the end."
  53   `(setf ,place (nconc ,place (list ,object))))
  54
  55 (defmacro maybe-push (object place &aux (the-object (gensym "object")))
  56   "Like push, but only if OBJECT is non-nil."
  57   `(let ((,the-object ,object))
  58      (when ,the-object (push ,the-object ,place))))
  59
  60 (defmacro accumulate
  61     ((initial-value) &body body
  62                      &aux (place (gensym "place"))
  63                           (initial-place (gensym "initial-place")))
  64   "Accumulate BODY forms in a list beginning with INITIAL-VALUE.
  65 INITIAL-VALUE is not evaluated. BODY forms are accumulated only when their
  66 value is non-nil.
  67 If nothing to accumulate, then return nil instead of the list of
  68 INITIAL-VALUE."
  69   `(let* ((,place (list ',initial-value))
  70           (,initial-place ,place))
  71      ,@(mapcar (lambda (body-form)
  72                  `(maybe-push ,body-form ,place))
  73                body)
  74      (when (not (eq ,initial-place ,place))
  75        (nreverse ,place))))
  76
  77 (defun beginning-of-string-p
  78     (beginning string &optional ignore-case &aux (length (length beginning)))
  79   "Check that STRING starts with BEGINNING.
  80 If IGNORE-CASE, well, ignore case."
  81   (and (>= (length string) length)
  82        (funcall (if ignore-case #'string-equal #'string=)
  83                 beginning string :end2 length)))
  84
  85 #i(closest-match 2)
  86 (defun closest-match
  87     (match list &key ignore-case (key #'identity)
  88                 &aux (match-length (length match))
  89                      (shortest-distance most-positive-fixnum)
  90                      closest-match)
  91   "Return the LIST element closest to MATCH, or nil.
  92 If IGNORE-CASE, well, ignore case.
  93 KEY should provide a way to get a string from each LIST element."
  94   (dolist (elt list)
  95     (let ((elt-string (funcall key elt))
  96           distance)
  97       (when (and (beginning-of-string-p match elt-string ignore-case)
  98                  (< (setq distance (- (length elt-string) match-length))
  99                     shortest-distance))
 100         (setq shortest-distance distance)
 101         (setq closest-match elt))))
 102   closest-match)
 103
 104 (defun complete-string (beginning complete)
 105   "Complete BEGINNING with the rest of COMPLETE in parentheses.
 106 For instance, completing 'he' with 'help' will produce 'he(lp)'."
 107   (assert (beginning-of-string-p beginning complete))
 108   (assert (not (string= beginning complete)))
 109   (concatenate 'string beginning "(" (subseq complete (length beginning)) ")"))
 110
 111 (defun list-to-string (list &key (key #'identity) (separator ", "))
 112   "Return a SEPARATOR-separated string of all LIST elements.
 113 - KEY should provide a way to get a string from each LIST element.
 114 - SEPARATOR is the string to insert between elements."
 115   (reduce (lambda (str1 str2) (concatenate 'string str1 separator str2))
 116       list
 117     :key key))
 118
 119
 120
 121 ;; ==========================================================================
 122 ;; Key-Value Pairs Manipulation
 123 ;; ==========================================================================
 124
 125 (defun select-keys (keys &rest selected)
 126   "Return a new property list from KEYS with only SELECTED ones."
 127   (loop :for key :in keys :by #'cddr
 128         :for val :in (cdr keys) :by #'cddr
 129         :when (member key selected)
 130           :nconc (list key val)))
 131
 132 (defun remove-keys (keys &rest removed)
 133   "Return a new property list from KEYS without REMOVED ones."
 134   (loop :for key :in keys :by #'cddr
 135         :for val :in (cdr keys) :by #'cddr
 136         :unless (member key removed)
 137           :nconc (list key val)))
 138
 139 #i(replace-in-keys 3)
 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 #i(replace-keys 1)
 211 (defun replace-keys (keys &rest replacements &aux (new-keys keys))
 212   "Return a new property list from KEYS with REPLACEMENTS.
 213 See REPLACE-KEY for more information on the replacement syntax."
 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 declare-valid-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 validate-superclass((class ,class) (superclass ,superclass))
 235      #+ecl (declare (ignore class superclass))
 236      t))
 237
 238
 239 ;; ----------------
 240 ;; Abstract classes
 241 ;; ----------------
 242
 243 (defclass abstract-class (standard-class)
 244   ()
 245   (:documentation "The ABSTRACT-CLASS class.
 246 This is the meta-class for abstract classes."))
 247
 248 (defmacro defabstract (class super-classes slots &rest options)
 249   "Like DEFCLASS, but define an abstract class."
 250   (when (assoc :metaclass options)
 251     (error "Defining abstract class ~S: explicit meta-class option." class))
 252   `(defclass ,class ,super-classes ,slots ,@options
 253              (:metaclass abstract-class)))
 254
 255 (defmethod make-instance ((class abstract-class) &rest initargs)
 256   (declare (ignore initargs))
 257   (error "Instanciating class ~S: is abstract." (class-name class)))
 258
 259 (declare-valid-superclass abstract-class standard-class)
 260 (declare-valid-superclass standard-class abstract-class)
 261
 262
 263 ;; ----------------
 264 ;; Instance copying
 265 ;; ----------------
 266
 267 (defgeneric copy-instance (instance &optional subclass)
 268   (:documentation "Return a copy of INSTANCE.
 269 Copy is either an object of INSTANCE's class, or INSTANCE's SUBCLASS if given.")
 270   (:method (instance &optional subclass)
 271     "Return a copy of INSTANCE.
 272 Both instances share the same slot values."
 273     (let* ((class (class-of instance))
 274            (slots (class-slots class))
 275            (new-instance (make-instance (or subclass class))))
 276       (loop :for slot :in slots
 277             :when (slot-boundp instance (slot-definition-name slot))
 278               :do (setf (slot-value new-instance (slot-definition-name slot))
 279                         (slot-value instance (slot-definition-name slot))))
 280       new-instance)))
 281
 282
 283
 284 ;; ==========================================================================
 285 ;; System-related utilities
 286 ;; ==========================================================================
 287
 288 (defun home-directory ()
 289   "Return user's home directory in canonical form."
 290   (truename (user-homedir-pathname)))
 291
 292 (defun macosp ()
 293   "Return t if running on Mac OS."
 294   (string= (software-type) "Darwin"))
 295
 296
 297
 298 ;; ==========================================================================
 299 ;; Wrappers around non ANSI features
 300 ;; ==========================================================================
 301
 302 ;; Thanks Nikodemus!
 303 (defgeneric stream-file-stream (stream &optional direction)
 304   (:documentation "Convert STREAM to a file-stream.")
 305   (:method ((stream file-stream) &optional direction)
 306     (declare (ignore direction))
 307     stream)
 308   (:method ((stream synonym-stream) &optional direction)
 309     (declare (ignore direction))
 310     (stream-file-stream (symbol-value (synonym-stream-symbol stream))))
 311   (:method ((stream two-way-stream) &optional direction)
 312     (stream-file-stream
 313      (case direction
 314        (:input (two-way-stream-input-stream stream))
 315        (:output (two-way-stream-output-stream stream))
 316        (otherwise
 317         (error "Cannot extract file-stream from TWO-WAY-STREAM ~A:
 318 invalid direction: ~S"
 319                stream direction)))
 320      direction)))
 321
 322 #+ecl
 323 (defun fd-line-width (fd)
 324   "Get the line width for FD (file descriptor).
 325 Return two values:
 326 - the line width, or -1 if it can't be computed
 327   (typically when FD does not denote a tty),
 328 - an error message if the operation failed."
 329   (ffi:c-inline (fd) (:int) (values :int :cstring) "{
 330     int fd = #0;
 331
 332     int cols = -1;
 333     char *msg = NULL;
 334
 335     struct winsize window;
 336     if (ioctl (fd, TIOCGWINSZ, &window) == -1)
 337       {
 338         if (errno != ENOTTY)
 339           msg = strerror (errno);
 340       }
 341     else
 342       cols = (int) window.ws_col;
 343
 344     @(return 0) = cols;
 345     @(return 1) = msg;
 346 }"))
 347
 348 ;; #### NOTE: SBCL and CLISP have their specific, not "inlined" version of
 349 ;; this function elsewhere because they both use a separate ASDF module. The
 350 ;; SBCL one depends on SB-GROVEL and the CLISP one depends on CFFI.
 351 (defun stream-line-width (stream)
 352   "Get STREAM's line width.
 353 Return two values:
 354 - the stream's line width, or nil if it can't be computed
 355   (typically when the stream does not denote a tty),
 356 - an error message if the operation failed."
 357   ;; #### NOTE: doing a TIOCGWINSZ ioctl here is a convenient way to both know
 358   ;; whether we're connected to a tty, and getting the terminal width at the
 359   ;; same time. In case the ioctl fails, we need to distinguish between and
 360   ;; ENOTTY error, which simply means that we're not connected to a terminal,
 361   ;; and the other which are real errors and need to be reported.
 362   ;; #### PORTME.
 363   #+abcl (declare (ignore stream))
 364   #+sbcl
 365   (sbcl/stream-line-width stream)
 366   #+cmu
 367   (locally (declare (optimize (ext:inhibit-warnings 3)))
 368     (alien:with-alien ((winsize (alien:struct unix:winsize)))
 369       (multiple-value-bind (success error-number)
 370           (unix:unix-ioctl
 371            (system:fd-stream-fd (stream-file-stream stream :output))
 372            unix:tiocgwinsz
 373            winsize)
 374         (if success
 375             (alien:slot winsize 'unix:ws-col)
 376           (unless (= error-number unix:enotty)
 377             (values nil (unix:get-unix-error-msg error-number)))))))
 378   #+ccl
 379   (ccl:rlet ((winsize :winsize))
 380     (let ((result
 381             (ccl::int-errno-call
 382              (#_ioctl (ccl::stream-device stream :output)
 383                       #$TIOCGWINSZ
 384                       :address winsize))))
 385       (if (zerop result)
 386           (ccl:pref winsize :winsize.ws_col)
 387         (unless (= result (- #$ENOTTY))
 388           (values nil (ccl::%strerror (- result)))))))
 389   #+ecl
 390   (multiple-value-bind (cols msg)
 391       (fd-line-width (ext:file-stream-fd stream))
 392     (values (unless (= cols -1) cols) msg))
 393   #+clisp
 394   (when (fboundp 'clisp/stream-line-width)
 395     (clisp/stream-line-width stream))
 396   #+abcl
 397   nil)
 398
 399 (defun exit (&optional (status 0))
 400   "Quit the current application with STATUS."
 401   ;; #### PORTME.
 402   #+sbcl  (sb-ext:quit :unix-status status)
 403   #+cmu   (unix:unix-exit status)
 404   #+ccl   (ccl:quit status)
 405   #+ecl   (ext:quit status)
 406   #+clisp (ext:exit status)
 407   #+abcl  (extensions:exit :status status))
 408
 409 (defun cmdline ()
 410   "Get the current application's command-line."
 411   ;; #### PORTME.
 412   #+sbcl  sb-ext:*posix-argv*
 413   #+cmu   lisp::lisp-command-line-list
 414   #+ccl   ccl::*command-line-argument-list*
 415   #+ecl   (ext:command-args)
 416   #+clisp (cons (aref (ext:argv) 0) ext:*args*)
 417   ;; #### NOTE: the trickery below is here to make CMDLINE work even when Clon
 418   ;; is loaded into ABCL without dumping the Clon way (see
 419   ;; +ABCL-MAIN-CLASS-TEMPLATE+).
 420   #+abcl  (cons (or (let ((symbol (find-symbol "*ARGV0*" 'extensions)))
 421                       (when symbol
 422                         (symbol-value symbol)))
 423                     "abcl")
 424                 extensions:*command-line-argument-list*))
 425
 426 (defun getenv (variable)
 427   "Get environment VARIABLE's value. VARIABLE may be null."
 428   ;; #### PORTME.
 429   (when variable
 430     (#+sbcl  sb-posix:getenv
 431      #+cmu   unix:unix-getenv
 432      #+ccl   ccl:getenv
 433      #+ecl   ext:getenv
 434      #+clisp ext:getenv
 435      #+abcl  extensions:getenv
 436      variable)))
 437
 438 ;; #### NOTE: JAVA doesn't provide a way to set an environment variable. I've
 439 ;; seen tricks around to modify the startup environment memory mapping instead
 440 ;; of doing a real putenv, but I'll just disable the "modify-environment"
 441 ;; restart in environ.lisp for now.
 442 #-abcl
 443 (defun putenv (variable value)
 444   "Set environment VARIABLE to VALUE."
 445   ;; #### PORTME.
 446   #+sbcl  (sb-posix:putenv  (concatenate 'string variable "=" value))
 447   #+cmu   (unix:unix-putenv (concatenate 'string variable "=" value))
 448   #+ccl   (ccl:setenv variable value)
 449   #+ecl   (ext:setenv variable value)
 450   #+clisp (setf (ext:getenv variable) value))
 451
 452 #+abcl
 453 (defconstant +abcl-main-class-template+
 454   "import org.armedbear.lisp.*;
 455
 456 public class ~A
 457 {
 458     public static void main (final String[] argv)
 459     {
 460         Runnable r = new Runnable ()
 461             {
 462                 public void run()
 463                 {
 464                     try
 465                         {
 466                             LispObject cmdline = Lisp.NIL;
 467                             for (String arg : argv)
 468                                 cmdline = new Cons (arg, cmdline);
 469                             cmdline.nreverse ();
 470                             Lisp._COMMAND_LINE_ARGUMENT_LIST_.setSymbolValue
 471                                 (cmdline);
 472
 473                             Interpreter interpreter =
 474                               Interpreter.createInstance ();
 475                             interpreter.eval
 476                               (\"(defvar extensions::*argv0* \\\"~A\\\")\");
 477                             interpreter.eval
 478                               (\"(export 'extensions::*argv0* 'extensions)\");
 479
 480                             Load.loadSystemFile (\"/~A\", false, false, false);
 481                         }
 482                     catch (ProcessingTerminated e)
 483                         {
 484                             System.exit (e.getStatus ());
 485                         }
 486                 }
 487             };
 488
 489         new Thread (null, r, \"interpreter\", 4194304L).start();
 490     }
 491 }~%"
 492   "Main class template for ABCL.")
 493
 494 (defmacro dump (name function)
 495   "Dump a standalone executable named NAME starting with FUNCTION.
 496
 497 Since executable dumping is not available in all supported implementations,
 498 this function behaves differently in some cases, as described below.
 499
 500 - ECL doesn't create executables by dumping a Lisp image, but relies on having
 501   toplevel code to execute instead, so this macro simply expands to a call to
 502   FUNCTION.
 503 - ABCL can't dump executables at all because of the underlying Java
 504   implementation, so this macro expands to just (PROGN) but creates a Java
 505   class file with a main function that creates an interpreter, loads
 506   the file in which this macro call appears and calls FUNCTION."
 507   ;; #### PORTME.
 508   #+ecl (declare (ignore name))
 509   #+sbcl  `(sb-ext:save-lisp-and-die ,name
 510              :toplevel #',function
 511              :executable t
 512              :save-runtime-options t)
 513   #+cmu   `(ext:save-lisp ,name
 514              :init-function #',function
 515              :executable t
 516              :load-init-file nil
 517              :site-init nil
 518              :print-herald nil
 519              :process-command-line nil)
 520   #+ccl   `(ccl:save-application ,name
 521              :toplevel-function #',function
 522              :init-file nil
 523              :error-handler :quit
 524              :prepend-kernel t)
 525   ;; #### NOTE: ECL works differently: it needs an entry point (i.e. actual
 526   ;; code to execute) instead of a main function. So we expand DUMP to just
 527   ;; call that function.
 528   #+ecl   (list function)
 529   ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
 530   #+clisp `(progn
 531              (ext:saveinitmem ,name
 532                :init-function #',function
 533                :executable 0
 534                :quiet t
 535                :norc t)
 536              (exit))
 537   #+abcl (if (boundp 'cl-user::com.dvlsoft.clon.dump)
 538              (let ((source-pathname (or *compile-file-pathname*
 539                                         *load-pathname*))
 540                    (class-name (copy-seq name)))
 541                (setf (aref class-name 0) (char-upcase (aref class-name 0)))
 542                (with-open-file
 543                    (*standard-output*
 544                     (merge-pathnames
 545                      (make-pathname :name class-name :type "java")
 546                      source-pathname)
 547                     :direction :output :if-exists :supersede)
 548                  (format t +abcl-main-class-template+
 549                    class-name name (namestring source-pathname)))
 550                '(progn))
 551            (list function)))
 552
 553
 554 ;;; util.lisp ends here