lambda-utils/ext.lisp

   1 ;;; Basic extensions: conditions, compositions &c
   2 ;;;
   3 ;;; Copyright (C) 1999-2003 by Sam Steingold
   4 ;;; This is open-source software.
   5 ;;; GNU Lesser General Public License (LGPL) is applicable:
   6 ;;; No warranty; you may copy/modify/redistribute under the same
   7 ;;; conditions with the source code.
   8 ;;; See <URL:http://www.gnu.org/copyleft/lesser.html>
   9 ;;; for details and the precise copyright document.
  10 ;;;
  11 ;;; $Id: ext.lisp,v 1.36 2004/08/02 22:44:48 sds Exp $
  12 ;;; $Source: /cvsroot/clocc/clocc/src/port/ext.lisp,v $
  13
  14
  15 (in-package :lambda-utils)
  16
  17 ;;;
  18 ;;; Conditions
  19 ;;;
  20
  21 (define-condition code (error)
  22   ((proc :reader code-proc :initarg :proc :initform nil)
  23    (mesg :type (or null simple-string) :reader code-mesg
  24          :initarg :mesg :initform nil)
  25    (args :type list :reader code-args :initarg :args :initform nil))
  26   (:documentation "An error in the user code.")
  27   (:report (lambda (cc out)
  28              (declare (stream out))
  29              (format out "[~s]~@[ ~?~]" (code-proc cc) (code-mesg cc)
  30                      (code-args cc)))))
  31
  32 (define-condition case-error (code)
  33   ((mesg :type simple-string :reader code-mesg :initform
  34          "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]"))
  35   (:documentation "An error in a case statement.
  36 This carries the function name which makes the error message more useful."))
  37
  38 (define-condition not-implemented (code)
  39   ((mesg :type simple-string :reader code-mesg :initform
  40          "not implemented for ~a [~a]")
  41    (args :type list :reader code-args :initform
  42          (list (lisp-implementation-type) (lisp-implementation-version))))
  43   (:documentation "Your implementation does not support this functionality."))
  44
  45 ;;;
  46 ;;; Extensions
  47 ;;;
  48
  49 (defmacro defsubst (name arglist &body body)
  50   "Declare an inline defun."
  51   `(progn (declaim (inline ,name)) (defun ,name ,arglist ,@body)))
  52
  53 (defmacro defcustom (name type init doc)
  54   "Define a typed global variable."
  55   `(progn (declaim (type ,type ,name))
  56     (defvar ,name (the ,type ,init) ,doc)))
  57
  58 (defmacro defconst (name type init doc)
  59   "Define a typed constant."
  60   `(progn (declaim (type ,type ,name))
  61     ;; since constant redefinition must be the same under EQL, there
  62     ;; can be no constants other than symbols, numbers and characters
  63     ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables"
  64     (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar)
  65      ,name (the ,type ,init) ,doc)))
  66
  67 (defmacro mk-arr (type init &optional len)
  68   "Make array with elements of TYPE, initializing."
  69   (if len `(make-array ,len :element-type ,type :initial-element ,init)
  70       `(make-array (length ,init) :element-type ,type
  71         :initial-contents ,init)))
  72
  73 (defmacro map-in (fn seq &rest seqs)
  74   "`map-into' the first sequence, evaluating it once.
  75   (map-in F S) == (map-into S F S)"
  76   (with-gensyms (mi)
  77     `(let ((,mi ,seq)) (map-into ,mi ,fn ,mi ,@seqs))))
  78
  79 (defun gc ()
  80   "Invoke the garbage collector."
  81   #+abcl (ext:gc)
  82   #+allegro (excl:gc)
  83   #+clisp (#+lisp=cl ext:gc #-lisp=cl lisp:gc)
  84   #+cmu (ext:gc)
  85   #+cormanlisp (cl::gc)
  86   #+gcl (si::gbc)
  87   #+lispworks (hcl:normal-gc)
  88   #+lucid (lcl:gc)
  89   #+sbcl (sb-ext:gc)
  90   #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
  91   (error 'not-implemented :proc (list 'gc)))
  92
  93 (defun quit (&optional code)
  94   #+abcl (ext:quit code)
  95   #+allegro (excl:exit code)
  96   #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
  97   #+cmu (ext:quit code)
  98   #+cormanlisp (win32:exitprocess code)
  99   #+gcl (lisp:bye code)
 100   #+lispworks (lw:quit :status code)
 101   #+lucid (lcl:quit code)
 102   #+sbcl (sb-ext:quit :unix-code (typecase code (number code) (null 0) (t 1)))
 103   #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
 104   (error 'not-implemented :proc (list 'quit code)))
 105
 106 (defconst +eof+ cons (list '+eof+)
 107   "*The end-of-file object.
 108 To be passed as the third arg to `read' and checked against using `eq'.")
 109
 110 (defun eof-p (stream)
 111   "Return T if the stream has no more data in it."
 112   (null (peek-char nil stream nil nil)))
 113
 114 (defun string-tokens (string &key (start 0) max)
 115   "Read from STRING repeatedly, starting with START, up to MAX tokens.
 116 Return the list of objects read and the final index in STRING.
 117 Binds `*package*' to the keyword package,
 118 so that the bare symbols are read as keywords."
 119   (declare (type (or null fixnum) max) (type fixnum start))
 120   (let ((*package* (find-package :keyword)))
 121     (if max
 122         (do ((beg start) obj res (num 0 (1+ num)))
 123             ((= max num) (values (nreverse res) beg))
 124           (declare (fixnum beg num))
 125           (setf (values obj beg)
 126                 (read-from-string string nil +eof+ :start beg))
 127           (if (eq obj +eof+)
 128               (return (values (nreverse res) beg))
 129               (push obj res)))
 130         (read-from-string (concatenate 'string "(" string ")")
 131                           t nil :start start))))
 132
 133 (defun remove-plist (plist &rest keys)
 134   "Remove the keys from the plist.
 135 Useful for re-using the &REST arg after removing some options."
 136   (do (copy rest)
 137       ((null (setq rest (nth-value 2 (get-properties plist keys))))
 138        (nreconc copy plist))
 139     (do () ((eq plist rest))
 140       (push (pop plist) copy)
 141       (push (pop plist) copy))
 142     (setq plist (cddr plist))))
 143
 144 #+cmu (progn
 145         (import 'ext:required-argument :port)
 146         (export 'ext:required-argument :port))
 147 #-cmu (progn
 148         ;; return type NIL means non-returning function
 149         (proclaim '(ftype (function () nil) required-argument))
 150         (defun required-argument ()
 151           "A useful default for required arguments and DEFSTRUCT slots."
 152           (error "A required argument was not supplied.")))
 153