X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/c1a5cdbbf6420dcf1e85b1645cec0aec1ab20f59..203681e230fc5783f54dabe79d765f4c4cec0351:/cairo/cairo.lisp

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
index 9baed3a..8e72a06 100644
--- a/cairo/cairo.lisp
+++ b/cairo/cairo.lisp
@@ -20,12 +20,14 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: cairo.lisp,v 1.5 2006-02-09 22:30:39 espen Exp $
+;; $Id: cairo.lisp,v 1.25 2009-02-09 11:45:03 espen Exp $
 
 (in-package "CAIRO")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (define-enum-type surface-format :argb32 :rgb24 :a8 :a1)
+  (define-enum-type content :color :alpha :color-alpha)
+  (define-enum-type svg-version :svg-1.1 :svg-1.2)
 
   (define-enum-type status
     :success :no-memory :invalid-restore :invalid-pop-group
@@ -38,7 +40,7 @@   (define-enum-type status
   (define-enum-type fill-rule :winding :even-odd)
   (define-enum-type line-cap :butt :round :square)
   (define-enum-type line-join :miter :round :bevel)    
-  (define-enum-type font-slant :normal :itaic :oblique)
+  (define-enum-type font-slant :normal :italic :oblique)
   (define-enum-type font-weight :normal :bold)
 
   (define-enum-type operator
@@ -52,6 +54,18 @@   (define-enum-type subpixel-order :default :rgb :bgr :vrgb :vbgr)
   (define-enum-type hint-style :default :none :slight :medium :full)
   (define-enum-type hint-metrics :default :off :on)
 
+
+  (define-enum-type surface-type 
+    image-surface pdf-surface ps-surface xlib-surface xcb-surface 
+    glitz-surface quartz-surface win32-surface beos-surface 
+    directfb-surface svg-surface os2-surface)
+
+  (defclass surface-class (proxy-class)
+    ())
+
+  (defmethod validate-superclass ((class surface-class) (super standard-class))
+    (subtypep (class-name super) 'surface))
+
   (defclass glyph (struct)
     ((index 
       :allocation :alien 
@@ -70,11 +84,13 @@   (defclass glyph (struct)
       :type double-float))
     (:metaclass struct-class))
 
-  (defclass font-face (proxy)
+  (defclass font-face (ref-counted-object)
     ()
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)
+    (:ref %font-face-reference)
+    (:unref %font-face-destroy))
 
-  (defclass font-options (proxy)
+  (defclass font-options (ref-counted-object)
     ((antialias
       :allocation :virtual 
       :getter "font_options_get_antialias"
@@ -99,11 +115,15 @@   (defclass font-options (proxy)
       :setter "font_options_set_hint_metrics"
       :accessor font-options-hint-metrics
       :type hint-metrics))
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)    
+    (:ref %font-options-reference)
+    (:unref %font-options-destroy))
 
-  (defclass scaled-font (proxy)
+  (defclass scaled-font (ref-counted-object)
     ()
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)
+    (:ref %scaled-font-reference)
+    (:unref %scaled-font-destroy))
 
   (defclass matrix (struct)
     ((xx :allocation :alien :initarg :xx :initform 1.0
@@ -120,6 +140,13 @@   (defclass matrix (struct)
 	 :accessor matrix-y0 :type double-float))
     (:metaclass struct-class))
 
+  (defclass font-extents (struct)
+    ((ascent :allocation :alien :reader font-extents-ascent :type double-float)
+     (descent :allocation :alien :reader font-extents-descent :type double-float)
+     (height :allocation :alien :reader font-extents-height :type double-float)
+     (max-x-advance :allocation :alien :reader font-extents-max-x-advance :type double-float)
+     (max-y-advance :allocation :alien :reader font-extents-max-y-advance :type double-float))
+    (:metaclass struct-class))
 
   (defclass text-extents (struct)
     ((x-bearing :allocation :alien :reader text-extents-x-bearing :type double-float)
@@ -130,7 +157,7 @@   (defclass text-extents (struct)
      (y-advance :allocation :alien :reader text-extents-y-advance :type double-float))
     (:metaclass struct-class))
 
-  (defclass pattern (proxy)
+  (defclass pattern (ref-counted-object)
     ((extend
       :allocation :virtual 
       :getter "cairo_pattern_get_extend"
@@ -149,9 +176,79 @@   (defclass pattern (proxy)
       :setter "cairo_pattern_set_matrix"
       :accessor pattern-matrix
       :type matrix))
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)
+    (:ref %pattern-reference)
+    (:unref %pattern-destroy))
+
+
+  (defclass surface (ref-counted-object)
+    ((content 
+      :allocation :virtual 
+      :getter "cairo_surface_get_content"
+      :reader surface-content
+      :type content))
+    (:metaclass surface-class))
+
+  (defclass image-surface (surface)
+    ((data
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_data"
+      :reader surface-data
+      :type pointer)
+     (format
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_format"
+      :reader surface-format
+      :type surface-format)
+     (width
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_width"
+      :reader surface-width
+      :type int)
+     (height
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_height"
+      :reader surface-height
+      :type int)
+     (stride
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_stride"
+      :reader surface-stride
+      :type int))
+    (:metaclass surface-class))
+
+  (defclass xlib-surface (surface)
+    ((width
+      :allocation :virtual 
+      :getter "cairo_xlib_surface_get_width"
+      :reader surface-width
+      :type int)
+     (height
+      :allocation :virtual 
+      :getter "cairo_xlib_surface_get_height"
+      :reader surface-height
+      :type int))
+    (:metaclass surface-class))
+
+  (defclass vector-surface (surface)
+    ((width :allocation :virtual :getter surface-width)
+     (height :allocation :virtual :setter surface-height))
+    (:metaclass surface-class))
+
+  (defclass pdf-surface (vector-surface)
+    ()
+    (:metaclass surface-class))
+  
+  (defclass ps-surface (vector-surface)
+    ()
+    (:metaclass surface-class))
+    
+  (defclass svg-surface (vector-surface)
+    ()
+    (:metaclass surface-class))
+
 
-  (defclass context (proxy)
+  (defclass context (ref-counted-object)
     ((target
       :allocation :virtual 
       :getter "cairo_get_target"
@@ -207,15 +304,15 @@   (defclass context (proxy)
       :type double-float)
      (font-matrix
       :allocation :virtual 
-      :getter "cairo_get_font_matrix"
+      :getter font-matrix
       :setter "cairo_set_font_matrix"
-      :accessor font-matrix
+      :writer (setf font-matrix)
       :type matrix)
      (font-options
       :allocation :virtual 
-      :getter "cairo_get_font_options"
+      :getter font-options
       :setter "cairo_set_font_options"
-      :accessor font-options
+      :writer (setf font-options)
       :type font-options)
      (font-face
       :allocation :virtual 
@@ -223,6 +320,13 @@   (defclass context (proxy)
       :setter "cairo_set_font_face"
       :accessor font-face
       :type font-face)
+     #?(pkg-exists-p "cairo" :atleast-version "1.4")
+     (scaled-font
+      :allocation :virtual 
+      :getter "cairo_get_scaled_font"
+      :setter "cairo_set_scaled_font"
+      :accessor scaled-font
+      :type scaled-font)
      (operator
       :allocation :virtual 
       :getter "cairo_get_operator"
@@ -236,54 +340,71 @@   (defclass context (proxy)
       :writer (setf matrix)
       :type matrix)
      )
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)
+    (:ref %reference)
+    (:unref %destroy))
 
-  (defclass surface (proxy)
-    ()
-    (:metaclass proxy-class))
 
-  (defclass image-surface (surface)
-    ((width
-      :allocation :virtual 
-      :getter "cairo_image_surface_get_width"
-      :reader surface-width
+   (defclass path (struct)
+     ((status :allocation :alien :type status)
+      (data :allocation :alien :type pointer)
+      (length :allocation :alien :type int))
+     (:metaclass proxy-class)
+     (:unref %path-destroy))
+
+  (defclass jpeg-parameter (struct)
+    ((quality     
+      :allocation :alien 
+      :initarg :quality
+      :initform 75
       :type int)
-     (height
-      :allocation :virtual 
-      :getter "cairo_image_surface_get_height"
-      :reader surface-height
-      :type int))
-    (:metaclass proxy-class))
+     (interlace     
+      :allocation :alien 
+      :initarg :interlace
+      :initform t
+      :type boolean))
+    (:metaclass struct-class)))
+
+
+(define-condition cairo-error (error)
+  ((status :initarg :status :reader cairo-status))
+  (:report (lambda (condition stream)
+	     (format stream "Cairo function returned with status code: ~A"
+	      (cairo-status condition)))))
 
-;;   (defclass path (proxy)
-;;     ()
-;;     (:metaclass proxy-class))
+(deftype status-signal () 'status)
+
+(define-type-method from-alien-form ((type status-signal) status &key ref)
+  (declare (ignore type ref))
+  `(let ((status ,(from-alien-form 'status status)))
+     (unless (eq status :success)
+       (error 'cairo-error :status status))
+     status))
 
-)
 
 
 ;;; Cairo context
 
-(defbinding %reference () nil
+(defmethod allocate-foreign ((context context) &key target)
+  (%create-context target))
+
+(defbinding (%create-context "cairo_create") () pointer
+  (target surface))
+
+(defbinding %reference () pointer
   (location pointer))
 
 (defbinding %destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'context))) location)
-  (%reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'context))) location)
-  (%destroy location))
-
 (defbinding (save-context "cairo_save") () nil
   (cr context))
 
 (defbinding (restore-context "cairo_restore") () nil
   (cr context))
 
-(defmacro with-context ((cr) &body body)
-  (let ((context (make-symbol "CONTEXT")))
+(defmacro with-context ((cr &optional var) &body body)
+  (let ((context (or var (make-symbol "CONTEXT"))))
     `(let ((,context ,cr))
        (save-context ,context)
        (unwind-protect
@@ -293,19 +414,32 @@ (defmacro with-context ((cr) &body body)
 (defbinding status () status
   (cr context))
 
+(defun ensure-color-component (component)
+  (etypecase component
+    (float component)
+    (integer (/ component 256.0))))
+
 (defbinding (set-source-color "cairo_set_source_rgba") (cr red green blue &optional (alpha 1.0)) nil
   (cr context)
-  (red double-float)
-  (green double-float)
-  (blue double-float)
-  (alpha double-float))
+  ((ensure-color-component red) double-float)
+  ((ensure-color-component green) double-float)
+  ((ensure-color-component blue) double-float)
+  ((ensure-color-component alpha) double-float))
 
-(defbinding set-source-surface () nil
+(defbinding set-source-surface (cr surface &optional (x 0.0) (y 0.0)) nil
   (cr context)
   (surface surface)
   (x double-float)
   (y double-float))
 
+(defun set-source (cr source)
+  (etypecase source
+    (pattern (setf (source cr) source))
+    (surface (set-source-surface cr source))
+    (null (set-source-color cr 0.0 0.0 0.0))
+    (list (apply #'set-source-color cr source))
+    (vector (apply #'set-source-color cr (coerce source 'list)))))
+
 (defbinding set-dash (cr dashes &optional (offset 0.0)) nil
   (cr context)
   (dashes (vector double-float))
@@ -346,7 +480,7 @@ 	       (defbinding ,tname () boolean
 		 (cr context)
 		 (x double-float)
 		 (y double-float))
-	       (defbinding ,ename () boolean
+	       (defbinding ,ename () nil
 		 (cr context)
 		 (x1 double-float :out)
 		 (y1 double-float :out)
@@ -369,68 +503,71 @@ (defbinding show-page () nil
 
 ;;; Paths
 
-(defbinding get-current-point () nil
-  (cr context)
-  (x double-float :out)
-  (y double-float :out))
+(defbinding %path-destroy () nil
+  (location pointer))
 
-(defbinding new-path () nil
+(defbinding copy-path () path
   (cr context))
 
-(defbinding close-path () nil
+(defbinding copy-path-flat () path
   (cr context))
 
-(defbinding arc () nil
+(defbinding append-path () nil
   (cr context)
-  (xc double-float)
-  (yc double-float)
-  (radius double-float)
-  (angle1 double-float)
-  (angle2 double-float))
+  (path path))
 
-(defbinding arc-negative () nil
+(defbinding get-current-point () nil
   (cr context)
-  (xc double-float)
-  (yc double-float)
-  (radius double-float)
-  (angle1 double-float)
-  (angle2 double-float))
+  (x double-float :out)
+  (y double-float :out))
 
-(defun circle (cr x y radius)
-  (arc cr x y radius 0.0 (* pi 2)))
+(defbinding new-path () nil
+  (cr context))
 
-(defmacro defpath (name &rest args)
-  (let ((relname (intern (format nil "REL-~A" name))))
-    `(progn
-       (defbinding ,name () nil
-	 (cr context)
-	 ,@args)
-       (defbinding ,relname () nil
-	 (cr context)
-	 ,@args))))
-
-(defpath curve-to
-  (x1 double-float)
-  (y1 double-float)
-  (x2 double-float)
-  (y2 double-float)
-  (x3 double-float)
-  (y3 double-float))
+#?(pkg-exists-p "cairo" :atleast-version "1.2")
+(defbinding new-sub-path () nil
+  (cr context))
 
-(defpath line-to
-  (x double-float)
-  (y double-float))
+(defbinding close-path () nil
+  (cr context))
 
-(defpath move-to
-  (x double-float)
-  (y double-float))
+(defmacro defpath (name args &optional relative-p)
+  (flet ((def (name type)
+ 	   `(progn
+ 	      ,(when (eq type 'optimized-double-float)
+ 		 `(declaim (inline ,(first name))))
+	      (defbinding ,name () nil
+		(cr context)
+		,@(mapcar #'(lambda (arg) (list arg type)) args)))))
+
+  `(progn
+     ,(def name 'double-float)
+     ,(let ((name (intern (format nil "FAST-~A" name)))
+	    (cname (gffi::default-alien-fname name)))
+	(def (list name cname) 'optimized-double-float))
+     ,@(when relative-p
+	 (let* ((rel-name (intern (format nil "REL-~A" name)))
+		(fast-rel-name (intern (format nil "FAST-REL-~A" name)))
+		(cname (gffi::default-alien-fname rel-name)))
+	   (list
+	    (def rel-name 'double-float)
+	    (def (list fast-rel-name cname) 'optimized-double-float)))))))
+
+
+(defpath arc (xc yc radius angle1 angle2))
+(defpath arc-negative (xc yc radius angle1 angle2))
+(defpath curve-to (x1 y1 x2 y2 x3 y3) t)
+(defpath line-to (x y) t)
+(defpath move-to (x y) t)
+(defpath rectangle (x y width height))
+
+(defun circle (cr x y radius &optional negative-p)
+  (move-to cr radius 0.0d0)
+  (if negative-p
+      (arc-negative cr x y radius (* pi 2) 0.0d0)
+    (arc cr x y radius 0.0d0 (* pi 2)))
+  (close-path cr))
 
-(defbinding rectangle () nil
-  (cr context)
-  (x double-float)
-  (y double-float)
-  (width double-float)
-  (height double-float))
 
 (defbinding glyph-path (cr glyphs) nil
   (cr context)
@@ -449,17 +586,17 @@ (defbinding (pattern-add-color-stop "cairo_pattern_add_color_stop_rgba")
     (pattern offset red green blue &optional (alpha 1.0)) nil
   (pattern pattern)
   (offset double-float)
-  (red double-float)
-  (green double-float)
-  (blue double-float)
-  (alpha double-float))
+  ((ensure-color-component red) double-float)
+  ((ensure-color-component green) double-float)
+  ((ensure-color-component blue) double-float)
+  ((ensure-color-component alpha) double-float))
 
 (defbinding (pattern-create "cairo_pattern_create_rgba")
     (red green blue &optional (alpha 1.0)) pattern   
-  (red double-float)
-  (green double-float)
-  (blue double-float)
-  (alpha double-float))
+  ((ensure-color-component red) double-float)
+  ((ensure-color-component green) double-float)
+  ((ensure-color-component blue) double-float)
+  ((ensure-color-component alpha) double-float))
 
 (defbinding pattern-create-for-surface () pattern
   (surface surface))
@@ -478,18 +615,12 @@ (defbinding pattern-create-radial () pattern
   (cy1 double-float)
   (radius1 double-float))
 
-(defbinding %pattern-reference () nil
+(defbinding %pattern-reference () pointer
   (location pointer))
 
 (defbinding %pattern-destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'pattern))) location)
-  (%pattern-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'pattern))) location)
-  (%pattern-destroy location))
-
 (defbinding pattern-status () status
   (pattern pattern))
 
@@ -502,11 +633,22 @@ (defbinding translate () nil
   (tx double-float)
   (ty double-float))
 
-(defbinding scale () nil
+(defbinding scale (cr sx &optional (sy sx)) nil
   (cr context)
   (sx double-float)
   (sy double-float))
 
+(defun scale-to-device (cr &optional keep-rotation-p)
+  (if keep-rotation-p
+      (multiple-value-bind (dx dy) (device-to-user-distance cr 1.0 0.0)
+	(scale cr (sqrt (+ (* dx dx) (* dy dy)))))
+    (multiple-value-bind (x y)
+	(with-context (cr)
+	  (move-to cr 0.0 0.0)
+	  (multiple-value-call #'user-to-device cr (get-current-point cr)))
+      (identity-matrix cr)
+      (translate cr x y))))
+
 (defbinding rotate () nil
   (cr context)
   (angle double-float))
@@ -517,30 +659,30 @@ (defbinding transform () nil
 
 (defbinding (matrix "cairo_get_matrix") () nil
   (cr context)
-  ((make-instance 'matrix) matrix :return))
+  ((make-instance 'matrix) matrix :in/return))
 
 (defbinding identity-matrix () nil
   (cr context))
 
 (defbinding user-to-device () nil
   (cr context)
-  (x double-float :in-out)
-  (y double-float :in-out))
+  (x double-float :in/out)
+  (y double-float :in/out))
 
-(defbinding user-to-device-distance () nil
+(defbinding user-to-device-distance (cr dx &optional (dy dx)) nil
   (cr context)
-  (dx double-float :in-out)
-  (dy double-float :in-out))
+  (dx double-float :in/out)
+  (dy double-float :in/out))
 
 (defbinding device-to-user () nil
   (cr context)
-  (x double-float :in-out)
-  (y double-float :in-out))
+  (x double-float :in/out)
+  (y double-float :in/out))
 
-(defbinding device-to-user-distance () nil
+(defbinding device-to-user-distance (cr dx &optional (dy dx)) nil
   (cr context)
-  (dx double-float :in-out)
-  (dy double-float :in-out))
+  (dx double-float :in/out)
+  (dy double-float :in/out))
 
 
 ;;; Text
@@ -555,44 +697,47 @@ (defbinding set-font-size () nil
   (cr context)
   (size double-float))
 
+(defbinding (font-matrix "cairo_get_font_matrix") () nil
+  (cr context)
+  ((make-instance 'matrix) matrix :in/return))
+
+(defbinding (font-options "cairo_get_font_options") () nil
+  (cr context)
+  ((make-instance 'font-options) font-options :in/return))
+
 (defbinding show-text () nil
   (cr context)
   (text string))
 
 (defbinding show-glyphs () nil
   (cr context)
-  (glyphs (vector glyph))
+  (glyphs (vector (inlined glyph)))
   ((length glyphs) int))
 
-(defbinding font-extents () boolean
-  (cr context))
+(defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil
+  (cr context)
+  (extents font-extents :in/return))
 
 (defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
   (cr context)
   (text string)
-  (extents text-extents :return))
+  (extents text-extents :in/return))
 
 (defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-extents))) nil
   (cr context)
   (glyphs (vector glyph))
   ((length glyphs) int)
-  (extents text-extents :return))
+  (extents text-extents :in/return))
 
 
 ;;; Fonts
 
-(defbinding %font-face-reference () nil
+(defbinding %font-face-reference () pointer
   (location pointer))
 
 (defbinding %font-face-destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'font-face))) location)
-  (%font-face-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'font-face))) location)
-  (%font-face-destroy location))
-
 (defbinding font-face-status () status
   (font-face font-face))
 
@@ -600,30 +745,24 @@ (defbinding font-face-status () status
 
 ;;; Scaled Fonts
 
-(defbinding %scaled-font-reference () nil
+(defbinding %scaled-font-reference () pointer
   (location pointer))
 
 (defbinding %scaled-font-destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'scaled-font))) location)
-  (%scaled-font-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'scaled-font))) location)
-  (%scaled-font-destroy location))
-
 (defbinding scaled-font-status () status
   (scaled-font scaled-font))
 
 (defbinding scaled-font-extents (scaled-font &optional (extents (make-instance 'text-extents))) nil
   (scaled-font scaled-font)
-  (extents text-extents :return))
+  (extents text-extents :in/return))
 
 (defbinding scaled-font-glyph-extents (scaled-font glyphs &optional (extents (make-instance 'text-extents))) nil
   (scaled-font scaled-font)
   (glyphs (vector glyph))
   ((length glyphs) int)
-  (extents text-extents :return))
+  (extents text-extents :in/return))
 
 (defbinding %scaled-font-create () pointer
   (font-face font-face)
@@ -645,12 +784,6 @@ (defbinding %font-options-copy () nil
 (defbinding %font-options-destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'font-options))) location)
-  (%font-options-copy location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'font-options))) location)
-  (%font-options-destroy location))
-
 (defbinding font-options-status () status
   (font-options font-options))
 
@@ -661,7 +794,7 @@ (defmethod allocate-foreign ((font-options font-options) &rest initargs)
   (%font-options-create))
 
 (defbinding font-options-merge () nil
-  (options1 font-options :return)
+  (options1 font-options :in/return)
   (options2 font-options))
 
 (defbinding font-options-hash () unsigned-int
@@ -675,17 +808,58 @@ (defbinding font-options-equal-p () boolean
 
 ;;; Surfaces
 
-(defbinding %surface-reference () nil
+(defgeneric user-data (surface key))
+(defgeneric (setf user-data) (value surface key))
+
+(defmethod make-proxy-instance :around ((class surface-class) location 
+					&rest initargs)
+  (let ((class (find-class (%surface-get-type location))))
+    (apply #'call-next-method class location initargs)))
+
+(defbinding %surface-get-type () surface-type
+  (location pointer))
+
+(defbinding %surface-reference () pointer
   (location pointer))
 
 (defbinding %surface-destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'surface))) location)
-  (%surface-reference location))
+(defbinding %surface-status () status
+  pointer)
 
-(defmethod unreference-foreign ((class (eql (find-class 'surface))) location)
-  (%surface-destroy location))
+(defmethod allocate-foreign :around ((surface surface) &key)
+  (let ((location (call-next-method)))
+    (cond
+      ((not (eq (%surface-status location) :success))
+       (%surface-destroy location)
+       (error 'cairo-error :status (%surface-status location)))
+      (t location))))
+
+(defmethod reference-function ((class surface-class))
+  (declare (ignore class))
+  #'%surface-reference)
+
+(defmethod unreference-function ((class surface-class))
+  (declare (ignore class))
+  #'%surface-destroy)
+
+(defbinding %surface-set-user-data (surface key data-id) status-signal
+  (surface pointer)
+  ((quark-intern key) pointer-data)
+  (data-id pointer-data)
+  (user-data-destroy-callback callback))
+
+(defmethod (setf user-data) (data (surface surface) key)
+  (%surface-set-user-data (foreign-location surface) key (register-user-data data))
+  data)
+
+(defbinding %surface-get-user-data () pointer-data
+  (surface surface)
+  (key pointer-data))
+
+(defmethod user-data ((surface surface) key)
+  (find-user-data (%surface-get-user-data surface (quark-intern key))))
 
 (defbinding surface-create-similar () surface
   (other surface)
@@ -701,7 +875,7 @@ (defbinding surface-flush () nil
 
 (defbinding surface-get-font-options () nil
   (surface surface)
-  ((make-instance 'font-options) font-options :return))
+  ((make-instance 'font-options) font-options :in/return))
 
 (defbinding surface-set-device-offset () nil
   (surface surface)
@@ -726,100 +900,383 @@ (defun surface-mark-dirty (surface &optional x y width height)
       (%surface-mark-dirty-rectangle surface x y width height)
     (%surface-mark-dirty surface)))
 
+(defbinding surface-set-fallback-resolution () nil
+  (surface surface)
+  (x-pixels-per-inch double-float)
+  (y-pixels-per-inch double-float))
+
+(defun %stream-write-func (stream-id data length)
+  (let ((stream (find-user-data stream-id))
+	(sequence 
+	 (map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))
+    (handler-case (etypecase stream
+		    (stream 
+		     (write-sequence sequence stream)
+		     length)
+		    ((or symbol function) 
+		     (funcall stream sequence)))
+      (serious-condition (condition)
+	(declare (ignore condition))
+	0))))
+
+(define-callback stream-write-func status 
+    ((stream-id pointer-data) (data pointer) (length unsigned-int))
+  (if (= (%stream-write-func stream-id data length) length)
+      :success
+    :write-error))
+
+(defun %stream-read-func (stream-id data length)
+  (let* ((stream (find-user-data stream-id)))
+    (handler-case                              
+        (multiple-value-bind (sequence bytes-read)
+            (etypecase stream
+              (stream
+               (let ((sequence (make-array length
+                                :element-type '(unsigned-byte 8))))
+                 (values sequence (read-sequence sequence stream))))
+              ((or symbol function) (funcall stream length)))
+          (make-c-vector '(unsigned-byte 8) (or bytes-read (length sequence))
+           :content sequence :location data)
+          (or bytes-read (length sequence)))
+      (serious-condition (condition)
+        (declare (ignore condition))
+        0))))
+
+(define-callback stream-read-func status 
+    ((stream-id pointer-data) (data pointer) (length unsigned-int))
+  (if (= (%stream-read-func stream-id data length) length)
+      :success
+    :read-error))
+
+(defmacro with-surface ((surface cr) &body body)
+  `(let ((,cr (make-instance 'context :target ,surface)))
+     ,@body))
 
 
 ;; Image Surface
 
-;; Should data be automatically freed when the surface is GCed?
-(defmethod allocate-foreign ((surface image-surface) 
-			     &key width height stride format data)
-  (if (not data)
-      (%image-surface-create format width height)
-    (%image-surface-create-for-data data format width height 
-     (or 
-      stride
-      (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
-	(ceiling (* width element-size)))))))
-
-
-(defbinding %image-surface-create () image-surface
+(defmethod allocate-foreign ((surface image-surface) &key source type
+			     width height stride format)
+  (etypecase source
+   (null (%image-surface-create format width height))
+   ((or stream function symbol)
+    (let ((stream-id (register-user-data source)))
+      (unwind-protect
+	   (cond
+	     ((member type '("png" "image/png") :test #'equal)
+	      (%image-surface-create-from-png-stream stream-id))
+	     ((member type '("jpeg" "image/jpeg") :test #'equal)
+	      (%image-surface-create-from-jpeg-stream stream-id))
+	     ((not type) (error "Image type must be specified"))
+	     ((error "Can't handle image type ~A" type)))
+	(destroy-user-data stream-id))))
+   ((or string pathname)
+    (cond 
+      ((member type '("png" "image/png") :test #'equal)
+       (%image-surface-create-from-png source))
+      ((member type '("jpeg" "image/jpeg") :test #'equal)
+       (%image-surface-create-from-jpeg source))
+      ((not type) (error "Image type must be specified"))
+      ((error "Can't handle image type ~A" type))))
+   (pointer
+    (%image-surface-create-for-data source format width height 
+     (or stride (format-stride-for-width format width))))))
+
+#?(pkg-exists-p "cairo" :atleast-version "1.6")
+(defbinding format-stride-for-width () int
+  surface-format (width int))
+
+#?-(pkg-exists-p "cairo" :atleast-version "1.6")
+(defun format-stride-for-width (format width)
+  (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
+    (ceiling (* width element-size))))
+
+
+(defbinding %image-surface-create () pointer
   (format surface-format)
   (width int)
   (hegit int))
 
-(defbinding %image-surface-create-for-data () image-surface
+(defbinding %image-surface-create-for-data () pointer
   (data pointer)
   (format surface-format)
   (width int)
   (hegit int)
   (stride int))
 
+(defbinding %image-surface-create-from-png () pointer
+  (filename pathname))
 
+(defbinding %image-surface-create-from-png-stream (stream) pointer
+  (stream-read-func callback)
+  (stream pointer-data))
 
-;;; PNG Surface
+(defbinding %surface-write-to-png () status-signal
+  (surface surface)
+  (filename pathname))
+
+(defbinding %surface-write-to-png-stream (surface stream) status-signal
+  (surface surface)
+  (stream-write-func callback)
+  (stream pointer-data))
+
+(defgeneric surface-write-to-png (surface dest))
+
+(defmethod surface-write-to-png (surface filename)
+  (%surface-write-to-png surface filename))
+
+(defmethod surface-write-to-png (surface (stream stream))
+  (let ((stream-id (register-user-data stream)))
+    (unwind-protect
+	 (%surface-write-to-png-stream surface stream-id)
+      (destroy-user-data stream-id))))
+
+
+;;; JPEG support
+
+(define-callback jpeg-stream-write-func unsigned
+    ((stream-id pointer-data) (data pointer) (length unsigned-int))
+  (%stream-write-func stream-id data length))
+
+(define-callback jpeg-stream-read-func unsigned
+    ((stream-id pointer-data) (data pointer) (length unsigned-int))
+  (%stream-read-func stream-id data length))
+
+(defbinding %image-surface-create-from-jpeg () pointer
+  (filename pathname)
+  (status status-signal :out))
+
+(defbinding %image-surface-create-from-jpeg-stream (stream) pointer
+  (jpeg-stream-read-func callback)
+  (stream pointer-data)
+  (status status-signal :out))
+
+(defgeneric surface-write-to-jpeg (surface dest &key quality interlace))
+
+(defun %surface-acquire-image (surface)
+  (typecase surface
+    (image-surface surface)
+    ((let ((image (make-instance 'image-surface
+		   :width (surface-width surface)
+		   :height (surface-height surface)
+		   :format :argb32)))
+       (with-surface (image cr)
+	 (set-source-surface cr surface)
+	 (setf (operator cr) :source)
+	 (paint cr))
+       image))))
+
+(defbinding %surface-write-to-jpeg () status-signal
+  (surface image-surface)
+  (filename pathname)
+  (param jpeg-parameter))
+
+(defmethod surface-write-to-jpeg (surface filename &key 
+				  (quality 75) (interlace t))
+  (let ((param (make-instance 'jpeg-parameter 
+		:quality quality :interlace interlace)))
+    (%surface-write-to-jpeg (%surface-acquire-image surface) filename param)))
+
+(defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal
+  (surface surface)
+  (jpeg-stream-write-func callback)
+  (stream pointer-data)
+  (param jpeg-parameter))
+
+(defmethod surface-write-to-jpeg (surface (stream stream) &key 
+				  (quality 75) (interlace t))
+  (let ((stream-id (register-user-data stream))
+	(param (make-instance 'jpeg-parameter 
+		:quality quality :interlace interlace)))
+    (unwind-protect
+	 (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param)
+      (destroy-user-data stream-id))))
+
+
+;;; Virtual size surface (abstract class)
+
+(defmethod initialize-instance :after ((surface vector-surface) &key
+				       width height)
+  (setf (user-data surface 'width) width)
+  (setf (user-data surface 'height) height))
+
+(defmethod surface-width ((surface vector-surface))
+  (user-data surface 'width))
+
+(defmethod surface-height ((surface vector-surface))
+  (user-data surface 'height))
+
+
+(defun allocate-vector-surface (surface-create surface-create-for-stream
+				&key output filename stream width height)
+  (let ((location
+	 (cond
+	   ((/= (count-if #'identity (list output filename stream)) 1)
+	    (error "One and only one of the arguments :OUTPUT, :FILENAME and :STREAM shoud be specified"))
+	   (filename (funcall surface-create filename width height))
+	   ((typep output '(or string pathname))
+	    (%svg-surface-create output width height))
+	   (t
+	    (let* ((stream-id (register-user-data (or stream output)))
+		   (location (funcall surface-create-for-stream 
+			      stream-id width height)))
+	      (%surface-set-user-data location 'stream stream-id)
+	      location)))))
+    location))
+
+
+;;; PDF Surface
+
+(defmethod allocate-foreign ((surface pdf-surface) &rest args)
+  (apply #'allocate-vector-surface 
+   #'%pdf-surface-create #'%pdf-surface-create-for-stream args))
+
+(defbinding %pdf-surface-create () pointer
+  (filename pathname)
+  (width double-float)
+  (height double-float))
+
+(defbinding %pdf-surface-create-for-stream (stream width height) pointer
+  (stream-write-func callback)
+  (stream pointer-data)
+  (width double-float)
+  (height double-float))
+
+(defbinding pdf-surface-set-size () nil
+  (surface pdf-surface)
+  (width double-float)
+  (height double-float))
+
+
+;;; PS Surface
+
+(defmethod allocate-foreign ((surface ps-surface) &rest args)
+  (apply #'allocate-vector-surface 
+   #'%ps-surface-create #'%ps-surface-create-for-stream args))
+
+(defbinding %ps-surface-create () pointer
+  (filename pathname)
+  (width double-float)
+  (height double-float))
+
+(defbinding %ps-surface-create-for-stream (stream width height) pointer
+  (stream-write-func callback)
+  (stream pointer-data)
+  (width double-float)
+  (height double-float))
+
+(defbinding ps-surface-set-size () nil
+  (surface ps-surface)
+  (width double-float)
+  (height double-float))
+
+(defbinding ps-surface-dsc-begin-setup () nil
+  (surface ps-surface))
+
+(defbinding ps-surface-dsc-begin-page-setup () nil
+  (surface ps-surface))
+
+(defbinding ps-surface-dsc-comment () nil
+  (surface ps-surface)
+  (comment string))
+
+
+;;; SVG Surface
+
+(defmethod allocate-foreign ((surface svg-surface) &rest args)
+  (apply #'allocate-vector-surface 
+   #'%svg-surface-create #'%svg-surface-create-for-stream args))
 
-(defbinding image-surface-create-from-png (filename) image-surface
-  ((truename filename) pathname))
+(defbinding %svg-surface-create () pointer
+  (filename pathname)
+  (width double-float)
+  (height double-float))
+
+(defbinding %svg-surface-create-for-stream (stream width height) pointer
+  (stream-write-func callback)
+  (stream pointer-data)
+  (width double-float)
+  (height double-float))
 
+(defbinding svg-surface-restrict-to-version () nil
+  (surface svg-surface)
+  (version svg-version))
 
 
 
 ;;; Matrices
 
-(defbinding matrix-init () nil
-  (matrix matrix :return)
+(defbinding matrix-init (xx yx xy yy x0 y0 &optional (matrix (make-instance 'matrix))) nil
+  (matrix matrix :in/return)
   (xx double-float) (yx double-float) 
   (xy double-float) (yy double-float) 
   (x0 double-float) (y0 double-float))
 
-(defbinding matrix-init-identity () nil
-  (matrix matrix :return))
+(defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
+  (matrix matrix :in/return))
 
-(defbinding matrix-init-translate () nil
-  (matrix matrix :return)
+(defun identity-matrix-p (matrix)
+  (with-slots (xx yx xy yy x0 y0) matrix
+    (and 
+     (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
+     (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
+
+(defbinding matrix-init-translate (tx ty &optional (matrix (make-instance 'matrix))) nil
+  (matrix matrix :in/return)
   (tx double-float)
   (ty double-float))
 
-(defbinding matrix-init-scale () nil
-  (matrix matrix :return)
+(defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil
+  (matrix matrix :in/return)
   (sx double-float)
   (sy double-float))
 
-(defbinding matrix-init-rotate () nil
-  (matrix matrix :return)
-  (radians double-float))
+(defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil
+  (matrix matrix :in/return)
+  (rotation double-float))
 
 (defbinding matrix-translate () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (tx double-float)
   (ty double-float))
 
-(defbinding matrix-scale () nil
-  (matrix matrix :return)
+(defbinding matrix-scale (matrix sx &optional (sy sx)) nil
+  (matrix matrix :in/return)
   (sx double-float)
   (sy double-float))
 
 (defbinding matrix-rotate () nil
-  (matrix matrix :return)
-  (radians double-float))
+  (matrix matrix :in/return)
+  (rotation double-float))
 
 (defbinding matrix-invert () nil
-  (matrix matrix :return))
+  (matrix matrix :in/return))
 
 (defbinding matrix-multiply () nil
   (result matrix :out)
   (a matrix)
   (b matrix))
 
-(defbinding matrix-transform-distance () nil
-  (matrix matrix :return)
-  (dx double-float)
-  (dy double-float))
+(defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil
+  (matrix matrix)
+  (dx double-float :in/out)
+  (dy double-float :in/out))
 
 (defbinding matrix-transform-point () nil
-  (matrix matrix :return)
-  (x double-float)
-  (y double-float))
+  (matrix matrix)
+  (x double-float :in/out)
+  (y double-float :in/out))
+
+
+;; Version information
 
+(defbinding %version () int)
 
+(defun version ()
+  (let ((version (%version)))
+    (values 
+     (mod (truncate version 10000) 100)
+     (mod (truncate version 100) 100)
+     (mod version 100))))
 
+(defbinding version-string () (static string))