From 1af88b30a8a953b704573ca65c0f892e6234abd0 Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Fri, 20 May 2011 10:39:39 -0400
Subject: [PATCH] using version-case to insulate against bytecode changes

---
 README                                        |   2 +-
 package.rkt                                   |   2 +-
 parse-bytecode.rkt                            |  11 ++
 test-all.rkt                                  |   2 +-
 test-get-dependencies.rkt                     |   2 +-
 test-helpers.rkt                              |   2 +-
 ...ecode-5.1.1.rkt => test-parse-bytecode.rkt |   2 +-
 version-case/version-case.rkt                 |  45 ++++++++
 version-case/version-misc.rkt                 | 101 ++++++++++++++++++
 9 files changed, 163 insertions(+), 6 deletions(-)
 create mode 100644 parse-bytecode.rkt
 rename test-parse-bytecode-5.1.1.rkt => test-parse-bytecode.rkt (99%)
 create mode 100644 version-case/version-case.rkt
 create mode 100644 version-case/version-misc.rkt

diff --git a/README b/README
index c0cca3f..f4aa445 100644
--- a/README
+++ b/README
@@ -45,7 +45,7 @@ controlled environment.
 
 ======================================================================
 
-parse-bytecode-5.1.1.rkt
+parse-bytecode.rkt
 
 This is intended to reuse the Racket compiler to produce the AST
 structures defined in compiler/zo-parse.
