utils.lisp 3.03 KB
Newer Older
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
1 2 3 4 5 6 7
;;;;
;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr@freebits.de>
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
8 9 10

(in-package :editor-hints.named-readtables)

11 12 13 14 15 16 17 18
(define-condition simple-style-warning (simple-warning style-warning)
  ())

(defun simple-style-warn (format-control &rest format-args)
  (warn 'simple-style-warning
	 :format-control format-control
	 :format-arguments format-args))

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
19 20
(defmacro without-package-lock ((&rest package-names) &body body)
  (declare (ignorable package-names))
21 22 23 24 25 26 27 28 29 30 31 32 33 34
  #+clisp
  (return-from without-package-lock
    `(ext:without-package-lock (,@package-names) ,@body))
  #+lispworks
  (return-from without-package-lock
    `(let ((hcl:*packages-for-warn-on-redefinition*
            (set-difference hcl:*packages-for-warn-on-redefinition*
                            '(,@package-names)
                            :key (lambda (package-designator)
                                   (if (packagep package-designator)
                                       (package-name package-designator)
                                       package-designator))
                            :test #'string=)))
       ,@body))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
35 36
  `(progn ,@body))

37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
;;; Taken from SWANK (which is Public Domain.)

(defmacro destructure-case (value &rest patterns)
  "Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
  ((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
  (let ((operator (gensym "op-"))
        (operands (gensym "rand-"))
        (tmp (gensym "tmp-")))
    `(let* ((,tmp ,value)
            (,operator (car ,tmp))
            (,operands (cdr ,tmp)))
       (case ,operator
         ,@(loop for (pattern . body) in patterns collect
                   (if (eq pattern t)
                       `(t ,@body)
                       (destructuring-bind (op &rest rands) pattern
                         `(,op (destructuring-bind ,rands ,operands
                                 ,@body)))))
         ,@(if (eq (caar (last patterns)) t)
               '()
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
62 63 64 65 66 67 68 69
               `((t (error "destructure-case failed: ~S" ,tmp))))))))

;;; Taken from Alexandria (which is Public Domain, or BSD.)

(defun required-argument (&optional name)
  "Signals an error for a missing argument of NAME. Intended for
use as an initialization form for structure and class-slots, and
a default value for required keyword arguments."
70 71 72 73 74 75 76 77 78 79 80 81
  (error "Required argument ~@[~S ~]missing." name))

(declaim (inline ensure-function))	; to propagate return type.
(declaim (ftype (function (t) (values function &optional))
                ensure-function))
(defun ensure-function (function-designator)
  "Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
  (if (functionp function-designator)
      function-designator
      (fdefinition function-designator)))