From 6b991a5f606197315943a85cca8520cfa55d7fc8 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 28 Oct 2010 14:16:08 -0500
Subject: [PATCH] fixed a bug in the way old 2htdp/image files were parsed
 (those that contain bitmaps)

original commit: 7ef1e8bd907b5f18f563848346628da0dcd2406f
---
 collects/mrlib/image-core.rkt    | 26 ++++++++++++++++++++------
 collects/mrlib/private/regmk.rkt | 27 ++++++++++-----------------
 2 files changed, 30 insertions(+), 23 deletions(-)

diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index 9dffb18b..117a1f65 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -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)
diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt
index 87a68f3b..171f0622 100644
--- a/collects/mrlib/private/regmk.rkt
+++ b/collects/mrlib/private/regmk.rkt
@@ -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)