From 08d469893480648263ed359b0aa5e9b5c3f28805 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 20 May 2020 10:46:57 -0600
Subject: [PATCH] cs-bootstrap: additions to work on latest Chez Scheme

---
 racket/src/cs/bootstrap/make-boot.rkt   | 35 ++++++++++++++++++-------
 racket/src/cs/bootstrap/r6rs-lang.rkt   | 10 +++++++
 racket/src/cs/bootstrap/scheme-lang.rkt |  2 ++
 3 files changed, 38 insertions(+), 9 deletions(-)

diff --git a/racket/src/cs/bootstrap/make-boot.rkt b/racket/src/cs/bootstrap/make-boot.rkt
index 5bad66adf5..9038803fbd 100644
--- a/racket/src/cs/bootstrap/make-boot.rkt
+++ b/racket/src/cs/bootstrap/make-boot.rkt
@@ -192,10 +192,15 @@
      (call-with-expressions
       (build-path scheme-dir "s/syntax.ss")
       (lambda (e)
-        (when (and (pair? e)
-                   (eq? 'define-syntax (car e)))
-          ((current-expand) `(define-syntax ,(cadr e)
-                               ',(orig-eval (caddr e)))))))
+        (let loop ([e e])
+          (cond
+            [(and (pair? e)
+                  (eq? 'define-syntax (car e)))
+             ((current-expand) `(define-syntax ,(cadr e)
+                                  ',(orig-eval (caddr e))))]
+            [(and (pair? e)
+                  (eq? 'begin (car e)))
+             (for-each loop  (cdr e))]))))
      (status "Install evaluator")
      (current-eval
       (let ([e (current-eval)])
@@ -280,6 +285,8 @@
        (match e
          [`(let () ,es ...)
           (for-each loop es)]
+         [`(begin ,es ...)
+          (for-each loop es)]
          [`(define-syntax ,id . ,_)
           (when (want-syntax? id)
             (eval e))]
@@ -296,6 +303,8 @@
        (match e
          [`(let () ,es ...)
           (for-each loop es)]
+         [`(begin ,es ...)
+          (for-each loop es)]
          [`(set-who! $fasl-strip-options . ,_)
           (eval e)]
          [`(set-who! $make-fasl-strip-options . ,_)
@@ -308,6 +317,10 @@
    (lambda (e)
      (let loop ([e e])
        (match e
+         [`(let () ,es ...)
+          (for-each loop es)]
+         [`(begin ,es ...)
+          (for-each loop es)]
          [`(define $format-scheme-version . ,_)
           (eval e)]
          [`(define ($compiled-file-header? . ,_) . ,_)
@@ -319,14 +332,16 @@
    (build-path scheme-dir "s/front.ss")
    (lambda (e)
      ;; Skip `package-stubs`, which would undo "syntax.ss" definitions
-     (match e
-       [`(package-stubs . ,_) (void)]
-       [`(define-who make-parameter . ,_) (void)]
-       [_ (eval e)])))
+     (let loop ([e e])
+       (match e
+         [`(package-stubs . ,_) (void)]
+         [`(define-who make-parameter . ,_) (void)]
+         [`(begin . ,es) (for-each loop es)]
+         [_ (eval e)]))))
   ((orig-eval 'current-eval) eval)
   ((orig-eval 'current-expand) (current-expand))
   ((orig-eval 'enable-type-recovery) #f)
-
+  
   (status "Define $filter-foreign-type")
   (eval `(define $filter-foreign-type
            (lambda (ty)
@@ -376,6 +391,8 @@
     (status (format "Load ~a" s))
     (load-ss (build-path scheme-dir "s" s)))
 
+  ((orig-eval 'fasl-compressed) #f)
+
   (let ([failed? #f])
     (for ([src (append petite-sources scheme-sources)])
       (let ([dest (path->string (path->complete-path (build-path out-subdir (path-replace-suffix src #".so"))))])
diff --git a/racket/src/cs/bootstrap/r6rs-lang.rkt b/racket/src/cs/bootstrap/r6rs-lang.rkt
index 9562d4fceb..99abf533e7 100644
--- a/racket/src/cs/bootstrap/r6rs-lang.rkt
+++ b/racket/src/cs/bootstrap/r6rs-lang.rkt
@@ -135,6 +135,8 @@
          fixnum-width
          set-car!
          set-cdr!
+         bytevector-copy!
+         call-with-bytevector-output-port
          make-compile-time-value
          optimize-level)
 
@@ -772,6 +774,14 @@
             (define (set-cdr! p v) (unsafe-set-mcdr! p v)))])]))
 (define-mutable-pair-hacks set-car! set-cdr!)
 
+(define (bytevector-copy! src src-start dst dst-start n)
+  (bytes-copy! dst dst-start src src-start (+ src-start n)))
+
+(define (call-with-bytevector-output-port proc)
+  (define o (open-output-bytes))
+  (proc o)
+  (get-output-bytes o))
+
 (define (fixnum-width) (or fixnum-bits 63))
 
 (define low-fixnum (- (expt 2 (sub1 (fixnum-width)))))
diff --git a/racket/src/cs/bootstrap/scheme-lang.rkt b/racket/src/cs/bootstrap/scheme-lang.rkt
index c5faa73a0c..5d372c4d43 100644
--- a/racket/src/cs/bootstrap/scheme-lang.rkt
+++ b/racket/src/cs/bootstrap/scheme-lang.rkt
@@ -267,6 +267,7 @@
          enable-cross-library-optimization
          enable-arithmetic-left-associative
          enable-type-recovery
+         fasl-compressed
          current-expand
          current-generate-id
          internal-defines-as-letrec*
@@ -1079,6 +1080,7 @@
 (define enable-cross-library-optimization (make-parameter #t))
 (define enable-arithmetic-left-associative (make-parameter #f))
 (define enable-type-recovery (make-parameter #t))
+(define fasl-compressed (make-parameter #f))
 
 (define current-generate-id (make-parameter gensym))