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.1 2000-08-14 16:44:34 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
  34 (in-package "GLIB")
  35
  36
  37 (defun type-expand-to (type form)
  38   (labels ((expand (form0)
  39              (if (eq (first (mklist form0)) type)
  40                  form0
  41                (multiple-value-bind (expanded-form expanded-p)
  42                    (type-expand-1 form0)
  43                  (if expanded-p
  44                      (expand expanded-form)
  45                    (error "~A can not be expanded to ~A" form type))))))
  46     (expand form)))
  47
  48 (defmacro with-gc-disabled (&body body)
  49   (let ((gc-inhibit (make-symbol "GC-INHIBIT")))
  50     `(progn
  51        (let ((,gc-inhibit lisp::*gc-inhibit*))
  52          (ext:gc-off)
  53          (unwind-protect
  54              ,@body
  55            (unless ,gc-inhibit
  56              (ext:gc-on)))))))
  57
  58 (defun mklist (obj)
  59   (if (atom obj) (list obj) obj))
  60
  61 (defun namep (obj)
  62   (and (symbolp obj) (not (member obj '(t nil)))))
  63
  64 (defun all-equal (&rest objects)
  65   (or
  66    (null objects)
  67    (null (rest objects))
  68    (and
  69     (equal (first objects) (second objects))
  70     (apply #'all-equal (rest objects)))))
  71
  72 (defun neq (obj1 obj2)
  73   (not (eq obj1 obj2)))
  74
  75 (defmacro return-if (form)
  76   (let ((result (make-symbol "RESULT")))
  77     `(let ((,result ,form))
  78        (when ,result
  79          (return ,result)))))
  80
  81 (defun make-pointer (address)
  82   (int-sap address))
  83
  84 (defun null-pointer-p (pointer)
  85   (zerop (sap-int pointer)))