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 with-gensyms (syms &body body)
  74   "Bind symbols to gensyms.  First sym is a string - `gensym' prefix.
  75 Inspired by Paul Graham, <On Lisp>, p. 145."
  76   `(let (,@(mapcar (lambda (sy)
  77                      `(,sy (gensym ,(concatenate 'string (car syms)
  78                                                  (symbol-name sy) "-"))))
  79                    (cdr syms)))
  80      ,@body))
  81
  82 (defmacro map-in (fn seq &rest seqs)
  83   "`map-into' the first sequence, evaluating it once.
  84   (map-in F S) == (map-into S F S)"
  85   (with-gensyms ("MI-" mi)
  86     `(let ((,mi ,seq)) (map-into ,mi ,fn ,mi ,@seqs))))
  87
  88 (defun gc ()
  89   "Invoke the garbage collector."
  90   #+abcl (ext:gc)
  91   #+allegro (excl:gc)
  92   #+clisp (#+lisp=cl ext:gc #-lisp=cl lisp:gc)
  93   #+cmu (ext:gc)
  94   #+cormanlisp (cl::gc)
  95   #+gcl (si::gbc)
  96   #+lispworks (hcl:normal-gc)
  97   #+lucid (lcl:gc)
  98   #+sbcl (sb-ext:gc)
  99   #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
 100   (error 'not-implemented :proc (list 'gc)))
 101
 102 (defun quit (&optional code)
 103   #+abcl (ext:quit code)
 104   #+allegro (excl:exit code)
 105   #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
 106   #+cmu (ext:quit code)
 107   #+cormanlisp (win32:exitprocess code)
 108   #+gcl (lisp:bye code)
 109   #+lispworks (lw:quit :status code)
 110   #+lucid (lcl:quit code)
 111   #+sbcl (sb-ext:quit :unix-code (typecase code (number code) (null 0) (t 1)))
 112   #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
 113   (error 'not-implemented :proc (list 'quit code)))
 114
 115 (defconst +eof+ cons (list '+eof+)
 116   "*The end-of-file object.
 117 To be passed as the third arg to `read' and checked against using `eq'.")
 118
 119 (defun eof-p (stream)
 120   "Return T if the stream has no more data in it."
 121   (null (peek-char nil stream nil nil)))
 122
 123 (defun string-tokens (string &key (start 0) max)
 124   "Read from STRING repeatedly, starting with START, up to MAX tokens.
 125 Return the list of objects read and the final index in STRING.
 126 Binds `*package*' to the keyword package,
 127 so that the bare symbols are read as keywords."
 128   (declare (type (or null fixnum) max) (type fixnum start))
 129   (let ((*package* (find-package :keyword)))
 130     (if max
 131         (do ((beg start) obj res (num 0 (1+ num)))
 132             ((= max num) (values (nreverse res) beg))
 133           (declare (fixnum beg num))
 134           (setf (values obj beg)
 135                 (read-from-string string nil +eof+ :start beg))
 136           (if (eq obj +eof+)
 137               (return (values (nreverse res) beg))
 138               (push obj res)))
 139         (read-from-string (concatenate 'string "(" string ")")
 140                           t nil :start start))))
 141
 142 (defun remove-plist (plist &rest keys)
 143   "Remove the keys from the plist.
 144 Useful for re-using the &REST arg after removing some options."
 145   (do (copy rest)
 146       ((null (setq rest (nth-value 2 (get-properties plist keys))))
 147        (nreconc copy plist))
 148     (do () ((eq plist rest))
 149       (push (pop plist) copy)
 150       (push (pop plist) copy))
 151     (setq plist (cddr plist))))
 152
 153 #+cmu (progn
 154         (import 'ext:required-argument :port)
 155         (export 'ext:required-argument :port))
 156 #-cmu (progn
 157         ;; return type NIL means non-returning function
 158         (proclaim '(ftype (function () nil) required-argument))
 159         (defun required-argument ()
 160           "A useful default for required arguments and DEFSTRUCT slots."
 161           (error "A required argument was not supplied.")))
 162
 163 ;;;
 164 ;;; Function Compositions
 165 ;;;
 166
 167 (defmacro compose (&rest functions)
 168   "Macro: compose functions or macros of 1 argument into a lambda.
 169 E.g., (compose abs (dl-val zz) 'key) ==>
 170   (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))"
 171   (labels ((rec (xx yy)
 172              (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy))))
 173                (if (consp (car xx))
 174                    (cons 'funcall (if (eq (caar xx) 'quote)
 175                                       (cons (cadar xx) (cdr rr)) rr))
 176                    rr))))
 177     (with-gensyms ("COMPOSE-" arg)
 178       (let ((ff (rec functions arg)))
 179         `(lambda (,arg) ,ff)))))
 180
 181 (defun compose-f (&rest functions)
 182   "Return the composition of all the arguments.
 183 All FUNCTIONS should take one argument, except for
 184 the last one, which can take several."
 185   (reduce (lambda (f0 f1)
 186             (declare (function f0 f1))
 187             (lambda (&rest args) (funcall f0 (apply f1 args))))
 188           functions :initial-value #'identity))
 189
 190 (defun compose-all (&rest functions)
 191   "Return the composition of all the arguments.
 192 All the values from nth function are fed to the n-1th."
 193   (reduce (lambda (f0 f1)
 194             (declare (function f0 f1))
 195             (lambda (&rest args) (multiple-value-call f0 (apply f1 args))))
 196           functions :initial-value #'identity))