chiark - git - mdw - clg/blob - glib/gutils.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gutils.lisp,v 1.6 2001-05-11 15:57:13 espen Exp $
  19
  20
  21 (in-package "KERNEL")
  22
  23 (defun type-expand-1 (form)
  24   (let ((def (cond ((symbolp form)
  25                     (info type expander form))
  26                    ((and (consp form) (symbolp (car form)))
  27                     (info type expander (car form)))
  28                    (t nil))))
  29     (if def
  30         (values (funcall def (if (consp form) form (list form))) t)
  31       (values form nil))))
  32
  33 (in-package "PCL")
  34
  35 ;;;; Make PCL's class finalization protocol behave as specified in AMOP
  36
  37 (defmethod finalize-inheritance ((class std-class))
  38   (update-cpl class (compute-class-precedence-list class))
  39   (update-slots class (compute-slots class))
  40   (update-gfs-of-class class)
  41   (update-inits class (compute-default-initargs class))
  42   (update-make-instance-function-table class))
  43
  44 (defun update-class (class &optional finalizep)
  45   (declare (ignore finalizep))
  46   (unless (class-has-a-forward-referenced-superclass-p class)
  47     (finalize-inheritance class)
  48     (dolist (sub (class-direct-subclasses class))
  49       (update-class sub))))
  50
  51
  52 (in-package "GLIB")
  53
  54 (defun type-expand-to (type form)
  55   (labels ((expand (form0)
  56              (if (eq (first (mklist form0)) type)
  57                  form0
  58                (multiple-value-bind (expanded-form expanded-p)
  59                    (type-expand-1 form0)
  60                  (if expanded-p
  61                      (expand expanded-form)
  62                    (error "~A can not be expanded to ~A" form type))))))
  63     (expand form)))
  64
  65 (defmacro with-gc-disabled (&body body)
  66   (let ((gc-inhibit (make-symbol "GC-INHIBIT")))
  67     `(progn
  68        (let ((,gc-inhibit lisp::*gc-inhibit*))
  69          (ext:gc-off)
  70                  (unwind-protect
  71              ,@body
  72            (unless ,gc-inhibit
  73              (ext:gc-on)))))))
  74
  75 (defun mklist (obj)
  76   (if (atom obj) (list obj) obj))
  77
  78 (defun namep (obj)
  79   (and (symbolp obj) (not (member obj '(t nil)))))
  80
  81 (defun all-equal (&rest objects)
  82   (or
  83    (null objects)
  84    (null (rest objects))
  85    (and
  86     (equal (first objects) (second objects))
  87     (apply #'all-equal (rest objects)))))
  88
  89 (defun neq (obj1 obj2)
  90   (not (eq obj1 obj2)))
  91
  92 (defmacro return-if (form)
  93   (let ((result (make-symbol "RESULT")))
  94     `(let ((,result ,form))
  95        (when ,result
  96          (return ,result)))))
  97
  98 (defun make-pointer (address)
  99   (int-sap address))
 100
 101 (defun null-pointer-p (pointer)
 102   (zerop (sap-int pointer)))
 103
 104
 105 (defmacro when-bind ((var expr) &body body)
 106   `(let ((,var ,expr))
 107      (when ,var
 108        ,@body)))
 109
 110
 111 (defmacro assoc-ref (key alist &key (test #'eq))
 112   `(cdr (assoc ,key ,alist :test ,test)))
 113
 114
 115 (defmacro assoc-lref (key alist &key (test #'eq))
 116   `(cadr (assoc ,key ,alist :test ,test)))
 117
 118
 119 (defun assoc-rem (key alist &key (test #'eq))
 120   (remove-if #'(lambda (element) (funcall test key (car element))) alist))
 121
 122
 123 (defun assoc-delete (key alist &key (test #'eq))
 124   (delete-if #'(lambda (element) (funcall test key (car element))) alist))
 125
 126
 127 (defun funcallable (object)
 128   (if (consp object)
 129       (fdefinition object)
 130     object))
 131
 132 (defun intersection-p (list1 list2 &key (test #'eq))
 133   (dolist (obj list1 nil)
 134     (when (member obj list2 :test test)
 135       (return-from intersection-p t))))
 136
 137
 138 (defun split-string (string delimiter)
 139   (declare (simple-string string) (character delimiter))
 140   (check-type string string)
 141   (check-type delimiter character)
 142   (let ((pos (position delimiter string)))
 143    (if (not pos)
 144         (list string)
 145       (cons
 146        (subseq string 0 pos)
 147        (split-string (subseq string (1+ pos)) delimiter)))))
 148
 149 (defun split-string-if (string predicate)
 150   (declare (simple-string string))
 151   (check-type string string)
 152   (check-type predicate (or symbol function))
 153   (let ((pos (position-if predicate string :start 1)))
 154     (if (not pos)
 155         (list string)
 156       (cons
 157        (subseq string 0 pos)
 158        (split-string-if (subseq string pos) predicate)))))
 159
 160 (defun concatenate-strings (strings &optional delimiter)
 161   (if (not (rest strings))
 162       (first strings)
 163     (concatenate
 164      'string
 165      (first strings)
 166      (if delimiter (string delimiter) "")
 167      (concatenate-strings (rest strings)))))
 168
 169 (defun string-prefix-p (string1 string2)
 170   (string= string1 string2 :end2 (length string1)))