Changes required by CLISP

diff --git a/examples/testcairo.lisp b/examples/testcairo.lisp
index bbdc56c9381f7255eb18c8fe5664b00264b67690..41b7230c71ef0c41d45639fddd35c87f5d745221 100644 (file)
--- a/examples/testcairo.lisp
+++ b/examples/testcairo.lisp
@@ -2,18 +2,17 @@
 ;; See http://cairographics.org/samples/
 
 #+sbcl(require :gtk)
-#+cmu(asdf:oos 'asdf:load-op :gtk)
 #+sbcl(require :cairo)
-#+cmu(asdf:oos 'asdf:load-op :cairo)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :cairo)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (if (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93" :error nil)
-      (push :rsvg *features*)
+  (unless (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
     (warn "SVG tests disabled as the required version of librsvg is not available.")))
 
-
-#+(and sbcl rsvg)(require :rsvg)
-#+(and cmu  rsvg)(asdf:oos 'asdf:load-op :rsvg)
+#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
+#+sbcl(require :rsvg)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :rsvg)
 
 (defpackage "TESTCAIRO"
   (:use "COMMON-LISP" "GTK")
@@ -151,53 +150,54 @@ (define-snippet clip-rectangle (cr)
   (cairo:stroke cr))
 
 
+(defun %curve-rectangle (cr x0 y0 width height radius)
+  (unless (and (zerop width) (zerop height))
+    (let ((x1 (+ x0 width))
+         (y1 (+ y0 height)))
+      (cond
+       ((and (< (* 0.5 width) radius) (< (* 0.5 height) radius))
+       (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
+       (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
+       (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
+       (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
+       (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
+       ((< (* 0.5 width) radius)
+       (cairo:move-to  cr x0 (+ y0 radius))
+       (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
+       (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
+       (cairo:line-to cr x1  (- y1 radius))
+       (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
+       (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius)))
+       ((< (* 0.5 height) radius)
+       (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
+       (cairo:curve-to cr x0  y0 x0  y0 (+ x0 radius) y0)
+       (cairo:line-to cr (- x1 radius) y0)
+       (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
+       (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
+       (cairo:line-to cr (+ x0 radius) y1)
+       (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
+       (t
+       (cairo:move-to cr x0 (+ y0 radius))
+       (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0)
+       (cairo:line-to cr (- x1 radius) y0)
+       (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
+       (cairo:line-to cr x1 (- y1 radius))
+       (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
+       (cairo:line-to cr (+ x0 radius) y1)
+       (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius))))
+      (cairo:close-path cr))))
+
 (define-snippet curve-rectangle (cr)
   (let ((x0 0.1)
        (y0 0.1)
        (width 0.8)
        (height 0.8)
        (radius 0.4))
-    (unless (and (zerop width) (zerop height))
-      (let ((x1 (+ x0 width))
-           (y1 (+ y0 height)))
-       (cond
-        ((and (< (* 0.5 width) radius) (< (* 0.5 height) radius))
-         (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
-         (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
-         (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
-         (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
-         (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
-        ((< (* 0.5 width) radius)
-         (cairo:move-to  cr x0 (+ y0 radius))
-         (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
-         (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
-         (cairo:line-to cr x1  (- y1 radius))
-         (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
-         (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius)))
-        ((< (* 0.5 height) radius)
-         (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
-         (cairo:curve-to cr x0  y0 x0  y0 (+ x0 radius) y0)
-         (cairo:line-to cr (- x1 radius) y0)
-         (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
-         (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
-         (cairo:line-to cr (+ x0 radius) y1)
-         (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
-        (t
-         (cairo:move-to cr x0 (+ y0 radius))
-         (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0)
-         (cairo:line-to cr (- x1 radius) y0)
-         (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
-         (cairo:line-to cr x1 (- y1 radius))
-         (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
-         (cairo:line-to cr (+ x0 radius) y1)
-         (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius))))
-       (cairo:close-path cr)
-
-       (cairo:set-source-color cr 0.5 0.5 1.0)
-       (cairo:fill cr t)
-       (cairo:set-source-color cr 0.5 0.0 0.0 0.5)
-       (cairo:stroke cr)))))
-
+    (%curve-rectangle cr x0 y0 width height radius)
+    (cairo:set-source-color cr 0.5 0.5 1.0)
+    (cairo:fill cr t)
+    (cairo:set-source-color cr 0.5 0.0 0.0 0.5)
+    (cairo:stroke cr)))
 
 
 (define-snippet curve-to (cr)
@@ -309,7 +309,8 @@ (define-snippet image-pattern (cr)
     (cairo:fill cr)))
 
 
-#+rsvg(progn
+#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
+(progn
 (defun snippet-set-bg-svg (cr filename)
   (let ((handle (make-instance 'rsvg:handle :filename filename)))
     (cairo:with-context (cr)
@@ -492,7 +493,7 @@ (defun create-tests ()
                           :vscrollbar-policy :automatic
                           :border-width 10))
         (close-button (make-instance 'button 
-                       :label "close" :can-default t
+                       :stock "gtk-close" :can-default t
                        :signal (list 'clicked #'widget-destroy 
                                 :object main-window))))
 
@@ -508,9 +509,14 @@ (defun create-tests ()
      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
      :child (list (make-instance 'label :label (clg-version)) :fill nil)
      :child (list (make-instance 'label                          
-                  :label #-cmu(format nil "~A (~A)" 
-                               (lisp-implementation-type)
-                               (lisp-implementation-version))
+                  :label #-cmu
+                         (format nil "~A (~A)" 
+                          (lisp-implementation-type)
+                          #-clisp
+                          (lisp-implementation-version)
+                          #+clisp
+                          (let ((version (lisp-implementation-version)))
+                            (subseq version 0 (position #\sp version))))
                          ;; The version string in CMUCL is far too long
                          #+cmu(lisp-implementation-type))
                  :fill nil)
@@ -534,7 +540,8 @@ (defun create-tests ()
 
 
 (clg-init)
-#+rsvg(rsvg:init)
+#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
+(rsvg:init)
 
 ;; We need to turn off floating point exceptions, because Cairo is
 ;; presumably using internal code which generates NaNs in some cases.

diff --git a/examples/testdnd.lisp b/examples/testdnd.lisp
index d796fd79be2d739d1672105129e3e37db6051651..1d7c8162054f496c3776f94a1fcaa21efebb2edf 100644 (file)
--- a/examples/testdnd.lisp
+++ b/examples/testdnd.lisp
@@ -1,7 +1,7 @@
 ;;;; Translation of dragndrop.py from the PyGTK 2.0 Tutorial
 
 #+sbcl(require :gtk)
-#+cmu(asdf:oos 'asdf:load-op :gtk)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
 
 (defpackage "TESTDND"
   (:use "COMMON-LISP" "GTK")
@@ -70,8 +70,6 @@ (defvar to-button
 (defvar to-canvas 
   (make-instance 'target-entry :target "image/png" :id *target-type-image*))
 
-
-
 (defun add-image (layout pixbuf xd yd)
   (let ((button (make-instance 'button
                 :child (make-instance 'image :pixbuf pixbuf))))
@@ -84,12 +82,14 @@ (defun add-image (layout pixbuf xd yd)
          ((= target-type *target-type-text*)
           (selection-data-set-text selection 
            #+cmu(ext:format-universal-time nil (get-universal-time) :style :rfc1123 :print-timezone nil)
-           #+sbcl(sb-int:format-universal-time nil (get-universal-time) :style :abbreviated :print-timezone nil)))
+           #+sbcl(sb-int:format-universal-time nil (get-universal-time) :style :abbreviated :print-timezone nil)
+           #+clisp(os:string-time "%x %X")
+           #-(or cmu sbcl clisp)(format nil "~D" (get-universal-time))))
          ((= target-type *target-type-image*)
           (selection-data-set-pixbuf selection pixbuf)))))
      
     (drag-source-set button :button1 from-image :copy)
-      
+ 
     (with-slots (hadjustment vadjustment) layout
       (layout-put layout button
        (truncate (+ xd (adjustment-value hadjustment)))