using version-case to insulate against bytecode changes

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.

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"

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))])

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"

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

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)

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")
 

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)]))

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)))