diff --git a/package.rkt b/package.rkt
index f1f276b..db581e0 100644
--- a/package.rkt
+++ b/package.rkt
@@ -3,7 +3,7 @@
 (require "compiler.rkt"
          "compiler-structs.rkt"
          "js-assembler/assemble.rkt"
-	 "parse-bytecode-5.1.1.rkt"
+	 "parse-bytecode.rkt"
 	 "language-namespace.rkt"
          "il-structs.rkt"
          "bootstrapped-primitives.rkt"
diff --git a/parse-bytecode.rkt b/parse-bytecode.rkt
new file mode 100644
index 0000000..6095f07
--- /dev/null
+++ b/parse-bytecode.rkt
@@ -0,0 +1,11 @@
+#lang racket/base
+(require "version-case/version-case.rkt"
+         (for-syntax racket/base))
+
+(version-case
+  [(version>= (version) "5.1.1")
+   (begin      
+     (require "parse-bytecode-5.1.1.rkt")
+     (provide parse-bytecode))]
+  [else
+   (error 'parse-bytecode "Currently no compatible parser for Racket ~a" (version))])
\ No newline at end of file
diff --git a/test-all.rkt b/test-all.rkt
index fb49948..fd3e6a8 100644
--- a/test-all.rkt
+++ b/test-all.rkt
@@ -1,7 +1,7 @@
 #lang racket
 
 (require "test-parse.rkt"
-         "test-parse-bytecode-5.1.1.rkt"
+         "test-parse-bytecode.rkt"
          "test-simulator.rkt"
          "test-compiler.rkt"
          "test-compiler-2.rkt"
diff --git a/test-get-dependencies.rkt b/test-get-dependencies.rkt
index 5f2d460..1101422 100644
--- a/test-get-dependencies.rkt
+++ b/test-get-dependencies.rkt
@@ -1,7 +1,7 @@
 #lang racket
 (require "get-dependencies.rkt"
          "get-module-bytecode.rkt"
-         "parse-bytecode-5.1.1.rkt"
+         "parse-bytecode.rkt"
          "lexical-structs.rkt"
          racket/path
          racket/runtime-path
diff --git a/test-helpers.rkt b/test-helpers.rkt
index 13c452b..10b7dc8 100644
--- a/test-helpers.rkt
+++ b/test-helpers.rkt
@@ -4,7 +4,7 @@
          racket/runtime-path
          "compiler-structs.rkt"
          "compiler.rkt"
-         "parse-bytecode-5.1.1.rkt"
+         "parse-bytecode.rkt"
          "get-module-bytecode.rkt"
          "language-namespace.rkt"
          syntax/modcode)
diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode.rkt
similarity index 99%
rename from test-parse-bytecode-5.1.1.rkt
rename to test-parse-bytecode.rkt
index 797d604..68bbf9c 100644
--- a/test-parse-bytecode-5.1.1.rkt
+++ b/test-parse-bytecode.rkt
@@ -5,7 +5,7 @@
          racket/match
          (for-syntax racket/base)
          "parameters.rkt"
-         "parse-bytecode-5.1.1.rkt"
+         "parse-bytecode.rkt"
          "lexical-structs.rkt"
          "expression-structs.rkt")
 
diff --git a/version-case/version-case.rkt b/version-case/version-case.rkt
new file mode 100644
index 0000000..c340cea
--- /dev/null
+++ b/version-case/version-case.rkt
@@ -0,0 +1,45 @@
+#lang racket/base
+
+(require (for-syntax racket/base)
+         (for-syntax racket/bool)
+         (for-syntax "version-misc.rkt"))
+
+
+(provide (for-syntax (all-from-out "version-misc.rkt")))
+(provide version-case)
+
+
+(define-for-syntax usage-message "Usage: (version-case [test code] ... [else ...]))")
+
+(define-syntax (version-case stx)
+  (syntax-case stx (else)
+    [(_ [test code ...] ... [-else last-code ...])
+     (and (not (null? (syntax->list (syntax ((test code ...) ...)))))
+          (identifier? #'-else)
+          (symbol=? (syntax-e #'-else) 'else))
+     (with-syntax ([name (syntax/loc stx the-macro)]
+                   [transformer
+                    (syntax/loc stx
+                      (lambda (stx*)
+                        (cond [test
+                               (syntax-local-introduce
+                                (quote-syntax (begin code ...)))]
+                              ...
+                              [else 
+                               (syntax-local-introduce
+                                (quote-syntax (begin last-code ...)))])))])
+       (case (syntax-local-context)
+         [(expression)
+          (syntax/loc stx
+            (let-syntax ([name transformer])
+              (name)))]
+         [else
+          (syntax/loc stx
+            (begin
+              (define-syntax name transformer)
+              (name)))]))]
+    [else
+     (raise-syntax-error 
+      #f 
+      usage-message
+      stx)]))
\ No newline at end of file
diff --git a/version-case/version-misc.rkt b/version-case/version-misc.rkt
new file mode 100644
index 0000000..8f1e190
--- /dev/null
+++ b/version-case/version-misc.rkt
@@ -0,0 +1,101 @@
+#lang racket/base
+(require racket/string
+         racket/list
+         racket/contract
+         (prefix-in 67: srfi/67)
+         (prefix-in 1: srfi/1))
+
+(provide/contract [version<= (string? string? . -> . boolean?)]
+                  [version< (string? string? . -> . boolean?)]
+                  [version= (string? string? . -> . boolean?)]
+                  [version>= (string? string? . -> . boolean?)]
+                  [version> (string? string? . -> . boolean?)])
+
+
+;; The definitions of mz-version, string->version, and
+;; version<= were adapted (copied and pasted) from PLaneT's
+;; implementation in (planet/private/planet-shared.ss).
+
+(define-struct mz-version (numbers) #:transparent)
+
+;; string->version : string -> mz-version | #f
+(define (string->version str)
+  (cond
+   ;; Old style numbering (with three digits in front)
+   [(regexp-match #rx"^([0-9][0-9][0-9])([.0-9]*)$" str)
+    =>
+    (lambda (ver)
+      (let* ([major (string->number (list-ref ver 1))]
+             [after-major
+              (map string->number
+                   (rest (regexp-split "\\." (list-ref ver 2))))]
+             [minor (if (>= (length after-major) 1)
+                        (first after-major)
+                        0)]
+             [maintenances (my-drop after-major 1)])
+        (make-mz-version (list*
+                          (remainder (quotient major 100) 10)
+                          (remainder (quotient major 10) 10)
+                          (remainder major 10)
+                          minor
+                          maintenances))))]
+   ;; New style numbering
+   [(regexp-match #rx"^([.0-9]*)$" str)
+    =>
+    (lambda (ver)
+      (let* ([numbers (regexp-split "\\." (list-ref ver 1))])
+        (make-mz-version (map string->number numbers))))]
+   [else #f]))
+
+
+;; drop: (listof X) number -> (listof X)
+;; A more permissive version of drop that returns the empty list
+;; if we try to take off too many elements.
+(define (my-drop a-list n)
+  (1:drop a-list (min n (length a-list))))
+
+
+
+;; version-cmp: mz-version mz-version -> (union -1 0 1)
+;; Returns -1 if v1 < v2, 0 if v1 = v2, and 1 if v1 > v2.
+(define (version-cmp v1 v2)
+  (67:list-compare 67:integer-compare
+                   (mz-version-numbers v1)
+                   (mz-version-numbers v2)))
+
+
+;; version<= : string string -> boolean
+;; determines if a is the version string of an earlier
+;; mzscheme release than b
+;; [n.b. this relies on a guarantee from Matthew that
+;; mzscheme version x1.y1 is older than version x2.y2 iff
+;;  x1<x2 or x1=x2 and y1<y2]
+(define (version<= a b)
+  (let ([a (string->version a)]
+        [b (string->version b)])
+    (not (= (version-cmp a b)
+            1))))
+
+(define (version>= a b)
+  (let ([a (string->version a)]
+        [b (string->version b)])
+    (not (= (version-cmp a b)
+            -1))))
+
+(define (version= a b)
+  (let ([a (string->version a)]
+        [b (string->version b)])
+    (= (version-cmp a b)
+       0)))
+
+(define (version< a b)
+  (let ([a (string->version a)]
+        [b (string->version b)])
+    (= (version-cmp a b)
+       -1)))
+
+(define (version> a b)
+  (let ([a (string->version a)]
+        [b (string->version b)])
+    (= (version-cmp a b)
+       1)))
\ No newline at end of file