Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | minor fixes on cairo |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
35fd13c928d2842c158971314c603467 |
| User & Date: | aldo 2016-12-08 00:39:41 |
Context
|
2016-12-08
| ||
| 00:41 | moved cast and char*->bytevector to ffi-utils check-in: 6cf5622d30 user: aldo tags: trunk | |
| 00:39 | minor fixes on cairo check-in: 35fd13c928 user: aldo tags: trunk | |
| 00:38 | improved error info form matchable check-in: 3efc59d401 user: aldo tags: trunk | |
Changes
Changes to cairo.sls.
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
...
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
cairo-rectangle-list-t cairo-scaled-font-t cairo-font-face-t cairo-glyph-t cairo-text-cluster-t cairo-text-cluster-flags-t cairo-text-extents-t cairo-text-extents-t cairo-font-extents-t cairo-font-extents-t cairo-font-slant-t cairo-font-weight-t cairo-subpixel-order-t cairo-hint-style-t cairo-hint-metrics-t cairo-font-options-t ................................................................................ with-cairo let-struct ) (import (chezscheme) (ffi-utils)) (include "cairo/ffi-utils.ss") (define (cairo-library-init . t) (load-shared-object (if (null? t) "libcairo.so" (car t)))) (include "cairo/types.ss") (define cairo-guardian (make-guardian)) (define (cairo-guard-pointer obj) (cairo-free-garbage) (cairo-guardian obj) obj) (define (cairo-free-garbage) (let loop ([p (cairo-guardian)]) (when p (when (ftype-pointer? p) ;(printf "cairo-free-garbage: freeing memory at ~x\n" p) ;;[(ftype-pointer? usb-device*-array p) (cond [(ftype-pointer? cairo-t p) (cairo-destroy p)] [(ftype-pointer? cairo-surface-t p) (cairo-surface-destroy p)] [(ftype-pointer? cairo-pattern-t p) (cairo-pattern-destroy p)] [(ftype-pointer? cairo-region-t p) (cairo-region-destroy p)] [(ftype-pointer? cairo-rectangle-list-t p) (cairo-rectangle-list-destroy p)] [(ftype-pointer? cairo-font-options-t p) (cairo-font-options-destroy p)] [(ftype-pointer? cairo-font-face-t p) (cairo-font-face-destroy p)] [(ftype-pointer? cairo-scaled-font-t p) (cairo-scaled-font-destroy p)] [(ftype-pointer? cairo-path-t p) (cairo-path-destroy p)] [(ftype-pointer? cairo-device-t p) (cairo-device-destroy p)] [else (foreign-free (ftype-pointer-address p))] )) (loop (cairo-guardian))))) |
<
<
|
|
|
|
218
219
220
221
222
223
224
225
226
227
228
229
230
231
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
|
cairo-rectangle-list-t cairo-scaled-font-t cairo-font-face-t cairo-glyph-t cairo-text-cluster-t cairo-text-cluster-flags-t cairo-text-extents-t cairo-font-extents-t cairo-font-slant-t cairo-font-weight-t cairo-subpixel-order-t cairo-hint-style-t cairo-hint-metrics-t cairo-font-options-t ................................................................................ with-cairo let-struct ) (import (chezscheme) (ffi-utils)) (include "cairo/ffi-utils.ss") (define (cairo-library-init . t) (load-shared-object (if (null? t) "libcairo.so.2.11502.0" (car t)))) (include "cairo/types.ss") (define cairo-guardian (make-guardian)) (define (cairo-guard-pointer obj) (cairo-free-garbage) (cairo-guardian obj) obj) (define (cairo-free-garbage) (let loop ([p (cairo-guardian)]) (when p (when (ftype-pointer? p) (printf "cairo-free-garbage: freeing memory at ~x\n" p) ;;[(ftype-pointer? usb-device*-array p) (cond [(ftype-pointer? cairo-t p) (cairo-destroy p)] [(ftype-pointer? cairo-surface-t p) (cairo-surface-destroy p)] [(ftype-pointer? cairo-pattern-t p) (cairo-pattern-destroy p)] [(ftype-pointer? cairo-region-t p) (cairo-region-destroy p)] [(ftype-pointer? cairo-rectangle-list-t p) (cairo-rectangle-list-destroy p)] [(ftype-pointer? cairo-font-options-t p) (cairo-font-options-destroy p)] [(ftype-pointer? cairo-font-face-t p) (cairo-font-face-destroy p)] ;[(ftype-pointer? cairo-scaled-font-t p) (cairo-scaled-font-destroy p)] [(ftype-pointer? cairo-path-t p) (cairo-path-destroy p)] [(ftype-pointer? cairo-device-t p) (cairo-device-destroy p)] [else (foreign-free (ftype-pointer-address p))] )) (loop (cairo-guardian))))) |
Changes to cairo/ffi-utils.ss.
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
(symbol->string (syntax->datum x)))
(define (string->datum t x)
(datum->syntax t (string->symbol x)))
(syntax-case x ()
[(_ ret-type name ((arg-name arg-type) ...) c-name)
(with-syntax ([(renamed-type ...) (map rename-scheme->c #'(arg-type ...))]
[renamed-ret (rename-scheme->c #'ret-type)]
[function-ftype (datum->syntax #'name (string->symbol (string-append (symbol->string (syntax->datum #'name)) "-ft")))]
[((arg-name arg-convert) ...) (map (lambda (n t)
(list n (convert-scheme->c #'name n t)))
#'(arg-name ...) #'(arg-type ...))])
(begin
; (indirect-export cairo-guard-pointer)
#`(begin
(define (name arg-name ...)
(define-ftype function-ftype (function (renamed-type ...) renamed-ret))
(let* ([function-fptr (make-ftype-pointer function-ftype c-name)]
[function (ftype-ref function-ftype () function-fptr)]
[arg-name arg-convert] ...)
(let ([result (function arg-name ...)])
#,(case (syntax->datum #'ret-type)
[(cairo-status-t) #'(cairo-status-enum-ref result)]
[((* cairo-t) (* cairo-surface-t) (* cairo-pattern-t)
(* cairo-region-t) (* cairo-rectangle-list-t) (* cairo-font-options-t)
(* cairo-font-face-t) (* cairo-scaled-font-t) (* cairo-path-t)
(* cairo-device-t))
#'(cairo-guard-pointer result)]
[else #'result])))))))])))
(define-syntax define-ftype-allocator
(lambda (x)
(syntax-case x ()
[(_ name type)
(begin
; (indirect-export cairo-guard-pointer)
|
> | | | | > | | | | | | | | | | > | > | | > | > > | > > | > | | | |
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
(symbol->string (syntax->datum x)))
(define (string->datum t x)
(datum->syntax t (string->symbol x)))
(syntax-case x ()
[(_ ret-type name ((arg-name arg-type) ...) c-name)
(with-syntax
([(renamed-type ...) (map rename-scheme->c #'(arg-type ...))]
[renamed-ret (rename-scheme->c #'ret-type)]
[function-ftype (datum->syntax #'name (string->symbol (string-append (symbol->string (syntax->datum #'name)) "-ft")))]
[((arg-name arg-convert) ...)
(map (lambda (n t)
(list n (convert-scheme->c #'name n t)))
#'(arg-name ...) #'(arg-type ...))])
(begin
; (indirect-export cairo-guard-pointer)
#`(begin
(define (name arg-name ...)
(define-ftype function-ftype (function (renamed-type ...) renamed-ret))
(let* ([function-fptr (make-ftype-pointer function-ftype c-name)]
[function (ftype-ref function-ftype () function-fptr)]
[arg-name arg-convert] ...)
(printf "calling ffi ~d ~n" c-name)
(let ([result (function arg-name ...)])
#,(case (syntax->datum #'ret-type)
[(cairo-status-t) #'(cairo-status-enum-ref result)]
[((* cairo-t)
(* cairo-surface-t)
(* cairo-pattern-t)
(* cairo-region-t)
(* cairo-rectangle-list-t)
(* cairo-font-options-t)
(* cairo-font-face-t)
(* cairo-scaled-font-t)
(* cairo-path-t)
(* cairo-device-t))
#'(cairo-guard-pointer result)]
[else #'result])))))))])))
(define-syntax define-ftype-allocator
(lambda (x)
(syntax-case x ()
[(_ name type)
(begin
; (indirect-export cairo-guard-pointer)
|