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 ;; Clon is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License version 3,
  12 ;; as published by the Free Software Foundation.
  13
  14 ;; Clon is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software
  21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23
  24 ;;; Commentary:
  25
  26 ;; Contents management by FCM version 0.1.
  27
  28
  29 ;;; Code:
  30
  31 (in-package :com.dvlsoft.clon)
  32 (in-readtable :com.dvlsoft.clon)
  33
  34
  35 ;; Preamble C code needed for ECL's FD-LINE-WIDTH function.
  36 #+ecl (ffi:clines "
  37 #include <stdio.h>
  38 #include <errno.h>
  39 #include <sys/ioctl.h>")
  40
  41
  42
  43 ;; ==========================================================================
  44 ;; Miscellaneous Auxiliary Routines
  45 ;; ==========================================================================
  46
  47 (defmacro econd (&body clauses)
  48   "Like COND, but signal an error if no clause evaluates to t."
  49   `(cond ,@(append clauses
  50                    '((t (error "Fell out of ECOND clauses."))))))
  51
  52 (defmacro endpush (object place)
  53   "Like push, but at the end."
  54   `(setf ,place (nconc ,place (list ,object))))
  55
  56 (defmacro maybe-push (object place)
  57   "Like push, but only if OBJECT is non-nil."
  58   (let ((the-object (gensym "object")))
  59     `(let ((,the-object ,object))
  60       (when ,the-object (push ,the-object ,place)))))
  61
  62 (defmacro accumulate ((initial-value) &body body)
  63   "Accumulate BODY forms in a list beginning with INITIAL-VALUE.
  64 INITIAL-VALUE is not evaluated. BODY forms are accumulated only when their
  65 value is non-nil.
  66 If nothing to accumulate, then return nil instead of the list of
  67 INITIAL-VALUE."
  68   (let ((place (gensym "place"))
  69         (initial-place (gensym "initial-place")))
  70     `(let* ((,place (list ',initial-value))
  71             (,initial-place ,place))
  72       ,@(mapcar (lambda (body-form)
  73                   `(maybe-push ,body-form ,place))
  74                 body)
  75       (when (not (eq ,initial-place ,place))
  76         (nreverse ,place)))))
  77
  78 (defun beginning-of-string-p (beginning string &optional ignore-case)
  79   "Check that STRING starts with BEGINNING.
  80 If IGNORE-CASE, well, ignore case."
  81   (let ((length (length beginning)))
  82     (and (>= (length string) length)
  83          (funcall (if ignore-case #'string-equal #'string=)
  84                   beginning string :end2 length))))
  85
  86 (defun closest-match (match list &key ignore-case (key #'identity))
  87   "Return the LIST element closest to MATCH, or nil.
  88 If IGNORE-CASE, well, ignore case.
  89 KEY should provide a way to get a string from each LIST element."
  90   (let ((match-length (length match))
  91         (shortest-distance most-positive-fixnum)
  92         closest-match)
  93     (dolist (elt list)
  94       (let ((elt-string (funcall key elt))
  95             distance)
  96         (when (and (beginning-of-string-p match elt-string ignore-case)
  97                    (< (setq distance (- (length elt-string) match-length))
  98                       shortest-distance))
  99           (setq shortest-distance distance)
 100           (setq closest-match elt))))
 101     closest-match))
 102
 103 (defun complete-string (beginning complete)
 104   "Complete BEGINNING with the rest of COMPLETE in parentheses.
 105 For instance, completing 'he' with 'help' will produce 'he(lp)'."
 106   (assert (beginning-of-string-p beginning complete))
 107   (assert (not (string= beginning complete)))
 108   (concatenate 'string beginning "(" (subseq complete (length beginning)) ")"))
 109
 110 (defun list-to-string (list &key (key #'identity) (separator ", "))
 111   "Return a SEPARATOR-separated string of all LIST elements.
 112 - KEY should provide a way to get a string from each LIST element.
 113 - SEPARATOR is the string to insert between elements."
 114   (reduce (lambda (str1 str2) (concatenate 'string str1 separator str2))
 115           list
 116           :key key))
 117
 118
 119
 120 ;; ==========================================================================
 121 ;; Key-Value Pairs Manipulation
 122 ;; ==========================================================================
 123
 124 (defun select-keys (keys &rest selected)
 125   "Return a new property list from KEYS with only SELECTED ones."
 126   (loop :for key :in keys :by #'cddr
 127         :for val :in (cdr keys) :by #'cddr
 128         :when (member key selected)
 129         :nconc (list key val)))
 130
 131 (defun remove-keys (keys &rest removed)
 132   "Return a new property list from KEYS without REMOVED ones."
 133   (loop :for key :in keys :by #'cddr
 134         :for val :in (cdr keys) :by #'cddr
 135         :unless (member key removed)
 136         :nconc (list key val)))
 137
 138 (defmacro replace-in-keys ((key val) keys the-key form)
 139   "Replace every occurrence of THE-KEY in KEYS with FORM.
 140 At every KEYS round, KEY and VAL are bound to the current key-value pair.
 141 FORM is evaluated each time and should return a key-value list."
 142   `(loop :for ,key :in ,keys :by #'cddr
 143     :for ,val :in (cdr ,keys) :by #'cddr
 144     :if (eql ,key ,the-key)
 145     :append ,form
 146     :else
 147     :nconc (list ,key ,val)))
 148
 149 ;; #### NOTE: that's the typical situation where I would like a
 150 ;; destructuring-cond, but it seems difficult to do so because of the
 151 ;; standard imprecision of the reported error in case of a pattern matching
 152 ;; failure.
 153 ;; #### NOTE: I could extend this utility by supporting a global :test, or
 154 ;; even a per-replacement local one.
 155 (defun replace-key (replacement keys)
 156   "Return a new property list from KEYS with REPLACEMENT.
 157 REPLACEMENT can take the following forms:
 158 - :KEY
 159   The effect is to remove :KEY from KEYS, as per REMOVE-KEYS.
 160 - (:KEY :NEW-KEY)
 161   The effect is to replace :KEY with :NEW-KEY, leaving the values unchanged.
 162 - (:KEY :NEW-KEY (VAL-OR-VALS NEW-VAL)*), with VAL-OR-VALS being
 163   either a value or a list of values. The effect is to replace :KEY with
 164   :NEW-KEY and a value matching one of the VAL-OR-VALS with the
 165   corresponding NEW-VAL. Values not matching any VAL-OR-VALS remain unchanged.
 166 - (:KEY (VAL-OR-VALS :NEW-KEY NEW-VAL...)*), with VAL-OR-VALS as above. The
 167   effect is the same as above, but :NEW-KEY additionally depends on the
 168   matched value. If multiple :NEW-KEY NEW-VAL couples are provided, that many
 169   new keys are inserted along with their values. For values not matching any
 170   VAL-OR-VALS, :KEY and its value remain unchanged."
 171   (econd ((symbolp replacement)
 172           (remove-keys keys replacement))
 173          ((and (consp replacement)
 174                (= (length replacement) 2)
 175                (symbolp (car replacement))
 176                (symbolp (cadr replacement)))
 177           (destructuring-bind (old-key new-key) replacement
 178             (replace-in-keys (key val) keys old-key
 179               (list new-key val))))
 180          ((and (consp replacement)
 181                (> (length replacement) 2)
 182                (symbolp (car replacement))
 183                (symbolp (cadr replacement)))
 184           (destructuring-bind (old-key new-key &rest replacements) replacement
 185             (replace-in-keys (key val) keys old-key
 186               (list new-key
 187                     (let ((match
 188                            (assoc val replacements
 189                                   :test (lambda (val val-or-vals)
 190                                           (if (consp val-or-vals)
 191                                               (member val val-or-vals)
 192                                               (eql val val-or-vals))))))
 193                       (if match (cadr match) val))))))
 194          ((and (consp replacement)
 195                (> (length replacement) 1)
 196                (symbolp (car replacement)))
 197           (destructuring-bind (old-key &rest replacements) replacement
 198             (replace-in-keys (key val) keys old-key
 199               (let ((match (assoc val replacements
 200                                   :test (lambda (val val-or-vals)
 201                                           (if (consp val-or-vals)
 202                                               (member val val-or-vals)
 203                                               (eql val val-or-vals))))))
 204                 (if match
 205                     (cdr match)
 206                     (list key val))))))))
 207
 208 (defun replace-keys (keys &rest replacements)
 209   "Return a new property list from KEYS with REPLACEMENTS.
 210 See REPLACE-KEY for more information on the replacement syntax."
 211   (let ((new-keys keys))
 212     (dolist (replacement replacements)
 213       (setq new-keys (replace-key replacement new-keys)))
 214     new-keys))
 215
 216
 217
 218 ;; ==========================================================================
 219 ;; CLOS Utility Routines
 220 ;; ==========================================================================
 221
 222 ;; --------------------
 223 ;; Portability wrappers
 224 ;; --------------------
 225
 226 (defmacro validate-superclass (class superclass)
 227   "Validate SUPERCLASS classes for CLASS classes."
 228   ;; #### PORTME.
 229   #+abcl (declare (ignore class superclass))
 230   #+abcl '(progn)
 231   #-abcl
 232   `(defmethod #+sbcl  sb-mop:validate-superclass
 233               #+cmu   mop:validate-superclass
 234               #+ccl   ccl:validate-superclass
 235               #+ecl   clos:validate-superclass
 236               #+clisp clos:validate-superclass
 237     ((class ,class) (superclass ,superclass))
 238     #+ecl (declare (ignore class superclass))
 239     t))
 240
 241 (defun class-slots (class)
 242   "Return CLASS slots."
 243   ;; #### PORTME.
 244   (#+sbcl  sb-mop:class-slots
 245    #+cmu   mop:class-slots
 246    #+ccl   ccl:class-slots
 247    #+ecl   clos:class-slots
 248    #+clisp clos:class-slots
 249    #+abcl  mop:class-slots
 250    class))
 251
 252 (defun slot-definition-name (slot)
 253   "Return SLOT's definition name."
 254   ;; #### PORTME.
 255   (#+sbcl  sb-mop:slot-definition-name
 256    #+cmu   mop:slot-definition-name
 257    #+ccl   ccl:slot-definition-name
 258    #+ecl   clos:slot-definition-name
 259    #+clisp clos:slot-definition-name
 260    #+abcl  mop:slot-definition-name
 261    slot))
 262
 263
 264 ;; ----------------
 265 ;; Abstract classes
 266 ;; ----------------
 267
 268 (defclass abstract-class (standard-class)
 269   ()
 270   (:documentation "The ABSTRACT-CLASS class.
 271 This is the meta-class for abstract classes."))
 272
 273 (defmacro defabstract (class super-classes slots &rest options)
 274   "Like DEFCLASS, but define an abstract class."
 275   (when (assoc :metaclass options)
 276     (error "Defining abstract class ~S: explicit meta-class option." class))
 277   `(defclass ,class ,super-classes ,slots ,@options
 278     (:metaclass abstract-class)))
 279
 280 (defmethod make-instance ((class abstract-class) &rest initargs)
 281   (declare (ignore initargs))
 282   (error "Instanciating class ~S: is abstract." (class-name class)))
 283
 284 (validate-superclass abstract-class standard-class)
 285 (validate-superclass standard-class abstract-class)
 286
 287
 288 ;; ----------------
 289 ;; Instance copying
 290 ;; ----------------
 291
 292 (defgeneric copy-instance (instance &optional subclass)
 293   (:documentation "Return a copy of INSTANCE.
 294 Copy is either an object of INSTANCE's class, or INSTANCE's SUBCLASS if given.")
 295   (:method (instance &optional subclass)
 296     "Return a copy of INSTANCE.
 297 Both instances share the same slot values."
 298     (let* ((class (class-of instance))
 299            (slots (class-slots class))
 300            (new-instance (make-instance (or subclass class))))
 301       (loop :for slot :in slots
 302             :when (slot-boundp instance (slot-definition-name slot))
 303             :do (setf (slot-value new-instance (slot-definition-name slot))
 304                       (slot-value instance (slot-definition-name slot))))
 305       new-instance)))
 306
 307
 308
 309 ;; ==========================================================================
 310 ;; System-related utilities
 311 ;; ==========================================================================
 312
 313 (defun home-directory ()
 314   "Return user's home directory in canonical form."
 315   (truename (user-homedir-pathname)))
 316
 317 (defun macosp ()
 318   "Return t if running on Mac OS."
 319   (string= (software-type) "Darwin"))
 320
 321
 322
 323 ;; ==========================================================================
 324 ;; Wrappers around non ANSI features
 325 ;; ==========================================================================
 326
 327 ;; Thanks Nikodemus!
 328 (defgeneric stream-file-stream (stream &optional direction)
 329   (:documentation "Convert STREAM to a file-stream.")
 330   (:method ((stream file-stream) &optional direction)
 331     (declare (ignore direction))
 332     stream)
 333   (:method ((stream synonym-stream) &optional direction)
 334     (declare (ignore direction))
 335     (stream-file-stream (symbol-value (synonym-stream-symbol stream))))
 336   (:method ((stream two-way-stream) &optional direction)
 337     (stream-file-stream
 338         (case direction
 339           (:input (two-way-stream-input-stream stream))
 340           (:output (two-way-stream-output-stream stream))
 341           (otherwise
 342            (error "Cannot extract file-stream from TWO-WAY-STREAM ~A:
 343 invalid direction: ~S"
 344                   stream direction)))
 345         direction)))
 346
 347 #+ecl
 348 (defun fd-line-width (fd)
 349   "Get the line width for FD (file descriptor).
 350 Return two values:
 351 - the line width, or -1 if it can't be computed
 352   (typically when FD does not denote a tty),
 353 - an error message if the operation failed."
 354   (ffi:c-inline (fd) (:int) (values :int :cstring) "{
 355     int fd = #0;
 356
 357     int cols = -1;
 358     char *msg = NULL;
 359
 360     struct winsize window;
 361     if (ioctl (fd, TIOCGWINSZ, &window) == -1)
 362       {
 363         if (errno != ENOTTY)
 364           msg = strerror (errno);
 365       }
 366     else
 367       cols = (int) window.ws_col;
 368
 369     @(return 0) = cols;
 370     @(return 1) = msg;
 371 }"))
 372
 373 ;; #### NOTE: SBCL and CLISP have their specific, not "inlined" version of
 374 ;; this function elsewhere because they both use a separate ASDF module. The
 375 ;; SBCL one depends on SB-GROVEL and the CLISP one depends on CFFI.
 376 (defun stream-line-width (stream)
 377   "Get STREAM's line width.
 378 Return two values:
 379 - the stream's line width, or nil if it can't be computed
 380   (typically when the stream does not denote a tty),
 381 - an error message if the operation failed."
 382   ;; #### NOTE: doing a TIOCGWINSZ ioctl here is a convenient way to both know
 383   ;; whether we're connected to a tty, and getting the terminal width at the
 384   ;; same time. In case the ioctl fails, we need to distinguish between and
 385   ;; ENOTTY error, which simply means that we're not connected to a terminal,
 386   ;; and the other which are real errors and need to be reported.
 387   ;; #### PORTME.
 388   #+abcl (declare (ignore stream))
 389   #+sbcl
 390   (sbcl/stream-line-width stream)
 391   #+cmu
 392   (locally (declare (optimize (ext:inhibit-warnings 3)))
 393     (alien:with-alien ((winsize (alien:struct unix:winsize)))
 394       (multiple-value-bind (success error-number)
 395           (unix:unix-ioctl
 396            (system:fd-stream-fd (stream-file-stream stream :output))
 397            unix:tiocgwinsz
 398            winsize)
 399         (if success
 400             (alien:slot winsize 'unix:ws-col)
 401           (unless (= error-number unix:enotty)
 402             (values nil (unix:get-unix-error-msg error-number)))))))
 403   #+ccl
 404   (ccl:rlet ((winsize :winsize))
 405     (let ((result
 406            (ccl::int-errno-call
 407             (#_ioctl (ccl::stream-device stream :output)
 408                      #$TIOCGWINSZ
 409                      :address winsize))))
 410       (if (zerop result)
 411           (ccl:pref winsize :winsize.ws_col)
 412         (unless (= result (- #$ENOTTY))
 413           (values nil (ccl::%strerror (- result)))))))
 414   #+ecl
 415   (multiple-value-bind (cols msg)
 416       (fd-line-width (ext:file-stream-fd stream))
 417     (values (unless (= cols -1) cols) msg))
 418   #+clisp
 419   (when (fboundp 'clisp/stream-line-width)
 420     (clisp/stream-line-width stream))
 421   #+abcl
 422   nil)
 423
 424 (defun exit (&optional (status 0))
 425   "Quit the current application with STATUS."
 426   ;; #### PORTME.
 427   #+sbcl  (sb-ext:quit :unix-status status)
 428   #+cmu   (unix:unix-exit status)
 429   #+ccl   (ccl:quit status)
 430   #+ecl   (ext:quit status)
 431   #+clisp (ext:exit status)
 432   #+abcl  (extensions:exit :status status))
 433
 434 (defun cmdline ()
 435   "Get the current application's command-line."
 436   ;; #### PORTME.
 437   #+sbcl  sb-ext:*posix-argv*
 438   #+cmu   lisp::lisp-command-line-list
 439   #+ccl   ccl::*command-line-argument-list*
 440   #+ecl   (ext:command-args)
 441   #+clisp (cons (aref (ext:argv) 0) ext:*args*)
 442   #+abcl  (cons "abcl" extensions:*command-line-argument-list*))
 443
 444 (defun getenv (variable)
 445   "Get environment VARIABLE's value. VARIABLE may be null."
 446   ;; #### PORTME.
 447   (when variable
 448     (#+sbcl  sb-posix:getenv
 449      #+cmu   unix:unix-getenv
 450      #+ccl   ccl:getenv
 451      #+ecl   ext:getenv
 452      #+clisp ext:getenv
 453      #+abcl  extensions:getenv
 454      variable)))
 455
 456 ;; #### NOTE: JAVA doesn't provide a way to set an environment variable. I've
 457 ;; seen tricks around to modify the startup environment memory mapping instead
 458 ;; of doing a real putenv, but I'll just disable the "modify-environment"
 459 ;; restart in environ.lisp for now.
 460 #-abcl
 461 (defun putenv (variable value)
 462   "Set environment VARIABLE to VALUE."
 463   ;; #### PORTME.
 464   #+sbcl  (sb-posix:putenv  (concatenate 'string variable "=" value))
 465   #+cmu   (unix:unix-putenv (concatenate 'string variable "=" value))
 466   #+ccl   (ccl:setenv variable value)
 467   #+ecl   (ext:setenv variable value)
 468   #+clisp (setf (ext:getenv variable) value))
 469
 470 #+abcl
 471 (defconstant +abcl-main-class-template+
 472   "import org.armedbear.lisp.*;
 473
 474 public class ~A
 475 {
 476     public static void main (final String[] argv)
 477     {
 478         Runnable r = new Runnable ()
 479             {
 480                 public void run()
 481                 {
 482                     try
 483                         {
 484                             LispObject cmdline = Lisp.NIL;
 485                             for (String arg : argv)
 486                                 cmdline = new Cons (arg, cmdline);
 487                             cmdline.nreverse ();
 488                             Lisp._COMMAND_LINE_ARGUMENT_LIST_.setSymbolValue
 489                                 (cmdline);
 490
 491                             Interpreter.createInstance ();
 492                             Load.loadSystemFile (\"/~A\", false, false, false);
 493                         }
 494                     catch (ProcessingTerminated e)
 495                         {
 496                             System.exit (e.getStatus ());
 497                         }
 498                 }
 499             };
 500
 501         new Thread (null, r, \"interpreter\", 4194304L).start();
 502     }
 503 }~%"
 504   "Main class template for ABCL.")
 505
 506 (defmacro dump (name function)
 507   "Dump a standalone executable named NAME starting with FUNCTION.
 508
 509 Since executable dumping is not available in all supported implementations,
 510 this function behaves differently in some cases, as described below.
 511
 512 - ECL doesn't create executables by dumping a Lisp image, but relies on having
 513   toplevel code to execute instead, so this macro simply expands to a call to
 514   FUNCTION.
 515 - ABCL can't dump executables at all because of the underlying Java
 516   implementation, so this macro expands to just (PROGN) but creates a Java
 517   class file with a main function that creates an interpreter, loads
 518   the file in which this macro call appears and calls FUNCTION."
 519   ;; #### PORTME.
 520   #+ecl (declare (ignore name))
 521   #+sbcl  `(sb-ext:save-lisp-and-die ,name
 522             :toplevel #',function
 523             :executable t
 524             :save-runtime-options t)
 525   #+cmu   `(ext:save-lisp ,name
 526             :init-function #',function
 527             :executable t
 528             :load-init-file nil
 529             :site-init nil
 530             :print-herald nil
 531             :process-command-line nil)
 532   #+ccl   `(ccl:save-application ,name
 533             :toplevel-function #',function
 534             :init-file nil
 535             :error-handler :quit
 536             :prepend-kernel t)
 537   ;; #### NOTE: ECL works differently: it needs an entry point (i.e. actual
 538   ;; code to execute) instead of a main function. So we expand DUMP to just
 539   ;; call that function.
 540   #+ecl   (list function)
 541   ;; CLISP's saveinitmem function doesn't quit, so we need to do so here.
 542   #+clisp `(progn
 543             (ext:saveinitmem ,name
 544              :init-function #',function
 545              :executable 0
 546              :quiet t
 547              :norc t)
 548             (exit))
 549   #+abcl (if (boundp 'cl-user::com.dvlsoft.clon.dump)
 550              (let ((source-pathname (or *compile-file-pathname*
 551                                         *load-pathname*))
 552                    (class-name (copy-seq name)))
 553                (setf (aref class-name 0) (char-upcase (aref class-name 0)))
 554                (with-open-file
 555                    (*standard-output*
 556                     (merge-pathnames
 557                      (make-pathname :name class-name :type "java")
 558                      source-pathname)
 559                     :direction :output :if-exists :supersede)
 560                  (format t +abcl-main-class-template+
 561                    class-name (namestring source-pathname)))
 562                '(progn))
 563            (list function)))
 564
 565
 566 ;;; util.lisp ends here