69 lines
2.1 KiB
Racket
69 lines
2.1 KiB
Racket
(module include-bitmap mzscheme
|
|
(require mred
|
|
mzlib/class
|
|
mzlib/file
|
|
setup/main-collects)
|
|
(require-for-syntax 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 'c-file 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-table 'equal))
|
|
|
|
(define (get-or-load-bitmap content orig type)
|
|
(hash-table-get cached (cons content type)
|
|
(lambda ()
|
|
(let ([bm (let ([fn (make-temporary-file)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(with-output-to-file fn
|
|
(lambda () (display content))
|
|
'truncate)
|
|
(make-object bitmap% fn type))
|
|
(lambda ()
|
|
(delete-file fn))))])
|
|
(unless (send bm ok?)
|
|
(error 'include-bitmap
|
|
"unable to parse image, originated from: ~a"
|
|
(path->string (main-collects-relative->path orig))))
|
|
(hash-table-put! cached (cons content type) bm)
|
|
bm)))))
|