cairo-shim.so: cairo-shim.o
echo "(link-shim)" | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
- `pkg-config --libs cairo`
+ `pkg-config --libs pangocairo`
cairo-shim.o: cairo-shim.c
echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Scheme Graphics Operations to a Cairo Image Surface.
+;;; package: (cairo graphics)
+
+(define-structure (cairo-graphics
+ (constructor %make-cairo-graphics
+ (width height surface context)))
+
+ ;; Cairo Surface -- |cairo_surface_t| alien.
+ surface width height
+
+ ;; Cairo Context -- |cairo_t| alien.
+ context
+
+ ;; Bounds to which context is clipped, scaled, translated...
+ (limits '(-1. -1. 1. 1.))
+ (scale 1.)
+
+ (fgcolor #f)
+ (fgcolor-name #f)
+ (bgcolor #f)
+ (bgcolor-name #f))
+
+(define (make-cairo-graphics width height)
+ (let ((factor (->flonum (/ (min (-1+ width) (-1+ height)) 2))))
+ (if (not (flo:positive? factor))
+ (error "Invalid width x height:" width height))
+ (let* ((surface (cairo-image-surface-create width height))
+ (cr (cairo-create surface))
+ (graphics (%make-cairo-graphics width height surface cr)))
+ (cairo-save cr)
+ (cairo-scale cr factor (flo:negate factor))
+ (set-cairo-graphics-scale! graphics factor)
+ (cairo-set-line-width cr (flo:/ 1.0 factor))
+ (cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
+ (cairo-matrix k 0. 0.
+ 0. (flo:negate k) 0.)))
+ (cairo-translate cr 1.0 -1.0)
+ (let ((black (->color "black" 'make-cairo-graphics))
+ (white (->color "white" 'make-cairo-graphics)))
+ (cairo-set-source-color cr white)
+ (cairo-paint cr)
+ (cairo-set-source-color cr black)
+ (set-cairo-graphics-bgcolor-name! graphics "white")
+ (set-cairo-graphics-bgcolor! graphics white)
+ (set-cairo-graphics-fgcolor-name! graphics "black")
+ (set-cairo-graphics-fgcolor! graphics black))
+ graphics)))
+
+(define (cairo-graphics/available?) #t)
+
+(define (cairo-graphics/open make-device #!optional width height)
+ (let ((width (if (default-object? width) 512 width))
+ (height (if (default-object? height) 384 height)))
+ (guarantee-positive-fixnum width 'cairo-graphics/open)
+ (guarantee-positive-fixnum height 'cairo-graphics/open)
+ (make-device (make-cairo-graphics width height))))
+
+(define (cairo-graphics/close device)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((surface (cairo-graphics-surface graphics)))
+ (if surface
+ (let ((cr (cairo-graphics-context graphics)))
+ (cairo-destroy cr)
+ (set-cairo-graphics-context! graphics #f)
+ (cairo-surface-destroy surface)
+ (set-cairo-graphics-surface! graphics #f))))))
+
+(define (cairo-graphics/device-coordinate-limits device)
+ (let ((graphics (graphics-device/descriptor device)))
+ (values 0 (cairo-graphics-height graphics)
+ (cairo-graphics-width graphics) 0)))
+
+(define (cairo-graphics/coordinate-limits device)
+ (apply values (cairo-graphics-limits (graphics-device/descriptor device))))
+
+(define (cairo-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics)))
+ (if (zero? (- x-right x-left)) (error "Zero width coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
+ (if (zero? (- y-bottom y-top)) (error "Zero height coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
+ (cairo-restore cr) ;back to device coords.
+ (cairo-save cr)
+ (let ((x-factor (->flonum (/ (-1+ (cairo-graphics-width graphics))
+ (- x-right x-left))))
+ (y-factor (->flonum (/ (-1+ (cairo-graphics-height graphics))
+ (- y-bottom y-top)))))
+ (cairo-scale cr x-factor y-factor)
+ (let ((factor (flo:min (flo:abs x-factor) (flo:abs y-factor))))
+ (set-cairo-graphics-scale! graphics factor)
+ (cairo-set-line-width cr (flo:/ 1.0 factor))
+ (cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
+ (cairo-matrix k 0. 0.
+ 0. (flo:negate k) 0.)))))
+ (cairo-translate cr (- x-left) (- y-top))
+ (let ((fgcolor (cairo-graphics-fgcolor graphics)))
+ (cairo-set-source-color cr fgcolor)))
+ (set-cairo-graphics-limits! graphics (list x-left y-bottom x-right y-top))))
+
+(define (cairo-graphics/clear device)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (bgcolor (cairo-graphics-bgcolor graphics))
+ (bgcolor-name (cairo-graphics-bgcolor-name graphics)))
+ (set-cairo-graphics-fgcolor! graphics bgcolor)
+ (set-cairo-graphics-fgcolor-name! graphics bgcolor-name)
+ (cairo-set-source-color cr bgcolor)
+ (cairo-reset-clip cr)
+ (cairo-paint cr))))
+
+(define (cairo-graphics/draw-point device x y)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y))
+ (radius (/ 3.0 (cairo-graphics-scale device))))
+ (cairo-arc cr x y radius 0. 2pi)
+ (cairo-stroke cr))))
+
+(define (cairo-graphics/draw-line device x-start y-start x-end y-end)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (x (->flonum x-start))
+ (y (->flonum y-start)))
+ (let ((dx (flo:- (->flonum x-end) x))
+ (dy (flo:- (->flonum y-end) y)))
+ (cairo-move-to cr x y)
+ (cairo-rel-line-to cr dx dy)
+ (cairo-stroke cr)))))
+
+(define (cairo-graphics/draw-text device x y string)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y)))
+ (cairo-move-to cr x y)
+ (cairo-show-text cr string))))
+
+(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
+
+(define (cairo-graphics/draw-circle device x y radius)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y))
+ (radius (->flonum radius)))
+ (cairo-arc cr x y radius 0. 2pi)
+ (cairo-stroke cr))))
+
+(define (cairo-graphics/move-cursor device x y)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y)))
+ (cairo-move-to cr x y))))
+
+(define (cairo-graphics/drag-cursor device x y)
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (x (->flonum x))
+ (y (->flonum y)))
+ (cairo-line-to cr x y)
+ (cairo-stroke cr))))
+
+(define (cairo-graphics/set-drawing-mode device mode)
+ (let ((operator
+ (case mode
+ ((0) 'CLEAR) ;GXclear 0
+ ((1) 'IN) ;GXand src AND dst
+ ((2) 'OUT) ;GXandReverse src AND NOT dst
+ ((3) 'SOURCE) ;GXcopy src
+ ((4) 'DEST-OUT) ;GXandInverted NOT src AND dst
+ ((5) 'DEST) ;GXnoop dst
+ ((6) 'XOR) ;GXxor src XOR dst
+ ((7) 'OVER) ;GXor src OR dst
+ ((8) (warn "unimplemented:" '|GXnor|) #f) ;GXnor NOT src AND NOT dst
+ ((9) (warn "unimplemented:" '|GXequiv|) #f) ;GXequiv NOT src XOR dst
+ ((10) (warn "unimplemented:" '|GXinvert|) #f) ;GXinvert NOT dst
+ ((11) (warn "unimplemented:" '|GXorReverse|) #f) ;GXorReverse src OR NOT dst
+ ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted NOT src
+ ((13) (warn "unimplemented:" '|GXorInverted|) #f) ;GXorInverted NOT src OR dst
+ ((14) (warn "unimplemented:" '|GXnand|) #f) ;GXnand NOT src OR NOT dst
+ ((15) 'SOURCE) ;GXset 1
+ (else (error:wrong-type-argument mode "a drawing mode"
+ 'cairo-graphics/set-drawing-mode)))))
+ (if operator
+ (cairo-set-operator
+ (cairo-graphics-context (graphics-device/descriptor device))
+ operator))))
+
+(define (cairo-graphics/set-line-style device style)
+ (let ((graphics (graphics-device/descriptor device))
+ (dashes
+ (case style
+ ((0) '())
+ ((1) '(8.))
+ ((2) '(1.))
+ ((3) '(13. 1. 1. 1.))
+ ((4) '(11. 1. 1. 1. 1. 1.))
+ ((5) '(11. 5.))
+ ((6) '(12. 1. 2. 1))
+ ((7) '( 9. 1. 2. 1. 2. 1.))
+ (else (error:wrong-type-argument style "a line style"
+ 'cairo-graphics/set-line-style)))))
+ (let ((cr (cairo-graphics-context graphics))
+ (factor (flo:/ 16. (cairo-graphics-scale graphics))))
+ (cairo-set-dash cr (map (lambda (len) (flo:* len factor)) dashes)))))
+
+(define (cairo-graphics/fill-polygon-list device points)
+ ;; POINTS should be a list of flo:vectors each with a length greater than 1.
+ (let ((graphics (graphics-device/descriptor device)))
+ (let ((cr (cairo-graphics-context graphics))
+ (p (car points)))
+ (define-integrable (x p) (flo:vector-ref p 0))
+ (define-integrable (y p) (flo:vector-ref p 1))
+ (cairo-move-to cr (x p) (y p))
+ (for-each (lambda (p)
+ (cairo-line-to cr (x p) (y p)))
+ (cdr points))
+ (cairo-close-path cr)
+ (cairo-fill cr))))
+
+(define (cairo-graphics/flush device)
+ (cairo-surface-flush
+ (or (cairo-graphics-surface
+ (graphics-device/descriptor device))
+ (error "Cairo graphics device closed:" device))))
+
+(define (cairo-graphics/write-to-png device filename)
+ (cairo-surface-write-to-png
+ (or (cairo-graphics-surface
+ (graphics-device/descriptor device))
+ (error "Cairo graphics device closed:" device))
+ (->namestring filename)))
+
+(define (cairo-graphics/destroy device)
+ (cairo-surface-destroy (cairo-graphics-surface
+ (graphics-device/descriptor device))))
+
+(define (cairo-graphics/set-background-color device name)
+ (let ((graphics (graphics-device/descriptor device)))
+ (if (not (string=? name (cairo-graphics-bgcolor-name graphics)))
+ (let ((new (->color name 'cairo-graphics/set-background-color)))
+ (set-cairo-graphics-bgcolor! graphics new)
+ (set-cairo-graphics-bgcolor-name! graphics name)))))
+
+(define (cairo-graphics/set-foreground-color device name)
+ (let ((graphics (graphics-device/descriptor device)))
+ (if (not (string=? name (cairo-graphics-fgcolor-name graphics)))
+ (let ((new (->color name 'cairo-graphics/set-foreground-color)))
+ (set-cairo-graphics-fgcolor! graphics new)
+ (set-cairo-graphics-fgcolor-name! graphics name)
+ (cairo-set-source-color (cairo-graphics-context graphics) new)))))
+
+(define (cairo-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
+ (let ((cr (cairo-graphics-context (graphics-device/descriptor device)))
+ (x (->flonum x-left))
+ (y (->flonum y-top)))
+ (let ((width (flo:- (->flonum x-right) x))
+ (height (flo:- (->flonum y-bottom) y)))
+ (cairo-rectangle cr x y width height)
+ (cairo-clip cr))))
+
+(define (cairo-graphics/reset-clip-rectangle device)
+ (cairo-reset-clip (cairo-graphics-context
+ (graphics-device/descriptor device))))
+
+(define cairo-graphics-device-type)
+
+(define (initialize-package!)
+ (set! cairo-graphics-device-type
+ (make-graphics-device-type
+ 'CAIRO
+ `((available? ,cairo-graphics/available?)
+ (open ,cairo-graphics/open)
+ (clear ,cairo-graphics/clear)
+ (close ,cairo-graphics/close)
+ (coordinate-limits ,cairo-graphics/coordinate-limits)
+ (device-coordinate-limits ,cairo-graphics/device-coordinate-limits)
+ (move-cursor ,cairo-graphics/move-cursor)
+ (drag-cursor ,cairo-graphics/drag-cursor)
+ (draw-line ,cairo-graphics/draw-line)
+ (draw-point ,cairo-graphics/draw-point)
+ (draw-text ,cairo-graphics/draw-text)
+ (draw-circle ,cairo-graphics/draw-circle)
+ (flush ,cairo-graphics/flush)
+ (reset-clip-rectangle ,cairo-graphics/reset-clip-rectangle)
+ (set-clip-rectangle ,cairo-graphics/set-clip-rectangle)
+ (set-coordinate-limits ,cairo-graphics/set-coordinate-limits)
+ (set-drawing-mode ,cairo-graphics/set-drawing-mode)
+ (set-line-style ,cairo-graphics/set-line-style)))))
+
+(initialize-package!)
\ No newline at end of file
cairo-fill cairo-fill-preserve
cairo-stroke cairo-stroke-preserve
cairo-set-font-matrix
- cairo-matrix))
\ No newline at end of file
+ cairo-matrix))
+
+(define-package (cairo graphics)
+ (parent (cairo))
+ (files "cairo-graphics")
+ (export ()
+ cairo-graphics/set-background-color
+ cairo-graphics/set-foreground-color
+ cairo-graphics/draw-line
+ cairo-graphics/draw-text
+ cairo-graphics/draw-circle
+ cairo-graphics/fill-polygon-list
+ cairo-graphics/clear
+ cairo-graphics/flush
+ cairo-graphics/write-to-png
+ cairo-graphics/destroy))
\ No newline at end of file
(define (cairo-image-surface-create width height)
(let ((surface (make-alien '|cairo_surface_t|))
(copy (make-alien '|cairo_surface_t|)))
- (add-gc-cleanup surface (make-cairo-surface-cleanup copy))
+ (add-glib-cleanup surface (make-cairo-surface-cleanup copy))
(C-call "cairo_image_surface_create" copy
(C-enum "CAIRO_FORMAT_RGB24") width height)
(copy-alien-address! surface copy)
(lambda ()
(if (not (alien-null? surface))
(begin
- (C-call "cairo_surface_destroy" surface)
- (alien-null! surface)))))
- (punt-gc-cleanup surface))
+ (execute-glib-cleanup surface)
+ (alien-null! surface))))))
(define (check-cairo-surface-status surface)
(let ((status (C-call "cairo_surface_status" surface)))
(define (cairo-pattern-create-linear x1 y1 x2 y2)
(let ((pattern (make-alien '|cairo_pattern_t|))
(copy (make-alien '|cairo_pattern_t|)))
- (add-gc-cleanup pattern (make-cairo-pattern-cleanup copy))
+ (add-glib-cleanup pattern (make-cairo-pattern-cleanup copy))
(C-call "cairo_pattern_create_linear" copy
(->flonum x1) (->flonum y1) (->flonum x2) (->flonum y2))
(copy-alien-address! pattern copy)
(define (cairo-pattern-create-radial cx0 cy0 radius0 cx1 cy1 radius1)
(let ((pattern (make-alien '|cairo_pattern_t|))
(copy (make-alien '|cairo_pattern_t|)))
- (add-gc-cleanup pattern (make-cairo-pattern-cleanup copy))
+ (add-glib-cleanup pattern (make-cairo-pattern-cleanup copy))
(C-call "cairo_pattern_create_radial" copy
(->flonum cx0) (->flonum cy0) (->flonum radius0)
(->flonum cx1) (->flonum cy1) (->flonum radius1))
(lambda ()
(if (not (alien-null? pattern))
(begin
- (C-call "cairo_pattern_destroy" pattern)
- (alien-null! pattern)))))
- (punt-gc-cleanup pattern))
+ (execute-glib-cleanup pattern)
+ (alien-null! pattern))))))
(define (check-cairo-pattern-status pattern)
(let ((status (C-call "cairo_pattern_status" pattern)))
(guarantee-cairo-surface surface 'cairo-create)
(let ((cairo (make-alien '|cairo_t|))
(copy (make-alien '|cairo_t|)))
- (add-gc-cleanup cairo (make-cairo-cleanup copy))
+ (add-glib-cleanup cairo (make-cairo-cleanup copy))
(C-call "cairo_create" copy surface)
(copy-alien-address! cairo copy)
(check-cairo-status cairo)
(lambda ()
(if (not (alien-null? cairo))
(begin
- (C-call "cairo_destroy" cairo)
- (alien-null! cairo)))))
- (punt-gc-cleanup cairo))
+ (execute-glib-cleanup cairo)
+ (alien-null! cairo))))))
(define (check-cairo-status cairo)
(let ((status (C-call "cairo_status" cairo)))
(guarantee-cairo cairo 'cairo-line-to)
(let ((x (->flonum x))
(y (->flonum y)))
- (C-call "cairo_rel_line_to" cairo x y)))
+ (C-call "cairo_line_to" cairo x y)))
(define (cairo-rel-line-to cairo dx dy)
(guarantee-cairo cairo 'cairo-rel-line-to)
(compile-file "cairo" '("cairo-const.bin")
(->environment '(cairo)))
+ (compile-file "cairo-graphics" '("cairo-const.bin")
+ (->environment '(cairo graphics)))
+
(cref/generate-constructors "cairo" 'ALL)))))
\ No newline at end of file
(load-option 'FFI)
(load-option 'GTK)
-(if (gtk-thread-running?)
+(if (gtk-initialized?)
(begin
(let ((env (->environment '(runtime pathname))))
(set! (access library-directory-path env)
(define-method initialize-instance ((widget <glx-widget>) width height)
(call-next-method widget width height)
- (add-gc-cleanup widget (make-glx-widget-cleanup
- (glx-widget-xdisplay widget)
- (glx-widget-glxcontext widget)))
+ (add-glib-cleanup widget (make-glx-widget-cleanup
+ (glx-widget-xdisplay widget)
+ (glx-widget-glxcontext widget)))
(C-call "gtk_widget_set_double_buffered" (gobject-alien widget) 0))
(define (make-glx-widget-cleanup xdisplay glxcontext)
(define-method gtk-widget-destroy-callback ((widget <glx-widget>))
(without-interrupts
(lambda ()
- (punt-gc-cleanup widget)
- (cleanup-glx-widget (glx-widget-xdisplay widget)
- (glx-widget-glxcontext widget))))
+ (execute-glib-cleanup widget)))
(call-next-method widget))
(define-method fix-widget-realize-callback ((widget <glx-widget>))
(copy (make-alien '|GLXFBConfig|))
(attribs (make-attribs attrib-list))
(num-configs (malloc (C-sizeof "int") 'int)))
- (add-gc-cleanup configs (make-fb-configs-cleanup copy))
+ (add-glib-cleanup configs (make-fb-configs-cleanup copy))
(C-call "glXChooseFBConfig" copy
display screen-num attribs num-configs)
(free attribs)
(free num-configs)
- (if (alien-null? copy)
- (begin
- (punt-gc-cleanup configs)
- #f)
- (begin
- (copy-alien-address! configs copy)
- configs))))
+ (copy-alien-address! configs copy)
+ (error-if-null configs "Could not find:" configs)
+ configs))
#;(define (make-fb-configs-cleanup alien)
(named-lambda (fb-configs-cleanup)
(C-call "XFree" alien)
(alien-null! alien))))
-#;(define (xfree alien)
- (without-interrupts
- (lambda ()
- (if (not (alien-null? alien))
- (let ((cleanup (punt-gc-cleanup alien)))
- (if cleanup (cleanup))
- (alien-null! alien))))))
-
(define (make-attribs attribs)
(let* ((len (length attribs))
(alien (malloc (* len (C-sizeof "int")) '|int|)))
"GError pointer not set.")))
(gerror-pointer-free gerror*)
(error message))))))
-
-#;(define (make-gerror-pointer)
- (let ((alien (make-alien '(* |GError|)))
- (copy (make-alien '(* |GError|))))
- (add-gc-cleanup alien (make-gerror-pointer-cleanup copy))
- (C-call "g_try_malloc0" copy (C-sizeof "* GError"))
- (if (alien-null? copy)
- (begin
- (punt-gc-cleanup alien)
- (error "Could not create:" alien))
- (begin
- (copy-alien-address! alien copy)
- alien))))
-
-#;(define (make-gerror-pointer-cleanup gerror*)
- (named-lambda (gerror-pointer-cleanup)
- ;;without-interrupts
- (if (not (alien-null? gerror*))
- (let ((gerror (make-alien '|GError|)))
- (C-> gerror* "* GError" gerror)
- (if (not (alien-null? gerror))
- (C-call "g_error_free" gerror))
- (C-call "g_free" gerror*)
- (alien-null! gerror*)))))
-
-#;(define (gerror-pointer-free gerror*)
- (without-interrupts
- (lambda ()
- (if (not (alien-null? gerror*))
- (let ((cleanup (punt-gc-cleanup gerror*)))
- (if cleanup (cleanup))
- (alien-null! gerror*))))))
\f
(define-class (<glx-viewport> (constructor () (width height)))
;; A <glx-widget> with camera parameters, and a default key-press
(global-definitions runtime/)
(global-definitions ffi/)
(global-definitions sos/)
+(global-definitions glib/)
(global-definitions gtk/)
(define-package (gl)
ucode-primitive)
(import (runtime ffi)
%set-alien/address!)
- (import (gtk gobject)
+ (import (glib)
+ add-glib-cleanup execute-glib-cleanup)
+ (import (gobject)
+ gobject-alien)
+ (import (gtk gdk)
make-pixbuf)
(import (gtk gtk-widget)
gtk-widget-destroy-callback)
fix-widget-geometry fix-widget-window
set-fix-widget-map-handler! set-fix-widget-unmap-handler!)
(import (gtk)
- cairo-clip-extents
- add-gc-cleanup punt-gc-cleanup error-if-null
- gobject-alien gtk-window-new
+ error-if-null
+ gtk-window-new
gtk-widget-destroy gtk-widget-parent
gtk-widget-show-all
gtk-widget-queue-draw
(define-method initialize-instance ((object <g-input-stream>))
(call-next-method object)
- (add-gc-cleanup object (make-g-input-stream-cleanup
- (gio-cleanup-info object)
- (g-input-stream-cleanup-info object))))
+ (add-glib-cleanup object (make-g-input-stream-cleanup
+ (gio-cleanup-info object)
+ (g-input-stream-cleanup-info object))))
(define (make-g-input-stream-cleanup gio-info info)
(named-lambda (g-input-stream-cleanup)
(cleanup-g-input-stream gio-info info)))
(define (cleanup-g-input-stream gio-info info)
- ;; For gc-cleanup. Run without-interrupts.
+ ;; For glib-cleanups. Run without-interrupts.
(cleanup-gio gio-info)
(cleanup-callback-id info g-input-stream read-id)
(cleanup-callback-id info g-input-stream skip-id))
(define-method initialize-instance ((object <g-output-stream>))
(call-next-method object)
- (add-gc-cleanup object (make-g-output-stream-cleanup
- (gio-cleanup-info object)
- (g-output-stream-cleanup-info object))))
+ (add-glib-cleanup object (make-g-output-stream-cleanup
+ (gio-cleanup-info object)
+ (g-output-stream-cleanup-info object))))
(define (make-g-output-stream-cleanup gio-info info)
(named-lambda (g-output-stream-cleanup)
(cleanup-g-output-stream gio-info info)))
(define (cleanup-g-output-stream gio-info info)
- ;; For gc-cleanup. Run without-interrupts.
+ ;; For glib-cleanups. Run without-interrupts.
(cleanup-gio gio-info)
(cleanup-callback-id info g-output-stream write-id)
(cleanup-callback-id info g-output-stream flush-id))
(define-method initialize-instance ((object <gfile-info>))
(call-next-method object)
- (add-gc-cleanup object (make-ginfo-cleanup (gio-cleanup-info object))))
+ (add-glib-cleanup object (make-ginfo-cleanup (gio-cleanup-info object))))
(define (make-ginfo-cleanup gio-info)
(named-lambda (ginfo-cleanup)
(define-method initialize-instance ((object <gfile-enumerator>))
(call-next-method object)
- (add-gc-cleanup object (make-gfile-enumerator-cleanup
- (gio-cleanup-info object)
- (gfile-enumerator-ginfos object))))
+ (add-glib-cleanup object (make-gfile-enumerator-cleanup
+ (gio-cleanup-info object)
+ (gfile-enumerator-ginfos object))))
(define (make-gfile-enumerator-cleanup gio-info ginfos)
(named-lambda (gfile-enumerator-cleanup)
(cleanup-gfile-enumerator gio-info ginfos)))
(define (cleanup-gfile-enumerator gio-info ginfos)
- ;; For gc-cleanup. Run without-interrupts.
+ ;; For glib-cleanups. Run without-interrupts.
(cleanup-gio gio-info)
(cleanup-ginfos ginfos))
(define-method initialize-instance ((gmountop <g-mount-operation>))
(call-next-method gmountop)
- (add-gc-cleanup gmountop (make-gmountop-cleanup (gio-cleanup-info gmountop)))
+ (add-glib-cleanup gmountop
+ (make-gmountop-cleanup (gio-cleanup-info gmountop)))
(let ((alien (gobject-alien gmountop)))
(set-alien/ctype! alien '|GMountOperation|)
(C-call "g_mount_operation_new" alien)
;; SETTER is applied to an alien that must not escape.
(let ((alien (make-alien '(* uchar)))
(copy (make-alien '(* uchar))))
- (add-gc-cleanup alien (make-cstringv-cleanup copy))
+ (add-glib-cleanup alien (make-cstringv-cleanup copy))
(setter copy)
(copy-alien-address! alien copy)
alien))
(define (free-cstringv alien)
(without-interrupts
(lambda ()
- (let ((cleanup (punt-gc-cleanup alien)))
- (if cleanup (cleanup))
- (alien-null! alien)))))
+ (execute-glib-cleanup alien)
+ (alien-null! alien))))
(define %trace? #f)
(let ((gc-tick (car (gc-timestamp))))
(if (fix:< done-tick gc-tick)
(begin
- (run-gc-cleanups)
+ (run-glib-cleanups)
(set! done-tick gc-tick)))
(if (fix:< next-secondary-tick gc-tick)
(begin
<gobject> gobject-alien
gobject-live? gobject-unref!
g-signal-connect g-signal-disconnect
- add-gc-cleanup punt-gc-cleanup
gobject-get-property gobject-set-properties
gquark-from-string gquark-to-string))
;;(depends-on "main")
(export ()
stop-glib-thread)
- (import (gobject)
- run-gc-cleanups)
+ (import (glib)
+ run-glib-cleanups)
(import (glib main)
run-glib)
(import (runtime primitive-io)
(if (color? o) (flo:vector-set! o 2 b)(error:wrong-type-argument o"a color")))
(define-integrable-operator (set-color-alpha! o a)
- (if (color? o) (flo:vector-set! o 3 a)(error:wrong-type-argument o"a color")))
\ No newline at end of file
+ (if (color? o) (flo:vector-set! o 3 a)(error:wrong-type-argument o"a color")))
+\f
+;;; GLib Cleanups
+
+(define glib-cleanups)
+
+(define (initialize-glib-cleanups!)
+ (set! glib-cleanups '()))
+
+(define (run-glib-cleanups)
+ (let loop ((alist glib-cleanups)
+ (prev #f))
+ (if (pair? alist)
+ (if (weak-pair/car? (car alist))
+ (loop (cdr alist) alist)
+ (let ((thunk (weak-cdr (car alist)))
+ (next (cdr alist)))
+ (thunk)
+ (if prev
+ (set-cdr! prev next)
+ (set! glib-cleanups next))
+ (loop next prev))))))
+
+(define (reset-glib-cleanups!)
+ (set! glib-cleanups '()))
+
+(define (add-glib-cleanup object cleanup-thunk)
+ (let ((weak-pair (weak-cons object cleanup-thunk)))
+ (without-interrupts
+ (lambda ()
+ (set! glib-cleanups (cons weak-pair glib-cleanups))))
+ weak-pair))
+
+(define (execute-glib-cleanup object)
+ (let ((entry (weak-assq object glib-cleanups)))
+ (if entry
+ (begin
+ ((weak-cdr entry))
+ (set! glib-cleanups (delq! entry glib-cleanups)))))
+ unspecific)
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist) #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key) entry
+ (loop (cdr alist)))))))
+
+(define (initialize-package!)
+ (initialize-glib-cleanups!)
+ (add-event-receiver! event:after-restore reset-glib-cleanups!))
+
+(initialize-package!)
\ No newline at end of file
@unnumberedsec Toolkit Resource Usage
-Each gobject instance is tracked by the weak alist @code{gc-cleanups},
+Each gobject instance is tracked by the weak alist @code{glib-cleanups},
so that the toolkit object can be @code{g_object_unref}'ed when the
instance is GCed.
The initialize-instance method for subclasses of gobject should chain
-up early, adding the instance's alien to gc-cleanups @emph{before}
+up early, adding the instance's alien to glib-cleanups @emph{before}
calling out to the toolkit. This ensures that an allocated toolkit
object will not be dropped; its alien address is on the list of GC
cleanups before it is even allocated. @emph{After} the callout, the
signaled.
TODO: A world save hook might warn of gobject instances still on the
-gc-cleanups list. A world restore hook could kill them.
+glib-cleanups list. A world restore hook could kill them.
@node GNU Free Documentation License, , Implementation Notes, Top
@appendix GNU Free Documentation License
{
struct handler_record * scan;
+ trace (";signal %d: in scheme_thread\n", signo);
scan = old_handlers;
while (scan != NULL)
{
if (scan->signo == signo)
{
+ trace (";signal %d: invoking original handler\n", signo);
(scan->handler)(signo, siginfo, ptr);
+ trace (";signal %d: original handler returned\n", signo);
return;
}
scan = scan->next;
}
- complain (";signal_forwarder: no handler for signo %d\n", signo);
+ complain (";signal %d: no handler\n", signo);
}
else
{
int err;
+ trace (";signal %d: outside scheme_thread\n", signo);
err = pthread_kill (scheme_thread, signo);
if (err != 0)
{
- complain (";signal_forwarder: pthread_kill failed: %s\n",
- errno_name (err));
+ complain (";signal %d: pthread_kill failed: %s\n",
+ signo, errno_name (err));
sleep (1);
}
}
(signals define standard
initializer (lambda () (list 'GOBJECT-SIGNALS)))
- ;; This instance's weak-pair on the gc-cleanups list. This is
+ ;; This instance's weak-pair on the glib-cleanups list. This is
;; cached here mainly for g-signal-connect, which must create
;; callbacks that only weakly reference this instance.
(weak-self define standard))
(define-method initialize-instance ((object <gobject>))
(call-next-method object)
(set-gobject-weak-self!
- object (add-gc-cleanup object (make-gobject-cleanup-thunk
- (gobject-alien object)
- (gobject-signals object)))))
+ object (add-glib-cleanup object (make-gobject-cleanup
+ (gobject-alien object)
+ (gobject-signals object)))))
-(define (make-gobject-cleanup-thunk alien signals)
+(define (make-gobject-cleanup alien signals)
;; This separate procedure ensures that the gobject is not caught in
;; the closure.
- (named-lambda (gobject-cleanup-thunk)
- (gobject-cleanup alien signals)))
+ (named-lambda (gobject-cleanup)
+ (%trace ";gobject-cleanup "alien"\n")
+ (if (not (alien-null? alien))
+ (begin
+ (for-each
+ (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle)))
+ (cdr signals))
+ (C-call "g_object_unref" alien)
+ (alien-null! alien)))
+ (%trace ";gobject-cleanup done with "alien"\n")))
(define (gobject-unref! object)
(without-interrupts
(lambda ()
- (gobject-cleanup (gobject-alien object) (gobject-signals object))
- (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups))
- unspecific)))
-
-(define (gobject-cleanup alien signals)
- ;; Run as a gc-daemon, or with exclusive write access to ALIEN and
- ;; SIGNALS (or without-interrupts).
-
- (%trace ";gobject-cleanup "alien"\n")
- (if (not (alien-null? alien))
- (begin
- (for-each
- (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle)))
- (cdr signals))
- (C-call "g_object_unref" alien)
- (alien-null! alien)))
- (%trace ";gobject-cleanup done with "alien"\n"))
+ (execute-glib-cleanup object))))
(define (g-signal-connect gobject alien-function callback
#!optional signal-name)
(set-car! id.handle #f)
#t)))
\f
-;;; GC Cleanups
-
-(define gc-cleanups)
-
-(define (initialize-gc-cleanups!)
- (set! gc-cleanups '()))
-
-(define (run-gc-cleanups)
- (%trace ";run-gc-cleanups\n")
- (let loop ((alist gc-cleanups)
- (prev #f))
- (if (pair? alist)
- (if (weak-pair/car? (car alist))
- (loop (cdr alist) alist)
- (let ((thunk (weak-cdr (car alist)))
- (next (cdr alist)))
- (thunk)
- (if prev
- (set-cdr! prev next)
- (set! gc-cleanups next))
- (loop next prev)))))
- (%trace ";run-gc-cleanups done\n"))
-
-(define (reset-gc-cleanups!)
- (set! gc-cleanups '()))
-
-(define-integrable (add-gc-cleanup object cleanup-thunk)
- (let ((weak-pair (weak-cons object cleanup-thunk)))
- (without-interrupts
- (lambda ()
- (set! gc-cleanups (cons weak-pair gc-cleanups))))
- weak-pair))
-
-(define-integrable (punt-gc-cleanup object)
- (without-interrupts
- (lambda ()
- (let ((entry (weak-assq object gc-cleanups)))
- (if entry
- (begin
- (set! gc-cleanups (delq! entry gc-cleanups))
- (weak-cdr entry))
- #f)))))
-
-(define (weak-assq obj alist)
- (let loop ((alist alist))
- (if (null? alist) #f
- (let* ((entry (car alist))
- (key (weak-car entry)))
- (if (eq? obj key) entry
- (loop (cdr alist)))))))
-\f
;;; Properties
unspecific)
(define (initialize-package!)
- (initialize-gc-cleanups!)
(add-event-receiver! event:after-restore reset-quark-cache!)
- (add-event-receiver! event:after-restore reset-gc-cleanups!)
unspecific)
(define %trace? #f)
(bindings (append (pmodel/global-exports pmodel)
(pmodel/package-bindings pmodel '(gtk))))
(missing (minus (minus bindings deffns)
- '(add-gc-cleanup
- punt-gc-cleanup
- make-pole-zero
+ '(make-pole-zero
make-fix-layout-demo
make-gtk-event-viewer-demo)))
(extras (minus deffns bindings)))
(let ((fill (get-option ink 'FILL '())))
(if (not (null? fill))
(begin
+ (cairo-save cr)
(set-fill-options! cr ink)
- (cairo-fill-preserve cr))))
+ (cairo-fill-preserve cr)
+ (cairo-restore cr))))
(let ((outline (get-option ink 'OUTLINE '())))
(if (not (null? outline))
(begin
;;; package: (gdk)
(define (gdk-cairo-create gdkwindow)
- (guarantee-gdk-window gdkwindow 'gdk-window-process-updates)
+ (guarantee-gdk-window gdkwindow 'gdk-cairo-create)
(let ((cairo (make-alien '|cairo_t|))
(copy (make-alien '|cairo_t|)))
- (add-gc-cleanup cairo (make-cairo-cleanup copy))
+ (add-glib-cleanup cairo (make-cairo-cleanup copy))
(C-call "gdk_cairo_create" copy gdkwindow)
(copy-alien-address! cairo copy)
+ (error-if-null cairo "Could not create:" cairo gdkwindow)
(check-cairo-status cairo)
cairo))
(define (make-gerror-pointer)
(let ((alien (make-alien '(* |GError|)))
(copy (make-alien '(* |GError|))))
- (add-gc-cleanup alien (make-gerror-pointer-cleanup copy))
+ (add-glib-cleanup alien (make-gerror-pointer-cleanup copy))
(C-call "g_try_malloc0" copy (C-sizeof "* GError"))
- (if (alien-null? copy)
- (error "Could not create a GError pointer."))
(copy-alien-address! alien copy)
+ (error-if-null alien "Could not create:" alien)
alien))
(define (make-gerror-pointer-cleanup copy)
(without-interrupts
(lambda ()
(if (not (alien-null? gerror*))
- (let ((gerror (make-alien '|GError|)))
- (C-> gerror* "* GError" gerror)
- (if (not (alien-null? gerror))
- (C-call "g_error_free" gerror))
- (C-call "g_free" gerror*)
+ (begin
+ (execute-glib-cleanup gerror*)
(alien-null! gerror*))))))
(define (load-pixbuf-from-file loader filename)
'gtk-demos.callbacks
(named-lambda (gtk-demos.callbacks-test)
(assert = 0 (car (registered-callback-count))
- '(REGISTERED-CALLBACK-COUNT))))
+ '(CAR (REGISTERED-CALLBACK-COUNT)))))
(run-test
'gtk-demos.mallocs
(gtk-widget-show-all window)
(make-device graphics)))))
-(define (gtk-graphics/make width height)
- (guarantee-positive-fixnum width 'gtk-graphics/open)
- (guarantee-positive-fixnum height 'gtk-graphics/open)
- (%make-graphics-device gtk-graphics-device-type
- (make-gtk-graphics width height)))
-
(define (toplevel graphics)
(let ((widgets (fix-drawing-widgets (fix-ink-drawing graphics))))
(if (null? (cdr widgets))
;;; This is unfortunate. We rely on the most specialized method to
;;; call out, creating a specific type of GtkWidget. We want the
-;;; <gobject> method to go first, as usual, to add a gc-cleanup, but
+;;; <gobject> method to go first, as usual, to add a glib-cleanup, but
;;; this method to go last, AFTER the most specific (most unusual!)
;;; else it cannot connect its destroy-callback. To do both would
;;; take... a computed effective method procedure? For now, rely on
(import (gtk fix-layout)
fix-ink-extent fix-rect-height fix-rect-width
->color set-surface-ink-surface! drawing-damage)
- (import (runtime graphics)
- %make-graphics-device)
(export ()
gtk-graphics/set-background-color
gtk-graphics/set-foreground-color
gtk-graphics/draw-circle
gtk-graphics/fill-polygon-list
gtk-graphics/clear
- gtk-graphics/flush
- gtk-graphics/make))
+ gtk-graphics/flush))
(define-package (gtk fix-layout demo)
(parent (gtk fix-layout))
device will write to the surface, but not put the surface in a window.
Instead the device's descriptor, a @bref{<surface-ink>}, can be added
to any fix-drawing, or its Cairo surface can be passed to e.g.
-@bref{cairo-surface-write-to-png}.
+@code{cairo-surface-write-to-png}.
By default (or when @var{no-window?} is @code{#f}) the device's output
appears in a scrollable window.
You can draw on the surface with the simple graphics interface and/or
the following procedures.
-@deffn Procedure gtk-graphics/make width height
-Creates a Gtk graphics device even if the output device is not
-available. The output still goes to a new Cairo image surface with
-@var{width}x@var{height} pixels. It just can't be displayed (only
-written to a file).
-@end deffn
-
@deffn Procedure gtk-graphics/fill-polygon-list device points
Draws a filled polygon. @var{Points} is a list of flo:vectors each
containing at least two flonums, the x and y coordinates of a point.
@end deffn
@deffn Procedure gtk-graphics/flush device
-Applies @bref{cairo-surface-flush} to @var{device}'s Cairo surface,
+Applies @code{cairo-surface-flush} to @var{device}'s Cairo surface,
and updates any drawings containing @var{device}'s descriptor, a
-@bref{<surface-ink>}. @xref{cairo-surface-flush}. This is the method
+@bref{<surface-ink>}. This is the method
used by @code{graphics-flush}.
@end deffn
A gtk-widget is a gobject that can be "destroyed". Each instance is
connected to the "destroy" signal of its GtkWidget. The callback
-applies @bref{gobject-unref!} to the instance,
+applies @code{gobject-unref!} to the instance,
allowing the toolkit to finalize and dispose of the widget.
If a Gtk Widget is "dropped", never destroyed, eventually GCed, the
-usual gobject cleanup will effect a @bref{gobject-unref!} and
+usual gobject cleanup will effect a @code{gobject-unref!} and
(potentially) release the toolkit resources.
A Gtk Widget also has a ``parent'' slot --- a @bref{gtk-container} or
@var{widget}'s attributes. @var{Widget}'s @code{style-set} and
@code{direction-changed} signals indicate when the context has
changed. If you keep a PangoLayout using this default context, the
-signal callbacks should apply @bref{pango-layout-context-changed}.
+signal callbacks should apply @code{pango-layout-context-changed}.
@end deffn
@deffn Procedure gtk-widget-create-pango-layout widget #!optional text
description, and base direction for drawing text for @var{widget}.
The layout will be empty unless @var{text}, a string, is provided. If
@var{widget}'s base direction or font changes, apply
-@bref{pango-layout-context-changed} to re-lay-out the text.
+@code{pango-layout-context-changed} to re-lay-out the text.
@end deffn
@deffn Procedure gtk-widget-get-size widget
@deffn Procedure set-simple-text-ink-font! text font
Sets @var{text}'s pango layout's font to @var{font}. @var{Font}
should be a PangoFontDescription, or a string acceptable to
-@bref{pango-font-description-from-string} (e.g. @code{courier 12}).
+@code{pango-font-description-from-string} (e.g. @code{courier 12}).
@end deffn
@subsection Image Ink
object represents the GtkLabel. It is a gtk-label instance, whose
class is a specialization of the abstract gtk-object class.
-@unnumberedsec Gtk Thread
-
-When the Gtk system loads, it starts a toolkit main loop with Scheme
-attached as an custom idle task. The main loop then re-starts Scheme,
-which creates a thread to ``run'' the toolkit (actually, return to
-it). Thus Scheme threads multitask with the toolkit. Scheme runs as
-an idle task in the toolkit, and the toolkit runs in a Scheme thread.
-A program using the Gtk system does not call @code{gtk_init} nor
-@code{gtk_main}. It need only create toolkit objects and attach
-signal handlers to them.
-
-@unnumberedsec Toolkit Resource Usage
-
-Each gobject instance is tracked by the weak alist @code{gc-cleanups},
-so that the toolkit object can be @code{g_object_unref}'ed when the
-instance is GCed.
-
-The initialize-instance method for subclasses of gobject should chain
-up early, adding the instance's alien to gc-cleanups @emph{before}
-calling out to the toolkit. This ensures that an allocated toolkit
-object will not be dropped; its alien address is on the list of GC
-cleanups before it is even allocated. @emph{After} the callout, the
-initialize method should also @code{g_object_ref_sink} any floating
-refs it receives.
-
-The following scenarios are typical of Gtk resource management.
-
-Temporary alien: The (alien) address of a PangoFontDescription
-is read from a PangoLayout member. The layout ``owns'' the
-font description. Scheme does not. The address should only be used
-while without-toolkit (or without-interrupts), else the
-toolkit may "dispose" of it while Scheme is using it.
-
-Schemely: A toolkit object is created and reflected in Scheme by a
-gobject instance. Scheme owns the toolkit object, holds a reference,
-and should eventually @code{g_object_unref} it. The instance may be
-shared among any number of Scheme widgets or other data structures
-(e.g a file->pixbuf cache) and @emph{never} explicitly ``killed''.
-When there are no more Scheme objects sharing the instance, it
-will be GCed and its GC cleanup procedure will ``kill''
-(@code{g_object_unref}) the toolkit object. This may release toolkit
-resources or not depending on references elsewhere in the toolkit
-data structures. In any case the instance was GCed --- the object
-cannot be erroneously used by Scheme in the future.
-
-Signals: The @bref{g-signal-connect} procedure takes pains not to hold
-a strong reference to a gobject instance. These instances can be GCed
-even while signal handlers are connected. The registered callbacks
-hold only a weak reference to the instance. It is assumed a callback
-will not be invoked after an instance is GCed, else an error should be
-signaled.
-
-TODO: A world save hook might warn of gobject instances still on the
-gc-cleanups list. A world restore hook could kill them.
-
@node GNU Free Documentation License, , Implementation Notes, Top
@appendix GNU Free Documentation License
(guarantee-pango-layout layout 'pango-layout-get-baseline)
(let ((iter (make-alien '|PangoLayoutIter|))
(copy (make-alien '|PangoLayoutIter|)))
- (add-gc-cleanup iter (make-pango-layout-iter-cleanup copy))
+ (add-glib-cleanup iter (make-pango-layout-iter-cleanup copy))
(C-call "pango_layout_get_iter" copy (gobject-alien layout))
- (if (alien-null? copy)
- (begin
- (punt-gc-cleanup iter)
- #f)
- (begin
- (copy-alien-address! iter copy)
- (let ((baseline
- (pangos->pixels
- (C-call "pango_layout_iter_get_baseline" iter))))
- (pango-layout-iter-free iter)
- baseline)))))
+ (copy-alien-address! iter copy)
+ (error-if-null iter "Could not create:" iter layout)
+ (let ((baseline
+ (pangos->pixels
+ (C-call "pango_layout_iter_get_baseline" iter))))
+ (pango-layout-iter-free iter)
+ baseline)))
(define (make-pango-layout-iter-cleanup alien)
(named-lambda (pango-layout-iter-cleanup)
(lambda ()
(if (not (alien-null? iter))
(begin
- (C-call "pango_layout_iter_free" iter)
- (alien-null! iter)
- (punt-gc-cleanup iter))))))
+ (execute-glib-cleanup iter)
+ (alien-null! iter))))))
\f
;;; PangoFontDescription
(guarantee-string string 'pango-font-description-from-string)
(let ((font (make-alien '|PangoFontDescription|))
(copy (make-alien '|PangoFontDescription|)))
- (add-gc-cleanup font (make-pango-font-description-cleanup copy))
+ (add-glib-cleanup font (make-pango-font-description-cleanup copy))
(C-call "pango_font_description_from_string" copy string)
- (if (alien-null? copy)
- (begin
- (punt-gc-cleanup font)
- #f)
- (begin
- (copy-alien-address! font copy)
- font))))
+ (copy-alien-address! font copy)
+ (error-if-null font "Could not create:" font)
+ font))
(define (make-pango-font-description-cleanup alien)
(named-lambda (pango-font-description-cleanup)
(lambda ()
(if (not (alien-null? font))
(begin
- (C-call "pango_font_description_free" font)
- (alien-null! font)
- (punt-gc-cleanup font))))))
+ (execute-glib-cleanup font)
+ (alien-null! font))))))
(define (pango-font-description-to-string font)
(guarantee-pango-font-description font 'pango-font-description-to-string)
(define (pango-font-description-copy font)
(let ((new (make-alien '|PangoFontDescription|))
(copy (make-alien '|PangoFontDescription|)))
- (add-gc-cleanup new (make-pango-font-description-cleanup copy))
+ (add-glib-cleanup new (make-pango-font-description-cleanup copy))
(C-call "pango_font_description_copy" copy font)
- (if (alien-null? copy)
- (begin
- (punt-gc-cleanup font)
- #f)
- (begin
- (copy-alien-address! new copy)
- new))))
+ (copy-alien-address! new copy)
+ (error-if-null new "Could not create:" new font)
+ new))
(define-integrable (guarantee-pango-font-description object operator)
(if (not (and (alien? object)
(guarantee-pango-font-description font 'pango-context-get-metrics)
(let ((alien (make-alien '|PangoFontMetrics|))
(copy (make-alien '|PangoFontMetrics|)))
- (add-gc-cleanup alien (make-pango-font-metrics-cleanup copy))
+ (add-glib-cleanup alien (make-pango-font-metrics-cleanup copy))
(C-call "pango_context_get_metrics" copy context font 0)
(copy-alien-address! alien copy)
+ (error-if-null alien "Could not get:" alien)
alien))
(define (pango-context-spacing context)
(lambda ()
(if (not (alien-null? metrics))
(begin
- (C-call "pango_font_metrics_unref" metrics)
- (alien-null! metrics)
- (punt-gc-cleanup metrics))))))
+ (execute-glib-cleanup metrics)
+ (alien-null! metrics))))))
(define (pango-font-metrics-get-ascent metrics)
(guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-ascent)
(define-integrable (pixels->pangos pixel-units)
(* pixel-units 1024))
\f
-;;; Debugging hacks. No gc-cleanups!
+;;; Debugging hacks. No cleanups!
(define (pango-context-list-families PangoContext)
(let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFamily|))))
--- /dev/null
+# Copyright (C) 2014 Matthew Birkholz
+#
+# This file is part of an extension to MIT/GNU Scheme.
+#
+# MIT/GNU Scheme is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+exe = '$(MIT_SCHEME_EXE)' --batch-mode
+
+all:
+ echo '(load "mit-compile")' | $(exe)
+ @if [ -s mit-3d-unx.crf ]; then \
+ echo "mit-3d-unx.crf:0: error: non-empty"; exit 1; fi
+
+check:
+ echo '(load "mit-check")' | $(exe)
+
+.PHONY: all check
+
+maintainer-clean distclean clean:
+ rm -f *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd
+
+tags:
+ etags *.scm
+
+.PHONY: clean distclean maintainer-clean tags
(define (latitude-longitude->string lat/lng)
;; Format a latitude/longitude in the standard form, e.g.
;;
- ;; 30°26.40′N 122°44.40′W
+ ;; 30°26.400′N 122°44.400′W
(let ((lat (latitude lat/lng))
(lng (longitude lat/lng)))
(string-append
(number->string (inexact->exact lat-deg) '(int))
"°"
- (number->string lat-min '(fix 2))
+ (number->string lat-min '(fix 3))
"′"
(if neg-lat? "S " "N ")
(number->string (inexact->exact lng-deg) '(int))
"°"
- (number->string lng-min '(fix 2))
+ (number->string lng-min '(fix 3))
"′"
(if neg-lng? "W" "E")))))))
+(define (string->latitude-longitude string)
+ (let* ((digits "\\([0-9]+\\)")
+ (regs (re-string-match
+ (string-append "^"digits"°"digits"."digits"′\\([SN]\\)"
+ " "digits"°"digits"."digits"′\\([EW]\\)$")
+ string)))
+
+ (define-integrable (->flo n)
+ (->flonum (string->number (re-match-extract string regs n))))
+
+ (define-integrable (->neg? num)
+ (let ((string (re-match-extract string regs num)))
+ (or (string=? "W" string)
+ (string=? "S" string))))
+
+ (define-integrable (dms.->d neg? degrees minutes millimin)
+ (let ((absolute (flo:+ degrees
+ (flo:* 60.0 (flo:+ minutes
+ (flo:/ millimin 1000.))))))
+ (if neg?
+ (flo:negate absolute)
+ absolute)))
+
+ (and regs
+ (make-latitude/longitude
+ (dms.->d (->neg? 4) (->flo 1) (->flo 2) (->flo 3))
+ (dms.->d (->neg? 8) (->flo 5) (->flo 6) (->flo 7))))))
+
(define (geodesic-distance p1 p2)
;; "[Given] the geographic coordinates of two points on the surface
;; of the Earth [...] the shortest distance S between these points,
(flo:+ pi d)
d))))))
+#;(define (package-tests)
+ (run-test test-lat/lng-un/parse)
+ (run-test test-angular-separation))
+
+(define (test-lat/lng-un/parse)
+ (let ((samp "30°26.432′N 122°44.456′W"))
+ (if (not (string=? samp (latitude-longitude->string
+ (string->latitude-longitude samp))))
+ (warn "Latitude/longitude un/parsing failed."))))
+
(define (test-angular-separation)
(define (test lat1 lng1 lat2 lng2 degrees tolerance)
(global-definitions runtime/)
(global-definitions sos/)
(global-definitions xml/)
+(global-definitions glib/)
(global-definitions gtk/)
(global-definitions gl/)
(global-definitions "./mit")
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; System specific code for MIT Scheme using a cairo-graphics device.
+
+(define (make-suitable-graphics-device)
+ (let ((device (make-graphics-device 'cairo 512 512)))
+ (graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
+ device))
+
+(define-integrable (x p) (flo:vector-ref p 0))
+(define-integrable (y p) (flo:vector-ref p 1))
+
+(define (draw-segment device start end color)
+ (cairo-graphics/set-foreground-color device color)
+ #;(cairo-graphics/draw-line-points device start end)
+ (cairo-graphics/draw-line device
+ (x start) (y start)
+ (x end) (y end)))
+
+(define (draw-circle device center radius color)
+ (cairo-graphics/set-foreground-color device color)
+ (cairo-graphics/draw-circle device (x center) (y center) radius))
+
+(define (draw-text device coords string color)
+ (cairo-graphics/set-foreground-color device color)
+ (cairo-graphics/draw-text device (x coords) (y coords) string))
+
+(define (fill-polygon-available?) #t)
+
+(define (fill-polygon device points color)
+ (cairo-graphics/set-foreground-color device color)
+ (cairo-graphics/fill-polygon-list device points))
+
+(define (clear-graphics device)
+ (cairo-graphics/clear device))
+
+(define (flush-graphics device)
+ (cairo-graphics/flush device))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2013 Matthew Birkholz
+Copyright (C) 2013, 2014 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
(cf '("earth" "tellurion")
'("geometry" "matrices") '(planetarium))
(cf "mit-gtk" '() '(planetarium gtk-graphics))
+ (cf "mit-cairo" '() '(planetarium cairo-graphics))
(cf "mit-x" '() '(planetarium x-graphics))
(cf "mit-graphics" '() '(planetarium simple-graphics))
(cf "mit-cil" `("mit-syntax" ,@(directory-read "cil-*.txt"))
#| -*-Scheme-*-
-Copyright (C) 2013 Matthew Birkholz
+Copyright (C) 2013, 2014 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
;;;; Generate snapshots (PNG files).
;; Expect warning about DISPLAY not set.
-(load-option 'GTK)
+(load-option 'CAIRO)
(with-working-directory-pathname
(directory-pathname (current-load-pathname))
(lambda ()
- (load "mit-compile")
- (let* ((package-set (package-set-pathname "mit"))
- (file (fasload package-set)))
- (if (not ((access package-file? (->environment '(package))) file))
- (error "Malformed package-description file:" pkg))
- (load-packages-from-file file '()
- (lambda (pathname environment)
- (load pathname environment 'DEFAULT #t)))
- ((access initialize-packages-from-file (->environment '(package))) file)
- (flush-purification-queue!))))
+ (load-package-set "mit")))
(let ((planet (->environment '(planetarium)))
- (graphics (->environment '(planetarium gtk-graphics))))
+ (graphics (->environment '(planetarium cairo-graphics))))
(for-each (lambda (name) (environment-link-name planet graphics name))
- '(make-suitable-graphics-device
- draw-segment draw-circle draw-text
+ '(draw-segment draw-circle draw-text
fill-polygon-available? fill-polygon
clear-graphics flush-graphics)))
(let ((here (the-environment))
- (planet (->environment '(planetarium)))
- (gtk (->environment '(gtk))))
+ (planet (->environment '(planetarium))))
(for-each (lambda (name) (environment-link-name here planet name))
- '(make-latitude/longitude draw-tellurion))
- (for-each (lambda (name) (environment-link-name here gtk name))
- '(surface-ink-surface
- cairo-surface-write-to-png cairo-surface-destroy)))
+ '(make-latitude/longitude draw-tellurion)))
(let ((time (get-universal-time))
(latitude 33.3)
(longitude -111.9)
- (device (gtk-graphics/make 400 400)))
+ (device (make-graphics-device 'cairo 400 400)))
(graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
(call-with-append-file "tellurion.log"
(write-string (universal-time->local-time-string time) out)
(newline out)))))
- (let ((surface (surface-ink-surface (graphics-device/descriptor device))))
- (cairo-surface-write-to-png surface "tellurion.png")
- (cairo-surface-destroy surface)))
\ No newline at end of file
+ (cairo-graphics/write-to-png device "tellurion.png")
+ (cairo-graphics/destroy device))
\ No newline at end of file
;;;; Planetarium Packaging
(global-definitions runtime/)
+(global-definitions cairo/)
(global-definitions gtk/)
(define-package (r3rs essential)
decoded-time/year decoded-time/month decoded-time/day
universal-time->string
+ re-string-match re-match-extract
+
error warn)
(import (planetarium syntax)
define-integrable-operator)
(export ()
make-tellurion))
+(define-package (planetarium cairo-graphics)
+ (parent ())
+ (files "mit-cairo")
+ (export (planetarium)
+ ;; Exports must be set up manually, as in mit-link.scm, if
+ ;; this is the desired type of output device.
+ ))
+
(define-package (planetarium gtk-graphics)
(parent ())
(files "mit-gtk")
(export (planetarium)
- ;; Exports are actually set up by make.scm per the available graphics.
+ ;; Exports are set up by mit-link.scm per the available graphics.
))
(define-package (planetarium x-graphics)
(parent ())
(files "mit-x")
(export (planetarium)
- ;; Exports are actually set up by make.scm per the available graphics.
+ ;; Exports are set up by mit-link.scm per the available graphics.
))
(define-package (planetarium simple-graphics)
(parent ())
(files "mit-graphics")
(export (planetarium)
- ;; Exports are actually set up by make.scm per the available graphics.
+ ;; Exports are set up by mit-link.scm per the available graphics.
))
(define-package (planetarium earth-cil)
(define (run-tellurion queue)
(let ((device (make-suitable-graphics-device))
;; Latitude and longitude per GPS -- positive degrees long. to the east.
- (lat/long (make-latitude/longitude 23.271 0.))
+ (lat/lng (make-latitude/longitude 23.271 0.))
(time (get-universal-time))
(stopped? #f))
(define-integrable (draw)
- (draw-tellurion device time lat/long))
+ (draw-tellurion device time lat/lng))
(draw)
(let loop ()
(let ((command (if stopped?
(set! time (get-universal-time))
(draw))
((eq? (car command) 'TURN-TO)
- (set-latitude! lat/long (cadr command))
- (set-longitude! lat/long (caddr command))
+ (set-latitude! lat/lng (cadr command))
+ (set-longitude! lat/lng (caddr command))
(draw))
((eq? (car command) 'TIME-TO)
(if (eq? (cadr command) 'current)
(loop))))
(define draw-tellurion
- (let ((lat/long-pos (make-2d-point -1. -1.02))
+ (let ((lat/lng-pos (make-2d-point -1. -1.02))
(time-pos (make-2d-point -1. 1.))
(cross-hair-left (make-2d-point -.02 0.))
(cross-hair-right (make-2d-point .02 0.))
(cross-hair-top (make-2d-point 0. .02))
(cross-hair-bottom (make-2d-point 0. -.02)))
- (named-lambda (draw-tellurion device time lat/long)
+ (named-lambda (draw-tellurion device time lat/lng)
(clear-graphics device)
(draw-text device time-pos (universal-time->string time) "black")
- (draw-text device lat/long-pos (latitude/longitude-string lat/long) "black")
+ (draw-text device lat/lng-pos (latitude-longitude->string lat/lng) "black")
(draw-earth device
- (orientation-matrix lat/long)
+ (orientation-matrix lat/lng)
(solar-latitude/longitude
(universal-time->julian-day time)))
(draw-segment device cross-hair-left cross-hair-right "black")
(draw-segment device cross-hair-top cross-hair-bottom "black")
(flush-graphics device))))
-(define (orientation-matrix lat/long)
+(define (orientation-matrix lat/lng)
(let ((Mx (make-x-rotation-matrix (degrees->radians
- (latitude lat/long))))
+ (latitude lat/lng))))
(My (make-y-rotation-matrix (degrees->radians
- (flo:negate (longitude lat/long))))))
+ (flo:negate (longitude lat/lng))))))
(3d-multiply! Mx My Mx)
- Mx))
-
-(define (latitude/longitude-string lat/long)
- (let ((lat (latitude lat/long))
- (long (longitude lat/long)))
- (let ((lat-deg (truncate->exact (abs lat)))
- (long-deg (truncate->exact (abs long))))
- (let ((lat-minutes (* 60 (- (abs lat) lat-deg)))
- (long-minutes (* 60 (- (abs long) long-deg))))
- (let ((lat-min (truncate->exact lat-minutes))
- (long-min (truncate->exact long-minutes)))
- (let ((lat-frac (round->exact (* 1000 (- lat-minutes lat-min))))
- (long-frac (round->exact (* 1000 (- long-minutes long-min)))))
- (string-append (cond ((flo:negative? lat) "S")
- ((flo:positive? lat) "N")
- (else ""))
- (number->string lat-deg '(int))
- "°"
- (string-pad-left (number->string lat-min '(int))
- 2 #\0)
- "."
- (string-pad-left (number->string lat-frac '(int))
- 3 #\0)
- "' "
- (cond ((flo:negative? long) "W")
- ((flo:positive? long) "E")
- (else ""))
- (number->string long-deg '(int))
- "°"
- (string-pad-left (number->string long-min '(int))
- 2 #\0)
- "."
- (string-pad-left (number->string long-frac '(int))
- 3 #\0)
- "'")))))))
\ No newline at end of file
+ Mx))
\ No newline at end of file
projects / mit-scheme.git / commitdiff