Re: fails to build with sbcl 0.9.11
Espen S Johnsen <[email protected]> 12 Apr 2006 09:07:14 +0200
| Newsgroups | gmane.lisp.clg.devel |
|---|---|
| Message-ID | <[email protected]> |
Peter De Wachter <[email protected]> writes: > clg 0.92 fails to build for me with sbcl 0.9.11 on amd64. Earlier > versions of sbcl work ok. I've attached a build log and a backtrace. Thanks, I hadn't noticed this because in my current development tree this bug wasn't triggered due to the gtk classes being defined in different order. > It seems this is the sbcl patch that broke clg: > http://article.gmane.org/gmane.lisp.steel-bank.cvs/8116 > If I revert that, clg works. I hope this is useful, I don't understand > this CLOS magic at all. This change to SBCL seem causes class finalization process to be done slightly differently than before, but the clg changes required were quite trivial. > Oh, and this is a patch for the sbcl version detection. CVS versions > of sbcl have a fourth version component, which confused clg. I have committed this patch and made some other bug fixes (including the changes to widget-modify-font mentioned in another post) to CVS. As the updates hasn't propagated to anonymous CVS yet, server even seems to be down at the moment, I have attached a patch made against clg 0.92. If no other bugs turn up I will release this as 0.92.1 soon. diff -urbE clg-0.92/gdk/gdk.lisp clg/gdk/gdk.lisp --- clg-0.92/gdk/gdk.lisp 2006-02-26 16:09:44.000000000 +0100 +++ clg/gdk/gdk.lisp 2006-04-11 20:28:38.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gdk.lisp,v 1.22 2006/02/26 15:09:44 espen Exp $ +;; $Id: gdk.lisp,v 1.25 2006/04/11 18:28:38 espen Exp $ (in-package "GDK") @@ -503,13 +503,24 @@ ;;; Color +(defbinding %color-copy () pointer + (location pointer)) + +(defmethod allocate-foreign ((color color) &rest initargs) + (declare (ignore color initargs)) + ;; Color structs are allocated as memory chunks by gdk, and since + ;; there is no gdk_color_new we have to use this hack to get a new + ;; color chunk + (with-allocated-memory (location #.(foreign-size (find-class 'color))) + (%color-copy location))) + (defun %scale-value (value) (etypecase value (integer value) (float (truncate (* value 65535))))) (defmethod initialize-instance ((color color) &rest initargs - &key red green blue) + &key (red 0.0) (green 0.0) (blue 0.0)) (declare (ignore initargs)) (call-next-method) (with-slots ((%red red) (%green green) (%blue blue)) color @@ -518,14 +529,24 @@ %green (%scale-value green) %blue (%scale-value blue)))) +(defbinding %color-parse () boolean + (spec string) + (color color :return)) + +(defun color-parse (spec &optional (color (make-instance 'color))) + (multiple-value-bind (succeeded-p color) (%color-parse spec color) + (if succeeded-p + color + (error "Parsing color specification ~S failed." spec)))) + (defun ensure-color (color) (etypecase color (null nil) (color color) + (string (color-parse color)) (vector - (make-instance - 'color :red (svref color 0) :green (svref color 1) - :blue (svref color 2))))) + (make-instance 'color + :red (svref color 0) :green (svref color 1) :blue (svref color 2))))) diff -urbE clg-0.92/gdk/gdktypes.lisp clg/gdk/gdktypes.lisp --- clg-0.92/gdk/gdktypes.lisp 2006-02-27 00:47:50.000000000 +0100 +++ clg/gdk/gdktypes.lisp 2006-04-10 20:16:24.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gdktypes.lisp,v 1.22 2006/02/26 23:47:50 espen Exp $ +;; $Id: gdktypes.lisp,v 1.23 2006/04/10 18:16:24 espen Exp $ (in-package "GDK") @@ -36,19 +36,19 @@ (defclass color (boxed) ((pixel :allocation :alien - :type unsigned-long) + :type (unsigned 32)) (red :allocation :alien :accessor color-red - :type unsigned-short) + :type (unsigned 16)) (green :allocation :alien :offset 6 :accessor color-green - :type unsigned-short) + :type (unsigned 16)) (blue :allocation :alien :offset 8 :accessor color-blue - :type unsigned-short)) + :type (unsigned 16))) (:metaclass boxed-class)) diff -urbE clg-0.92/glib/glib.asd clg/glib/glib.asd --- clg-0.92/glib/glib.asd 2006-03-06 15:28:01.000000000 +0100 +++ clg/glib/glib.asd 2006-04-10 19:45:23.000000000 +0200 @@ -20,30 +20,17 @@ (pkg-exists-p "glib-2.0" :atleast-version "2.4.0") -(when (string>= (pkg-version "glib-2.0") "2.6.0") +(when (pkg-exists-p "glib-2.0" :atleast-version "2.6.0" :error nil) (push :glib2.6 *features*)) -(when (string>= (pkg-version "glib-2.0") "2.8.0") +(when (pkg-exists-p "glib-2.0" :atleast-version "2.8.0" :error nil) (push :glib2.8 *features*)) #+sbcl (progn - (defun sbcl-version () - (let ((dot1 (position #\. (lisp-implementation-version))) - (dot2 (position #\. (lisp-implementation-version) :from-end t))) - (values - (parse-integer (lisp-implementation-version) :end dot1) - (parse-integer (lisp-implementation-version) :start (1+ dot1) :end dot2) - (parse-integer (lisp-implementation-version) :start (1+ dot2))))) - (defun sbcl-version>= (req-major req-minor req-micro) - (multiple-value-bind (major minor micro) (sbcl-version) - (or - (> major req-major) - (and (= major req-major) (> minor req-minor)) - (and (= major req-major) (= minor req-minor) (>= micro req-micro))))) - (when (sbcl-version>= 0 9 8) + (when (sbcl>= 0 9 8) (push :sbcl>=0.9.8 *features*)) - (when (sbcl-version>= 0 9 10) + (when (sbcl>= 0 9 10) (push :sbcl>=0.9.10 *features*))) #+(and sbcl (not alien-callbacks)) diff -urbE clg-0.92/glib/gtype.lisp clg/glib/gtype.lisp --- clg-0.92/glib/gtype.lisp 2006-03-06 21:57:08.000000000 +0100 +++ clg/glib/gtype.lisp 2006-04-10 19:34:45.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtype.lisp,v 1.49 2006/03/06 20:57:08 espen Exp $ +;; $Id: gtype.lisp,v 1.50 2006/04/10 17:34:45 espen Exp $ (in-package "GLIB") @@ -298,7 +298,6 @@ (defmethod finalize-inheritance ((class ginstance-class)) - (call-next-method) (let* ((class-name (class-name class)) (super (most-specific-proxy-superclass class)) (gtype (or @@ -320,8 +319,8 @@ (not (eq (class-name super) (supertype type-number)))) (warn "Super class mismatch between CLOS and GObject for ~A" class-name))) - - (update-size class)) + (update-size class) + (call-next-method)) (defmethod shared-initialize ((class ginstance-class) names &rest initargs) diff -urbE clg-0.92/gtk/gtk.asd clg/gtk/gtk.asd --- clg-0.92/gtk/gtk.asd 2006-02-06 13:01:11.000000000 +0100 +++ clg/gtk/gtk.asd 2006-04-10 20:48:03.000000000 +0200 @@ -9,10 +9,10 @@ (pkg-exists-p "gtk+-2.0" :atleast-version "2.4.0") -(when (string>= (pkg-version "gtk+-2.0") "2.6.0") +(when (pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil) (pushnew :gtk2.6 *features*)) -(when (string>= (pkg-version "gtk+-2.0") "2.8.0") +(when (pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0" :error nil) (pushnew :gtk2.8 *features*)) (defsystem gtk diff -urbE clg-0.92/gtk/gtk.lisp clg/gtk/gtk.lisp --- clg-0.92/gtk/gtk.lisp 2006-02-28 17:29:45.000000000 +0100 +++ clg/gtk/gtk.lisp 2006-04-10 20:56:19.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtk.lisp,v 1.59 2006/02/28 16:29:45 espen Exp $ +;; $Id: gtk.lisp,v 1.60 2006/04/10 18:56:19 espen Exp $ (in-package "GTK") @@ -45,7 +45,7 @@ (format nil "Gtk+ v~A.~A.~A" major minor micro)))) (defun clg-version () - "clg 0.92") + "clg 0.92.1") ;;;; Initalization diff -urbE clg-0.92/gtk/gtkselection.lisp clg/gtk/gtkselection.lisp --- clg-0.92/gtk/gtkselection.lisp 2006-02-26 16:22:47.000000000 +0100 +++ clg/gtk/gtkselection.lisp 2006-04-10 20:54:47.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkselection.lisp,v 1.7 2006/02/26 15:22:47 espen Exp $ +;; $Id: gtkselection.lisp,v 1.8 2006/04/10 18:54:47 espen Exp $ (in-package "GTK") @@ -97,7 +97,8 @@ boolean (display gdk:display) (widget widget) - ((gdk:atom-intern selection) gdk:atom)) + ((gdk:atom-intern selection) gdk:atom) + (time (unsigned 32))) (defbinding selection-add-target () nil (widget widget) diff -urbE clg-0.92/gtk/gtkwidget.lisp clg/gtk/gtkwidget.lisp --- clg-0.92/gtk/gtkwidget.lisp 2006-02-26 16:24:46.000000000 +0100 +++ clg/gtk/gtkwidget.lisp 2006-04-10 20:42:08.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkwidget.lisp,v 1.20 2006/02/26 15:24:46 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.21 2006/04/10 18:42:08 espen Exp $ (in-package "GTK") @@ -333,10 +333,12 @@ (state state-type) (color gdk:color)) -(defbinding widget-modify-font () nil +(defbinding widget-modify-font (widget font-desc) nil (widget widget) - (state state-type) - (font-desc pango:font-description)) + ((etypecase font-desc + (pango:font-description font-desc) + (string (pango:font-description-from-string font-desc))) + pango:font-description)) (defbinding widget-create-pango-context () pango:context (widget widget)) diff -urbE clg-0.92/pango/pango.lisp clg/pango/pango.lisp --- clg-0.92/pango/pango.lisp 2005-04-23 18:48:52.000000000 +0200 +++ clg/pango/pango.lisp 2006-04-10 20:39:31.000000000 +0200 @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: pango.lisp,v 1.9 2005/04/23 16:48:52 espen Exp $ +;; $Id: pango.lisp,v 1.10 2006/04/10 18:39:31 espen Exp $ (in-package "PANGO") @@ -35,4 +35,9 @@ (pkg-config:pkg-variable "pango" "libdir") "/libpangoft2-1.0.so") :prefix "pango_fc")) -(define-types-by-introspection "Pango") +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-types-by-introspection "Pango")) + +(defbinding font-description-from-string () font-description + (desc string)) + diff -urbE clg-0.92/systems/clg-tools.asd clg/systems/clg-tools.asd --- clg-0.92/systems/clg-tools.asd 2004-10-30 21:23:49.000000000 +0200 +++ clg/systems/clg-tools.asd 2006-03-29 12:00:03.000000000 +0200 @@ -9,6 +9,7 @@ (defsystem clg-tools :components ((:file "autoexport") - (:file "config") + (:file "utils") + (:file "config" :depends-on ("utils")) (:file "asdf-extensions"))) diff -urbE clg-0.92/systems/glib.asd clg/systems/glib.asd --- clg-0.92/systems/glib.asd 2006-03-06 15:28:01.000000000 +0100 +++ clg/systems/glib.asd 2006-04-10 19:45:23.000000000 +0200 @@ -20,30 +20,17 @@ (pkg-exists-p "glib-2.0" :atleast-version "2.4.0") -(when (string>= (pkg-version "glib-2.0") "2.6.0") +(when (pkg-exists-p "glib-2.0" :atleast-version "2.6.0" :error nil) (push :glib2.6 *features*)) -(when (string>= (pkg-version "glib-2.0") "2.8.0") +(when (pkg-exists-p "glib-2.0" :atleast-version "2.8.0" :error nil) (push :glib2.8 *features*)) #+sbcl (progn - (defun sbcl-version () - (let ((dot1 (position #\. (lisp-implementation-version))) - (dot2 (position #\. (lisp-implementation-version) :from-end t))) - (values - (parse-integer (lisp-implementation-version) :end dot1) - (parse-integer (lisp-implementation-version) :start (1+ dot1) :end dot2) - (parse-integer (lisp-implementation-version) :start (1+ dot2))))) - (defun sbcl-version>= (req-major req-minor req-micro) - (multiple-value-bind (major minor micro) (sbcl-version) - (or - (> major req-major) - (and (= major req-major) (> minor req-minor)) - (and (= major req-major) (= minor req-minor) (>= micro req-micro))))) - (when (sbcl-version>= 0 9 8) + (when (sbcl>= 0 9 8) (push :sbcl>=0.9.8 *features*)) - (when (sbcl-version>= 0 9 10) + (when (sbcl>= 0 9 10) (push :sbcl>=0.9.10 *features*))) #+(and sbcl (not alien-callbacks)) diff -urbE clg-0.92/systems/gtk.asd clg/systems/gtk.asd --- clg-0.92/systems/gtk.asd 2006-02-06 13:01:11.000000000 +0100 +++ clg/systems/gtk.asd 2006-04-10 20:48:03.000000000 +0200 @@ -9,10 +9,10 @@ (pkg-exists-p "gtk+-2.0" :atleast-version "2.4.0") -(when (string>= (pkg-version "gtk+-2.0") "2.6.0") +(when (pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil) (pushnew :gtk2.6 *features*)) -(when (string>= (pkg-version "gtk+-2.0") "2.8.0") +(when (pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0" :error nil) (pushnew :gtk2.8 *features*)) (defsystem gtk diff -urbE clg-0.92/tools/asdf-extensions.lisp clg/tools/asdf-extensions.lisp --- clg-0.92/tools/asdf-extensions.lisp 2006-02-16 00:36:17.000000000 +0100 +++ clg/tools/asdf-extensions.lisp 2006-03-29 12:01:30.000000000 +0200 @@ -51,10 +51,16 @@ (module-components dso))))) (error 'operation-error :operation operation :component dso)))) +#+clisp +(defvar *loaded-libraries* ()) (defun load-dso (filename) #+sbcl(sb-alien:load-shared-object filename) - #+cmu(ext:load-foreign filename)) + #+cmu(ext:load-foreign filename) + #+clisp + (unless (find filename *loaded-libraries* :test #'equal) + (ffi::foreign-library (namestring filename)) + (push filename *loaded-libraries*))) (defmethod perform ((o load-op) (c unix-dso)) @@ -135,7 +141,8 @@ system::*global-table* :key #'(lambda (pathname) (when pathname (unix::unix-namestring pathname))) - :test #'equal)) + :test #'equal) + #+clisp(find (component-pathname c) *loaded-libraries* :test #'equal)) (defmethod operation-done-p ((o operation) (c library)) t) diff -urbE clg-0.92/tools/clg-tools.asd clg/tools/clg-tools.asd --- clg-0.92/tools/clg-tools.asd 2004-10-30 21:23:49.000000000 +0200 +++ clg/tools/clg-tools.asd 2006-03-29 12:00:03.000000000 +0200 @@ -9,6 +9,7 @@ (defsystem clg-tools :components ((:file "autoexport") - (:file "config") + (:file "utils") + (:file "config" :depends-on ("utils")) (:file "asdf-extensions"))) diff -urbE clg-0.92/tools/config.lisp clg/tools/config.lisp --- clg-0.92/tools/config.lisp 2006-02-15 10:59:26.000000000 +0100 +++ clg/tools/config.lisp 2006-04-10 19:38:51.000000000 +0200 @@ -1,59 +1,27 @@ (defpackage #:pkg-config - (:use #:common-lisp #+cmu #:ext #+sbcl #:sb-ext) - (:export #:pkg-cflags #:pkg-libs #:pkg-exists-p #:pkg-version - #:pkg-variable)) + (:use #:common-lisp #:clg-utils #+(or cmu clisp) #:ext #+sbcl #:sb-ext) + #+sbcl + (:import-from #:sb-int #:featurep) + (:export #:pkg-cflags #:pkg-libs #:pkg-exists-p #:pkg-version #:pkg-variable) + (:export #:featurep #:sbcl>=)) (in-package #:pkg-config) (defparameter *pkg-config* "/usr/bin/pkg-config") -(defun split-string (string &key (start 0) (end (length string))) - (let ((position (position #\sp string :start start :end end))) - (cond - ((zerop (- end start)) nil) - ((not position) (list (subseq string start end))) - ((= position start) (split-string string :start (1+ start) :end end)) - (t (cons - (subseq string start position) - (split-string string :start (1+ position) :end end)))))) - - -(defun read-lines (&optional (stream *standard-input*)) - (let ((line (read-line stream nil))) - (when line - (cons line (read-lines stream))))) - - -(defun read-string (&optional (stream *standard-input*) - (delimiter #\newline) (eof-error-p t) eof-value) - (let ((string (make-array 0 :element-type 'character - :fill-pointer t :adjustable t))) - ;; I really need to learn how to use the loop facility - (labels ((read-chars () - (let ((char (read-char stream (and eof-error-p delimiter)))) - (when char - (vector-push-extend char string) - (unless (eq char delimiter) - (read-chars)))))) - (read-chars)) - (cond - ((not (zerop (length string))) string) - ((not eof-error-p) eof-value) - ((error 'end-of-file :stream stream))))) - #+(or sbcl cmu) -(defun run-pkg-config (package error &rest options) +(defun run-pkg-config (package error-p &rest options) (let ((process (run-program *pkg-config* (cons package options) :wait t :output :stream))) (unless process (error "Unable to run ~A" *pkg-config*)) (let ((exit-code (process-exit-code process))) - (unless (or (not error) (zerop exit-code)) + (unless (or (not error-p) (zerop exit-code)) (error (or - (read-string (process-error process) nil) + (format nil "~A: ~{~A~%~}" *pkg-config* (read-lines (process-error process))) (format nil "~A terminated with exit code ~A" *pkg-config* exit-code)))) (let ((output (read-lines (process-output process)))) @@ -61,11 +29,37 @@ (values output exit-code))))) #+clisp -;; I haven't figured out how to do error checking with CLISP's run-program -(defun run-pkg-config (package error &rest options) - (declare (ignore error)) - (let ((stream (ext:run-program *pkg-config* :arguments (cons package options) :output :stream))) - (read-lines stream))) +(defun run-pkg-config (package error-p &rest options) + (let ((outfile (format nil "/tmp/clg-pkg-config-~A-output" (os:process-id))) + (errfile (format nil "/tmp/clg-pkg-config-~A-error" (os:process-id)))) + (unwind-protect + (let ((exit-code + (run-shell-command + (format nil "~A ~A ~{~A ~}2>~A" + *pkg-config* package + (mapcar #'(lambda (option) + (format nil "'~A'" option)) + options) + errfile) + :output outfile :if-output-exists :overwrite))) + (cond + ((= exit-code 127) (error "Unable to run ~A" *pkg-config*)) + ((and error-p (not (zerop exit-code))) + (with-open-file (output errfile) + (let ((errmsg (read-lines output))) + (error + (if (not errmsg) + (format nil "~A terminated with exit code ~A" *pkg-config* exit-code) + (format nil "~A: ~{~A~%~}" *pkg-config* errmsg)))))) + (t + (values + (with-open-file (output outfile) + (read-lines output)) + exit-code)))) + (progn + (delete-file outfile) + (delete-file errfile))))) + (defun pkg-cflags (package) (split-string (first (run-pkg-config package t "--cflags")))) @@ -98,3 +92,46 @@ (defun pkg-variable (package variable) (first (run-pkg-config package t "--variable" variable))) + + +(defun |#?-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (let ((not-p (when (char= (peek-char nil stream) #\-) + (read-char stream))) + (conditional (read stream t nil t))) + (cond + (*read-suppress* (read stream t nil t)) + ((not *read-eval*) + (error 'reader-error + :format-control "Attempt to read #? while *READ-EVAL* is bound to NIL." + :format-arguments nil :stream stream)) + ((if not-p + (eval conditional) + (not (eval conditional))) + (let ((*read-suppress* t)) + (read stream t nil t))))) + (values)) + +(set-dispatch-macro-character #\# #\? #'|#?-reader|) + + +#+sbcl +(progn + (defun sbcl-version () + (let* ((dot1 (position #\. (lisp-implementation-version))) + (dot2 (position #\. (lisp-implementation-version) :start (1+ dot1)))) + (values + (parse-integer (lisp-implementation-version) :end dot1) + (parse-integer (lisp-implementation-version) :start (1+ dot1) :end dot2) + (parse-integer (lisp-implementation-version) :start (1+ dot2) :junk-allowed t)))) + (defun sbcl>= (req-major req-minor req-micro) + (multiple-value-bind (major minor micro) (sbcl-version) + (or + (> major req-major) + (and (= major req-major) (> minor req-minor)) + (and (= major req-major) (= minor req-minor) (>= micro req-micro)))))) + +#-sbcl +(defun sbcl>= (req-major req-minor req-micro) + (declare (ignore req-major req-minor req-micro)) + nil) -- Espen ------------------------------------------------------- This SF.Net email is sponsored by xPML, a groundbreaking scripting language that extends applications into web and mobile media. Attend the live webcast and join the prime developer group breaking into this new coding territory! http://sel.as-us.falkag.net/sel?cmd=lnk&kid=110944&bid=241720&dat=121642