X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/0d07716fe78436ae6c9c324cabdd401c25e336af..87775569cef57ed5298d4a154ec911a476e8628a:/glib/gutils.lisp diff --git a/glib/gutils.lisp b/glib/gutils.lisp index cf939c3..15a43d3 100644 --- a/glib/gutils.lisp +++ b/glib/gutils.lisp @@ -15,7 +15,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gutils.lisp,v 1.1 2000/08/14 16:44:34 espen Exp $ +;; $Id: gutils.lisp,v 1.7 2001/05/20 23:10:36 espen Exp $ (in-package "KERNEL") @@ -30,9 +30,43 @@ (values (funcall def (if (consp form) form (list form))) t) (values form nil)))) +(in-package "PCL") -(in-package "GLIB") +;;;; Make PCL's class finalization protocol behave as specified in AMOP + +(defmethod finalize-inheritance ((class std-class)) + (dolist (super (class-direct-superclasses class)) + (unless (class-finalized-p super) (finalize-inheritance super))) + (update-cpl class (compute-class-precedence-list class)) + (update-slots class (compute-slots class)) + (update-gfs-of-class class) + (update-inits class (compute-default-initargs class)) + (update-make-instance-function-table class)) + +(defmethod finalize-inheritance ((class forward-referenced-class)) + (error "~A can't be finalized" class)) + +(defun update-class (class &optional finalizep) + (declare (ignore finalizep)) + (when (and + (class-finalized-p class) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (dolist (sub (class-direct-subclasses class)) + (update-class sub)))) +(defmethod add-method :before ((gf standard-generic-function) + (method standard-method)) + (declare (ignore gf)) + (dolist (specializer (method-specializers method)) + (when (and + (typep specializer 'standard-class) + (not (class-finalized-p specializer)) + (not (class-has-a-forward-referenced-superclass-p specializer))) + (finalize-inheritance specializer)))) + + +(in-package "GLIB") (defun type-expand-to (type form) (labels ((expand (form0) @@ -50,7 +84,7 @@ `(progn (let ((,gc-inhibit lisp::*gc-inhibit*)) (ext:gc-off) - (unwind-protect + (unwind-protect ,@body (unless ,gc-inhibit (ext:gc-on))))))) @@ -83,3 +117,73 @@ (defun null-pointer-p (pointer) (zerop (sap-int pointer))) + + +(defmacro when-bind ((var expr) &body body) + `(let ((,var ,expr)) + (when ,var + ,@body))) + + +(defmacro assoc-ref (key alist &key (test #'eq)) + `(cdr (assoc ,key ,alist :test ,test))) + + +(defmacro assoc-lref (key alist &key (test #'eq)) + `(cadr (assoc ,key ,alist :test ,test))) + + +(defun assoc-rem (key alist &key (test #'eq)) + (remove-if #'(lambda (element) (funcall test key (car element))) alist)) + + +(defun assoc-delete (key alist &key (test #'eq)) + (delete-if #'(lambda (element) (funcall test key (car element))) alist)) + + +(defun funcallable (object) + (if (consp object) + (fdefinition object) + object)) + +(defun intersection-p (list1 list2 &key (test #'eq)) + (dolist (obj list1 nil) + (when (member obj list2 :test test) + (return-from intersection-p t)))) + + +(defun split-string (string delimiter) + (declare (simple-string string) (character delimiter)) + (check-type string string) + (check-type delimiter character) + (let ((pos (position delimiter string))) + (if (not pos) + (list string) + (cons + (subseq string 0 pos) + (split-string (subseq string (1+ pos)) delimiter))))) + +(defun split-string-if (string predicate) + (declare (simple-string string)) + (check-type string string) + (check-type predicate (or symbol function)) + (let ((pos (position-if predicate string :start 1))) + (if (not pos) + (list string) + (cons + (subseq string 0 pos) + (split-string-if (subseq string pos) predicate))))) + +(defun concatenate-strings (strings &optional delimiter) + (if (not (rest strings)) + (first strings) + (concatenate + 'string + (first strings) + (if delimiter (string delimiter) "") + (concatenate-strings (rest strings) delimiter)))) + +(defun string-prefix-p (prefix string) + (and + (>= (length string) (length prefix)) + (string= prefix string :end2 (length prefix))))