1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
#lang racket/base
(require racket/gui/base
racket/class
racket/file
setup/main-collects)
(require (for-syntax racket/base
syntax/path-spec
compiler/cm-accomplice
setup/main-collects))
(provide include-bitmap
include-bitmap/relative-to)
(define-syntax (-include-bitmap stx)
(syntax-case stx ()
[(_ orig-stx source path-spec type)
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx)]
[content
(with-handlers ([exn:fail?
(lambda (exn)
(error 'include-bitmap
"could not load ~e: ~a"
c-file
(if (exn? exn)
(exn-message exn)
(format "~e" exn))))])
(with-input-from-file c-file
(lambda ()
(read-bytes (file-size c-file)))))])
(register-external-file c-file)
(with-syntax ([content content]
[c-file (path->main-collects-relative c-file)])
(syntax/loc stx
(get-or-load-bitmap content 'path-spec type))))]))
(define-syntax (include-bitmap/relative-to stx)
(syntax-case stx ()
[(_ source path-spec) #`(-include-bitmap #,stx source path-spec 'unknown/mask)]
[(_ source path-spec type) #`(-include-bitmap #,stx source path-spec type)]))
(define-syntax (include-bitmap stx)
(syntax-case stx ()
[(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec 'unknown/mask)]
[(_ path-spec type) #`(-include-bitmap #,stx #,stx path-spec type)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Run-time support
(define cached (make-hash))
(define (get-or-load-bitmap content orig type)
(hash-ref cached
(cons content type)
(λ ()
(define-values (in out) (make-pipe))
(thread
(λ ()
(display content out)
(close-output-port out)))
(define bm (make-object bitmap% in type))
(unless (send bm ok?)
(error 'include-bitmap
"unable to parse image, originated from: ~a"
(path->string (main-collects-relative->path orig))))
(hash-set! cached (cons content type) bm)
bm)))
|
