suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 4108bba7c76d2141cdb4217e90faec2393e44f52
This commit is contained in:
Matthew Flatt 2003-03-07 17:04:28 +00:00
parent 7d8fbcc934
commit 68bb9652e4
1 changed files with 32 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
collects/mrlib/bitmap-constant.ss
View File

@ -2,79 +2,42 @@
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "file.ss"))
(require-for-syntax (lib "stx.ss" "syntax"))
(require-for-syntax (lib "path-spec.ss" "syntax"))
(provide bitmap-constant)
(provide bitmap-constant
bitmap-constant/relative-to)
(define-syntax (-bitmap-constant stx)
(syntax-case stx ()
[(_ orig-stx source path-spec)
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx #'build-path)]
[content
(with-handlers ([not-break-exn?
(lambda (exn)
(error 'bitmap-constant
"could not load ~e: ~a"
c-file
(if (exn? exn)
(exn-message exn)
(format "~e" exn))))])
(with-input-from-file c-file
(lambda ()
(read-string (file-size c-file)))))])
(with-syntax ([content content]
[c-file c-file])
(syntax/loc stx
(get-or-load-bitmap-constant content c-file))))]))
(define-syntax (bitmap-constant/relative-to stx)
(syntax-case stx ()
[(_ source path-spec) #`(-bitmap-constant #,stx source path-spec)]))
(define-syntax (bitmap-constant stx)
(syntax-case stx ()
[(_ floc)
(let* ([loc #'floc]
[file
(syntax-case* loc (lib build-path) module-or-top-identifier=?
[_
(and (string? (syntax-e loc))
(or (relative-path? (syntax-e loc))
(absolute-path? (syntax-e loc))))
(syntax-e loc)]
[(build-path elem1 elem ...)
(apply build-path (syntax-object->datum (syntax (elem1 elem ...))))]
[(lib filename coll ...)
(let ([l (syntax-object->datum (syntax (filename coll ...)))])
(unless (andmap string? l)
(raise-syntax-error
#f
"`lib' keyword is not followed by a sequence of string datums"
stx
loc))
(build-path (if (null? (cdr l))
(collection-path "mzlib")
(apply collection-path (cdr l)))
(car l)))]
[else
(raise-syntax-error
#f
"not a pathname string, `build-path' form, or `lib' form for file"
stx
loc)])]
[c-file
(if (complete-path? file)
file
(path->complete-path
file
(cond
;; Src of include expression is a path?
[(and (string? (syntax-source loc))
(complete-path? (syntax-source loc)))
(let-values ([(base name dir?)
(split-path (syntax-source loc))])
(if dir?
(syntax-source loc)
base))]
;; Load relative?
[(current-load-relative-directory)]
;; Current directory
[(current-directory)]
[else (raise-syntax-error
#f
"can't determine a base path"
stx)])))])
(let ([content
(with-handlers ([not-break-exn?
(lambda (exn)
(error 'bitmap-constant
"could not load ~e: ~a"
c-file
(if (exn? exn)
(exn-message exn)
(format "~e" exn))))])
(with-input-from-file c-file
(lambda ()
(read-string (file-size c-file)))))])
(with-syntax ([content content]
[c-file c-file])
(syntax/loc stx
(get-or-load-bitmap-constant content c-file)))))]))
[(_ path-spec) #`(-bitmap-constant #,stx #,stx path-spec)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Run-time support
(define cached (make-hash-table 'equal))