(define-guarantee fix-widget "a <fix-widget>")
-(define-integrable guarantee-size guarantee-non-negative-fixnum)
+(define-integrable (guarantee-size object operator)
+ (guarantee non-negative-fixnum? object operator))
(define-method initialize-instance ((widget <fix-widget>) width height bgcolor)
(let ((bg (if (null? bgcolor)
(define (simplify name)
;; |GDK_BASED_ARROW_DOWN| => based-arrow-down
- (let ((string (symbol-name name)))
+ (let ((string (symbol->string name)))
(if (string-prefix? "GDK_" string)
(intern (string-replace (string-tail string 4) #\_ #\-))
(begin
(length (C-> GdkEvent "GdkEvent key length"))
(state (C-> GdkEvent "GdkEvent key state"))
(keyval (C-> GdkEvent "GdkEvent key keyval")))
- (let ((string (c-peek-cstring alien))
+ (let ((string (utf8->string (c-peek-cstring alien)))
(char-bits (gdk-key-state->char-bits state)))
(cond ((zero? (string-length string))
(cond ((fix:= length 1)
((and (fix:= 1 (string-length string))
(char=? #\backspace (string-ref string 0)))
(let ((name (gdk-keyval->name keyval)))
- (cond ((string-ci=? (symbol-name name) "backspace")
+ (cond ((string-ci=? (symbol->string name) "backspace")
(handler widget #\backspace char-bits))
((memq name '(|h| |H|))
(handler widget #\C-h
(floor->exact (C-> GdkEvent "GdkEventButton y")))))
(define (->button-event-type type operator)
- (guarantee-symbol type operator)
+ (guarantee symbol? type operator)
(case type
((PRESS) (C-enum "GDK_BUTTON_PRESS"))
((RELEASE) (C-enum "GDK_BUTTON_RELEASE"))
(define (fix-layout-scroll-to! widget x y)
(guarantee-fix-layout widget 'fix-layout-scroll-to!)
- (guarantee-fixnum x 'fix-layout-scroll-to!)
- (guarantee-fixnum y 'fix-layout-scroll-to!)
+ (guarantee fixnum? x 'fix-layout-scroll-to!)
+ (guarantee fixnum? y 'fix-layout-scroll-to!)
(scroll widget x y))
(define (fix-layout-scroll-nw! widget extent)
(define (set-fix-layout-scroll-step! widget width height)
(guarantee-fix-layout widget 'set-fix-layout-scroll-step!)
- (guarantee-positive-fixnum width 'set-fix-layout-scroll-step!)
- (guarantee-positive-fixnum height 'set-fix-layout-scroll-step!)
+ (guarantee positive-fixnum? width 'set-fix-layout-scroll-step!)
+ (guarantee positive-fixnum? height 'set-fix-layout-scroll-step!)
(let ((width.height (fix-layout-scroll-step widget)))
(set-car! width.height width)
(set-cdr! width.height height))
;; from the old drawing before the widget sees the new one.
(guarantee-fix-layout widget 'set-fix-layout-drawing!)
(guarantee-fix-drawing drawing 'set-fix-layout-drawing!)
- (guarantee-fixnum x 'set-fix-layout-drawing!)
- (guarantee-fixnum y 'set-fix-layout-drawing!)
+ (guarantee fixnum? x 'set-fix-layout-drawing!)
+ (guarantee fixnum? y 'set-fix-layout-drawing!)
(let* ((old (fix-layout-drawing widget))
(view (fix-layout-view widget)))
(if (and (eq? drawing old) (fix-rect-at-point? view x y))
(drawing-damage ink))))))
(define (set-line-ink! ink x1 y1 x2 y2)
- (guarantee-fixnum x1 'set-line-ink!)
- (guarantee-fixnum y1 'set-line-ink!)
- (guarantee-fixnum x2 'set-line-ink!)
- (guarantee-fixnum y2 'set-line-ink!)
+ (guarantee fixnum? x1 'set-line-ink!)
+ (guarantee fixnum? y1 'set-line-ink!)
+ (guarantee fixnum? x2 'set-line-ink!)
+ (guarantee fixnum? y2 'set-line-ink!)
(without-interrupts
(lambda ()
(let ((vector (line-ink-vector ink))
(define (set-line-ink-width! ink width)
(guarantee-line-ink ink 'set-line-ink-width!)
- (guarantee-positive-fixnum width 'set-line-ink-width!)
+ (guarantee positive-fixnum? width 'set-line-ink-width!)
(without-interrupts
(lambda ()
(if (set-option!? ink 'LINE-WIDTH (->flonum width))
(drawing-damage ink)))))
(define (set-rectangle-ink! ink x y width height)
- (guarantee-fixnum x 'set-rectangle-ink!)
- (guarantee-fixnum y 'set-rectangle-ink!)
+ (guarantee fixnum? x 'set-rectangle-ink!)
+ (guarantee fixnum? y 'set-rectangle-ink!)
(guarantee-size width 'set-rectangle-ink!)
(guarantee-size height 'set-rectangle-ink!)
(without-interrupts
(recache-rectangle-extent! ink)))))))
(define (set-rectangle-ink-position! ink x y)
- (guarantee-fixnum x 'set-rectangle-ink-position!)
- (guarantee-fixnum y 'set-rectangle-ink-position!)
+ (guarantee fixnum? x 'set-rectangle-ink-position!)
+ (guarantee fixnum? y 'set-rectangle-ink-position!)
(without-interrupts
(lambda ()
(let ((rect (rectangle-ink-rect ink)))
(define (set-rectangle-ink-width! ink width)
(guarantee-rectangle-ink ink 'set-rectangle-ink-width!)
- (guarantee-positive-fixnum width 'set-rectangle-ink-width!)
+ (guarantee positive-fixnum? width 'set-rectangle-ink-width!)
(without-interrupts
(lambda ()
(if (set-option!? ink 'LINE-WIDTH (->flonum width))
(define (set-polygon-ink-width! ink width)
(guarantee-polygon-ink ink 'set-polygon-ink-width!)
- (guarantee-positive-fixnum width 'set-polygon-ink-width!)
+ (guarantee positive-fixnum? width 'set-polygon-ink-width!)
(without-interrupts
(lambda ()
(if (set-option!? ink 'LINE-WIDTH (->flonum width))
(drawing-damage ink)))))
(define (set-arc-ink! ink x y width height)
- (guarantee-fixnum x 'set-arc-ink!)
- (guarantee-fixnum y 'set-arc-ink!)
+ (guarantee fixnum? x 'set-arc-ink!)
+ (guarantee fixnum? y 'set-arc-ink!)
(guarantee-size width 'set-arc-ink!)
(guarantee-size height 'set-arc-ink!)
(without-interrupts
(define (set-arc-ink-start-angle! arc degrees)
(guarantee-arc-ink arc 'set-arc-ink-start-angle!)
- (guarantee-real degrees 'set-arc-ink-start-angle!)
+ (guarantee real? degrees 'set-arc-ink-start-angle!)
(let ((new (flo:* (->flonum degrees) (flo:/ flo:pi 180.))))
(if (not (flo:= new (arc-ink-%start-angle arc)))
(begin
(define (set-arc-ink-sweep-angle! arc degrees)
(guarantee-arc-ink arc 'set-arc-ink-sweep-angle!)
- (guarantee-real degrees 'set-arc-ink-sweep-angle!)
+ (guarantee real? degrees 'set-arc-ink-sweep-angle!)
(let ((new (flo:* (->flonum degrees) (flo:/ flo:pi 180.))))
(if (not (flo:= new (arc-ink-%sweep-angle arc)))
(begin
(define (set-arc-ink-width! ink width)
(guarantee-arc-ink ink 'set-arc-ink-width!)
- (guarantee-positive-fixnum width 'set-arc-ink-width!)
+ (guarantee positive-fixnum? width 'set-arc-ink-width!)
(without-interrupts
(lambda ()
(if (set-option!? ink 'LINE-WIDTH (->flonum width))
(draw-ink-options ink)))
(define (set-text-ink-position! ink x y)
- (guarantee-fixnum x 'set-text-ink-position!)
- (guarantee-fixnum y 'set-text-ink-position!)
+ (guarantee fixnum? x 'set-text-ink-position!)
+ (guarantee fixnum? y 'set-text-ink-position!)
(without-interrupts
(lambda ()
(let ((rect (fix-ink-extent ink)))
;; The TEXT string is shared.
(guarantee-simple-text-ink ink 'set-simple-text-ink-text!)
(guarantee-gtk-widget widget 'set-simple-text-ink-text!)
- (guarantee-string text 'set-simple-text-ink-text!)
+ (guarantee string? text 'set-simple-text-ink-text!)
(without-interrupts
(lambda ()
(let ((old (simple-text-ink-text ink)))
ink))
(define (set-image-ink! ink x y)
- (guarantee-fixnum x 'set-image-ink-position!)
- (guarantee-fixnum y 'set-image-ink-position!)
+ (guarantee fixnum? x 'set-image-ink-position!)
+ (guarantee fixnum? y 'set-image-ink-position!)
(set-fix-ink-%position! ink x y))
\f
(define-class (<surface-ink> (constructor () (width height)))
(fix:<= min-y1 min-y2) (fix:<= max-y2 max-y1)))))))
(define (gdk-rectangle #!optional x y width height)
- (if (not (default-object? x)) (guarantee-fixnum x 'gdk-rectangle))
- (if (not (default-object? y)) (guarantee-fixnum y 'gdk-rectangle))
+ (if (not (default-object? x)) (guarantee fixnum? x 'gdk-rectangle))
+ (if (not (default-object? y)) (guarantee fixnum? y 'gdk-rectangle))
(if (not (default-object? width)) (guarantee-size width 'gdk-rectangle))
(if (not (default-object? height)) (guarantee-size height 'gdk-rectangle))
(let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|)))
(define (note-error)
(let* ((gerror (C-> gerror* "* GError"))
(message (or (and (not (alien-null? gerror))
- (c-peek-cstring
- (C-> gerror "GError message")))
+ (utf8->string
+ (c-peek-cstring
+ (C-> gerror "GError message"))))
"GError pointer not set.")))
(set-pixbuf-loader-error-message! loader message))
(note-done))
(if entry
(cdr entry)
(let ((atom (make-alien '(struct |_GdkAtom|))))
- (C-call "gdk_atom_intern" atom (symbol-name symbol) 0)
+ (C-call "gdk_atom_intern" atom
+ (string->utf8 (symbol->string symbol)) 0)
(set-gdk-display/atoms! display
(cons (cons symbol atom)
(gdk-display/atoms display)))
(define (gdk-display-set-clipboard-text display string)
(%trace "; gdk-display-set-clipboard-text "display"\n")
- (let ((string (string->utf8 string)))
+ (let ((string-bv (string->utf8 string)))
(C-call "gtk_clipboard_set_text"
(clipboard display)
- string (string-length string))))
+ string-bv (bytevector-length string-bv))))
(define (gdk-display-get-clipboard-text display msec)
(%trace "; gdk-display-get-clipboard-text "display" "msec"\n")
(declare (ignore clipboard))
(if (alien-null? char*)
(queue! queue #t)
- (queue! queue (c-peek-cstring char*))))))
+ (queue! queue (utf8->string (c-peek-cstring char*)))))))
(define (queue! queue value)
(thread-queue/queue! queue value)
(define (event-name-line GdkEvent)
(let ((type (C-> GdkEvent "GdkEvent any type")))
- (string-append (symbol-name (C-enum "GdkEventType" type)) "\n")))
+ (string-append (symbol->string (C-enum "GdkEventType" type)) "\n")))
(define (any-event-line GdkEvent)
(let ((event-time (C-call "gdk_event_get_time" GdkEvent))
(C-> GdkEvent "GdkEvent key keyval")))
(text (let ((alien (make-alien '|gchar|)))
(C-> GdkEvent "GdkEvent key string" alien)
- (c-peek-cstring alien))))
- (cat "Keyval: "keyval" Text: "(write-to-string text)"\n")))
+ (utf8->string (c-peek-cstring alien)))))
+ (cat "Keyval: "keyval" Text: "text"\n")))
(else
#f))))
\f
(let ((width (if (default-object? width) 512 width))
(height (if (default-object? height) 384 height))
(no-window? (if (default-object? no-window?) #f no-window?)))
- (guarantee-positive-fixnum width 'gtk-graphics/open)
- (guarantee-positive-fixnum height 'gtk-graphics/open)
+ (guarantee positive-fixnum? width 'gtk-graphics/open)
+ (guarantee positive-fixnum? height 'gtk-graphics/open)
(if no-window?
(make-device (make-gtk-graphics width height))
(let ((window (gtk-window-new 'toplevel))
(map (lambda (elt)
(let ((alien (weak-car elt)))
(if (eq? 'uchar (alien/ctype alien))
- (c-peek-cstring alien)
+ (utf8->string (c-peek-cstring alien))
alien)))
(access malloced-aliens ffi))))))
\ No newline at end of file
lower upper page-size
step-incr page-incr)
(guarantee-live-gtk-adjustment adjustment 'set-gtk-adjustment!)
- (guarantee-real lower 'set-gtk-adjustment!)
- (guarantee-real upper 'set-gtk-adjustment!)
- (guarantee-real page-size 'set-gtk-adjustment!)
- (guarantee-real step-incr 'set-gtk-adjustment!)
- (guarantee-real page-incr 'set-gtk-adjustment!)
+ (guarantee real? lower 'set-gtk-adjustment!)
+ (guarantee real? upper 'set-gtk-adjustment!)
+ (guarantee real? page-size 'set-gtk-adjustment!)
+ (guarantee real? step-incr 'set-gtk-adjustment!)
+ (guarantee real? page-incr 'set-gtk-adjustment!)
(define-integrable f->e floor->exact)
(let ((alien (gobject-alien adjustment))
(new-lower (f->e lower))
(define (gtk-widget-create-pango-layout widget #!optional text)
(guarantee-gtk-widget widget 'gtk-widget-create-pango-layout)
(if (not (default-object? text))
- (guarantee-string text 'gtk-widget-create-pango-layout))
+ (guarantee string? text 'gtk-widget-create-pango-layout))
(let* ((layout (make-pango-layout))
(alien (gobject-alien layout)))
(C-call "gtk_widget_create_pango_layout"
alien (gobject-alien widget)
- (if (default-object? text) 0 text))
+ (if (default-object? text) 0 (string->utf8 text)))
(error-if-null alien "Could not create:" layout)
layout))
(define (gtk-widget-set-opacity widget opacity)
(guarantee-gtk-widget widget 'gtk-widget-set-opacity)
- (guarantee-real opacity 'gtk-widget-set-opacity)
+ (guarantee real? opacity 'gtk-widget-set-opacity)
(if (not (<= 0. opacity 1.))
(error:bad-range-argument opacity 'gtk-widget-set-opacity))
(C-call "gtk_widget_set_opacity" (gobject-alien widget) opacity))
(define (gtk-widget-set-name widget name)
(guarantee-gtk-widget widget 'gtk-widget-set-name)
- (guarantee-string name 'gtk-widget-set-name)
- (C-call "gtk_widget_set_name" (gobject-alien widget) name))
+ (guarantee string? name 'gtk-widget-set-name)
+ (C-call "gtk_widget_set_name" (gobject-alien widget) (string->utf8 name)))
\f
;;; GtkStyleContext & GtkCssProvider
(define (error-if-gerror* gerror* message . data)
(let ((gerror (C-> gerror* "* GError")))
(if (not (alien-null? gerror))
- (let ((errmsg (c-peek-cstring (C-> gerror "GError message"))))
+ (let ((errmsg-bv (c-peek-cstring (C-> gerror "GError message"))))
(without-interruption
(lambda ()
(C->= gerror* "* GError" 0)
(C-call "g_error_free" gerror)))
- (apply error message errmsg data)))))
+ (apply error message (utf8->string errmsg-bv) data)))))
(define-class (<gtk-css-provider> (constructor ()))
(<gobject-with-gerror*>))
object))
(define (gtk-css-provider-get-named name variant)
- (guarantee-string name 'gtk-css-provider-get-named)
+ (guarantee string? name 'gtk-css-provider-get-named)
(let* ((v (if (eq? #f variant)
0
(begin
- (guarantee-string variant 'gtk-css-provider-get-named)
- variant)))
+ (guarantee string? variant 'gtk-css-provider-get-named)
+ (string->utf8 variant))))
(object (make-gtk-css-provider))
(alien (gobject-alien object)))
- (C-call "gtk_css_provider_get_named" alien name v)
+ (C-call "gtk_css_provider_get_named" alien (string->utf8 name) v)
(error-if-null alien "Could not get named GtkCssProvider:"
object name variant)
(C-call "g_object_ref" alien alien)
(define (gtk-css-provider-load-from-data provider string)
(guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-data)
- (guarantee-string string 'gtk-css-provider-load-from-data)
+ (guarantee string? string 'gtk-css-provider-load-from-data)
(let ((alien (gobject-alien provider))
- (gerror* (gobject-gerror* provider)))
- (C-call "gtk_css_provider_load_from_data" alien string -1 gerror*)
+ (gerror* (gobject-gerror* provider))
+ (string-bv (string->utf8 string)))
+ (C-call "gtk_css_provider_load_from_data" alien string-bv -1 gerror*)
(error-if-gerror* gerror* "Could not load GtkCssProvider data:" provider)))
(define-guarantee gfile "a <gfile>")
(merge-pathnames pathname (working-directory-pathname)))))
(alien (gobject-alien provider))
(gerror* (gobject-gerror* provider)))
- (C-call "gtk_css_provider_load_from_path" alien namestring gerror*)
+ (C-call "gtk_css_provider_load_from_path" alien
+ (string->utf8 namestring) gerror*)
(error-if-gerror* gerror* "Could not load GtkCssProvider path:"
provider namestring)))
\f
(define (gtk-container-set-border-width container width)
(guarantee-gtk-container container 'gtk-container-set-border-width)
- (guarantee-positive-fixnum width 'gtk-container-set-border-width)
+ (guarantee positive-fixnum? width 'gtk-container-set-border-width)
(C-call "gtk_container_set_border_width" (gobject-alien container) width))
(define (container-add! container child)
(define-method initialize-instance ((label <gtk-label>) string)
(call-next-method label)
(let ((alien (gobject-alien label)))
- (C-call "gtk_label_new" alien string)
+ (C-call "gtk_label_new" alien (string->utf8 string))
(error-if-null alien "Could not create:" label string)
(C-call "g_object_ref_sink" alien alien))
(set-gtk-widget-destroy-callback! label))
(define (gtk-label-new string)
- (guarantee-string string 'gtk-label-new)
+ (guarantee string? string 'gtk-label-new)
(make-gtk-label string))
(define (gtk-label-get-text label)
(guarantee-gtk-label label 'gtk-label-get-text)
(let ((retval (make-alien '|gchar|)))
(C-call "gtk_label_get_text" retval (gobject-alien label))
- (c-peek-cstring retval)))
+ (utf8->string (c-peek-cstring retval))))
(define (gtk-label-set-text label string)
(guarantee-gtk-label label 'gtk-label-set-text)
- (guarantee-string string 'gtk-label-set-text)
- (C-call "gtk_label_set_text" (gobject-alien label) string))
+ (guarantee string? string 'gtk-label-set-text)
+ (C-call "gtk_label_set_text" (gobject-alien label) (string->utf8 string)))
(define (gtk-label-set-width-chars label n-chars)
- (guarantee-non-negative-fixnum n-chars 'set-label-width!)
+ (guarantee non-negative-fixnum? n-chars 'set-label-width!)
(C-call "gtk_label_set_width_chars" (gobject-alien label) n-chars))
\f
;;; GtkButtons
(define (gtk-grid-set-row-spacing grid spacing)
(guarantee-gtk-grid grid 'gtk-grid-set-row-spacing)
- (guarantee-non-negative-fixnum spacing 'gtk-grid-set-row-spacing)
+ (guarantee non-negative-fixnum? spacing 'gtk-grid-set-row-spacing)
(C-call "gtk_grid_set_row_spacing" (gobject-alien grid) spacing))
(define (gtk-grid-set-column-spacing grid spacing)
(guarantee-gtk-grid grid 'gtk-grid-set-column-spacing)
- (guarantee-non-negative-fixnum spacing 'gtk-grid-set-column-spacing)
+ (guarantee non-negative-fixnum? spacing 'gtk-grid-set-column-spacing)
(C-call "gtk_grid_set_column_spacing" (gobject-alien grid) spacing))
(define (gtk-grid-attach grid widget left top width height)
(guarantee-gtk-grid grid 'gtk-grid-attach)
(guarantee-gtk-widget widget 'gtk-grid-attach)
- (guarantee-fixnum left 'gtk-grid-attach)
- (guarantee-fixnum top 'gtk-grid-attach)
- (guarantee-fixnum width 'gtk-grid-attach)
- (guarantee-fixnum height 'gtk-grid-attach)
+ (guarantee fixnum? left 'gtk-grid-attach)
+ (guarantee fixnum? top 'gtk-grid-attach)
+ (guarantee fixnum? width 'gtk-grid-attach)
+ (guarantee fixnum? height 'gtk-grid-attach)
(container-add! grid widget)
(C-call "gtk_grid_attach" (gobject-alien grid) (gobject-alien widget)
left top width height))
(guarantee-gtk-grid grid 'gtk-grid-attach-next-to)
(guarantee-gtk-widget child 'gtk-grid-attach-next-to)
(if sibling (guarantee-gtk-widget sibling 'gtk-grid-attach-next-to))
- (guarantee-fixnum width 'gtk-grid-attach-next-to)
- (guarantee-fixnum height 'gtk-grid-attach-next-to)
+ (guarantee fixnum? width 'gtk-grid-attach-next-to)
+ (guarantee fixnum? height 'gtk-grid-attach-next-to)
(let ((side-num (->side side 'gtk-grid-attach-next-to)))
(container-add! grid child)
(C-call "gtk_grid_attach_next_to"
(define-method initialize-instance ((frame <gtk-frame>) label)
(call-next-method frame)
(let ((alien (gobject-alien frame)))
- (C-call "gtk_frame_new" alien label)
+ (C-call "gtk_frame_new" alien
+ (if (string-null? label) 0 (string->utf8 label)))
(error-if-null alien "Could not create:" frame)
(C-call "g_object_ref_sink" alien alien))
(set-gtk-widget-destroy-callback! frame))
(define (gtk-frame-new label)
- (guarantee-string label 'gtk-frame-new)
+ (guarantee string? label 'gtk-frame-new)
(make-gtk-frame label))
(define (gtk-frame-set-shadow-type frame type)
(define (gtk-window-set-title window title)
(guarantee-gtk-window window 'gtk-window-set-title)
- (guarantee-string title 'gtk-window-set-title)
- (C-call "gtk_window_set_title" (gobject-alien window) title))
+ (guarantee string? title 'gtk-window-set-title)
+ (C-call "gtk_window_set_title" (gobject-alien window) (string->utf8 title)))
(define (gtk-window-set-type-hint window hint)
(guarantee-gtk-window window 'gtk-window-set-type-hint)
(define (gtk-window-set-default-size window width height)
(guarantee-gtk-window window 'gtk-window-set-default-size)
- (guarantee-integer width 'gtk-window-set-default-size)
- (guarantee-integer height 'gtk-window-set-default-size)
+ (guarantee integer? width 'gtk-window-set-default-size)
+ (guarantee integer? height 'gtk-window-set-default-size)
(C-call "gtk_window_set_default_size" (gobject-alien window) width height))
(define (gtk-window-set-geometry-hints window widget . hints)
(define (gtk-window-resize window width height)
(guarantee-gtk-window window 'gtk-window-resize)
- (guarantee-positive-fixnum width 'gtk-window-resize)
- (guarantee-positive-fixnum height 'gtk-window-resize)
+ (guarantee positive-fixnum? width 'gtk-window-resize)
+ (guarantee positive-fixnum? height 'gtk-window-resize)
(C-call "gtk_window_resize" (gobject-alien window) width height))
(define (gtk-window-present window)
(define (gtk-window-set-clipboard-text window string)
(guarantee-gtk-window window 'gtk-window-set-clipboard-text)
+ (guarantee string? string 'gtk-window-set-clipboard-text)
(let* ((gdkdisplay (C-call "gtk_widget_get_display"
(make-alien '|GtkDisplay|)
(gobject-alien window)))
(map (lambda (gdk-name.keyval)
(let* ((keyval (cdr gdk-name.keyval))
(gdk-name (car gdk-name.keyval))
- (string (symbol-name gdk-name))
+ (string (symbol->string gdk-name))
(name (cond ((string-prefix? "GDK_KEY_" string)
(string->symbol (string-tail string 8)))
(else
'INIT-GTK))
(vars-size (+ (C-sizeof "int") ;gtk_init_check return var
(C-sizeof "* * char")))) ;gtk_init_check return var
- (guarantee-string name 'INIT-GTK)
+ (guarantee string? name 'INIT-GTK)
(let* ((words (cons name args))
+ (words-bv (map string->utf8 words))
(vector-size
(* (C-sizeof "* char") (+ 1 arg-count)))
(total-size
(+ vars-size vector-size
(fold-left (lambda (sum arg)
- (+ sum (string-length arg) 1)) ;null terminated
- 0 words)))
+ (+ sum (bytevector-length arg) 1)) ;null terminated
+ 0 words-bv)))
(bytes (malloc total-size #f))
(vector (alien-byte-increment bytes vars-size))
(word-scan (alien-byte-increment vector vector-size))
(vector-scan (copy-alien vector))
(count-var bytes)
(vector-var (alien-byte-increment count-var (C-sizeof "int"))))
- (for-each (lambda (word)
+ (for-each (lambda (word-bv)
(c-poke-pointer! vector-scan word-scan)
- (c-poke-string! word-scan word))
- words)
+ (c-poke-string! word-scan word-bv))
+ words-bv)
(C->= count-var "int" (+ 1 arg-count))
(C->= vector-var "* * char" vector)
(if (fix:zero? (C-call "gtk_init_check" count-var vector-var))
(let loop ((i 0)(args '()))
(if (fix:< i new-argc)
(loop (fix:1+ i)
- (cons (c-peek-cstringp! vector-scan) args))
+ (cons (utf8->string
+ (c-peek-cstringp! vector-scan))
+ args))
(reverse! args)))))
(free bytes)
(set! initialized? #t)
(define (set-scm-widget-minimum-size! widget width height)
(guarantee-scm-widget widget 'set-scm-widget-minimum-size!)
- (guarantee-non-negative-fixnum width 'set-scm-widget-minimum-size!)
- (guarantee-non-negative-fixnum height 'set-scm-widget-minimum-size!)
+ (guarantee non-negative-fixnum? width 'set-scm-widget-minimum-size!)
+ (guarantee non-negative-fixnum? height 'set-scm-widget-minimum-size!)
(let ((a (gobject-alien widget)))
(C->= a "ScmWidget minimum_width" width)
(C->= a "ScmWidget minimum_height" height)))
(define (set-scm-widget-natural-size! widget width height)
(guarantee-scm-widget widget 'set-scm-widget-natural-size!)
- (guarantee-non-negative-fixnum width 'set-scm-widget-natural-size!)
- (guarantee-non-negative-fixnum height 'set-scm-widget-natural-size!)
+ (guarantee non-negative-fixnum? width 'set-scm-widget-natural-size!)
+ (guarantee non-negative-fixnum? height 'set-scm-widget-natural-size!)
(let ((a (gobject-alien widget)))
(C->= a "ScmWidget natural_width" width)
(C->= a "ScmWidget natural_height" height)))
\ No newline at end of file
(unset! (cdr items)))))))
(define (item-move! item dx dy)
- (guarantee-fixnum dx 'item-move!)
- (guarantee-fixnum dy 'item-move!)
+ (guarantee fixnum? dx 'item-move!)
+ (guarantee fixnum? dy 'item-move!)
(if (not (and (fix:zero? dx) (fix:zero? dy)))
(without-interrupts
(lambda ()
(lambda () (set-swat-text-%anchor! text anchor)))))
(define (set-swat-text-text! text string)
- (guarantee-string string 'set-swat-text-text!)
+ (guarantee string? string 'set-swat-text-text!)
(if (eq? 'nw (swat-text-anchor text))
(set-simple-text-ink-text! text string)
(hold-position text (lambda () (set-simple-text-ink-text! text string)))))
(define-generic set-text! (widget string))
(define-method set-text! ((button <swat-button>) string)
- (guarantee-string string '(set-text! <swat-button>))
+ (guarantee string? string '(set-text! <swat-button>))
(let ((label (gtk-bin-child button)))
(if (not label)
(gtk-container-add button (gtk-label-new string))
(gtk-label-set-text label string))))
(define-method set-text! ((label <swat-label>) string)
- (guarantee-string string '(set-text! <swat-label>))
+ (guarantee string? string '(set-text! <swat-label>))
(gtk-label-set-text (gtk-bin-child label) string))
(define-method set-text! ((button <swat-checkbutton>) string)
- (guarantee-string string '(set-text! <swat-checkbutton>))
+ (guarantee string? string '(set-text! <swat-checkbutton>))
(let ((label (gtk-bin-child button)))
(if (not label)
(gtk-container-add button (gtk-label-new string))
(define-generic set-item-text! (item value))
(define-method set-item-text! ((text <swat-text>) string)
- (guarantee-string string '(set-item-text! <swat-text>))
+ (guarantee string? string '(set-item-text! <swat-text>))
(set-swat-text-text! text string))
(define-generic set-item-width! (item value))
(if head (set-polygon-ink-width! head width)))
(set-line-ink-width! item width))
(define-method set-item-width! ((item <swat-oval>) width)
- (guarantee-positive-fixnum width '(set-item-width! <swat-oval>))
+ (guarantee positive-fixnum? width '(set-item-width! <swat-oval>))
(set-arc-ink-width! item width))
(define-method set-item-width! ((item <swat-rectangle>) width)
- (guarantee-positive-fixnum width '(set-item-width! <swat-rectangle>))
+ (guarantee positive-fixnum? width '(set-item-width! <swat-rectangle>))
(set-rectangle-ink-width! item width))
\f
;;;; SWAT Interface
;;; ClearArea, initialize-uitk!.
(define (after-delay seconds thunk)
- (guarantee-index-fixnum seconds 'after-delay)
+ (guarantee index-fixnum? seconds 'after-delay)
(guarantee-procedure-of-arity thunk 0 'after-delay)
(detach-thread
(create-thread
(for-each fix-ink-remove! (fix-drawing-display-list drawing))))
(define (make-line-on-canvas canvas x1 y1 x2 y2)
- (guarantee-fixnum x1 'make-line-on-canvas)
- (guarantee-fixnum y1 'make-line-on-canvas)
- (guarantee-fixnum x2 'make-line-on-canvas)
- (guarantee-fixnum y2 'make-line-on-canvas)
+ (guarantee fixnum? x1 'make-line-on-canvas)
+ (guarantee fixnum? y1 'make-line-on-canvas)
+ (guarantee fixnum? x2 'make-line-on-canvas)
+ (guarantee fixnum? y2 'make-line-on-canvas)
(let ((item (make-swat-line)))
(set-line-ink! item x1 y1 x2 y2)
(fix-drawing-add-ink! (fix-layout-drawing canvas) item)
item))
(define (make-rectangle-on-canvas canvas x y width height)
- (guarantee-fixnum x 'make-rectangle-on-canvas)
- (guarantee-fixnum y 'make-rectangle-on-canvas)
- (guarantee-positive-fixnum width 'make-rectangle-on-canvas)
- (guarantee-positive-fixnum height 'make-rectangle-on-canvas)
+ (guarantee fixnum? x 'make-rectangle-on-canvas)
+ (guarantee fixnum? y 'make-rectangle-on-canvas)
+ (guarantee positive-fixnum? width 'make-rectangle-on-canvas)
+ (guarantee positive-fixnum? height 'make-rectangle-on-canvas)
(let ((item (make-swat-rectangle)))
(set-rectangle-ink! item x y width height)
(fix-drawing-add-ink! (fix-layout-drawing canvas) item)
item))
(define (make-oval-on-canvas canvas x1 y1 x2 y2)
- (guarantee-fixnum x1 'make-oval-on-canvas)
- (guarantee-fixnum y1 'make-oval-on-canvas)
- (guarantee-fixnum x2 'make-oval-on-canvas)
- (guarantee-fixnum y2 'make-oval-on-canvas)
+ (guarantee fixnum? x1 'make-oval-on-canvas)
+ (guarantee fixnum? y1 'make-oval-on-canvas)
+ (guarantee fixnum? x2 'make-oval-on-canvas)
+ (guarantee fixnum? y2 'make-oval-on-canvas)
(let ((x (fix:min x1 x2))
(y (fix:min y1 y2))
(width (fix:abs (fix:- x2 x1)))
(let ((text (find-option options '-text ""))
(anchor (find-option options '-anchor 'center))
(ink (make-swat-text)))
- (guarantee-string text 'make-text-on-canvas)
+ (guarantee string? text 'make-text-on-canvas)
(set-simple-text-ink-text! ink canvas text)
(set-text-ink-position! ink x y)
(set-swat-text-anchor! ink anchor)
projects / mit-scheme.git / commitdiff