remove "cs-bootstrap" package

The "cs-bootstrap" package is now in the `racket/ChezScheme` repo,
because it needs to track the Chez Scheme implementation instead of
the Racket implementation.

Makefile

@@ -705,7 +705,7 @@ PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata -
 PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt
 
 pkgs-catalog:
-	$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander racket/src/cs/bootstrap
+	$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander
 	$(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)"
 	$(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog
 

racket/src/cs/bootstrap/Makefile

@@ -1,6 +0,0 @@
-RACKET=racket
-
-SCHEME_SRC=../../build/ChezScheme
-
-boot:
-	env SCHEME_SRC="$(SCHEME_SRC)" $(RACKET) make-boot.rkt

racket/src/cs/bootstrap/README.txt

@@ -1,19 +0,0 @@
-This directory constains enough of a Chez Scheme simulation to load
-the Chez Scheme compiler purely from source into Racket and apply the
-compiler to itself, thus bootstrapping Chez Scheme. (So, using an
-existing Racket build, but without using an existing Chez Scheme
-build.)
-
-The "make-boot.rkt" programs builds Chez Scheme ".boot" and ".h" files
-from source. The output is written to "<machine>/boot/<machine>" in a
-Chez Scheme source directory. Build boot files that way before
-`configure` and `make` to bootstrap the build.
-
-The Chez Scheme simulation hasn't been made especially fast, so expect
-the bootstrap process to take 5-10 times as long as using an existing
-Chez Scheme.
-
-While the similation of Chez Scheme should be robust to common Chez
-Scheme changes, it does rely on details of the Chez Scheme
-implementation and source, So, the simulation will have to be updated
-to accommodate some Chez Scheme changes.

racket/src/cs/bootstrap/config.rkt

@@ -1,34 +0,0 @@
-#lang racket/base
-(require ffi/unsafe/global)
-
-(provide scheme-dir
-         target-machine
-         optimize-level-init)
-
-(define ht (get-place-table))
-
-(define scheme-dir (or (hash-ref ht 'make-boot-scheme-dir #f)
-                       (let ([scheme-dir
-                              (getenv "SCHEME_SRC")])
-                         (and scheme-dir
-                              (simplify-path
-                               (path->complete-path scheme-dir))))))
-(hash-set! ht 'make-boot-scheme-dir scheme-dir)
-
-(define target-machine (or (hash-ref ht 'make-boot-targate-machine #f)
-                           (getenv "MACH")
-                           (case (system-type)
-                             [(macosx) (if (eqv? 64 (system-type 'word))
-                                           "ta6osx"
-                                           "ti3osx")]
-                             [(windows) (if (eqv? 64 (system-type 'word))
-                                           "ta6nt"
-                                           "ti3nt")]
-                             [else
-                              (case (path->string (system-library-subpath #f))
-                                [("x86_64-linux") "ta6le"]
-                                [("i386-linux") "ti3le"]
-                                [else #f])])))
-(hash-set! ht 'make-boot-targate-machine target-machine)
-
-(define optimize-level-init 3)

racket/src/cs/bootstrap/constant.rkt

@@ -1,92 +0,0 @@
-#lang racket/base
-(require racket/match
-         "scheme-readtable.rkt"
-         "config.rkt")
-
-;; Extract constants that we need to get started by reading
-;; "cmacros.ss" and the machine ".def" file (without trying to run or
-;; expand the files)
-
-(define ht (make-hasheq))
-
-(define (read-constants i)
-  (parameterize ([current-readtable scheme-readtable])
-    (let loop ()
-      (define e (read i))
-      (unless (eof-object? e)
-        (match e
-          [`(define-constant ,id2 (case (constant ,id1)
-                                    [(,v1) ,rv1]
-                                    [(,v2) ,rv2]
-                                    . ,_))
-           (define v (hash-ref ht id1))
-           (hash-set! ht id2
-                      (cond
-                        [(eqv? v v1) rv1]
-                        [(eqv? v v2) rv2]
-                        [else (error "unknown")]))]
-          [`(define-constant ,id ,e)
-           (let/cc esc
-             (hash-set! ht id (constant-eval e esc)))]
-          [`(define-constant-default ,id ,e)
-           (hash-ref ht id
-                     (lambda ()
-                       (let/cc esc
-                         (hash-set! ht id (constant-eval e esc)))))]
-          [`(include ,fn)
-           (unless (equal? fn "machine.def")
-             (read-constants-from-file fn))]
-          [_ (void)])
-        (loop)))))
-
-(define (constant-eval e esc)
-  (cond
-    [(pair? e)
-     (case (car e)
-       [(if)
-        (if (constant-eval (cadr e) esc)
-            (constant-eval (caddr e) esc)
-            (constant-eval (cadddr e) esc))]
-       [(constant)
-        (hash-ref ht (cadr e) esc)]
-       [(=)
-        (= (constant-eval (cadr e) ht)
-           (constant-eval (caddr e) ht))]
-       [(quote)
-        (cadr e)]
-       [else (esc)])]
-    [else e]))
-
-(define (read-constants-from-file fn)
-  (call-with-input-file
-   (build-path scheme-dir "s" fn)
-   read-constants))
-
-(when scheme-dir
-  (read-constants-from-file
-   (string-append target-machine ".def"))
-  (read-constants-from-file "cmacros.ss"))
-
-(define-syntax-rule (define-constant id ...)
-  (begin
-    (provide id ...)
-    (define id (hash-ref ht 'id #f)) ...))
-
-(hash-set! ht 'ptr-bytes (/ (hash-ref ht 'ptr-bits 64) 8))
-
-(define-constant
-  ptr-bytes
-  fixnum-bits
-  max-float-alignment
-  annotation-debug
-  annotation-profile
-  visit-tag
-  revisit-tag
-  prelex-is-flags-offset
-  prelex-was-flags-offset
-  prelex-sticky-mask
-  prelex-is-mask
-  scheme-version)
-
-(provide record-ptr-offset)
-(define record-ptr-offset 1)

racket/src/cs/bootstrap/define-datatype.rkt

@@ -1,78 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base))
-
-(provide define-datatype)
-
-(define-syntax define-datatype
-  (lambda (stx)
-    (syntax-case stx ()
-      [(_ name (variant field ...) ...)
-       (identifier? #'name)
-       #'(define-datatype (name) (variant field ...) ...)]
-      [(_ (name base-field ...) (variant field ...) ...)
-       (let ([clean (lambda (l)
-                      (map (lambda (f)
-                             (syntax-case f ()
-                               [(_ id) #'id]
-                               [id #'id]))
-                           (syntax->list l)))])
-         (with-syntax ([(base-field ...) (clean #'(base-field ...))]
-                       [((field ...) ...) (map clean
-                                               (syntax->list #'((field ...) ...)))]
-                       [(name-variant ...) (for/list ([variant (in-list (syntax->list #'(variant ...)))])
-                                             (format-id variant "~a-~a" #'name variant))]
-                       [([set-name-base-field! name-base-field-set!] ...)
-                        (for/list ([base-field (in-list (syntax->list #'(base-field ...)))])
-                          (define field (syntax-case base-field ()
-                                          [(_ id) #'id]
-                                          [id #'id]))
-                          (list (format-id field "set-~a-~a!" #'name field)
-                                (format-id field "~a-~a-set!" #'name field)))]
-                       [name-case (format-id #'name "~a-case" #'name)])
-           #'(begin
-               (define-struct name (base-field ...) #:mutable)
-               (define name-base-field-set! set-name-base-field!) ...
-               (define-struct (name-variant name) (field ...))
-               ...
-               (define-syntax (name-case stx)
-                 (generate-case stx #'[(name base-field ...)
-                                       (variant field ...) ...])))))])))
-
-(define-for-syntax (generate-case stx spec)
-  (syntax-case spec ()
-    [[(name base-field ...) (variant field ...) ...]
-     (let ([variants (syntax->list #'(variant ...))]
-           [fieldss (syntax->list #'((field ...) ...))])
-       (syntax-case stx ()
-         [(_ expr clause ...)
-          (with-syntax ([([lhs rhs ...] ...)
-                         (for/list ([clause (in-list (syntax->list #'(clause ...)))])
-                           (syntax-case clause (else)
-                             [[else . _] clause]
-                             [[c-variant (c-field ...) rhs ...]
-                              (or (for/or ([variant (in-list variants)]
-                                           [fields (in-list fieldss)]
-                                           #:when (eq? (syntax-e #'c-variant) (syntax-e variant)))
-                                    (with-syntax ([variant? (format-id variant "~a-~a?" #'name variant)]
-                                                  [(field-ref ...) (for/list ([field (in-list (syntax->list fields))])
-                                                                     (format-id field "~a-~a-~a" #'name variant field))])
-                                      #`[(variant? v)
-                                     (let ([c-field (field-ref v)] ...)
-                                       rhs ...)]))
-                                  (raise-syntax-error #f
-                                                      "no matching variant"
-                                                      stx
-                                                      clause))]
-                             [_ (raise-syntax-error #f
-                                                    "unrecognized clause"
-                                                    stx
-                                                    clause)]))])
-            #'(let ([v expr])
-                (cond
-                  [lhs rhs ...] ...)))]))]))
-
-(define-for-syntax (format-id ctx fmt . args)
-  (datum->syntax
-   ctx
-   (string->symbol
-    (apply format fmt (map syntax-e args)))))

racket/src/cs/bootstrap/format.rkt

@@ -1,162 +0,0 @@
-#lang racket/base
-(require "gensym.rkt")
-
-(provide s:format
-         s:printf
-         s:fprintf
-         s:error)
-
-(define (s:format fmt . args)
-  (define o (open-output-string))
-  (do-printf o fmt args)
-  (get-output-string o))
-
-(define (s:printf fmt . args)
-  (do-printf (current-output-port) fmt args))
-  
-(define (s:fprintf o fmt . args)
-  (do-printf o fmt args))
-
-(define (s:error sym fmt . args)
-  (define o (open-output-string))
-  (do-printf o fmt args)
-  (error sym "~a" (get-output-string o)))
-  
-(define (do-printf o fmt args)
-  (cond
-    [(and (equal? fmt "~s")
-          (not (print-gensym))
-          (and (pair? args)
-               (gensym? (car args))))
-     (write-string (gensym->pretty-string (car args)) o)]
-    [(and (let loop ([i 0])
-            (cond
-              [(= i (string-length fmt))
-               #t]
-              [(and (char=? #\~ (string-ref fmt i))
-                    (< i (sub1 (string-length fmt))))
-               (define c (string-ref fmt (add1 i)))
-               (if (or (char=? c #\a)
-                       (char=? c #\s)
-                       (char=? c #\v)
-                       (char=? c #\e))
-                   (loop (+ i 2))
-                   #f)]
-              [else (loop (add1 i))]))
-          (or (null? args)
-              (not (bytes? (car args)))))
-     (apply fprintf o fmt args)]
-    [else
-     ;; implement additional format functionality
-     (let loop ([i 0] [args args] [mode '()])
-       (cond
-         [(= i (string-length fmt))
-          (unless (null? args) (error 'format "leftover args"))]
-         [(and (char=? #\~ (string-ref fmt i))
-               (< i (sub1 (string-length fmt))))
-          (define c (string-ref fmt (add1 i)))
-          (case c
-            [(#\a #\d)
-             (define v (car args))
-             (cond
-               [(and (gensym? v)
-                     (not (print-gensym)))
-                (display (gensym->pretty-string v) o)]
-               [(bytes? v)
-                (begin
-                   (write-bytes #"#vu8" o)
-                   (display (bytes->list v) o))]
-               [else
-                (display (if (memq 'upcase mode)
-                             (string-upcase v)
-                             v)
-                         o)])
-             (loop (+ i 2) (cdr args) mode)]
-            [(#\s #\v #\e)
-             (define v (car args))
-             (if (bytes? v)
-                 (begin
-                   (write-bytes #"#vu8" o)
-                   (display (bytes->list v) o))
-                 (write v o))
-             (loop (+ i 2) (cdr args) mode)]
-            [(#\x)
-             (display (string-upcase (number->string (car args) 16)) o)
-             (loop (+ i 2) (cdr args) mode)]
-            [(#\: #\@)
-             (case (string-ref fmt (+ i 2))
-               [(#\[)
-                (define (until i char print?)
-                  (let loop ([i i])
-                    (define c (string-ref fmt i))
-                    (cond
-                      [(and (char=? c #\~)
-                            (char=? char (string-ref fmt (add1 i))))
-                       (+ i 2)]
-                      [print?
-                       (write-char c o)
-                       (loop (add1 i))]
-                      [else (loop (add1 i))])))
-                (define next-i (+ i 3))
-                (case c
-                  [(#\@)
-                   (cond
-                     [(car args)
-                      (define-values (close-i rest-args) (loop next-i args mode))
-                      (loop close-i rest-args mode)]
-                     [else
-                      (define close-i (until next-i #\] #f))
-                      (loop close-i (cdr args) mode)])]
-                  [else
-                   (define sep-i (until next-i #\; (not (car args))))
-                   (define close-i (until sep-i #\] (car args)))
-                   (loop close-i (cdr args) mode)])]
-               [(#\:)
-                (case (string-ref fmt (+ i 3))
-                  [(#\()
-                   (define-values (close-i rest-args) (loop (+ i 4) args (cons 'upcase mode)))
-                   (loop close-i rest-args mode)]
-                  [else
-                   (error "unexpected after @:" (string-ref fmt (+ i 3)))])]
-               [else
-                (error "unexpected after : or @" (string-ref fmt (+ i 2)))])]
-            [(#\{)
-             (define lst (car args))
-             (cond
-               [(null? lst)
-                (let eloop ([i (+ i 2)])
-                  (cond
-                    [(and (char=? #\~ (string-ref fmt i))
-                          (char=? #\} (string-ref fmt (add1 i))))
-                     (loop (+ i 2) (cdr args) mode)]
-                    [else (eloop (add1 i))]))]
-               [else
-                (define-values (next-i rest-args)
-                  (for/fold ([next-i (+ i 2)] [args (append lst (cdr args))]) ([x (in-list lst)])
-                    (loop (+ i 2) args mode)))
-                (loop next-i rest-args mode)])]
-            [(#\} #\] #\))
-             ;; assume we're in a loop via `~{` or `~[` or `~(`
-             (values (+ i 2) args)]
-            [(#\?)
-             (do-printf o (car args) (cadr args))
-             (loop (+ i 2) (cddr args) mode)]
-            [(#\%)
-             (newline o)
-             (loop (+ i 2) args mode)]
-            [(#\^)
-             (if (null? args)
-                 (let eloop ([i (+ i 2)])
-                   (cond
-                     [(= i (string-length fmt))
-                      (values i args)]
-                     [(and (char=? #\~ (string-ref fmt i))
-                           (char=? #\} (string-ref fmt (add1 i))))
-                      (values (+ i 2) args)]
-                     [else (eloop (add1 i))]))
-                 (loop (+ i 2) args mode))]
-            [else
-             (error "unexpected" fmt)])]
-         [else
-          (write-char (string-ref fmt i) o)
-          (loop (add1 i) args mode)]))]))

racket/src/cs/bootstrap/gensym.rkt

@@ -1,64 +0,0 @@
-#lang racket/base
-(require (only-in racket/base
-                  [gensym r:gensym]))
-
-;; Represent a gensym as a symbol of the form |{....}| where the
-;; "pretty name" must not contain spaces.
-
-(provide print-gensym
-         gensym
-         $intern3
-         gensym?
-         gensym->unique-string
-         gensym->pretty-string
-         hash-curly
-         uninterned-symbol?)
-
-(define print-gensym (make-parameter #t))
-
-(define gensym
-  (case-lambda
-    [() (gensym (r:gensym))]
-    [(pretty-name)
-     (gensym pretty-name (r:gensym "unique"))]
-    [(pretty-name unique-name)
-     (string->symbol
-      (format "{~a ~a}" pretty-name unique-name))]))
-
-(define ($intern3 gstring pretty-len full-len)
-  (gensym (substring gstring 0 pretty-len) gstring))
-
-(define (gensym? s)
-  (and (symbol? s)
-       (let ([str (symbol->string s)])
-         (define len (string-length str))
-         (and (positive? len)
-              (char=? #\{ (string-ref str 0))
-              (char=? #\} (string-ref str (sub1 len)))))))
-
-(define (gensym->unique-string s)
-  (cadr (regexp-match #rx"^{[^ ]* (.*)}$" (symbol->string s))))
-
-(define (gensym->pretty-string s)
-  (cadr (regexp-match #rx"^{([^ ]*) .*}$" (symbol->string s))))
-
-(define (hash-curly c in src line col pos)
-  (define sym
-    (string->symbol
-     (list->string
-      (cons
-       #\{
-       (let loop ()
-         (define ch (read-char in))
-         (if (eqv? ch #\})
-             '(#\})
-             (cons ch (loop))))))))
-  (when (regexp-match? #rx"[|]" (symbol->string sym))
-    (error "here"))
-  sym)
-
-(define (uninterned-symbol? v)
-  (and (symbol? v)
-       (not (or (symbol-interned? v)
-                (symbol-unreadable? v)))))
-

racket/src/cs/bootstrap/hand-coded.rkt

@@ -1,29 +0,0 @@
-#lang racket/base
-
-(provide $hand-coded)
-
-(define ($hand-coded sym)
-  (case sym
-    [($install-library-entry-procedure)
-     (lambda (key val)
-       (hash-set! library-entries key val))]
-    [($foreign-entry-procedure) void]
-    [(callcc call1cc) call/cc]
-    [(scan-remembered-set
-      get-room
-      call-error
-      dooverflood
-      dooverflow
-      dorest0 dorest1 dorest2 dorest3 dorest4 dorest5 doargerr
-      dounderflow nuate reify-cc
-      dofargint32 dofretint32 dofretuns32 dofargint64 dofretint64
-      dofretuns64 dofretu8* dofretu16* dofretu32* domvleterr
-      values-error $shift-attachment)
-     void]
-    [(bytevector=?) equal?]
-    [($wrapper-apply wrapper-apply arity-wrapper-apply) void]
-    [(nonprocedure-code) (lambda args (error "not a procedure"))]
-    [else
-     (error '$hand-coded "missing ~s" sym)]))
-
-(define library-entries (make-hasheqv))

racket/src/cs/bootstrap/immediate.rkt

@@ -1,16 +0,0 @@
-#lang racket/base
-
-(define-syntax-rule (immediate name name?)
-  (begin
-    (provide (rename-out [value name])
-             name?)
-    
-    ;; mutable preserves `eq?` in datum->syntax->datum conversion
-    (struct name ([v #:mutable]) #:prefab)
-    
-    (define value (name #f))))
-
-(immediate base-rtd base-rtd?)
-(immediate bwp bwp?)
-(immediate black-hole black-hole?)
-(immediate $unbound-object $unbound-object?)

racket/src/cs/bootstrap/info.rkt

@@ -1,10 +0,0 @@
-#lang info
-
-(define collection "cs-bootstrap")
-(define pkg-name "cs-bootstrap") ; for `create-dirs-catalog`
-
-(define deps '("base"))
-
-(define pkg-desc "Creates Chez Scheme boot files from source")
-
-(define pkg-authors '(mflatt))

racket/src/cs/bootstrap/main.rkt

@@ -1,29 +0,0 @@
-#lang racket/base
-(require racket/cmdline
-         racket/runtime-path)
-
-;; Wrapper around "make-boot.rkt" to make it work in a more normal way
-;; with command-line arguments, instead of environment variables.
-
-(define scheme-src #f)
-(define mach #f)
-
-(command-line
- #:once-each
- [("--scheme-src") dir "Select the directory (defaults to current directory)"
-                   (set! scheme-src dir)]
- [("--machine") machine "Select the machine type (defaults to inferred)"
-                (set! mach machine)])
-
-(unless scheme-src
-  (printf "Assuming current directory has Chez Scheme sources\n")
-  (flush-output))
-
-(void (putenv "SCHEME_SRC" (or scheme-src ".")))
-(when mach
-  (void (putenv "MACH" mach)))
-
-;; Dynamic, so that environment variables are visible to
-;; compile-time instantiation of `make-boot`:
-(define-runtime-path make-boot "make-boot.rkt")
-(dynamic-require make-boot #f)

racket/src/cs/bootstrap/make-boot.rkt

@@ -1,435 +0,0 @@
-#lang racket/base
-(require racket/runtime-path
-         racket/match
-         racket/file
-         racket/pretty
-         (only-in "r6rs-lang.rkt"
-                  optimize-level)
-         (only-in "scheme-lang.rkt"
-                  current-expand
-                  with-source-path)
-         (submod "scheme-lang.rkt" callback)
-         "syntax-mode.rkt"
-         "r6rs-readtable.rkt"
-         "scheme-readtable.rkt"
-         "parse-makefile.rkt"
-         "config.rkt"
-         "strip.rkt")
-
-;; Set `SCHEME_SRC` and `MACH` to specify the ChezScheme source
-;; directory and the target machine. Set the `MAKE_BOOT_FOR_CROSS`
-;; environment variable to generate just enough to run `configure`
-;; for a corss build.
-
-(unless scheme-dir
-  (error "set `SCHEME_SRC` environment variable"))
-(unless target-machine
-  (error "set `MACH` environment variable"))
-
-;; Writes ".boot" and ".h" files to a "boot" subdirectory of
-;; `SCHEME_SRC`.
-
-(define-runtime-path here-dir ".")
-(define out-subdir (build-path scheme-dir "boot" target-machine))
-(define nano-dir (build-path scheme-dir "nanopass"))
-
-(define (status msg)
-  (printf "~a\n" msg)
-  (flush-output))
-
-(define sources-date
-  (for/fold ([d 0]) ([dir (in-list (list here-dir
-                                         nano-dir
-                                         (build-path scheme-dir "s")))])
-    (status (format "Use ~a" dir))
-    (for/fold ([d d]) ([f (in-list (directory-list dir))]
-                       #:when (regexp-match? #rx"[.](?:rkt|ss|sls)$" f))
-      (max d (file-or-directory-modify-seconds (build-path dir f))))))
-
-(status (format "Check ~a" out-subdir))
-(when (for/and ([f (in-list (list "scheme.h"
-                                  "equates.h"
-                                  "petite.boot"
-                                  "scheme.boot"))])
-        (define d (file-or-directory-modify-seconds (build-path out-subdir f) #f (lambda () #f)))
-        (and d (d . >= . sources-date)))
-  (status "Up-to-date")
-  (exit))
-
-;; ----------------------------------------
-
-(define-runtime-module-path r6rs-lang-mod "r6rs-lang.rkt")
-(define-runtime-module-path scheme-lang-mod "scheme-lang.rkt")
-
-(define-values (petite-sources scheme-sources)
-  (get-sources-from-makefile scheme-dir))
-
-(define ns (make-base-empty-namespace))
-(namespace-attach-module (current-namespace) r6rs-lang-mod ns)
-(namespace-attach-module (current-namespace) scheme-lang-mod ns)
-
-(namespace-require r6rs-lang-mod ns) ; get `library`
-
-;; Change some bindings from imported to top-level references so that
-;; expressions are compiled to reference variables that are updated by
-;; loading the Chez Scheme compiler. This approach is better than
-;; using `namespace-require/copy`, because we want most primitives to
-;; be referenced directly to make the compiler run faster.
-(define (reset-toplevels [more '()])
-  (for-each (lambda (sym)
-              (eval `(define ,sym ,sym) ns))
-            (append
-             more
-             '(identifier?
-               datum->syntax
-               syntax->list
-               syntax->datum
-               generate-temporaries
-               free-identifier=?
-               bound-identifier=?
-               make-compile-time-value
-               current-eval
-               eval
-               expand
-               compile
-               error
-               format))))
-
-(reset-toplevels)
-
-(status "Load nanopass")
-(define (load-nanopass)
-  (load/cd (build-path nano-dir "nanopass/helpers.ss"))
-  (load/cd (build-path nano-dir "nanopass/syntaxconvert.ss"))
-  (load/cd (build-path nano-dir "nanopass/records.ss"))
-  (load/cd (build-path nano-dir "nanopass/meta-syntax-dispatch.ss"))
-  (load/cd (build-path nano-dir "nanopass/meta-parser.ss"))
-  (load/cd (build-path nano-dir "nanopass/pass.ss"))
-  (load/cd (build-path nano-dir "nanopass/language-node-counter.ss"))
-  (load/cd (build-path nano-dir "nanopass/unparser.ss"))
-  (load/cd (build-path nano-dir "nanopass/language-helpers.ss"))
-  (load/cd (build-path nano-dir "nanopass/language.ss"))
-  (load/cd (build-path nano-dir "nanopass/nano-syntax-dispatch.ss"))
-  (load/cd (build-path nano-dir "nanopass/parser.ss"))
-  (load/cd (build-path nano-dir "nanopass.ss")))
-(parameterize ([current-namespace ns]
-               [current-readtable r6rs-readtable])
-  (load/cd (build-path nano-dir "nanopass/implementation-helpers.ikarus.ss"))
-  (load-nanopass))
-
-(namespace-require ''nanopass ns)
-
-(namespace-require scheme-lang-mod ns)
-
-(reset-toplevels '(run-cp0
-                   errorf
-                   $oops
-                   $undefined-violation
-                   generate-interrupt-trap))
-
-(namespace-require `(for-syntax ,r6rs-lang-mod) ns)
-(namespace-require `(for-syntax ,scheme-lang-mod) ns)
-(namespace-require `(for-meta 2 ,r6rs-lang-mod) ns)
-(namespace-require `(for-meta 2 ,scheme-lang-mod) ns)
-
-(namespace-require `(only (submod (file ,(path->string (resolved-module-path-name r6rs-lang-mod))) ikarus) with-implicit)
-                   ns)
-
-(define show? #f)
-(define orig-eval (let ([e (current-eval)])
-                    (lambda args
-                      (when show? (pretty-write args))
-                      (apply e args))))
-
-(define (call-with-expressions path proc)
-  (call-with-input-file*
-   path
-   (lambda (i)
-     (let loop ()
-       (define e (read i))
-       (unless (eof-object? e)
-         (proc e)
-         (loop))))))
-
-(define (load-ss path)
-  (define-values (base name dir) (split-path (path->complete-path path)))
-  (parameterize ([current-directory base])
-    (call-with-expressions path eval)))
-
-(parameterize ([current-namespace ns]
-               [current-readtable scheme-readtable]
-               [compile-allow-set!-undefined #t]
-               [current-eval (current-eval)])
-
-  (status "Load cmacro parts")
-  (call-with-expressions
-   (build-path scheme-dir "s/cmacros.ss")
-   (lambda (e)
-     (define (define-macro? m)
-       (memq m '(define-syntactic-monad define-flags set-flags)))
-     (define (define-for-syntax? m)
-       (memq m '(lookup-constant flag->mask)))
-     (match e
-       [`(define-syntax ,m . ,_)
-        (when (define-macro? m)
-          (orig-eval e))]
-       [`(eval-when ,_ (define ,m . ,rhs))
-        (when (define-for-syntax? m)
-          (orig-eval `(begin-for-syntax (define ,m . ,rhs))))]
-       [`(define-flags . ,_)
-        (orig-eval e)]
-       [_ (void)])))
-
-  (set-current-expand-set-callback!
-   (lambda ()
-     (start-fully-unwrapping-syntax!)
-     (define $uncprep (orig-eval '$uncprep))
-     (current-eval
-      (lambda (stx)
-        (syntax-case stx ()
-          [("noexpand" form)
-           (orig-eval (strip-$app (strip-$primitive ($uncprep (syntax-e #'form)))))]
-          [_
-           (orig-eval stx)])))
-     (call-with-expressions
-      (build-path scheme-dir "s/syntax.ss")
-      (lambda (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)])
-        (lambda (stx)
-          (define (go ex)
-            (define r (strip-$app
-                       (strip-$primitive
-                        (if (struct? ex)
-                            ($uncprep ex)
-                            ex))))
-            (e r))
-          (let loop ([stx stx])
-            (syntax-case* stx (#%top-interaction
-                               eval-when compile
-                               begin
-                               include) (lambda (a b)
-                                          (eq? (syntax-e a) (syntax-e b)))
-              [(#%top-interaction . rest) (loop #'rest)]
-              [(eval-when (compile) . rest)
-               #'(eval-when (compile eval load) . rest)]
-              [(begin e ...)
-               (for-each loop (syntax->list #'(e ...)))]
-              [(include fn)
-               (loop
-                #`(begin #,@(with-source-path 'include (syntax->datum #'fn)
-                              (lambda (n)
-                                (call-with-input-file*
-                                 n
-                                 (lambda (i)
-                                   (let loop ()
-                                     (define r (read-syntax n i))
-                                     (if (eof-object? r)
-                                         '()
-                                         (cons r (loop))))))))))]
-              [_ (go ((current-expand) (syntax->datum stx)))])))))
-     (status "Load cmacros using expander")
-     (load-ss (build-path scheme-dir "s/cmacros.ss"))
-     (status "Continue loading expander")))
-
-  (status "Load enum")
-  (load-ss (build-path scheme-dir "s/enum.ss"))
-  (eval '(define $annotation-options (make-enumeration '(debug profile))))
-  (eval '(define $make-annotation-options (enum-set-constructor $annotation-options)))
-  (eval
-   '(define-syntax-rule (library-requirements-options id ...)
-      (with-syntax ([members ($enum-set-members ($make-library-requirements-options (datum (id ...))))])
-        #'($record (record-rtd $library-requirements-options) members))))
-
-  (status "Load cprep")
-  (load-ss (build-path scheme-dir "s/cprep.ss"))
-
-  (status "Load expander")
-  (load-ss (build-path scheme-dir "s/syntax.ss"))
-
-  (status "Initialize system libraries")
-  (define (init-libraries)
-    (eval '($make-base-modules))
-    (eval '($make-rnrs-libraries))
-    (eval '(library-search-handler (lambda args (values #f #f #f))))
-    (eval '(define-syntax guard
-             (syntax-rules (else)
-               [(_ (var clause ... [else e1 e2 ...]) b1 b2 ...)
-                ($guard #f (lambda (var) (cond clause ... [else e1 e2 ...]))
-                        (lambda () b1 b2 ...))]
-               [(_ (var clause1 clause2 ...) b1 b2 ...)
-                ($guard #t (lambda (var p) (cond clause1 clause2 ... [else (p)]))
-                        (lambda () b1 b2 ...))]))))
-  (init-libraries)
-  
-  (status "Load nanopass using expander")
-  (load-ss (build-path nano-dir "nanopass/implementation-helpers.chezscheme.sls"))
-  (load-nanopass)
-
-  (status "Load priminfo and primvars")
-  (load-ss (build-path scheme-dir "s/priminfo.ss"))
-  (load-ss (build-path scheme-dir "s/primvars.ss"))
-
-  (status "Load expander using expander")
-  (set-current-expand-set-callback! void)
-  (load-ss (build-path scheme-dir "s/syntax.ss"))
-
-  (status "Initialize system libraries in bootstrapped expander")
-  (init-libraries)
-  
-  (status "Declare nanopass in bootstrapped expander")
-  (load-ss (build-path nano-dir "nanopass/implementation-helpers.chezscheme.sls"))
-  (load-nanopass)
-
-  (status "Load some io.ss declarations")
-  (call-with-expressions
-   (build-path scheme-dir "s/io.ss")
-   (lambda (e)
-     (define (want-syntax? id)
-       (memq id '(file-options-list eol-style-list error-handling-mode-list)))
-     (define (want-val? id)
-       (memq id '($file-options $make-file-options $eol-style? buffer-mode? $error-handling-mode?)))
-     (let loop ([e e])
-       (match e
-         [`(let () ,es ...)
-          (for-each loop es)]
-         [`(begin ,es ...)
-          (for-each loop es)]
-         [`(define-syntax ,id . ,_)
-          (when (want-syntax? id)
-            (eval e))]
-         [`(set-who! ,id . ,_)
-          (when (want-val? id)
-            (eval e))]
-         [_ (void)]))))
-
-  (status "Load some strip.ss declarations")
-  (call-with-expressions
-   (build-path scheme-dir "s/strip.ss")
-   (lambda (e)
-     (let loop ([e e])
-       (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 . ,_)
-          (eval e)]
-         [_ (void)]))))
-
-  (status "Load some 7.ss declarations")
-  (call-with-expressions
-   (build-path scheme-dir "s/7.ss")
-   (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? . ,_) . ,_)
-          (eval e)]
-         [_ (void)]))))
-
-  (status "Load most front.ss declarations")
-  (call-with-expressions
-   (build-path scheme-dir "s/front.ss")
-   (lambda (e)
-     ;; Skip `package-stubs`, which would undo "syntax.ss" definitions
-     (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)
-             (filter-foreign-type ty))))
-
-  (make-directory* out-subdir)
-  
-  (status "Load mkheader")
-  (load-ss (build-path scheme-dir "s/mkheader.ss"))
-  (status "Generate headers")
-  (eval `(mkscheme.h ,(path->string (build-path out-subdir "scheme.h")) ,target-machine))
-  (eval `(mkequates.h ,(path->string (build-path out-subdir "equates.h"))))
-  (plumber-flush-all (current-plumber))
-
-  (let ([mkgc.ss (build-path scheme-dir "s/mkgc.ss")])
-    (when (file-exists? mkgc.ss)
-      (status "Load mkgc")
-      (load-ss (build-path scheme-dir "s/mkgc.ss"))
-      (status "Generate GC")
-      (eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc"))))
-      (eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc"))))
-      (eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc"))))
-      (plumber-flush-all (current-plumber))))
-
-  (when (getenv "MAKE_BOOT_FOR_CROSS")
-    ;; Working bootfiles are not needed for a cross build (only the
-    ;; ".h" files are needed), so just make dummy files in that case
-    ;; to let `configure` work
-    (define (touch p)
-      (unless (file-exists? p) (call-with-output-file* p void)))
-    (touch (build-path out-subdir "petite.boot"))
-    (touch (build-path out-subdir "scheme.boot"))
-    (exit))
-
-  (for ([s (in-list '("ftype.ss"
-                      "fasl.ss"
-                      "reloc.ss"
-                      "format.ss"
-                      "cp0.ss"
-                      "cpvalid.ss"
-                      "cpcheck.ss"
-                      "cpletrec.ss"
-                      "cpcommonize.ss"
-                      "cpnanopass.ss"
-                      "compile.ss"
-                      "back.ss"))])
-    (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"))))])
-        (parameterize ([current-directory (build-path scheme-dir "s")])
-          ;; (status (format "Compile ~a" src)) - Chez Scheme prints its own message
-          (with-handlers (#;[exn:fail? (lambda (exn)
-                                       (eprintf "ERROR: ~s\n" (exn-message exn))
-                                       (set! failed? #t))])
-            (time ((orig-eval 'compile-file) src dest))))))
-    (when failed?
-      (raise-user-error 'make-boot "compilation failure(s)")))
-
-  (let ([src->so (lambda (src)
-                   (path->string (build-path out-subdir (path-replace-suffix src #".so"))))])
-    (status "Writing petite.boot")
-    (eval `($make-boot-file ,(path->string (build-path out-subdir "petite.boot"))
-                            ',(string->symbol target-machine) '()
-                            ,@(map src->so petite-sources)))
-    (status "Writing scheme.boot")
-    (eval `($make-boot-file ,(path->string (build-path out-subdir "scheme.boot"))
-                            ',(string->symbol target-machine) '("petite")
-                            ,@(map src->so scheme-sources)))))

racket/src/cs/bootstrap/nanopass-patch.rkt

@@ -1,31 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base))
-
-;; To load the R6RS nanopass framework into Racket, we need to make
-;; an adjustment to the use of `datum->syntax` in `make-in-context-transformer`.
-;; This same adjustment appears in the Racket version of nanopass.
-
-(provide patch:define)
-
-(define-syntax (patch:define stx)
-  (syntax-case stx (make-in-context-transformer lambda x quote)
-    [(...
-      (_ id
-         (lambda args
-           (lambda (x)
-             (syntax-case x ()
-               [(_ . pat-rest)
-                (with-syntax ([qq (datum->syntax _ 'quasiquote)])
-                  body)])))))
-     (free-identifier=? #'id #'make-in-context-transformer)
-     (begin
-       (printf "Apply nanopass patch\n")
-       #'(...
-          (define id
-            (lambda args
-              (lambda (x)
-                (syntax-case x ()
-                  [(me . pat-rest)
-                   (with-syntax ([qq (datum->syntax #'me 'quasiquote)])
-                     body)]))))))]
-    [(_ . rest) #'(define . rest)]))

racket/src/cs/bootstrap/parse-makefile.rkt

@@ -1,17 +0,0 @@
-#lang racket/base
-(require racket/string)
-
-(provide get-sources-from-makefile)
-
-(define (get-sources-from-makefile scheme-dir)
-  (call-with-input-file*
-   (build-path scheme-dir "s" "Mf-base")
-   #:mode 'text
-   (lambda (i)
-     (define (extract-files m)
-       (string-split (regexp-replace* #rx"\\\\" (bytes->string/utf-8 (cadr m)) "")))
-     (define bases (extract-files (regexp-match #rx"basesrc =((?:[^\\\n]*\\\\\n)*[^\\\n]*)\n" i)))
-     (define compilers (extract-files (regexp-match #rx"compilersrc =((?:[^\\\n]*\\\\\n)*[^\\\n]*)\n" i)))
-     (values bases compilers))))
-
-     

racket/src/cs/bootstrap/primdata.rkt

@@ -1,108 +0,0 @@
-#lang racket/base
-(require racket/match
-         "scheme-struct.rkt"
-         "scheme-readtable.rkt"
-         "symbol.rkt")
-
-(provide get-primdata
-         (struct-out priminfo))
-
-(struct priminfo (unprefixed libraries mask signatures arity))
-
-;; Returns flags->bits for prim flags, `primvec` function, and `get-priminfo` function
-(define (get-primdata $sputprop scheme-dir)
-  (define flags->bits
-    (cond
-      [scheme-dir
-       (call-with-input-file*
-        (build-path scheme-dir "s/cmacros.ss")
-        (lambda (i)
-          (let loop ()
-            (define l (parameterize ([current-readtable scheme-readtable])
-                        (read i)))
-            (match l
-              [`(define-flags prim-mask ,specs ...)
-               (define bits
-                 (for/fold ([bits #hasheq()]) ([spec (in-list specs)])
-                   (define (get-val v)
-                     (if (number? v) v (hash-ref bits v)))
-                   (match spec
-                     [`(,name (or ,vals ...))
-                      (hash-set bits name (apply bitwise-ior (map get-val vals)))]
-                     [`(,name ,val)
-                      (hash-set bits name (get-val val))])))
-               (lambda (flags)
-                 (apply bitwise-ior (for/list ([flag (in-list flags)])
-                                      (hash-ref bits flag))))]
-              [_ (loop)]))))]
-      [else #hasheq()]))
-  (define primref-variant
-    (call-with-input-file*
-     (build-path scheme-dir "s/primref.ss")
-     (lambda (i)
-       (define decl (parameterize ([current-readtable scheme-readtable])
-                      (read i)))
-       (match decl
-         [`(define-record-type primref
-             (nongenerative ,variant)
-             . ,_)
-          variant]
-         [_
-          (error "cannot parse content of s/primref.ss")]))))
-  (define priminfos (make-hasheq))
-  (when scheme-dir
-    (call-with-input-file*
-     (build-path scheme-dir "s/primdata.ss")
-     (lambda (i)
-       (let loop ()
-         (define l (parameterize ([current-readtable #f])
-                     (read i)))
-         (unless (eof-object? l)
-           (match l
-             [`(,def-sym-flags
-                ([libraries ,libs ...] [flags ,group-flags ...])
-                ,clauses ...)
-              (for ([clause (in-list clauses)])
-                (match clause
-                  [`(,id ,specs ...)
-                   (define-values (flags sigs)
-                     (for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)])
-                       (match spec
-                         [`[sig ,sigs ...] (values flags sigs )]
-                         [`[flags ,flags ...] (values (append flags group-flags) sigs)]
-                         [`[feature ,features ...] (values flags sigs)])))
-                   (define plain-id (if (pair? id)
-                                        (string->symbol (format "~a~a"
-                                                                (car id)
-                                                                (cadr id)))
-                                        id))
-                   (define flag-bits (flags->bits flags))
-                   (define interface (map sig->interface sigs))
-                   (define pr (case primref-variant
-                                [(|{primref a0xltlrcpeygsahopkplcn-3}|)
-                                 (primref3 plain-id flag-bits interface sigs)]
-                                [(|{primref a0xltlrcpeygsahopkplcn-2}|)
-                                 (primref2 plain-id flag-bits interface)]
-                                [else (error "unrecognized primref variant in s/primref.ss"
-                                             primref-variant)]))
-                   (register-symbols plain-id)
-                   ($sputprop plain-id '*prim2* pr)
-                   ($sputprop plain-id '*prim3* pr)
-                   ($sputprop plain-id '*flags* flag-bits)
-                   (hash-set! priminfos plain-id (priminfo (if (pair? id) (cadr id) id)
-                                                           libs
-                                                           flag-bits
-                                                           sigs
-                                                           (map sig->interface sigs)))]))])
-           (loop))))))
-  (values (lambda () (list->vector (hash-keys priminfos)))
-          (lambda (sym) (hash-ref priminfos sym #f))))
-
-(define (sig->interface sig)
-  (match sig
-    [`((,args ... ,'...) ,ress ...)
-     (- -1 (length args))]
-    [`((,args ... ,'... ,last-arg) ,ress ...)
-     (- -2 (length args))]
-    [`((,args ...) ,ress ...)
-     (length args)]))

racket/src/cs/bootstrap/r6rs-lang.rkt

@@ -1,813 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base)
-         (for-template racket/base)
-         racket/fixnum
-         racket/flonum
-         racket/pretty
-         racket/list
-         racket/splicing
-         racket/unsafe/ops
-         "nanopass-patch.rkt"
-         "gensym.rkt"
-         "format.rkt"
-         "syntax-mode.rkt"
-         "constant.rkt"
-         "config.rkt"
-         "rcd.rkt"
-         (only-in "record.rkt"
-                  do-$make-record-type
-                  register-rtd-name!
-                  register-rtd-fields!
-                  s:struct-type?
-                  record-predicate
-                  record-accessor
-                  record-mutator)
-         (only-in "immediate.rkt"
-                  base-rtd)
-         (only-in "scheme-struct.rkt"
-                  syntax-object syntax-object? syntax-object-e syntax-object-ctx
-                  rec-cons-desc rec-cons-desc? rec-cons-desc-rtd rec-cons-desc-parent-rcd rec-cons-desc-protocol
-                  top-ribcage))
-
-(provide (except-out (all-from-out racket/base
-                                   racket/fixnum
-                                   racket/flonum)
-                     define
-                     syntax
-                     syntax-case
-                     syntax-rules
-                     with-syntax
-                     quasisyntax
-                     define-syntax
-                     syntax->datum
-                     module
-                     let-syntax
-                     letrec-syntax
-                     symbol->string
-                     format error
-                     if
-                     sort
-                     fixnum?
-                     open-output-file
-                     dynamic-wind)
-         library import export
-         (rename-out [patch:define define]
-                     [s:syntax syntax]
-                     [s:syntax-case syntax-case]
-                     [s:syntax-rules syntax-rules]
-                     [s:with-syntax with-syntax]
-                     [s:quasisyntax quasisyntax]
-                     [s:define-syntax define-syntax]
-                     [s:syntax->datum syntax->datum]
-                     [s:if if]
-                     [lambda trace-lambda]
-                     [define-syntax trace-define-syntax]
-                     [s:splicing-let-syntax let-syntax]
-                     [s:splicing-letrec-syntax letrec-syntax]
-                     [let trace-let]
-                     [define trace-define]
-                     [s:dynamic-wind dynamic-wind])
-         guard
-         identifier-syntax
-         (for-syntax datum)
-         assert
-         (rename-out [zero? fxzero?])
-         gensym gensym? gensym->unique-string
-         (rename-out [s:symbol->string symbol->string])
-         pretty-print
-         with-input-from-string with-output-to-string
-         define-record-type
-         record-type-descriptor
-         make-record-type-descriptor
-         make-record-type-descriptor*
-         make-record-constructor-descriptor
-         (rename-out [s:struct-type? record-type-descriptor?])
-         record-constructor-descriptor
-         record-constructor
-         (rename-out [record-constructor r6rs:record-constructor])
-         record-predicate
-         record-accessor
-         record-mutator
-         record-constructor-descriptor?
-         syntax-violation
-         port-position
-         close-port
-         eof-object
-         struct-name struct-ref
-         make-list memp partition fold-left fold-right find remp remv
-         (rename-out [andmap for-all]
-                     [ormap exists]
-                     [list* cons*]
-                     [s:fixnum? fixnum?]
-                     [fx= fx=?]
-                     [fx< fx<?]
-                     [fx> fx>?]
-                     [fx<= fx<=?]
-                     [fx>= fx>=?]
-                     [fxlshift fxarithmetic-shift-left]
-                     [fxnot fxlognot]
-                     [odd? fxodd?]
-                     [even? fxeven?]
-                     [div fxdiv]
-                     [mod fxmod]
-                     [div-and-mod fxdiv-and-mod]
-                     [integer-length fxlength]
-                     [exact->inexact inexact]
-                     [inexact->exact exact]
-                     [bitwise-reverse-bit-field fxreverse-bit-field]
-                     [bitwise-copy-bit-field fxcopy-bit-field]
-                     [bitwise-copy-bit fxcopy-bit]
-                     [make-hasheq make-eq-hashtable]
-                     [hash-ref/pair hashtable-ref]
-                     [hash-set!/pair hashtable-set!]
-                     [hash-set!/pair eq-hashtable-set!]
-                     [hash-ref-cell hashtable-cell]
-                     [equal-hash-code equal-hash]
-                     [s:format format]
-                     [s:error error])
-         most-positive-fixnum
-         most-negative-fixnum
-         bitwise-copy-bit-field
-         bitwise-copy-bit
-         bitwise-first-bit-set
-         bitwise-if
-         div mod div-and-mod
-         fixnum-width
-         set-car!
-         set-cdr!
-         bytevector-copy!
-         bytevector-ieee-double-native-set!
-         bytevector-ieee-double-native-ref
-         bytevector-u64-native-set!
-         bytevector-u64-native-ref
-         call-with-bytevector-output-port
-         make-compile-time-value
-         optimize-level)
-
-(module+ ikarus
-  (provide print-gensym
-           annotation? annotation-source
-           source-information-type
-           source-information-position-line
-           source-information-position-column
-           source-information-source-file
-           source-information-byte-offset-start
-           source-information-byte-offset-end
-           source-information-char-offset-start
-           source-information-char-offset-end
-           syntax->source-information
-           (rename-out [s:module module])
-           indirect-export
-           (for-syntax with-implicit)))
-
-(module+ hash-pair
-  (provide hash-ref/pair
-           hash-set!/pair
-           hash-ref-cell
-           s:fixnum?))
-
-(begin-for-syntax
-  (define here-path
-    (let ([p (resolved-module-path-name
-              (module-path-index-resolve
-               (variable-reference->module-path-index
-                (#%variable-reference))))])
-      (if (path? p)
-          (path->string p)
-          `(quote ,p)))))
-
-(define-syntax (library stx)
-  (syntax-case stx (nanopass export import)
-    [(library (nanopass name)
-       (export out ...)
-       (import in ...)
-       body ...)
-     (with-syntax ([here (datum->syntax #'name `(file ,here-path))])
-       #'(module name here
-           (require (for-syntax here)
-                    (except-in (for-template here) datum))
-           (export out) ...
-           (import in) ...
-           body ...))]
-    [(library (nanopass) . rest)
-     (syntax-case stx ()
-       [(_ (np) . _)
-        #'(library (np np) . rest)])]))
-
-(define-syntax-rule (export id)
-  (provide id))
-
-(define-syntax-rule (indirect-export . _)
-  (begin))
-
-(define-syntax (import stx)
-  (syntax-case stx (rnrs ikarus nanopass only chezscheme)
-    [(import (rnrs _ ...))
-     #'(begin)]
-    [(import (ikarus))
-     (syntax-case stx ()
-       [(_ (name))
-        (with-syntax ([ref (datum->syntax #'name `(submod (file ,here-path) ikarus))])
-          #`(require ref))])]
-    [(import (nanopass name))
-     (with-syntax ([ref (datum->syntax #'name (list 'quote #'name))])
-       #`(require ref (for-syntax ref) (for-template ref)))]
-    [(import (only (chezscheme) . _))
-     #'(begin)]))
-
-(define-syntax (s:syntax stx)
-  (syntax-case stx ()
-    [(_ e)
-     #`(unwrap-a-bit (syntax #,(mark-original #'e)))]))
-
-(define-syntax (s:syntax-case stx)
-  (syntax-case stx ()
-    [(_ e lits . rest)
-     #'(syntax-case* (strip-outer-struct e) lits s:free-identifier=? . rest)]))
-
-(define-syntax-rule (s:syntax-rules lits [a ... b] ...)
-  (lambda (stx)
-    (s:syntax-case stx lits
-      [a ... (s:syntax b)]
-      ...)))
-
-(define-syntax (s:with-syntax stx)
-  (syntax-case stx ()
-    [(_ ([pat e] ...) . rest)
-     #'(with-syntax ([pat (strip-outer-struct e)] ...) . rest)]))
-
-(define-syntax (s:quasisyntax stx)
-  (syntax-case stx ()
-    [(_ e)
-     (with-syntax ([qs #'quasisyntax])
-       #`(unwrap-a-bit (qs #,(mark-original #`e))))]))
-
-(define-for-syntax (mark-original e)
-  (cond
-    [(syntax? e)
-     (define v (syntax-e e))
-     (cond
-       [(pair? v)
-        (datum->syntax e
-                       (cons (mark-original (car v))
-                             (mark-original (cdr v)))
-                       e
-                       e)]
-       [(vector? v)
-        (for/vector #:length (vector-length v) ([i (in-vector v)])
-          (mark-original i))]
-       [(identifier? e) (syntax-property e 'original-in-syntax #t)]
-       [else e])]
-    [(pair? e)
-     (cons (mark-original (car e))
-           (mark-original (cdr e)))]
-    [else e]))
-
-(define (unwrap-a-bit e)
-  (cond
-    [fully-unwrap?
-     ;; Support use of `syntax-case` in expander implementation
-     ;; after the expander itself is expanded.
-     (let loop ([e e])
-       (cond
-         [(syntax? e)
-          (cond
-            [(and (identifier? e)
-                  (syntax-property e 'original-in-syntax))
-             (syntax-object (syntax-e e)
-                            (cons '(top) (list (top-ribcage '*system* #f))))]
-            [else
-             (define v (loop (syntax-e e)))
-             (define p (syntax-property e 'save-context))
-             (if p
-                 (syntax-object v p)
-                 v)])]
-         [(pair? e)
-          (cons (loop (car e))
-                (loop (cdr e)))]
-         [(vector? e)
-          (for/vector #:length (vector-length e) ([i (in-vector e)])
-            (loop i))]
-         [else e]))]
-    [else
-     ;; Simulate R6RS well enough
-     (or (syntax->list e)
-         e)]))
-
-;; Also to support use of `syntax-case` in expander implementation
-;; after the expander itself is expanded:
-(define strip-outer-struct
-  (let ()
-    (lambda (e)
-      (let loop ([e e] [w empty-wraps])
-        (cond
-          [(syntax-object? e)
-           (define v (syntax-object-e e))
-           (define new-w (join-wraps w (syntax-object-ctx e)))
-           (cond
-             [(pair? v)
-              (cons (loop (car v) new-w)
-                    (loop (cdr v) new-w))]
-             [(null? v) v]
-             [else
-              (syntax-property (datum->syntax #f v) 'save-context new-w)])]
-          [(pair? e)
-           (cons (loop (car e) w)
-                 (loop (cdr e) w))]
-          [(vector? e)
-           (for/vector #:length (vector-length e) ([i (in-vector e)])
-             (loop i w))]
-          [(box? e)
-           (box (loop (unbox e) w))]
-          [(symbol? e)
-           (if (equal? w empty-wraps)
-               e
-               (syntax-property (datum->syntax #f e) 'save-context w))]
-          [else e])))))
-
-(define (s:free-identifier=? a b)
-  (if fully-unwrap?
-      (eq? (syntax-e a) (syntax-e b))
-      (free-identifier=? a b)))
-
-(define empty-wraps '(() . ()))
-
-(define (join-wraps w1 w2)
-  (define a (join (car w1) (car w2)))
-  (define d (join (cdr w1) (cdr w2)))
-  (cond
-    [(and (eq? a (car w1))
-          (eq? d (cdr w1)))
-     w1]
-    [(and (eq? a (car w2))
-          (eq? d (cdr w2)))
-     w2]
-    [else (cons a d)]))
-
-(define (join l1 l2)
-  (cond
-    [(null? l1) l2]
-    [(null? l2) l1]
-    [else (append l1 l2)]))
-
-(define (s:syntax->datum s)
-  (syntax->datum (datum->syntax #f s)))
-
-(define-syntax-rule (s:define-syntax id rhs)
-  (define-syntax id
-    (wrap-transformer rhs)))
-
-(define-syntax-rule (s:splicing-let-syntax ([id rhs] ...) body ...)
-  (splicing-let-syntax ([id (wrap-transformer rhs)] ...) body ...))
-
-(define-syntax-rule (s:splicing-letrec-syntax ([id rhs] ...) body ...)
-  (splicing-letrec-syntax ([id (wrap-transformer rhs)] ...) body ...))
-
-(define-for-syntax (wrap-transformer proc)
-  (if (procedure? proc)
-      (lambda (stx)
-        (let loop ([result (proc stx)])
-          (if (procedure? result)
-              ;; Chez/Ikarus protocol to get syntax-local-value:
-              (loop (result syntax-local-value))
-              (datum->syntax #'here result))))
-      proc))
-
-(define-syntax s:if
-  (syntax-rules ()
-    [(_ tst thn els) (if tst thn els)]
-    [(_ tst thn) (if tst thn (void))]))
-
-(define-syntax-rule (guard (id [tst rslt ...] ...) body ...)
-  (with-handlers ([(lambda (id) (else-to-true tst)) (lambda (id) rslt ...)] ...)
-    body ...))
-
-(define-syntax else-to-true
-  (syntax-rules (else)
-    [(_ else) #t]
-    [(_ e) e]))
-
-(define s:dynamic-wind
-  (case-lambda
-    [(pre thunk post) (dynamic-wind pre thunk post)]
-    [(critical? pre thunk post) (dynamic-wind pre thunk post)]))
-
-(begin-for-syntax
-  (define-syntax-rule (with-implicit (tid id ...) body ...)
-    (with-syntax ([id (datum->syntax (syntax tid) 'id)] ...)
-      body ...)))
-
-(begin-for-syntax
-  (define-syntax-rule (datum e)
-    (syntax->datum (syntax e))))
- 
-(define-syntax (identifier-syntax stx)
-  (syntax-case stx ()
-    [(_ id)
-     (identifier? #'id)
-     #'(make-rename-transformer #'id)]
-    [(_ e)
-     #'(lambda (stx)
-         (if (identifier? stx)
-             #'e
-             (syntax-case stx ()
-               [(_ arg (... ...))
-                #'(e arg (... ...))])))]))
-
-(define-syntax-rule (s:module (id ...) body ...)
-  (begin
-    body ...))
-
-(define-syntax-rule (assert e)
-  (unless e
-    (error 'assert "failed: ~s" 'e)))
-
-(define (syntax->source-information stx) #f)
-(define (source-information-type si) #f)
-(define (source-information-position-line si) #f)
-(define (source-information-position-column si) #f)
-(define (source-information-source-file si) #f)
-(define (source-information-byte-offset-start si) #f)
-(define (source-information-byte-offset-end si) #f)
-(define (source-information-char-offset-start si) #f)
-(define (source-information-char-offset-end si) #f)
-
-(define (syntax-violation . args)
-  (apply error args))
-
-(define (s:symbol->string s)
-  (if (gensym? s)
-      (gensym->pretty-string s)
-      (symbol->string s)))
-
-(define (with-input-from-string str proc)
-  (parameterize ([current-input-port (open-input-string str)])
-    (proc)))
-
-(define (with-output-to-string proc)
-  (define o (open-output-string))
-  (parameterize ([current-output-port o])
-    (proc))
-  (get-output-string o))
-
-(define protocols (make-hasheq))
-(define (install-protocol! rtd protocol)
-  (hash-set! protocols rtd protocol))
-(define (lookup-protocol rtd)
-  (hash-ref protocols rtd))
-
-(define-syntax (define-record-type stx)
-  (syntax-case stx ()
-    [(_ (name make-name name?) clause ...)
-     (let loop ([clauses #'(clause ...)] [fs #'()] [p #f] [super #f] [uid #f] [o? #f] [s? #f])
-       (syntax-case clauses (nongenerative sealed fields protocol parent opaque sealed)
-         [((nongenerative uid) clause ...)
-          (loop #'(clause ...) fs p super #'uid o? s?)]
-         [((nongenerative . _) clause ...)
-          (loop #'(clause ...) fs p super uid o? s?)]
-         [((sealed _) clause ...)
-          (loop #'(clause ...) fs p super uid o? s?)]
-         [((fields field ...) clause ...)
-          (loop #'(clause ...) #'(field ...) p super uid o? s?)]
-         [((protocol proc) clause ...)
-          (loop #'(clause ...) fs #'proc super uid o? s?)]
-         [((parent super) clause ...)
-          (loop #'(clause ...) fs p #'super uid o? s?)]
-         [((opaque #t) clause ...)
-          (loop #'(clause ...) fs p super uid #t s?)]
-         [((sealed #t) clause ...)
-          (loop #'(clause ...) fs p super uid o? #t)]
-         [()
-          (let ()
-            (define (format-id ctx fmt . args)
-              (datum->syntax ctx (string->symbol
-                                  (apply format fmt (map syntax-e args)))))
-            (define (normalize-fields l)
-              (for/list ([f (in-list (syntax->list l))])
-                (syntax-case f (mutable immutable)
-                  [id
-                   (identifier? #'id)
-                   (list #'id (format-id #'id  "~a-~a" #'name #'id))]
-                  [(mutable id)
-                   (list #'id
-                         (format-id #'id  "~a-~a" #'name #'id)
-                         (format-id #'id  "~a-~a-set!" #'name #'id))]
-                  [(immutable id)
-                   (list #'id (format-id #'id  "~a-~a" #'name #'id))]
-                  [(mutable id ref set)
-                   (list #'id #'ref #'set)]
-                  [(immutable id ref)
-                   (list #'id #'ref)])))
-            (define all-fs (normalize-fields fs))
-            (define fs-ids (for/list ([f (in-list all-fs)])
-                             (syntax-case f ()
-                               [(id . _) #'id])))
-            (define parent-info (and super (syntax-local-value super)))
-            (with-syntax ([num-fields (length all-fs)]
-                          [protocol (or p
-                                        (if super
-                                            #`(lambda (parent-maker)
-                                                (lambda (#,@(list-ref parent-info 3) #,@fs-ids)
-                                                  ((parent-maker #,@(list-ref parent-info 3)) #,@fs-ids)))
-                                            #'(lambda (p) p)))]
-                          [maker (if super
-                                     #`(let ([parent-protocol (lookup-protocol #,(car parent-info))])
-                                         (lambda args
-                                           (apply (parent-protocol
-                                                   (lambda #,(list-ref parent-info 3)
-                                                     (lambda #,fs-ids
-                                                       (create-name #,@(list-ref parent-info 3) #,@fs-ids))))
-                                                  args)))
-                                     #'create-name)]
-                          [(getter ...)
-                           (for/list ([f (in-list all-fs)]
-                                      [pos (in-naturals)])
-                             (syntax-case f ()
-                               [(id ref . _) (list #'ref
-                                                   #`(make-struct-field-accessor name-ref #,pos 'id))]))]
-                          [(setter ...)
-                           (for/list ([f (in-list all-fs)]
-                                      [pos (in-naturals)]
-                                      #:when (syntax-case f ()
-                                               [(_ _ _) #t]
-                                               [_ #f]))
-                             (syntax-case f ()
-                               [(id _ set) (list #'set
-                                                 #`(make-struct-field-mutator name-set! #,pos 'id))]))]
-                          [super (if super
-                                     (car (syntax-local-value super))
-                                     #'#f)]
-                          [struct:name (format-id #'name "struct:~a" #'name)]
-                          [uid (or uid #'name)]
-                          [maybe-prefab (if uid #''prefab #'#f)]
-                          [fields-vec (list->vector (syntax-e fs))])
-              (with-syntax ([(all-getter-id ...)
-                             (append (for/list ([getter (in-list (reverse (syntax->list #'(getter ...))))])
-                                       (syntax-case getter ()
-                                         [(id . _) #'id]))
-                                     (if parent-info
-                                         (list-ref parent-info 3)
-                                         null))])
-                #`(begin
-                    (define-syntax name
-                      (list (quote-syntax struct:name)
-                            (quote-syntax create-name)
-                            (quote-syntax name?)
-                            (list (quote-syntax all-getter-id) ...)
-                            #f
-                            #f))
-                    (define-values (struct:name create-name name? name-ref name-set!)
-                      (make-struct-type 'uid super num-fields 0 #f null maybe-prefab))
-                    (define name-protocol protocol)
-                    (install-protocol! struct:name name-protocol)
-                    (register-rtd-name! struct:name 'name)
-                    (register-rtd-fields! struct:name 'fields-vec)
-                    (define make-name (name-protocol maker))
-                    (define . getter) ...
-                    (define . setter) ...))))]))]
-    [(_ name clause ...)
-     (with-syntax ([make-name (datum->syntax #'name
-                                             (string->symbol
-                                              (format "make-~a" (syntax-e #'name)))
-                                             #'name)]
-                   [name? (datum->syntax #'name
-                                         (string->symbol
-                                          (format "~a?" (syntax-e #'name)))
-                                         #'name)])
-       #`(define-record-type (name make-name name?) clause ...))]))
-
-(define-syntax (record-type-descriptor stx)
-  (syntax-case stx ()
-    [(_ id)
-     (car (syntax-local-value #'id))]))
-
-(define-syntax (record-constructor-descriptor stx)
-  (syntax-case stx ()
-    [(_ id)
-     #`(rtd->rcd #,(car (syntax-local-value #'id)))]))
-
-(define record-constructor-descriptor? rec-cons-desc?)
-
-(define (rtd->rcd rtd)
-  (rec-cons-desc rtd #f (lookup-protocol rtd)))
-
-(define (record-constructor rcd)
-  (cond
-    [(s:struct-type? rcd)
-     ;; For Chez Scheme's legacy procedure
-     (struct-type-make-constructor rcd)]
-    [(rec-cons-desc? rcd)
-     (rcd->constructor rcd lookup-protocol)]))
-
-(define (make-record-type-descriptor name parent uid s? o? fields)
-  (do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
-
-(define (make-record-type-descriptor* name parent uid s? o? num-fields mutability-mask)
-  (define fields (for ([i (in-range num-fields)])
-                   (list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable)
-                         (string->symbol (format "f~a" i)))))
-  (do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
-
-(define (make-record-constructor-descriptor rtd parent-rcd protocol)
-  (rec-cons-desc rtd parent-rcd protocol))
-
-(define (annotation? a) #f)
-(define (annotation-source a) #f)
-
-(define (port-position ip) (file-position ip))
-
-(define (close-port p)
-  (if (input-port? p)
-      (close-input-port p)
-      (close-output-port p)))
-
-(define (eof-object)
-  eof)
-
-(define (struct-name a) (substring (symbol->string (vector-ref (struct->vector a) 0))
-                                   ;; drop "struct:"
-                                   7))
-(define (struct-ref s i) (error 'struct-ref "oops"))
-
-(define (make-list n [v #f])
-  (vector->list (make-vector n v)))
-
-(define (memp pred l)
-  (cond
-    [(null? l) #f]
-    [(pred (car l)) l]
-    [else (memp pred (cdr l))]))
-
-(define (remp pred l)
-  (cond
-    [(null? l) l]
-    [(pred (car l)) (remp pred (cdr l))]
-    [else (cons (car l) (remp pred (cdr l)))]))
-
-(define (remv v l)
-  (cond
-    [(null? l) l]
-    [(eqv? v (car l)) (remv v (cdr l))]
-    [else (cons (car l) (remv v (cdr l)))]))
-
-(define (partition proc list)
-  (let loop ((list list) (yes '()) (no '()))
-    (cond ((null? list)
-           (values (reverse yes) (reverse no)))
-          ((proc (car list))
-           (loop (cdr list) (cons (car list) yes) no))
-          (else
-           (loop (cdr list) yes (cons (car list) no))))))
-
-(define (fold-left combine nil the-list . the-lists)
-  (if (null? the-lists)
-      (fold-left1 combine nil the-list)
-      (let loop ((accum nil) (list the-list) (lists the-lists))
-        (if (null? list)
-            accum
-            (loop (apply combine accum (car list) (map car lists))
-                  (cdr list)
-                  (map cdr lists))))))
-
-(define (fold-left1 combine nil list)
-  (let loop ((accum nil) (list list))
-    (if (null? list)
-        accum
-        (loop (combine accum (car list))
-              (cdr list)))))
-
-(define (fold-right combine nil the-list . the-lists)
-  (if (null? the-lists)
-      (fold-right1 combine nil the-list)
-      (let recur ((list the-list) (lists the-lists))
-        (if (null? list)
-            nil
-            (apply combine
-                   (car list)
-                   (append (map car lists)
-                           (cons (recur (cdr list) (map cdr lists))
-                                 '())))))))
-
-(define (fold-right1 combine nil list)
-  (let recur ((list list))
-    (if (null? list)
-        nil
-        (combine (car list) (recur (cdr list))))))
-
-(define (find proc list)
-  (let loop ((list list))
-    (cond
-      ((null? list) #f)
-      ((proc (car list)) (car list))
-      (else (loop (cdr list))))))
-
-(define (bitwise-if a b c)
-  (bitwise-ior (bitwise-and a b)
-               (bitwise-and (bitwise-not a) c)))
-
-(define (bitwise-reverse-bit-field n start end)
-  (let ([field (bitwise-bit-field n start end)]
-        [width (- end start)])
-    (let loop ([old field][new 0][width width])
-      (cond
-       [(zero? width) (bitwise-copy-bit-field n start end new)]
-       [else (loop (arithmetic-shift old -1)
-                   (bitwise-ior (arithmetic-shift new 1)
-                                (bitwise-and old 1))
-                   (sub1 width))]))))
-
-(define (bitwise-copy-bit-field to start end from)
-  (let* ([mask1 (arithmetic-shift -1 start)]
-         [mask2 (bitwise-not (arithmetic-shift -1 end))]
-         [mask (bitwise-and mask1 mask2)])
-    (bitwise-if mask
-                (arithmetic-shift from start)
-                to)))
-
-(define (bitwise-first-bit-set b)
-  (if (zero? b)
-      -1
-      (let loop ([b b][pos 0])
-        (if (zero? (bitwise-and b 1))
-            (loop (arithmetic-shift b -1) (add1 pos))
-            pos))))
-
-(define (bitwise-copy-bit b n bit)
-  (if (eq? bit 1)
-      (bitwise-ior b (arithmetic-shift 1 n))
-      (bitwise-and b (bitwise-not (arithmetic-shift 1 n)))))
-
-(define (div x y)
-  (quotient x y))
-
-(define (mod x y)
-  (modulo x y))
-
-(define (div-and-mod x y)
-  (values (div x y) (mod x y)))
-
-(define (hash-ref/pair ht key def-v)
-  (cdr (hash-ref ht key (cons #f def-v))))
-
-(define (hash-set!/pair ht key val)
-  (hash-set! ht key (cons (and (not (hash-weak? ht)) key) val)))
-
-(define (hash-ref-cell ht key def-v)
-  (or (hash-ref ht key #f)
-      (begin
-        (hash-set!/pair ht key def-v)
-        (hash-ref-cell ht key def-v))))
-
-;; HACK!
-(define-syntax (define-mutable-pair-hacks stx)
-  (syntax-case stx ()
-    [(_ set-car! set-cdr!)
-     (cond
-       [(eq? 'chez-scheme (system-type 'vm))
-        #'(begin
-            (require racket/linklet)
-            (define chez-eval (instantiate-linklet
-                               (compile-linklet '(linklet () () eval))
-                               null
-                               (make-instance 'scheme)))
-            (define set-car! (chez-eval 'set-car!))
-            (define set-cdr! (chez-eval 'set-cdr!)))]
-       [else
-        #'(begin
-            (define (set-car! p v) (unsafe-set-mcar! p v))
-            (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 (bytevector-ieee-double-native-set! bv pos val)
-  (real->floating-point-bytes val 8 (system-big-endian?) bv pos))
-(define (bytevector-ieee-double-native-ref bv pos)
-  (floating-point-bytes->real bv (system-big-endian?) pos (+ pos 8)))
-
-(define (bytevector-u64-native-set! bv pos val)
-  (integer->integer-bytes val 8 #f (system-big-endian?) bv pos))
-(define (bytevector-u64-native-ref bv pos)
-  (integer-bytes->integer bv #f (system-big-endian?) pos (+ pos 8)))
-
-(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)))))
-(define high-fixnum (sub1 (expt 2 (sub1 (fixnum-width)))))
-
-(define (most-positive-fixnum) high-fixnum)
-(define (most-negative-fixnum) low-fixnum)
-
-(define (s:fixnum? x)
-  (and (fixnum? x)
-       (<= low-fixnum x high-fixnum)))
-
-(define (make-compile-time-value v) v)
-
-(define optimize-level (make-parameter optimize-level-init))

racket/src/cs/bootstrap/r6rs-readtable.rkt

@@ -1,13 +0,0 @@
-#lang racket/base
-(require "gensym.rkt")
-
-(provide r6rs-readtable)
-
-(define (hash-bang c in src line col pos)
-  (make-special-comment (read-syntax/recursive src in)))
-
-(define r6rs-readtable
-  (make-readtable
-   #f
-   #\! 'dispatch-macro hash-bang
-   #\{ 'dispatch-macro hash-curly))

racket/src/cs/bootstrap/rcd.rkt

@@ -1,68 +0,0 @@
-#lang racket/base
-(require "scheme-struct.rkt"
-         (for-template racket/base))
-
-(provide rcd->constructor
-         (struct-out rcd-info)
-         rcd->rcdi)
-
-(define (rcd->constructor rcd lookup-protocol)
-  (define rtd (rec-cons-desc-rtd rcd))
-  (define ctr (struct-type-make-constructor rtd))
-  ((record-constructor-generator rcd lookup-protocol) ctr)) 
-
-(define (record-constructor-generator rcd lookup-protocol)
-  (define rtd (rec-cons-desc-rtd rcd))
-  (define p (rec-cons-desc-protocol rcd))
-  (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-    (struct-type-info rtd))
-  (cond
-    [(not p) (lambda (ctr) ctr)]
-    [(rec-cons-desc-parent-rcd rcd)
-     => (lambda (p-rcd)
-          (define p-gen (record-constructor-generator p-rcd lookup-protocol))
-          (and p-gen
-               (lambda (ctr)
-                 (p (p-gen
-                     (lambda args1
-                       (lambda args2
-                         (apply ctr (append args1 args2)))))))))]
-    [(and super (not lookup-protocol)) #f]
-    [super
-     (define parent-p (lookup-protocol super))
-     (lambda (ctr)
-       (p (parent-p
-           (lambda args1
-             (lambda args2
-               (apply ctr (append args1 args2)))))))]
-    [else p]))
-
-;; ----------------------------------------
-
-(struct rcd-info (rtd proto-expr base-rcdi init-cnt)
-  #:transparent)
-
-(define (rcd->rcdi rcd)
-  (cond
-    [(rec-cons-desc-parent-rcd rcd)
-     => (lambda (p-rcd)
-          (define p-rcdi (rcd->rcdi p-rcd))
-          (and p-rcdi
-               (let ()
-                 (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-                   (struct-type-info (rec-cons-desc-rtd rcd)))
-                 (define proto (rec-cons-desc-protocol rcd))
-                 (rcd-info (rec-cons-desc-rtd rcd)
-                           proto
-                           p-rcdi
-                           (+ init-cnt
-                              (rcd-info-init-cnt p-rcdi))))))]
-    [else
-     (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-       (struct-type-info (rec-cons-desc-rtd rcd)))
-     (define proto (rec-cons-desc-protocol rcd))
-     (and (not super)
-          (rcd-info (rec-cons-desc-rtd rcd)
-                    proto
-                    #f
-                    init-cnt))]))

racket/src/cs/bootstrap/record.rkt

@@ -1,583 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base)
-         racket/unsafe/ops
-         racket/vector
-         racket/list
-         "immediate.rkt"
-         "symbol.rkt"
-         "gensym.rkt"
-         "constant.rkt")
-
-(provide do-$make-record-type
-         register-rtd-name!
-         register-rtd-fields!
-         s:struct-type?
-
-         $make-record-type
-         $make-record-type-descriptor
-         $record
-         make-record-type
-         type-descriptor
-         record-predicate
-         record-accessor
-         record-mutator
-         compile-time-record-predicate
-         compile-time-record-accessor
-         compile-time-record-mutator
-         csv7:record-field-accessor
-         csv7:record-field-mutator
-         csv7:record-field-mutable?
-         record-rtd
-         record?
-         $record?
-         record-type-uid
-         record-type-name
-         record-type-sealed?
-         record-type-opaque?
-         record-type-parent
-         record-type-field-names
-         record-type-field-indices
-         csv7:record-type-field-names
-         csv7:record-type-field-indices
-         csv7:record-type-field-decls
-         record-writer
-         $object-ref)
-
-(define (s:struct-type? v)
-  (or (struct-type? v)
-      (base-rtd? v)))
-
-;; For rtds based on subtypes of #!base-rtd, the subtype instance
-;; that effectively extends the struct type with more fields:
-(define rtd-extensions (make-weak-hasheq))
-
-;; For structure types that extend #!base-rtd:
-(struct base-rtd-subtype () #:prefab)
-
-(define (subtype-of-base-rtd? rtd)
-  (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-    (struct-type-info rtd))
-  (and super
-       (or (eq? struct:base-rtd-subtype super)
-           (and (subtype-of-base-rtd? super)))))
-
-
-(define (do-$make-record-type in-base-rtd in-super in-name fields sealed? opaque? more
-                              #:uid [in-uid #f])
-  (define name (cond
-                 [(string? in-name) (string->symbol in-name)]
-                 [(gensym? in-name) (string->symbol (gensym->pretty-string in-name))]
-                 [else in-name]))
-  (define uid (or in-uid
-                  (cond
-                    [(gensym? in-name) in-name]
-                    [else #f])))
-  (define super
-    (cond
-      [(base-rtd? in-super) struct:base-rtd-subtype]
-      [else in-super]))
-  (define num-fields (if (vector? fields) (vector-length fields) (length fields)))
-  (define-values (struct:name make-name name? name-ref name-values)
-    (make-struct-type (or uid name) super num-fields 0 #f null (and uid 'prefab)))
-  (unless (base-rtd? in-base-rtd)
-    (hash-set! rtd-extensions struct:name (apply (struct-type-make-constructor in-base-rtd) more)))
-  (register-rtd-name! struct:name name)
-  (register-rtd-fields! struct:name fields)
-  (when sealed? (hash-set! rtd-sealed?s struct:name #t))
-  (when (or opaque?
-            (and super (hash-ref rtd-opaque?s super #f)))
-    (hash-set! rtd-opaque?s struct:name #t))
-  struct:name)
-
-(define ($make-record-type in-base-rtd super in-name fields sealed? opaque? . more)
-  (do-$make-record-type in-base-rtd super in-name fields sealed? opaque? more))
-
-(define ($make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields who . extras)
-  (do-$make-record-type base-rtd parent name (vector->list fields) sealed? opaque? extras #:uid uid))
-
-(define ($record rtd . args)
-  (cond
-    [(base-rtd? rtd)
-     (error "here")]
-    [(subtype-of-base-rtd? rtd)
-     (error "here, too" rtd args)]
-    [else
-     (apply (struct-type-make-constructor rtd) args)]))
-
-(define make-record-type
-  (case-lambda
-    [(parent in-name fields)
-     ($make-record-type base-rtd parent in-name fields #f #f)]
-    [(name fields)
-     (make-record-type #f name fields)]))
-
-
-(define rtd-names (make-weak-hasheq))
-
-(define (register-rtd-name! struct:name name)
-  (hash-set! rtd-names struct:name name))
-
-
-(define rtd-fields (make-weak-hasheq))
-
-;; Must match "cmacro.ss"
-(define (fld-name fld) (vector-ref fld 1))
-(define (fld-mutable? fld) (vector-ref fld 2))
-(define (fld-type fld) (vector-ref fld 3))
-(define (fld-byte fld) (vector-ref fld 4))
-(define (set-fld-byte! fld v) (vector-set! fld 4 v))
-(define fld-byte-value 0) ; doesn't matter; gets replaced in field vectors
-
-(define (register-rtd-fields! struct:name fields)
-  (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-    (struct-type-info struct:name))
-  (hash-set! rtd-fields struct:name (append
-                                     (cond
-                                       [(not super) null]
-                                       [(or (base-rtd? super)
-                                            (eq? super struct:base-rtd-subtype))
-                                        ;; fields added in `csv7:record-field-accessor`
-                                        null]
-                                       [else (hash-ref rtd-fields super)])
-                                     (normalize-fields
-                                      (if (vector? fields)
-                                          (for/list ([e (in-vector fields)])
-                                            (cond
-                                              [(symbol? e) (list 'immutable e)]
-                                              [(pair? (cdr e)) (list (car e) (cadr e))]
-                                              [else e]))
-                                          fields)))))
-
-(define (normalize-fields fields)
-  (unless (list? fields)
-    (error 'normalize-fields "not a list: ~s" fields))
-  (define (check-type t)
-    (case t
-      [(scheme-object uptr ptr double) t]
-      [else
-       (error 'make-struct-type "unsupported type ~s" t)]))
-  (define (is-mut? m)
-    (case m
-      [(mutable) #t]
-      [(immutable) #f]
-      [else (error 'make-struct-type "unrecognized mutability ~s" m)]))
-  (for/list ([field (in-list fields)])
-    (cond
-      [(and (vector? field)
-            (= 3 (vector-length field)))
-       (vector 'fld (vector-ref field 2) (is-mut? (vector-ref field 1)) (check-type (vector-ref field 0)) fld-byte-value)]
-      [(and (list? field)
-            (= 3 (length field)))
-       (vector 'fld (list-ref field 2) (is-mut? (list-ref field 0)) (check-type (list-ref field 1)) fld-byte-value)]
-      [(symbol? field)
-       (vector 'fld field #t 'scheme-object fld-byte-value)]
-      [(and (list? field)
-            (= 2 (length field)))
-       (vector 'fld (cadr field) (is-mut? (car field)) 'scheme-object fld-byte-value)]
-      [else
-       (error 'normalize-fields "unrecognized field format: ~s" field)])))
-
-(define-syntax (type-descriptor stx)
-  (syntax-case stx ()
-    [(_ id)
-     (car (syntax-local-value #'id))]))
-
-(define (record-predicate rtd)
-  (cond
-    [(base-rtd? rtd)
-     (lambda (v)
-       (or (base-rtd? v)
-           (base-rtd-subtype? v)))]
-    [else
-     (define pred (struct-type-make-predicate rtd))
-     (lambda (v)
-       (if (struct-type? v)
-           (pred (hash-ref rtd-extensions v #f))
-           (pred v)))]))
-
-(define (compile-time-record-predicate rtd)
-  (and (not (base-rtd-subtype-rtd? rtd))
-       (struct-type-make-predicate rtd)))
-
-(define (base-rtd-subtype-rtd? rtd)
-  (or (eq? struct:base-rtd-subtype rtd)
-      (let ()
-        (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-          (struct-type-info rtd))
-        (if super
-            (base-rtd-subtype-rtd? super)
-            #f))))
-
-;; `i` does not count parent fields
-(define (record-accessor rtd i [name #f])
-  (cond
-    [(base-rtd? rtd)
-     (error 'record-accessor "#!base-rtd not directly supported")]
-    [else
-     (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-       (struct-type-info rtd))
-     (define acc (make-struct-field-accessor ref i (or name (string->symbol (number->string i)))))
-     (if (subtype-of-base-rtd? rtd)
-         (lambda (rtd/ext)
-           (acc (if (struct-type? rtd/ext)
-                    (hash-ref rtd-extensions rtd/ext)
-                    rtd/ext)))
-         acc)]))
-
-(define (compile-time-record-accessor rtd i)
-  (and (not (base-rtd-subtype-rtd? rtd))
-       (let ()
-         (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-           (struct-type-info rtd))
-         (make-struct-field-accessor ref i))))
-
-;; `i` does not count parent fields
-(define (record-mutator rtd i [name #f])
-  (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-    (struct-type-info rtd))
-  (make-struct-field-mutator set i name))
-
-(define (compile-time-record-mutator rtd i)
-  (and (not (base-rtd-subtype-rtd? rtd))
-       (let ()
-         (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-           (struct-type-info rtd))
-         (make-struct-field-mutator set i))))
-
-(define base-rtd-fields
-  (map vector-copy
-       '(#(fld parent #f scheme-object 9)
-         #(fld size #f scheme-object 17)
-         #(fld pm #f scheme-object 25)
-         #(fld mpm #f scheme-object 33)
-         #(fld name #f scheme-object 41)
-         #(fld flds #f scheme-object 49)
-         #(fld flags #f scheme-object 57)
-         #(fld uid #f scheme-object 65)
-         #(fld counts #f scheme-object 73))))
-
-;; If `sym/i` is an integer, it *does* count parent fields
-(define (csv7:record-field-accessor/mutator rtd sym/i mut?)
-  (define (lookup-field-by-name rtd sym)
-    (define fields (hash-ref rtd-fields rtd))
-    (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-      (struct-type-info rtd))
-    (or (for/or ([field (in-list fields)]
-                 [i (in-naturals)])
-          (define name (fld-name field))
-          (and (eq? sym name)
-               (lookup-field-by-pos rtd i name)))
-        (error 'csv7:record-field-accessor
-               "cannot find ~a ~s in ~s"
-               (if mut? "mutator" "accessor")
-               sym
-               fields)))
-  ;; returns either a procedure or a number for a count of fields (less than `i`)
-  (define (lookup-field-by-pos rtd i [name #f] #:must-proc? [must-proc? #f])
-    (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-      (struct-type-info rtd))
-    (cond
-      [(not super)
-       (if (i . >= . init-cnt)
-           (if must-proc?
-               (error 'csv7:record-field-accessor/mutator "field count too large: ~a" i)
-               init-cnt)
-           (if mut?
-               (make-struct-field-mutator set i name)
-               (make-struct-field-accessor ref i name)))]
-      [else
-       (define s-proc (lookup-field-by-pos super i name))
-       (cond
-         [(integer? s-proc)
-          (if (i . >= . (+ s-proc init-cnt))
-              (if must-proc?
-                  (error 'csv7:record-field-accessor/mutator "field count too large: ~a" i)
-                  (+ s-proc init-cnt))
-              (if mut?
-                  (make-struct-field-mutator set (- i s-proc) name)
-                  (make-struct-field-accessor ref (- i s-proc) name)))]
-         [else s-proc])]))
-  (define (ptr-type? t)
-    (case t
-      [(scheme-object ptr) #t]
-      [(uptr double) #f]
-      [else (error "unrecognized type")]))
-  (define (assert-accessor)
-    (when mut? (error 'csv7:record-field-mutator "immutable base-rtd field")))
-  (cond
-    [(or (base-rtd? rtd)
-         (subtype-of-base-rtd? rtd))
-     (case sym/i
-       [(flds)
-        (assert-accessor)
-        (lambda (rtd)
-          (fix-offsets
-           (append
-            (if (or (base-rtd? rtd)
-                    (subtype-of-base-rtd? rtd))
-                base-rtd-fields
-                null)
-            (if (base-rtd? rtd)
-                null
-                (hash-ref rtd-fields rtd)))))]
-       [(parent)
-        (assert-accessor)
-        (lambda (rtd)
-          (cond
-            [(base-rtd? rtd) #f]
-            [else
-             (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-               (struct-type-info rtd))
-             (if (eq? super struct:base-rtd-subtype)
-                 base-rtd
-                 super)]))]
-       [(size)
-        (assert-accessor)
-        (lambda (rtd)
-          (let loop ([flds ((csv7:record-field-accessor base-rtd 'flds) rtd)] [x ptr-bytes])
-            (cond
-              [(null? flds) x]
-              [(eq? (fld-type (car flds)) 'double)
-               (let ([x (if (zero? (modulo x max-float-alignment))
-                            x
-                            (+ x (- 8 (modulo x max-float-alignment))))])
-                 (loop (cdr flds) (+ x 8)))]
-              [else (loop (cdr flds) (+ x ptr-bytes))])))]
-       [(pm)
-        (assert-accessor)
-        (lambda (rtd)
-          (define flds ((csv7:record-field-accessor base-rtd 'flds) rtd))
-          (cond
-            [(for/and ([fld (in-list flds)])
-               (ptr-type? (fld-type fld)))
-             -1]
-            [else
-             (for/fold ([m 1]) ([fld (in-list flds)]
-                                [i (in-naturals 1)]) ; start after base rtd
-               (if (ptr-type? (fld-type fld))
-                   (bitwise-ior m (arithmetic-shift 1 i))
-                   m))]))]
-       [(mpm)
-        (assert-accessor)
-        (lambda (rtd)
-          (for/fold ([m 0]) ([fld (in-list ((csv7:record-field-accessor base-rtd 'flds) rtd))]
-                             [i (in-naturals 1)])    ; start after base rtd
-            (if (and (fld-mutable? fld)
-                     (ptr-type? (fld-type fld)))
-                (bitwise-ior m (arithmetic-shift 1 i))
-                m)))]
-       [(name)
-        (assert-accessor)
-        record-type-name]
-       [(uid)
-        (assert-accessor)
-        record-type-uid]
-       [(flags)
-        (assert-accessor)
-        (lambda (rtd)
-          (bitwise-ior
-           (if (hash-ref rtd-opaque?s rtd #f)
-               (lookup-constant 'rtd-opaque)
-               0)
-           (if (hash-ref rtd-sealed?s rtd #f)
-               (lookup-constant 'rtd-sealed)
-               0)))]
-       [(counts)
-        (assert-accessor)
-        (lambda (rtd) #f)]
-       [else
-        (cond
-          [(and (integer? sym/i)
-                (base-rtd? rtd))
-           (assert-accessor)
-           (csv7:record-field-accessor rtd (fld-name (list-ref base-rtd-fields sym/i)))]
-          [(not (base-rtd? rtd))
-           (define proc (if (integer? sym/i)
-                            (lookup-field-by-pos rtd (- sym/i (length base-rtd-fields)) #:must-proc? #t)
-                            (lookup-field-by-name rtd sym/i)))
-           (if mut?
-               (lambda (rtd/ext v)
-                 (proc (if (struct-type? rtd/ext)
-                           (hash-ref rtd-extensions rtd/ext)
-                           rtd/ext)
-                       v))
-               (lambda (rtd/ext)
-                 (proc (if (struct-type? rtd/ext)
-                           (hash-ref rtd-extensions rtd/ext)
-                           rtd/ext))))]
-          [else
-           (error "unknown base-rtd field:" sym/i)])])]
-    [(integer? sym/i)
-     (lookup-field-by-pos rtd sym/i #:must-proc? #t)]
-    [else
-     (lookup-field-by-name rtd sym/i)]))
-
-;; If `sym/i` is an integer, it *does* count parent fields
-(define (csv7:record-field-accessor rtd sym/i)
-  (csv7:record-field-accessor/mutator rtd sym/i #f))
-
-;; If `sym/i` is an integer, it *does* count parent fields
-(define (csv7:record-field-mutator rtd sym/i)
-  (csv7:record-field-accessor/mutator rtd sym/i #t))
-
-;; `i` *does* count parent fields
-(define (csv7:record-field-mutable? rtd i)
-  (cond
-    [(or (base-rtd? rtd)
-         (subtype-of-base-rtd? rtd))
-     (error 'csv7:record-field-mutable? "not yet supported")]
-    [else
-     (define fields (hash-ref rtd-fields rtd))
-     (define f (list-ref fields i))
-     (fld-mutable? f)]))
-
-(define (record-rtd v)
-  (cond
-    [(base-rtd? v) base-rtd]
-    [(struct? v)
-     (define-values (s skipped?) (struct-info v))
-     s]
-    [(hash-ref rtd-extensions v #f)
-     => (lambda (ext)
-          (define-values (rtd skipped?) (struct-info ext))
-          rtd)]
-    [(struct-type? v) base-rtd]
-    [else (error 'record-rtd "not a record: ~s" v)]))
-
-(define record?
-  (case-lambda
-    [(v)
-     (and (not (bwp? v))
-          (not (black-hole? v))
-          (not ($unbound-object? v))
-          (or (struct? v)
-              (struct-type? v)
-              (base-rtd? v)))]
-    [(v rtd)
-     (and (or (struct? v)
-              (struct-type? v)
-              (base-rtd? v))
-          ((record-predicate rtd) v))]))
-
-(define ($record? v)
-  (record? v))
-
-(define (record-type-uid rtd)
-  (cond
-    [(base-rtd? rtd) '$base-rtd]
-    [else
-     (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-       (struct-type-info rtd))
-     r-name]))
-
-(define (record-type-name rtd)
-  (cond
-    [(base-rtd? rtd)
-     '$base-rtd]
-    [else
-     (hash-ref rtd-names rtd)]))
-
-(define (record-type-parent rtd)
-  (cond
-    [(base-rtd? rtd) #f]
-    [else
-     (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-       (struct-type-info rtd))
-     super]))
-
-;; all fields, including from parent
-(define (csv7:record-type-field-names rtd)
-  (cond
-    [(base-rtd? rtd)
-     (map fld-name base-rtd-fields)]
-    [else
-     (map fld-name (hash-ref rtd-fields rtd))]))
-
-;; all fields, including from parent
-(define (csv7:record-type-field-indices rtd)
-  (cond
-    [(base-rtd? rtd)
-     (for/list ([f (in-list base-rtd-fields)]
-                [i (in-naturals)])
-       i)]
-    [else
-     (for/list ([f (in-list (hash-ref rtd-fields rtd))]
-                [i (in-naturals)])
-       i)]))
-
-;; does not include parent fields
-(define (record-type-field-names rtd)
-  (cond
-    [(base-rtd? rtd)
-     (list->vector (csv7:record-type-field-names rtd))]
-    [else
-     (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-       (struct-type-info rtd))
-     (define all-fields (hash-ref rtd-fields rtd))
-     (define fields (reverse (take (reverse all-fields) init-cnt)))
-     (list->vector (map fld-name fields))]))
-
-;; does not include parent fields
-(define (record-type-field-indices rtd)
-  (cond
-    [(base-rtd? rtd)
-     (list->vector (csv7:record-type-field-indices rtd))]
-    [else
-     (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
-       (struct-type-info rtd))
-     (for/vector ([i (in-range init-cnt)])
-       i)]))
-
-(define (csv7:record-type-field-decls rtd)
-  (map (lambda (v) (list (if (fld-mutable? v) 'mutable 'immutable) (fld-type v) (fld-name v)))
-       (hash-ref rtd-fields rtd)))
-
-(define rtd-sealed?s (make-weak-hasheq))
-(define (record-type-sealed? rtd)
-  (hash-ref rtd-sealed?s rtd #f))
-
-(define rtd-opaque?s (make-weak-hasheq))
-(define (record-type-opaque? rtd)
-  (hash-ref rtd-opaque?s rtd #f))
-
-(define (record-writer . args)
-  (void))
-
-(define (fix-offsets flds)
-  (let loop ([flds flds] [offset ptr-bytes])
-    (unless (null? flds)
-      (cond
-        [(eq? (fld-type (car flds)) 'double)
-         (let ([offset (if (zero? (modulo offset max-float-alignment))
-                           offset
-                           (+ offset (- 8 (modulo offset max-float-alignment))))])
-           (set-fld-byte! (car flds)  (+ record-ptr-offset offset))
-           (loop (cdr flds) (+ offset 8)))]
-        [else
-         (set-fld-byte! (car flds)  (+ record-ptr-offset offset))
-         (loop (cdr flds) (+ offset ptr-bytes))])))
-  flds)
-
-;; assumes that `v` has only pointer-sized fields
-(define ($object-ref type v offset)
-  (cond
-    [(flonum? v)
-     (case type
-       [(unsigned-64)
-        (integer-bytes->integer (real->floating-point-bytes v 8) #f)]
-       [else (error "unrecognized floating-point access" type offset)])]
-    [else
-     (unless (or (eq? type 'scheme-object)
-                 (eq? type 'ptr))
-       (error '$object-ref "unrecognized type: ~e" type))
-     (define i (quotient (- offset (+ record-ptr-offset ptr-bytes)) ptr-bytes))
-     (cond
-       [(struct-type? v)
-        (cond
-          [(i . < . (length base-rtd-fields))
-           ((csv7:record-field-accessor/mutator base-rtd i #f) v)]
-          [else
-           (error '$object-ref "not yet supported for base-rtd subtypes")])]
-       [(base-rtd? v)
-        ((csv7:record-field-accessor/mutator base-rtd i #f) v)]
-       [else (unsafe-struct-ref v i)])]))

racket/src/cs/bootstrap/scheme-readtable.rkt

@@ -1,168 +0,0 @@
-#lang racket/base
-(require racket/fixnum
-         racket/port
-         "immediate.rkt"
-         "gensym.rkt")
-
-(provide scheme-readtable)
-
-(define (hash-three c in src line col pos)
-  (define got-c (peek-char in))
-  (cond
-    [(eqv? #\% got-c)
-     (read-char in)
-     `($primitive 3 ,(read/recursive in))]
-    [else
-     (hash-graph #\3 in src line col pos)]))
-
-(define (hash-two c in src line col pos)
-  (define got-c (peek-char in))
-  (cond
-    [(eqv? #\% got-c)
-     (read-char in)
-     `($primitive 2 ,(read/recursive in))]
-    [else
-     (hash-graph #\2 in src line col pos)]))
-
-(define (hash-one c in src line col pos)
-  (define got-c (peek-char in))
-  (cond
-    [(eqv? #\# got-c)
-     ;; "read.ss" has a `#1#` reference before the
-     ;; `#1=...` definition; it's going to turn out
-     ;; to be `black-hole`
-     (define name (object-name in))
-     (cond
-       [(and (or (string? name) (path? name))
-             (regexp-match? #rx"read[.]ss$" name))
-        (read-char in)
-        black-hole]
-       [else
-        (hash-graph #\1 in src line col pos)])]
-    [else
-     (hash-graph #\1 in src line col pos)]))
-
-(define (hash-graph c in src line col pos)
-  (cond
-    [(and (eqv? (peek-char in) #\=)
-          (eqv? (peek-char in 1) #\#)
-          (eqv? (peek-char in 2) c)
-          (eqv? (peek-char in 3) #\#))
-     (read-string 4 in)
-     black-hole]
-    [else
-     (define new-in (input-port-append #f (open-input-string (string #\# c)) in))
-     (read/recursive new-in #f #f #t)]))
-
-(define (hash-percent c in src line col pos)
-  `($primitive ,(read/recursive in)))
-
-(define (hash-bang c in src line col pos)
-  (define sym (read/recursive in))
-  (case sym
-    [(eof) eof]
-    [(base-rtd) base-rtd]
-    [(bwp) bwp]
-    [(chezscheme) (make-special-comment 'chezscheme)]
-    [else (error 'hash-bang "unrecognized ~s" sym)]))
-
-(define ((paren closer) c in src line col pos)
-  ;; parse a list, but allow an eof element as produced by #!eof
-  (let loop ()
-    (define c (peek-char in))
-    (cond
-      [(eqv? closer c)
-       (read-char in)
-       null]
-      [(char-whitespace? c)
-       (read-char in)
-       (loop)]
-      [(and (eqv? #\. c)
-            (char-whitespace? (peek-char in 1)))
-       (read-char in)
-       (begin0
-         (read/recursive in)
-         (let loop ()
-           (define c (read-char in))
-           (cond
-             [(char-whitespace? c) (loop)]
-             [(eqv? c closer) (void)]
-             [else (error 'parens "unexpected: ~s" c)])))]
-      [else
-       (define v (read/recursive in))
-       (if (special-comment? v)
-           (loop)
-           (cons v (loop)))])))
-
-(define (hash-backslash c in src line col pos)
-  (define next-c (peek-char in))
-  (cond
-    [(or (char-alphabetic? next-c)
-         (char-numeric? next-c))
-     (define sym (read/recursive in))
-     (case sym
-       [(newline) #\newline]
-       [(return) #\return]
-       [(nel) #\u85]
-       [(ls) #\u2028]
-       [(space) #\space]
-       [(nul) #\nul]
-       [(tab) #\tab]
-       [(vtab vt) #\vtab]
-       [(page) #\page]
-       [(alarm bel) #\u7]
-       [(backspace) #\backspace]
-       [(esc) #\u1b]
-       [(delete) #\u7F]
-       [(rubout) #\rubout]
-       [(linefeed) #\linefeed]
-       [(0 1 2 3 4 5 6 7 8 9)
-        (integer->char (+ sym (char->integer #\0)))]
-       [else
-        (define str (symbol->string sym))
-        (cond
-          [(= 1 (string-length str))
-           (string-ref str 0)]
-          [(eqv? #\x (string-ref str 0))
-           (integer->char (string->number (substring str 1) 16))]
-          [else
-           (error 'hash-backslash "unrecognized ~s" str)])])]
-    [else (read-char in)]))
-
-(define (hash-vee c in src line col pos)
-  (case (read-char in)
-    [(#\u)
-     (unless (eqv? #\8 (read-char in)) (error 'hash-vee "not 8"))
-     (define l (read/recursive in))
-     (list->bytes l)]
-    [(#\f)
-     (unless (eqv? #\x (read-char in)) (error 'hash-vee "not 8"))
-     (define l (read/recursive in))
-     (apply fxvector l)]
-    [else (error 'hash-vee "unexpected")]))
-
-(define (as-symbol c in src line col pos)
-  (string->symbol (string c)))
-
-(define scheme-readtable
-  (make-readtable
-   #f
-   #\0 'dispatch-macro hash-graph
-   #\1 'dispatch-macro hash-one
-   #\2 'dispatch-macro hash-two
-   #\3 'dispatch-macro hash-three
-   #\4 'dispatch-macro hash-graph
-   #\5 'dispatch-macro hash-graph
-   #\6 'dispatch-macro hash-graph
-   #\7 'dispatch-macro hash-graph
-   #\8 'dispatch-macro hash-graph
-   #\9 'dispatch-macro hash-graph
-   #\% 'dispatch-macro hash-percent
-   #\! 'dispatch-macro hash-bang
-   #\{ 'dispatch-macro hash-curly
-   #\{ 'terminating-macro as-symbol
-   #\} 'terminating-macro as-symbol
-   #\[ 'terminating-macro (paren #\])
-   #\( 'terminating-macro (paren #\))
-   #\\ 'dispatch-macro hash-backslash
-   #\v 'dispatch-macro hash-vee))

racket/src/cs/bootstrap/scheme-struct.rkt

@@ -1,26 +0,0 @@
-#lang racket/base
-
-(provide (all-defined-out))
-
-(struct syntax-object (e ctx) #:prefab #:mutable
-  #:reflection-name '|{syntax-object bdehkef6almh6ypb-a}|)
-
-(struct top-ribcage (x y) #:prefab #:mutable
-  #:reflection-name '|{top-ribcage fxdfzth2q3h88vd-a}|)
-
-(struct fixed-ribcage (x y z) #:prefab #:mutable
-  #:reflection-name '|{fixed-ribcage cqxefau3fa3vz4m0-0}|)
-
-(struct extensible-ribcage (chunks) #:prefab #:mutable
-  #:reflection-name '|{extensible-ribcage cqxefau3fa3vz4m0-1}|)
-
-(struct local-label (binding level) #:prefab #:mutable)
-
-(struct rec-cons-desc (rtd parent-rcd protocol) #:prefab #:mutable
-  #:reflection-name '|{rcd qh0yzh5qyrxmz2l-a}|)
-
-(struct primref2 (name flags arity) #:prefab #:mutable
-  #:reflection-name '|{primref a0xltlrcpeygsahopkplcn-2}|)
-
-(struct primref3 (name flags arity signatures) #:prefab #:mutable
-  #:reflection-name '|{primref a0xltlrcpeygsahopkplcn-3}|)

racket/src/cs/bootstrap/strip.rkt

@@ -1,30 +0,0 @@
-#lang racket/base
-
-(provide strip-$primitive
-         strip-$app)
-
-(define (strip-$primitive e)
-  (cond
-    [(and (pair? e)
-          (eq? (car e) 'quote))
-     e]
-    [(and (pair? e)
-          (eq? (car e) '$primitive))
-     (if (pair? (cddr e))
-         (caddr e)
-         (cadr e))]
-    [(list? e)
-     (map strip-$primitive e)]
-    [else e]))
-
-(define (strip-$app e)
-  (cond
-    [(and (pair? e)
-          (eq? (car e) 'quote))
-     e]
-    [(and (pair? e)
-          (eq? (car e) '$app))
-     (strip-$app (cdr e))]
-    [(list? e)
-     (map strip-$app e)]
-    [else e]))

racket/src/cs/bootstrap/symbol.rkt

@@ -1,52 +0,0 @@
-#lang racket/base
-
-(provide oblist
-         s:string->symbol
-         register-symbols
-
-         putprop getprop remprop
-         $sputprop $sgetprop $sremprop
-
-         lookup-constant)
-
-(define syms (make-hasheq))
-
-(define (oblist)
-  (hash-keys syms))
-
-(define (s:string->symbol str)
-  (define s (string->symbol str))
-  (hash-set! syms s #t)
-  s)
-
-(define (register-symbols v)
-  (cond
-    [(symbol? v) (hash-set! syms v #t)]
-    [(pair? v)
-     (register-symbols (car v))
-     (register-symbols (cdr v))]
-    [(box? v)
-     (register-symbols (unbox v))]
-    [(vector? v)
-     (for ([i (in-vector v)])
-       (register-symbols v))]))
-
-     
-(define (make-put-get ht)
-  (values
-   (lambda (sym key val)
-     (hash-set! syms sym #t)
-     (hash-update! ht sym (lambda (ht) (hash-set ht key val)) #hasheq()))
-   (lambda (sym key [def-val #f])
-     (hash-ref (hash-ref ht sym #hasheq()) key def-val))
-   (lambda (sym key)
-     (hash-update! ht sym (lambda (ht) (hash-remove ht key)) #hasheq()))))
-
-(define-values (putprop getprop remprop) (make-put-get (make-hasheq)))
-(define-values ($sputprop $sgetprop $sremprop) (make-put-get (make-hasheq)))
-
-(define (lookup-constant key [fail #f])
-  (or (getprop key '*constant* #f)
-      (if fail
-          (fail)
-          (error key "cannot find value"))))

racket/src/cs/bootstrap/syntax-mode.rkt

@@ -1,7 +0,0 @@
-#lang racket/base
-
-(provide fully-unwrap?
-         start-fully-unwrapping-syntax!)
-
-(define fully-unwrap? #f)
-(define (start-fully-unwrapping-syntax!) (set! fully-unwrap? #t))

racket/src/cs/c/Makefile.in

@@ -152,7 +152,7 @@ SCHEME_CONFIG_VARS = CC="$(CC)" CFLAGS="$(BASE_CFLAGS)" LDFLAGS="$(LDFLAGS)" \
                      WINDRES="$(WINDRES)"
 
 scheme-make-finish:
-	env SCHEME_SRC="$(SCHEME_SRC)" MACH="$(MACH)" $(BOOTSTRAP_RACKET) $(srcdir)/../bootstrap/make-boot.rkt
+	env SCHEME_SRC="$(SCHEME_SRC)" MACH="$(MACH)" $(BOOTSTRAP_RACKET) "$(SCHEME_SRC)"/rktboot/make-boot.rkt
 	cd $(SCHEME_SRC) && ./configure @SCHEME_CONFIG_ARGS@ $(SCHEME_CONFIG_VARS)
 	$(MAKE) sync-bootfiles
 	cd $(SCHEME_SRC) && $(MAKE)
@@ -185,7 +185,7 @@ $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/scheme.boot: $(SCHEME_SRC)/boot/$(MACH)/schem
 
 scheme-cross:
 	cd $(SCHEME_SRC) && git submodule -q init && git submodule -q update
-	env MAKE_BOOT_FOR_CROSS=yes SCHEME_SRC="$(SCHEME_SRC)" MACH="$(TARGET_MACH)" $(BOOTSTRAP_RACKET) $(srcdir)/../bootstrap/make-boot.rkt
+	env MAKE_BOOT_FOR_CROSS=yes SCHEME_SRC="$(SCHEME_SRC)" MACH="$(TARGET_MACH)" $(BOOTSTRAP_RACKET) "$(SCHEME_SRC)"/rktboot/make-boot.rkt
 	$(MAKE) sync-bootfiles MACH="$(TARGET_MACH)"
 	cd $(SCHEME_SRC) && ./configure @SCHEME_CROSS_CONFIG_ARGS@ $(SCHEME_CONFIG_VARS)
 	cd $(SCHEME_SRC)/$(TARGET_MACH)/c && $(MAKE) o=o cross=t

racket/src/worksp/csbuild.rkt

@@ -125,7 +125,7 @@
 				       (orig-exit v))))])
     (putenv "SCHEME_SRC" (path->string scheme-dir))
     (putenv "MACH" machine)
-    (dynamic-require (build-path here 'up "cs" "bootstrap" "make-boot.rkt") #f)))
+    (dynamic-require (build-path scheme-dir "rktboot" "make-boot.rkt") #f)))
 
 ;; Prepare to use Chez Scheme makefile
 (prep-chez-scheme scheme-dir machine)