From 4e07c20afef9a5c5ba5736232a9a4076bc57b43d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 13 Sep 2019 07:29:23 -0600 Subject: [PATCH] cs: improve Chez Scheme version check Use the new `scheme-fork-version-number` function to make sure the build uses the latest. --- pkgs/base/info.rkt | 2 +- racket/src/cs/bootstrap/constant.rkt | 3 +- racket/src/cs/bootstrap/scheme-lang.rkt | 18 ++++++- racket/src/cs/compile-file.ss | 70 +++++-------------------- racket/src/racket/src/schvers.h | 2 +- 5 files changed, 35 insertions(+), 60 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 6e6740c7e9..fbe980fcdd 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.4.0.8") +(define version "7.4.0.9") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/racket/src/cs/bootstrap/constant.rkt b/racket/src/cs/bootstrap/constant.rkt index 566d0cdd6f..83028d527c 100644 --- a/racket/src/cs/bootstrap/constant.rkt +++ b/racket/src/cs/bootstrap/constant.rkt @@ -57,7 +57,8 @@ prelex-is-flags-offset prelex-was-flags-offset prelex-sticky-mask - prelex-is-mask) + prelex-is-mask + scheme-version) (provide record-ptr-offset) (define record-ptr-offset 1) diff --git a/racket/src/cs/bootstrap/scheme-lang.rkt b/racket/src/cs/bootstrap/scheme-lang.rkt index 80ca4dadc9..e13dab9c55 100644 --- a/racket/src/cs/bootstrap/scheme-lang.rkt +++ b/racket/src/cs/bootstrap/scheme-lang.rkt @@ -99,6 +99,7 @@ $suppress-primitive-inlining debug-level scheme-version-number + scheme-fork-version-number (rename-out [make-parameter $make-thread-parameter] [make-parameter make-thread-parameter] [cons make-binding] @@ -845,7 +846,22 @@ (define $suppress-primitive-inlining (make-parameter #f)) (define debug-level (make-parameter 0)) -(define (scheme-version-number) (values 9 5 3)) +(define (scheme-version-number) + (define v (lookup-constant 'scheme-version)) + (if (zero? (arithmetic-shift v -24)) + (values (arithmetic-shift v -16) + (bitwise-and 255 (arithmetic-shift v -8)) + (bitwise-and 255 v)) + (values (arithmetic-shift v -24) + (bitwise-and 255 (arithmetic-shift v -16)) + (bitwise-and 255 (arithmetic-shift v -8))))) + +(define (scheme-fork-version-number) + (define v (lookup-constant 'scheme-version)) + (define-values (maj min sub) (scheme-version-number)) + (if (zero? (arithmetic-shift v -24)) + (values maj min sub 0) + (values maj min sub (bitwise-and 255 v)))) (define (make-hashtable hash eql?) (cond diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 5b6b74cb35..d53a53d17b 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -1,65 +1,23 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. +(define-values (need-maj need-min need-sub need-dev) + (values 9 5 3 1)) -(let-values ([(maj min sub) (scheme-version-number)]) - (unless (or (> maj 9) - (and (= maj 9) - (or (> min 5) - (and (= min 5) - (>= sub 3))))) +(unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) + (error 'compile-file + (error 'compile-file "need the Racket fork of Chez Scheme to build"))) + +(let-values ([(maj min sub dev) (scheme-fork-version-number)]) + (unless (or (> maj need-maj) + (and (= maj need-maj) + (or (> min need-min) + (and (= min need-min) + (or (>= sub need-sub) + (and (= sub need-sub) + (>= dev need-dev))))))) (error 'compile-file "need a newer Chez Scheme"))) -(define (check-ok what thunk) - (unless (guard (x [else #f]) (thunk)) - (error 'compile-file - (format - "failed trying `~a`; probably you need a newer Chez Scheme" - what)))) - -(define (check-defined expr) - (check-ok expr (lambda () (eval expr)))) - -(check-defined 'box-cas!) -(check-defined 'make-arity-wrapper-procedure) -(check-defined 'generate-procedure-source-information) -(check-defined 'object-backreferences) -(check-defined 'current-generate-id) -(check-defined 'load-compiled-from-port) -(check-defined 'collect-rendezvous) -(check-defined '(define-ftype T (function __collect_safe () void))) -(check-defined 'call-setting-continuation-attachment) -(check-defined 'hashtable-cells) -(check-ok "fxvector-set!" - (lambda () - (parameterize ([optimize-level 3] - [run-cp0 (lambda (cp0 x) x)]) - - (eval '(define (op x) - (if (fx- 0) 0 0))) - (eval '(define (f x) - (fxvector-set! x 0 (op 0)))) - (eval '(f (fxvector 0)))))) -(check-defined 'vfasl-convert-file) -(check-defined 'compute-size-increments) -(check-defined 'enable-type-recovery) -(check-defined 'make-wrapper-procedure) -(check-defined 'make-phantom-bytevector) -(check-defined 'enable-arithmetic-left-associative) -(check-ok "eq? on flonums" - (lambda () - (let* ([n (string->number "3.14")] - [v (vector n n)]) - (collect 0) - (unless (eq? (vector-ref v 0) (vector-ref v 1)) - (error 'eq-on-flonum "no"))))) -(check-defined 'procedure-known-single-valued?) -(check-defined 'compress-format) -(check-defined '#%$record-cas!) -(check-defined 'eq-hashtable-try-atomic-cell) -(check-defined 'hashtable-ref-cell) -(check-defined 'call-consuming-continuation-attachment) - ;; ---------------------------------------- (current-make-source-object diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 0ca505036c..b88be9570d 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 8 +#define MZSCHEME_VERSION_W 9 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x