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

fixed a bug in the way old 2htdp/image files were parsed (those that contain bitmaps)

Browse Source 
original commit: 7ef1e8bd907b5f18f563848346628da0dcd2406f
This commit is contained in:
Robby Findler 2010-10-28 14:16:08 -05:00
parent b78887e5a9
commit 6b991a5f60
2 changed files with 30 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mrlib/image-core.rkt
View File

@ -353,12 +353,26 @@ has been moved out).
;; bitmaps are vectors with a bytes in the first field
(apply bytes->bitmap (vector->list sexp))]
[else
(let ([constructor (id->constructor (vector-ref sexp 0))]
[args (cdr (vector->list sexp))])
(if (and constructor
(procedure-arity-includes? constructor (length args)))
(apply constructor (map loop args))
(k #f)))]))]
(let* ([tag (vector-ref sexp 0)]
[args (cdr (vector->list sexp))]
[constructor (id->constructor tag)]
[arg-count (length args)]
[parsed-args (map loop args)])
(cond
[(and constructor (procedure-arity-includes? constructor arg-count))
(apply constructor parsed-args)]
[(and (eq? tag 'struct:bitmap)
(= arg-count 7))
;; we changed the arity of the bitmap constructor from old versions,
;; so fix it up here.
(make-bitmap (list-ref parsed-args 0)
(list-ref parsed-args 1)
(list-ref parsed-args 2)
(list-ref parsed-args 3)
(list-ref parsed-args 4)
(make-hash))]
[else
(k #f)]))]))]
[else sexp]))))
(define (normalized-shape? s)

27
collects/mrlib/private/regmk.rkt
View File

@ -4,8 +4,8 @@
(struct-out point)
(struct-out bb))
(define-for-syntax id-constructor-pairs '())
(define-for-syntax (add-id-constructor-pair a b)
(define id-constructor-pairs '())
(define (add-id-constructor-pair a b)
(set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
(define-syntax (define-struct/reg-mk stx)
@ -14,22 +14,15 @@
(let ([build-name
(λ (fmt)
(datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
(add-id-constructor-pair (build-name "struct:~a")
(build-name "make-~a"))
#'(define-struct id . rest))]))
#`(begin
(define-struct id . rest)
(add-id-constructor-pair '#,(build-name "struct:~a")
#,(build-name "make-~a"))))]))
(define-syntax (define-id->constructor stx)
(syntax-case stx ()
[(_ fn)
#`(define (fn x)
(case x
#,@(map (λ (x)
(with-syntax ([(struct: maker) x])
#`[(struct:) maker]))
id-constructor-pairs)
[else #f]))]))
(define-id->constructor id->constructor)
(define (id->constructor id)
(let ([line (assoc id id-constructor-pairs)])
(and line
(list-ref line 1))))
(define-struct/reg-mk point (x y) #:transparent)