From efc95c2e1958d5d22034abb4724abc6537f9967d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 25 Jul 2020 15:38:31 -0600 Subject: [PATCH] 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 | 2 +- racket/src/cs/bootstrap/Makefile | 6 - racket/src/cs/bootstrap/README.txt | 19 - racket/src/cs/bootstrap/config.rkt | 34 - racket/src/cs/bootstrap/constant.rkt | 92 -- racket/src/cs/bootstrap/define-datatype.rkt | 78 -- racket/src/cs/bootstrap/format.rkt | 162 --- racket/src/cs/bootstrap/gensym.rkt | 64 - racket/src/cs/bootstrap/hand-coded.rkt | 29 - racket/src/cs/bootstrap/immediate.rkt | 16 - racket/src/cs/bootstrap/info.rkt | 10 - racket/src/cs/bootstrap/main.rkt | 29 - racket/src/cs/bootstrap/make-boot.rkt | 435 ------ racket/src/cs/bootstrap/nanopass-patch.rkt | 31 - racket/src/cs/bootstrap/parse-makefile.rkt | 17 - racket/src/cs/bootstrap/primdata.rkt | 108 -- racket/src/cs/bootstrap/r6rs-lang.rkt | 813 ----------- racket/src/cs/bootstrap/r6rs-readtable.rkt | 13 - racket/src/cs/bootstrap/rcd.rkt | 68 - racket/src/cs/bootstrap/record.rkt | 583 -------- racket/src/cs/bootstrap/scheme-lang.rkt | 1260 ------------------ racket/src/cs/bootstrap/scheme-readtable.rkt | 168 --- racket/src/cs/bootstrap/scheme-struct.rkt | 26 - racket/src/cs/bootstrap/strip.rkt | 30 - racket/src/cs/bootstrap/symbol.rkt | 52 - racket/src/cs/bootstrap/syntax-mode.rkt | 7 - racket/src/cs/c/Makefile.in | 4 +- racket/src/worksp/csbuild.rkt | 2 +- 28 files changed, 4 insertions(+), 4154 deletions(-) delete mode 100644 racket/src/cs/bootstrap/Makefile delete mode 100644 racket/src/cs/bootstrap/README.txt delete mode 100644 racket/src/cs/bootstrap/config.rkt delete mode 100644 racket/src/cs/bootstrap/constant.rkt delete mode 100644 racket/src/cs/bootstrap/define-datatype.rkt delete mode 100644 racket/src/cs/bootstrap/format.rkt delete mode 100644 racket/src/cs/bootstrap/gensym.rkt delete mode 100644 racket/src/cs/bootstrap/hand-coded.rkt delete mode 100644 racket/src/cs/bootstrap/immediate.rkt delete mode 100644 racket/src/cs/bootstrap/info.rkt delete mode 100644 racket/src/cs/bootstrap/main.rkt delete mode 100644 racket/src/cs/bootstrap/make-boot.rkt delete mode 100644 racket/src/cs/bootstrap/nanopass-patch.rkt delete mode 100644 racket/src/cs/bootstrap/parse-makefile.rkt delete mode 100644 racket/src/cs/bootstrap/primdata.rkt delete mode 100644 racket/src/cs/bootstrap/r6rs-lang.rkt delete mode 100644 racket/src/cs/bootstrap/r6rs-readtable.rkt delete mode 100644 racket/src/cs/bootstrap/rcd.rkt delete mode 100644 racket/src/cs/bootstrap/record.rkt delete mode 100644 racket/src/cs/bootstrap/scheme-lang.rkt delete mode 100644 racket/src/cs/bootstrap/scheme-readtable.rkt delete mode 100644 racket/src/cs/bootstrap/scheme-struct.rkt delete mode 100644 racket/src/cs/bootstrap/strip.rkt delete mode 100644 racket/src/cs/bootstrap/symbol.rkt delete mode 100644 racket/src/cs/bootstrap/syntax-mode.rkt diff --git a/Makefile b/Makefile index 63e93f1df5..ab84dac092 100644 --- a/Makefile +++ b/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 diff --git a/racket/src/cs/bootstrap/Makefile b/racket/src/cs/bootstrap/Makefile deleted file mode 100644 index f4c7d70557..0000000000 --- a/racket/src/cs/bootstrap/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -RACKET=racket - -SCHEME_SRC=../../build/ChezScheme - -boot: - env SCHEME_SRC="$(SCHEME_SRC)" $(RACKET) make-boot.rkt diff --git a/racket/src/cs/bootstrap/README.txt b/racket/src/cs/bootstrap/README.txt deleted file mode 100644 index 552d78df2d..0000000000 --- a/racket/src/cs/bootstrap/README.txt +++ /dev/null @@ -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 "/boot/" 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. diff --git a/racket/src/cs/bootstrap/config.rkt b/racket/src/cs/bootstrap/config.rkt deleted file mode 100644 index 7a969017ed..0000000000 --- a/racket/src/cs/bootstrap/config.rkt +++ /dev/null @@ -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) diff --git a/racket/src/cs/bootstrap/constant.rkt b/racket/src/cs/bootstrap/constant.rkt deleted file mode 100644 index 6d3edcc4af..0000000000 --- a/racket/src/cs/bootstrap/constant.rkt +++ /dev/null @@ -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) diff --git a/racket/src/cs/bootstrap/define-datatype.rkt b/racket/src/cs/bootstrap/define-datatype.rkt deleted file mode 100644 index bbb090f617..0000000000 --- a/racket/src/cs/bootstrap/define-datatype.rkt +++ /dev/null @@ -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))))) diff --git a/racket/src/cs/bootstrap/format.rkt b/racket/src/cs/bootstrap/format.rkt deleted file mode 100644 index 9ce0cb9d2d..0000000000 --- a/racket/src/cs/bootstrap/format.rkt +++ /dev/null @@ -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)]))])) diff --git a/racket/src/cs/bootstrap/gensym.rkt b/racket/src/cs/bootstrap/gensym.rkt deleted file mode 100644 index e7310ff20d..0000000000 --- a/racket/src/cs/bootstrap/gensym.rkt +++ /dev/null @@ -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))))) - diff --git a/racket/src/cs/bootstrap/hand-coded.rkt b/racket/src/cs/bootstrap/hand-coded.rkt deleted file mode 100644 index f4e65a9d77..0000000000 --- a/racket/src/cs/bootstrap/hand-coded.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/cs/bootstrap/immediate.rkt b/racket/src/cs/bootstrap/immediate.rkt deleted file mode 100644 index ac38615cc2..0000000000 --- a/racket/src/cs/bootstrap/immediate.rkt +++ /dev/null @@ -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?) diff --git a/racket/src/cs/bootstrap/info.rkt b/racket/src/cs/bootstrap/info.rkt deleted file mode 100644 index 716bade2e6..0000000000 --- a/racket/src/cs/bootstrap/info.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/cs/bootstrap/main.rkt b/racket/src/cs/bootstrap/main.rkt deleted file mode 100644 index 3dd96f6e9c..0000000000 --- a/racket/src/cs/bootstrap/main.rkt +++ /dev/null @@ -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) diff --git a/racket/src/cs/bootstrap/make-boot.rkt b/racket/src/cs/bootstrap/make-boot.rkt deleted file mode 100644 index 473d15bf3d..0000000000 --- a/racket/src/cs/bootstrap/make-boot.rkt +++ /dev/null @@ -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))))) diff --git a/racket/src/cs/bootstrap/nanopass-patch.rkt b/racket/src/cs/bootstrap/nanopass-patch.rkt deleted file mode 100644 index 4a4074d6e0..0000000000 --- a/racket/src/cs/bootstrap/nanopass-patch.rkt +++ /dev/null @@ -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)])) diff --git a/racket/src/cs/bootstrap/parse-makefile.rkt b/racket/src/cs/bootstrap/parse-makefile.rkt deleted file mode 100644 index 92793fc474..0000000000 --- a/racket/src/cs/bootstrap/parse-makefile.rkt +++ /dev/null @@ -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)))) - - diff --git a/racket/src/cs/bootstrap/primdata.rkt b/racket/src/cs/bootstrap/primdata.rkt deleted file mode 100644 index 1b3f773a29..0000000000 --- a/racket/src/cs/bootstrap/primdata.rkt +++ /dev/null @@ -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)])) diff --git a/racket/src/cs/bootstrap/r6rs-lang.rkt b/racket/src/cs/bootstrap/r6rs-lang.rkt deleted file mode 100644 index fbe8025931..0000000000 --- a/racket/src/cs/bootstrap/r6rs-lang.rkt +++ /dev/null @@ -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>=?] - [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)) diff --git a/racket/src/cs/bootstrap/r6rs-readtable.rkt b/racket/src/cs/bootstrap/r6rs-readtable.rkt deleted file mode 100644 index 461a8d82f5..0000000000 --- a/racket/src/cs/bootstrap/r6rs-readtable.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/cs/bootstrap/rcd.rkt b/racket/src/cs/bootstrap/rcd.rkt deleted file mode 100644 index 6f450fc7e1..0000000000 --- a/racket/src/cs/bootstrap/rcd.rkt +++ /dev/null @@ -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))])) diff --git a/racket/src/cs/bootstrap/record.rkt b/racket/src/cs/bootstrap/record.rkt deleted file mode 100644 index c88ed47556..0000000000 --- a/racket/src/cs/bootstrap/record.rkt +++ /dev/null @@ -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)])])) diff --git a/racket/src/cs/bootstrap/scheme-lang.rkt b/racket/src/cs/bootstrap/scheme-lang.rkt deleted file mode 100644 index 932ff97c75..0000000000 --- a/racket/src/cs/bootstrap/scheme-lang.rkt +++ /dev/null @@ -1,1260 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base - racket/match) - (prefix-in r: racket/include) - racket/fixnum - racket/flonum - racket/vector - racket/splicing - racket/pretty - racket/dict - "config.rkt" - (for-syntax "config.rkt") - (for-syntax "constant.rkt") - "immediate.rkt" - "define-datatype.rkt" - "primdata.rkt" - "gensym.rkt" - "format.rkt" - "hand-coded.rkt" - "scheme-struct.rkt" - "symbol.rkt" - "record.rkt" - (for-syntax "record.rkt") - "constant.rkt" - (only-in "r6rs-lang.rkt" - make-record-constructor-descriptor - set-car! - set-cdr!) - (submod "r6rs-lang.rkt" hash-pair) - (for-syntax "scheme-struct.rkt" - "rcd.rkt")) - -(provide (rename-out [s:define define] - [s:define define-threaded] - [s:define define-who] - [gen-let-values let-values] - [s:module module] - [s:parameterize parameterize]) - set-who! - import - include - when-feature - fluid-let - letrec* - putprop getprop remprop - $sputprop $sgetprop $sremprop - define-flags - $primitive - $tc $tc-field $thread-tc - enumerate - $make-record-type - $make-record-type-descriptor - $make-record-type-descriptor* - $make-record-constructor-descriptor - $record - $record? - $primitive - $unbound-object? - $app - (rename-out [get-$unbound-object $unbound-object]) - meta-cond - constant - $target-machine - $sfd - $current-mso - $block-counter - define-datatype - datum - rec - with-tc-mutex - with-values - make-record-type - type-descriptor - csv7:record-field-accessor - csv7:record-field-mutator - csv7:record-field-mutable? - record-writer - record-rtd - 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 - (rename-out [record-rtd $record-type-descriptor]) - record? - record-type-uid - $object-ref - stencil-vector? - (rename-out [s:vector-sort vector-sort] - [s:vector-sort! vector-sort!]) - vector-for-each - vector-map - primvec - get-priminfo - $top-level-value - $set-top-level-value! - $profile-source-data? - $compile-profile - compile-profile - $optimize-closures - $profile-block-data? - run-cp0 - generate-interrupt-trap - $track-dynamic-closure-counts - $suppress-primitive-inlining - uninterned-symbol? string->uninterned-symbol - debug-level - scheme-version-number - scheme-fork-version-number - (rename-out [make-parameter $make-thread-parameter] - [make-parameter make-thread-parameter] - [cons make-binding] - [car binding-type] - [cdr binding-value] - [set-car! set-binding-type!] - [set-cdr! set-binding-value!] - [mpair? binding?] - [fx+ r6rs:fx+] - [fx- r6rs:fx-] - [add1 fx1+] - [sub1 fx1-] - [add1 1+] - [sub1 1-] - [fxand fxlogand] - [fxior fxlogor] - [fxior fxlogior] - [fxxor fxlogxor] - [fxlshift fxsll] - [bitwise-bit-count fxbit-count] - [arithmetic-shift ash] - [arithmetic-shift bitwise-arithmetic-shift-left] - [arithmetic-shift bitwise-arithmetic-shift] - [fxrshift fxsra] - [bitwise-not lognot] - [bitwise-ior logor] - [bitwise-xor logxor] - [bitwise-ior logior] - [bitwise-and logand] - [bitwise-bit-set? fxbit-set?] - [integer-length bitwise-length] - [->fl fixnum->flonum] - [+ cfl+] - [- cfl-] - [* cfl*] - [/ cfl/] - [= cfl=] - [/ fx/] - [real-part cfl-real-part] - [imag-part cfl-imag-part] - [real-part $exactnum-real-part] - [imag-part $exactnum-imag-part] - [numerator $ratio-numerator] - [denominator $ratio-denominator] - [= r6rs:=] - [char=? r6rs:char=?] - [s:error $oops] - [error $undefined-violation] - [error errorf] - [error warningf] - [make-bytes make-bytevector] - [bytes bytevector] - [bytes-length bytevector-length] - [bytes? bytevector?] - [bytes-set! bytevector-u8-set!] - [bytes-ref bytevector-u8-ref] - [bwp? bwp-object?] - [number->string r6rs:number->string] - [s:printf printf] - [s:fprintf fprintf] - [file-position port-position] - [file-position set-port-position!] - [write-string display-string] - [call/ec call/1cc] - [s:string->symbol string->symbol]) - logbit? logbit1 logbit0 logtest - (rename-out [logbit? fxlogbit?] - [logbit1 fxlogbit1] - [logbit0 fxlogbit0] - [logtest fxlogtest]) - $fxu< - fxsrl - fxbit-field - fxpopcount - fxpopcount32 - fxpopcount16 - bitwise-bit-count - bitwise-arithmetic-shift-right - bytevector-u16-native-ref - bytevector-s16-native-ref - bytevector-u32-native-ref - bytevector-s32-native-ref - bytevector-u64-native-ref - bytevector-s64-native-ref - bytevector-s16-ref - bytevector-u16-ref - bytevector-s32-ref - bytevector-u32-ref - bytevector-s64-ref - bytevector-u64-ref - $integer-64? - $integer-32? - $flonum->digits - $flonum-sign - syntax-error - $source-warning - all-set? - any-set? - iota - list-head - subst substq substv - (rename-out [subst subst!] - [substv substv!] - [substq substq!]) - nonnegative? - nonpositive? - (rename-out [nonnegative? fxnonnegative?] - [nonpositive? fxnonpositive?]) - last-pair - oblist - make-hashtable - make-weak-eq-hashtable - symbol-hash - hashtable-keys - hashtable-entries - eq-hashtable? - eq-hashtable-weak? - eq-hashtable-ephemeron? - symbol-hashtable? - hashtable-equivalence-function - hashtable-mutable? - $ht-minlen - $ht-veclen - (rename-out [hash? hashtable?] - [hash-ref/pair/dict hashtable-ref] - [hash-ref/pair/dict eq-hashtable-ref] - [hash-ref-cell eq-hashtable-cell] - [hash-set!/pair/dict hashtable-set!] - [hash-remove! eq-hashtable-delete!] - [equal-hash-code string-hash] - [hash-set!/pair/dict symbol-hashtable-set!] - [hash-has-key? symbol-hashtable-contains?] - [hash-has-key? eq-hashtable-contains?] - [hash-ref/pair/dict symbol-hashtable-ref] - [hash-ref-cell symbol-hashtable-cell]) - bignum? - ratnum? - $inexactnum? - $exactnum? - $rtd-counts? - (rename-out [symbol->string $symbol-name]) - self-evaluating? - list-sort - (rename-out [list-sort sort]) - path-absolute? - subset-mode - weak-pair? - ephemeron-pair? - immutable-string? - immutable-vector? - immutable-bytevector? - immutable-fxvector? - immutable-box? - require-nongenerative-clause - generate-inspector-information - generate-procedure-source-information - enable-cross-library-optimization - enable-arithmetic-left-associative - enable-type-recovery - fasl-compressed - current-expand - current-generate-id - internal-defines-as-letrec* - eval-syntax-expanders-when - prelex-assigned set-prelex-assigned! - prelex-referenced set-prelex-referenced! - prelex-seen set-prelex-seen! - prelex-multiply-referenced set-prelex-multiply-referenced! - safe-assert - print-gensym $intern3 - print-level - print-depth - print-length - (rename-out [s:pretty-format pretty-format]) - interpret - who - with-source-path - $make-source-oops - $guard - $reset-protect - $map - $open-file-input-port - $open-file-output-port - (rename-out [s:open-output-file open-output-file]) - $open-bytevector-list-output-port - open-bytevector-output-port - native-transcoder - port-file-compressed! - file-buffer-size - $source-file-descriptor - transcoded-port - current-transcoder - textual-port? - binary-port? - put-bytevector - put-u8 - get-bytevector-n! - (rename-out [read-byte get-u8] - [peek-byte lookahead-u8] - [s:write write]) - console-output-port - path-root - path-last - $make-read - libspec? - $hand-coded - on-reset - disable-interrupts enable-interrupts - mutex-acquire mutex-release $tc-mutex $thread-list - $pass-time - priminfo-unprefixed - priminfo-libraries - $c-bufsiz - $foreign-procedure - make-guardian) - -(module+ callback - (provide set-current-expand-set-callback!)) - -(define-syntax-rule (import . _) - (void)) - -(define-syntax include - (lambda (stx) - (syntax-case stx () - [(form "machine.def") #`(form ,(string-append target-machine ".def"))] - [(form p) #'(r:include-at/relative-to form form p)]))) - -;; If we have to avoid `read-syntax`: -#; -(define-syntax include - (lambda (stx) - (syntax-case stx () - [(form "machine.def") #`(form #,(string-append target-machine ".def"))] - [(form p) - (let ([r (call-with-input-file* - (syntax->datum #'p) - (lambda (i) - (let loop () - (define e (read i)) - (if (eof-object? e) - null - (cons e (loop))))))]) - (datum->syntax #'form `(begin ,@r)))]))) - -(define-syntax when-feature - (syntax-rules () - [(_ pthreads . _) (begin)])) - -(define-syntax (fluid-let stx) - (syntax-case stx () - [(_ ([id rhs] ...) body ...) - (with-syntax ([(tmp-id ...) (generate-temporaries #'(id ...))]) - #'(let ([tmp-id rhs] - ...) - (define (swap) - (let ([v tmp-id]) (set! tmp-id id) (set! id v)) ...) - (dynamic-wind - swap - (lambda () body ...) - swap)))])) - -;; Help the Racket compiler by lifting immediate record operations out -;; of a `letrec`. Otherwise, the Racket compiler cannot figure out that -;; they won't capture continuations, etc., and will make access slow. -;; We may even be able to substitute a literal procedure, since all record -;; types are prefab structs. -(define-syntax (letrec* stx) - (syntax-case stx () - [(_ (clause ...) . body) - (let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()] [macros '()] [rcds #hasheq()]) - (cond - [(null? clauses) - #`(let #,(reverse lets) - (letrec-syntaxes+values #,(for/list ([s (in-list macros)]) - (syntax-case s () - [[id rhs] - #'[(id) (lambda (stx) (quote-syntax rhs))]])) - #,(for/list ([s (in-list (reverse letrecs))]) - (syntax-case s () - [[id rhs] - #'[(id) rhs]])) - . body))] - [else - (define (id-eq? a b) (eq? (syntax-e a) (syntax-e b))) - (syntax-case* (car clauses) ($primitive record-accessor record-predicate - $make-record-constructor-descriptor - make-record-constructor-descriptor - r6rs:record-constructor - quote) id-eq? - [[id (($primitive _ record-accessor) 'rtd n)] - (and (struct-type? (syntax-e #'rtd)) - (integer? (syntax-e #'n))) - (let ([a (compile-time-record-accessor (syntax-e #'rtd) (syntax-e #'n))]) - (loop (cdr clauses) (cons (if a - #`[id '#,a] - (car clauses)) - lets) - letrecs - macros - rcds))] - [[id (($primitive _ record-mutator) 'rtd n)] - (and (struct-type? (syntax-e #'rtd)) - (integer? (syntax-e #'n))) - (let ([m (compile-time-record-mutator (syntax-e #'rtd) (syntax-e #'n))]) - (loop (cdr clauses) (cons (if m - #`[id '#,m] - (car clauses)) - lets) - letrecs - macros - rcds))] - [[id (($primitive _ record-predicate) 'rtd)] - (struct-type? (syntax-e #'rtd)) - (let ([p (compile-time-record-predicate (syntax-e #'rtd))]) - (loop (cdr clauses) (cons (if p - #`[id '#,p] - (car clauses)) - lets) - letrecs - macros - rcds))] - [[id (($primitive _ r6rs:record-constructor) 'rcd)] - (rec-cons-desc? (syntax-e #'rcd)) - (let ([c (rcd->constructor (syntax-e #'rcd) #f)]) - (cond - [c (loop (cdr clauses) (cons #`[id #,c] - lets) - letrecs - macros - rcds)] - [else - (and (log-warning "couldn't inline ~s" (car clauses)) #f) - (loop (cdr clauses) lets (cons (car clauses) letrecs) macros rcds)]))] - [[id (($primitive _ mrcd) - 'rtd - base - proc - . maybe-name)] - (and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd)) - (eq? 'make-record-constructor-descriptor (syntax-e #'mrcd))) - (struct-type? (syntax-e #'rtd)) - (or (not (syntax-e #'base)) - (hash-ref rcds (syntax-e #'base) #f)) - (immediate-procedure-expression? #'proc)) - (let ([rtd (syntax-e #'rtd)] - [base-rcdi (and (syntax-e #'base) - (hash-ref rcds (syntax-e #'base) #f))]) - (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) - (struct-type-info rtd)) - (when (and (not base-rcdi) - super) - (error "can't handle an rcd without a base rcd and with a parent record type")) - (define rdci (rcd-info rtd #'proc base-rcdi (+ init-cnt (if base-rcdi - (rcd-info-init-cnt base-rcdi) - 0)))) - (loop (cdr clauses) - lets - (cons #`[id (mrcd - '#,rtd - base - proc - . maybe-name)] - letrecs) - macros - (hash-set rcds (syntax-e #'id) rdci)))] - [[id (($primitive _ mrcd) - 'rtd - 'base-rcd - proc - . maybe-name)] - (and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd)) - (eq? 'make-record-constructor-descriptor (syntax-e #'mrcd))) - (struct-type? (syntax-e #'rtd)) - (rec-cons-desc? (syntax-e #'base-rcd)) - (immediate-procedure-expression? #'proc)) - (let ([rtd (syntax-e #'rtd)] - [base-rcdi (rcd->rcdi (syntax-e #'base-rcd))]) - (unless base-rcdi - (error "can't handle this literal rcd: ~e" (syntax-e #'base-rcd))) - (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) - (struct-type-info rtd)) - (define rdci (rcd-info rtd #'proc base-rcdi (+ init-cnt (rcd-info-init-cnt base-rcdi)))) - (loop (cdr clauses) - lets - (cons #`[id (mrcd - '#,rtd - 'base-rcd - proc - . maybe-name)] - letrecs) - macros - (hash-set rcds (syntax-e #'id) rdci)))] - [[id (($primitive _ r6rs:record-constructor) rcd-id)] - (and (identifier? #'rcd-id) - (hash-ref rcds (syntax-e #'rcd-id) #f)) - (let ([rcdi (hash-ref rcds (syntax-e #'rcd-id))]) - (define (rcdi->generator rcdi) - (define base-rcdi (rcd-info-base-rcdi rcdi)) - (cond - [(not (rcd-info-proto-expr rcdi)) - #`(lambda (ctr) ctr)] - [(not base-rcdi) - (rcd-info-proto-expr rcdi)] - [else - (with-syntax ([ctr (gensym 'ctr)] - [(p-arg ...) (for/list ([i (in-range (rcd-info-init-cnt base-rcdi))]) - (gensym))] - [(c-arg ...) (for/list ([i (in-range (- (rcd-info-init-cnt rcdi) - (rcd-info-init-cnt base-rcdi)))]) - (gensym))]) - #`(lambda (ctr) - (#,(rcd-info-proto-expr rcdi) - (#,(rcdi->generator base-rcdi) - (lambda (p-arg ...) - (lambda (c-arg ...) - (ctr p-arg ... c-arg ...)))))))])) - (define c (struct-type-make-constructor (rcd-info-rtd rcdi))) - (loop (cdr clauses) - lets - (cons #`[id (#,(rcdi->generator rcdi) #,c)] - letrecs) - macros - rcds))] - [[id (($primitive _ r6rs:record-constructor) _)] - (and (log-warning "couldn't simplify ~s" (car clauses)) - #f) - (void)] - - [[id (($primitive _ mrcd) . _)] - (and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd)) - (eq? 'make-record-constructor-descriptor (syntax-e #'mrcd))) - (log-warning "couldn't recognize ~s" (car clauses)) - #f) - (void)] - [else - (loop (cdr clauses) lets (cons (car clauses) letrecs) macros rcds)])]))])) - -(define-for-syntax (immediate-procedure-expression? s) - (syntax-case s () - [(id . _) - (and (identifier? #'id) - (or (eq? (syntax-e #'id) 'lambda) - (eq? (syntax-e #'id) 'case-lambda)))] - [_ #f])) - -(define-syntax (with-inline-cache stx) - (syntax-case stx () - [(_ expr) - #`(let ([b #,(mcons #f #f)]) - (or (mcar b) - (let ([r expr]) - (set-mcar! b r) - r)))])) - -(define-syntax (s:parameterize stx) - (syntax-case stx () - [(_ ([id rhs] ...) body ...) - (with-syntax ([(tmp-id ...) (generate-temporaries #'(id ...))]) - #'(let ([tmp-id rhs] - ...) - (define (swap) - (let ([v tmp-id]) (set! tmp-id (id)) (id v)) ...) - (dynamic-wind - swap - (lambda () body ...) - swap)))])) - -(define-syntax s:define - (syntax-rules () - [(_ id) (define id (void))] - [(_ . rest) (define . rest)])) - -(define-syntax (gen-let-values stx) - (syntax-case stx () - [(_ ([lhs rhs] ...) body ...) - (with-syntax ([([lhs rhs] ...) - (for/list ([lhs (in-list (syntax->list #'(lhs ...)))] - [rhs (in-list (syntax->list #'(rhs ...)))]) - (syntax-case lhs () - [(id ...) (list lhs rhs)] - [_ (with-syntax ([flat-lhs (let loop ([lhs lhs]) - (syntax-case lhs () - [(id . rest) - (cons #'id (loop #'rest))] - [_ (list lhs)]))]) - #'[flat-lhs (call-with-values (lambda () rhs) - (lambda lhs (values . flat-lhs)))])]))]) - #'(let-values ([lhs rhs] ...) body ...))])) - -(define-values (primvec get-priminfo) - (get-primdata $sputprop scheme-dir)) - -(begin-for-syntax - (define (make-flags->bits 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)))))) - -(define-syntax (define-flags stx) - (syntax-case stx () - [(_ name spec ...) - #'(define-syntax name - (let ([flags->bits (make-flags->bits '(spec ...))]) - (lambda (stx) - (syntax-case stx (or) - [(_ . flags) - (flags->bits 'flags)]))))])) - -(define-syntax $primitive - (syntax-rules () - [(_ name) name] - [(_ opt name) name])) - -(define ($app proc . args) - (apply proc args)) - -(define tc (make-hasheq)) -(define ($tc) tc) -(define ($thread-tc tc) tc) - -(define $tc-field - (case-lambda - [(sym tc) (hash-ref tc sym (case sym - [(parameters) (vector)] - [else 0]))] - [(sym tc v) (hash-set! tc sym v)])) - -(define ($thread-list) (list tc)) - -(define (enumerate ls) - (for/list ([v (in-list ls)] - [i (in-naturals)]) - i)) - -(define ($make-record-constructor-descriptor rtd prcd protocol who) - (make-record-constructor-descriptor rtd prcd protocol)) - -(define ($make-record-type-descriptor* base-rtd name parent uid sealed? opaque? num-fields mutability-mask who . extras) - (define fields (for ([i (in-range num-fields)]) - (list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable) - (string->symbol (format "f~a" i))))) - (apply $make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields who extras)) - -(define-syntax-rule (s:module (id ...) body ...) - (begin - body ...)) - -(define-syntax-rule (meta-cond [q r ...] ...) - (splicing-let-syntax ([go - (lambda (stx) - (cond - [q #'(begin r ...)] - ...))]) - (go))) - -(define-syntax set-who! - (syntax-rules () - [(_ #(space id) rhs) (void)] - [(_ id rhs) (set! id rhs)])) - -(define-syntax (constant stx) - (syntax-case stx () - [(_ id) - #`#,(case (syntax-e #'id) - [(fixnum-bits) fixnum-bits] - [(most-negative-fixnum) (- (expt 2 (sub1 fixnum-bits)))] - [(most-positive-fixnum) (sub1 (expt 2 (sub1 fixnum-bits)))] - [(annotation-debug) annotation-debug] - [(annotation-profile) annotation-profile] - [(visit-tag) visit-tag] - [(revisit-tag) revisit-tag] - [(prelex-is-flags-offset) prelex-is-flags-offset] - [(prelex-was-flags-offset) prelex-was-flags-offset] - [(prelex-sticky-mask) prelex-sticky-mask] - [(prelex-is-mask) prelex-is-mask] - [else (error 'constant "unknown: ~s" #'id)])])) - -(define $target-machine (make-parameter (string->symbol target-machine))) -(define $sfd (make-parameter #f)) -(define $current-mso (make-parameter #f)) -(define $block-counter (make-parameter 0)) - -(define (any-set? mask x) - (not (fx= (fxand mask x) 0))) - -(define (all-set? mask x) - (let ((m mask)) (fx= (fxand m x) m))) - -(define (iota n) - (for/list ([i (in-range n)]) - i)) - -(define (list-head l n) - (if (zero? n) - null - (cons (car l) - (list-head (cdr l) (sub1 n))))) - -(define ((make-subst eql?) new old v) - (let loop ([v v]) - (cond - [(eql? v old) new] - [(pair? v) (cons (loop (car v)) - (loop (cdr v)))] - [else v]))) - -(define subst (make-subst equal?)) -(define substv (make-subst eqv?)) -(define substq (make-subst eq?)) - -(define-syntax-rule (datum e) - (syntax->datum (syntax e))) - -(define-syntax-rule (rec id rhs) - (letrec ([id rhs]) - id)) - -(define (nonnegative? v) - (and (real? v) - (v . >= . 0))) - -(define (nonpositive? v) - (and (real? v) - (v . <= . 0))) - -(define (last-pair p) - (if (and (pair? p) - (pair? (cdr p))) - (last-pair (cdr p)) - p)) - -(define-syntax-rule (with-tc-mutex body ...) - (let () body ...)) - -(define-syntax-rule (with-values prod con) - (call-with-values (lambda () prod) con)) - -(define (s:vector-sort proc vec) - (vector-sort vec proc)) - -(define (s:vector-sort! proc vec) - (vector-sort! vec proc)) - -(define vector-for-each - (case-lambda - [(proc vec) - (for ([e (in-vector vec)]) - (proc e))] - [(proc vec1 vec2) - (for ([e1 (in-vector vec1)] - [e2 (in-vector vec2)]) - (proc e1 e2))] - [(proc . vecs) - (apply for-each proc (map vector->list vecs))])) - -(define vector-map - (case-lambda - [(proc vec) - (for/vector #:length (vector-length vec) ([e (in-vector vec)]) - (proc e))] - [(proc . vecs) - (list->vector (apply map proc (map vector->list vecs)))])) - -(define (stencil-vector? v) #f) - -(define (fxpopcount32 x) - (let* ([x (- x (bitwise-and (arithmetic-shift x -1) #x55555555))] - [x (+ (bitwise-and x #x33333333) (bitwise-and (arithmetic-shift x -2) #x33333333))] - [x (bitwise-and (+ x (arithmetic-shift x -4)) #x0f0f0f0f)] - [x (+ x (arithmetic-shift x -8) (arithmetic-shift x -16) (arithmetic-shift x -24))]) - (bitwise-and x #x3f))) - -(define (fxpopcount x) - (fx+ (fxpopcount32 (bitwise-and x #xffffffff)) - (fxpopcount32 (arithmetic-shift x -32)))) - -(define (fxpopcount16 x) - (fxpopcount32 (bitwise-and x #xffff))) - -(define (logbit? m n) - (bitwise-bit-set? n m)) -(define (logbit1 i n) - (bitwise-ior (arithmetic-shift 1 i) n)) -(define (logbit0 i n) - (bitwise-and (bitwise-not (arithmetic-shift 1 i)) n)) -(define (logtest a b) - (not (eqv? 0 (bitwise-and a b)))) - -(define ($fxu< a b) - (if (< a 0) - #f - (< a b))) - -(define (fxsrl v amt) - (if (and (v . fx< . 0) - (amt . fx> . 0)) - (bitwise-and (fxrshift v amt) - (- (fxlshift 1 (- fixnum-bits amt)) 1)) - (fxrshift v amt))) - -(define (fxbit-field fx1 fx2 fx3) - (fxrshift (fxand fx1 (fxnot (fxlshift -1 fx3))) fx2)) - -(define (bitwise-bit-count fx) - (cond - [(eqv? fx 0) 0] - [(eqv? 0 (bitwise-and fx 1)) - (bitwise-bit-count (arithmetic-shift fx -1))] - [else - (add1 (bitwise-bit-count (arithmetic-shift fx -1)))])) - -(define (bitwise-arithmetic-shift-right v s) - (arithmetic-shift v (- s))) - -(define (bytevector-u16-native-ref bv i) - (integer-bytes->integer bv #f (system-big-endian?) i (+ i 2))) - -(define (bytevector-s16-native-ref bv i) - (integer-bytes->integer bv #t (system-big-endian?) i (+ i 2))) - -(define (bytevector-u32-native-ref bv i) - (integer-bytes->integer bv #t (system-big-endian?) i (+ i 4))) - -(define (bytevector-s32-native-ref bv i) - (integer-bytes->integer bv #t (system-big-endian?) i (+ i 4))) - -(define (bytevector-u64-native-ref bv i) - (integer-bytes->integer bv #t (system-big-endian?) i (+ i 8))) - -(define (bytevector-s64-native-ref bv i) - (integer-bytes->integer bv #t (system-big-endian?) i (+ i 8))) - -(define (bytevector-s16-ref bv i endness) - (integer-bytes->integer bv #t (eq? endness 'big) i (+ i 2))) - -(define (bytevector-u16-ref bv i endness) - (integer-bytes->integer bv #f (eq? endness 'big) i (+ i 2))) - -(define (bytevector-s32-ref bv i endness) - (integer-bytes->integer bv #t (eq? endness 'big) i (+ i 4))) - -(define (bytevector-u32-ref bv i endness) - (integer-bytes->integer bv #f (eq? endness 'big) i (+ i 4))) - -(define (bytevector-s64-ref bv i endness) - (integer-bytes->integer bv #t (eq? endness 'big) i (+ i 8))) - -(define (bytevector-u64-ref bv i endness) - (integer-bytes->integer bv #f (eq? endness 'big) i (+ i 8))) - -(define ($integer-64? x) - (<= (- (expt 2 63)) (sub1 (expt 2 64)))) - -(define ($integer-32? x) - (<= (- (expt 2 31)) (sub1 (expt 2 32)))) - -(define ($flonum->digits . args) - (error '$flonum->digits "not ready")) - -(define ($flonum-sign fl) - (if (or (eqv? fl -0.0) - (negative? fl)) - 1 - 0)) - -(define ($top-level-value name) - (case name - [(apply) apply] - [($capture-fasl-target) - (namespace-variable-value name #t (lambda () $unbound-object))] - [else - (namespace-variable-value name)])) - -(define ($set-top-level-value! name val) - (namespace-set-variable-value! name val)) - -(define (get-$unbound-object) - $unbound-object) - -(define ($profile-source-data?) - #f) - -(define $compile-profile (make-parameter #f)) -(define compile-profile $compile-profile) -(define $optimize-closures (make-parameter #t)) -(define $profile-block-data? (make-parameter #f)) -(define run-cp0 (make-parameter error)) -(define generate-interrupt-trap (make-parameter #t)) -(define $track-dynamic-closure-counts (make-parameter #f)) -(define $suppress-primitive-inlining (make-parameter #f)) -(define debug-level (make-parameter 0)) - -(define (scheme-version-number) - (define v (lookup-constant 'scheme-version)) - (if (zero? (arithmetic-shift v -24)) - (values (arithmetic-shift v -16) - (bitwise-and 255 (arithmetic-shift v -8)) - (bitwise-and 255 v)) - (values (arithmetic-shift v -24) - (bitwise-and 255 (arithmetic-shift v -16)) - (bitwise-and 255 (arithmetic-shift v -8))))) - -(define (scheme-fork-version-number) - (define v (lookup-constant 'scheme-version)) - (define-values (maj min sub) (scheme-version-number)) - (if (zero? (arithmetic-shift v -24)) - (values maj min sub 0) - (values maj min sub (bitwise-and 255 v)))) - -(define (make-hashtable hash eql?) - (cond - [(eq? hash symbol-hash) - (define ht (make-hasheq)) - (hash-set! symbol-hts ht eql?) - ht] - [(and (eq? hash equal-hash-code) - (or (eq? eql? equal?) - (eq? eql? string=?))) - (make-hash)] - [(and (eq? hash values) - (eq? eql? =)) - (make-hash)] - [else - (make-custom-hash eql? hash (lambda (a) 1))])) - -(define (make-weak-eq-hashtable) - (make-weak-hasheq)) - -(define (hash-ref/pair/dict ht key def-v) - (if (hash? ht) - (hash-ref/pair ht key def-v) - (dict-ref ht key def-v))) - -(define (hash-set!/pair/dict ht key v) - (if (hash? ht) - (hash-set!/pair ht key v) - (dict-set! ht key v))) - -(define (hashtable-keys ht) - (list->vector (if (hash? ht) - (hash-keys ht) - (dict-keys ht)))) - -(define (hashtable-entries ht) - (define ps (hash-values ht)) - (values (list->vector (map car ps)) - (list->vector (map cdr ps)))) - -(define (eq-hashtable? v) - (and (hash? v) (hash-eq? v) (not (symbol-hashtable? v)))) - -(define (eq-hashtable-weak? v) - (hash-weak? v)) -(define (eq-hashtable-ephemeron? v) - #f) - -(define symbol-hts (make-weak-hasheq)) - -(define (symbol-hash x) (eq-hash-code x)) - -(define (symbol-hashtable? v) - (and (hash-ref symbol-hts v #f) #t)) - -(define (hashtable-equivalence-function v) - (or (hash-ref symbol-hts v #f) - (error 'hashtable-equivalence-function "only implemented for symbol hashtables"))) - -(define (hashtable-mutable? ht) #t) - -(define ($ht-minlen ht) - (lookup-constant 'hashtable-default-size)) - -(define ($ht-veclen ht) - (arithmetic-shift 1 (integer-length (hash-count ht)))) - -(define (bignum? x) - (and (integer? x) - (exact? x) - (not (s:fixnum? x)))) - -(define (ratnum? x) - (and (real? x) - (exact? x) - (not (integer? x)))) - -(define ($inexactnum? x) - (and (complex? x) - (not (real? x)) - (inexact? x))) - -(define ($exactnum? x) - (and (complex? x) - (not (real? x)) - (exact? x))) - -(define ($rtd-counts? x) - #f) - -(define (self-evaluating? v) - (or (boolean? v) - (number? v) - (string? v) - (bytes? v) - (char? v) - (base-rtd? v) - (bwp? v))) - -(define (weak-pair? v) - #f) -(define (ephemeron-pair? v) - #f) - -;; The Chez Scheme compiler does not itself create -;; any immutable values, but Racket's `eval` coerces -;; to immutable. For fasl purposes, claim all as mutable. -(define any-immutable? #f) - -(define (immutable-string? s) - (and any-immutable? - (string? s) - (immutable? s))) - -(define (immutable-vector? s) - (and any-immutable? - (vector? s) - (immutable? s))) - -(define (immutable-bytevector? s) - (and any-immutable? - (bytes? s) - (immutable? s))) - -(define (immutable-fxvector? s) - #f) - -(define (immutable-box? s) - (and any-immutable? - (box? s) - (immutable? s))) - -(define (list-sort pred l) - (sort l pred)) - -(define (path-absolute? p) - (absolute-path? p)) - -(define current-expand-set-callback void) -(define (set-current-expand-set-callback! cb) - (set! current-expand-set-callback cb)) - -(define current-expand - (let ([v expand]) - (case-lambda - [() v] - [(new-v) - (set! v new-v) - (current-expand-set-callback)]))) - -(define subset-mode (make-parameter 'system)) -(define internal-defines-as-letrec* (make-parameter #t)) -(define (eval-syntax-expanders-when) '(compile eval load)) -(define require-nongenerative-clause (make-parameter #f)) -(define generate-inspector-information (make-parameter #f)) -(define generate-procedure-source-information (make-parameter #f)) -(define enable-cross-library-optimization (make-parameter #t)) -(define enable-arithmetic-left-associative (make-parameter #f)) -(define enable-type-recovery (make-parameter #t)) -(define fasl-compressed (make-parameter #f)) - -(define current-generate-id (make-parameter gensym)) - -(define (strip-syntax stx) - (cond - [(syntax-object? stx) (strip-syntax (syntax-object-e stx))] - [(pair? stx) (cons (strip-syntax (car stx)) - (strip-syntax (cdr stx)))] - [else stx])) - -(define (syntax-error stx . strs) - (error 'syntax-error "~s ~a" - (strip-syntax stx) - (apply string-append strs))) - -(define ($source-warning . args) - (void) - #; - (printf "WARNING ~s\n" args)) - -(define-syntax (define-flag-op stx) - (syntax-case stx () - [(_ get-id set-id k) - #`(begin - (define-syntax (get-id stx) - (with-syntax ([prelex-flags (datum->syntax stx 'prelex-flags)]) - (syntax-case stx () - [(_ e) #`(positive? (bitwise-and (prelex-flags e) k))]))) - (define-syntax (set-id stx) - (with-syntax ([prelex-flags-set! (datum->syntax stx 'prelex-flags-set!)] - [prelex-flags (datum->syntax stx 'prelex-flags)]) - (syntax-case stx () - [(_ e on?) #`(let ([v e]) - (prelex-flags-set! v (if on? - (bitwise-ior (prelex-flags v) k) - (bitwise-and (prelex-flags v) (bitwise-not k)))))]))))])) -(define-flag-op prelex-assigned set-prelex-assigned! #b0000000100000000) -(define-flag-op prelex-referenced set-prelex-referenced! #b0000001000000000) -(define-flag-op prelex-seen set-prelex-seen! #b0000010000000000) -(define-flag-op prelex-multiply-referenced set-prelex-multiply-referenced! #b0000100000000000) - -(define-syntax-rule (safe-assert . _) (void)) - -(define who 'some-who) - -(define (with-source-path who name procedure) - (cond - [(equal? name "machine.def") - (procedure (string-append target-machine ".def"))] - [else - (procedure name)])) - -(define ($make-source-oops . args) #f) - -(define ($guard else? handlers body) - (with-handlers ([(lambda (x) #t) (if else? - (lambda (v) (handlers v void)) - handlers)]) - (body))) -(define ($reset-protect body out) (body)) - -(define ($map who . args) (apply map args)) - -(define print-level (make-parameter #f)) -(define print-depth (make-parameter #f)) -(define print-length (make-parameter #f)) -(define (s:pretty-format sym [fmt #f]) (void)) - -(define (interpret e) (eval e)) - -(define ($open-file-input-port who filename [options #f]) - (open-input-file filename)) - -(define ($open-file-output-port who filename options) - (open-output-file filename #:exists (if (eval `(enum-set-subset? (file-options replace) ',options)) - 'replace - 'error))) - -(define (s:open-output-file filename [exists 'error]) - (open-output-file filename #:exists exists)) - -(define ($open-bytevector-list-output-port) - (define p (open-output-bytes)) - (values p - (lambda () - (define bv (get-output-bytes p)) - (values (list bv) (bytes-length bv))))) - -(define (open-bytevector-output-port [transcoder #f]) - (define p (open-output-bytes)) - (values p - (lambda () (get-output-bytes p)))) - -(define (native-transcoder) - #f) - -(define (port-file-compressed! p) - (void)) - -(define (file-buffer-size) - 4096) - -(define ($source-file-descriptor . args) - #f) - -(define (transcoded-port binary-port transcoder) - binary-port) - -(define current-transcoder (make-parameter #f)) -(define (textual-port? p) #t) -(define (binary-port? p) #t) - -(define (put-bytevector p bv [start 0] [end (bytes-length bv)]) - (write-bytes bv p start end)) - -(define (put-u8 p b) - (if (b . < . 0) - (write-byte (+ 256 b) p) - (write-byte b p))) - -(define (get-bytevector-n! p buf start end) - (read-bytes! buf p start end)) - -(define (s:write v [o (current-output-port)]) - (if (and (gensym? v) - (not (print-gensym))) - (write-string (gensym->pretty-string v) o) - (write v o))) - -(define (console-output-port) (current-output-port)) - -(define (path-root p) - (path->string (path-replace-suffix p #""))) - -(define (path-last p) - (define-values (base name dir?) (split-path p)) - (path->string name)) - -(define ($make-read p . args) - (cond - [(not (current-readtable)) - (lambda () (read p))] - [else - (lambda () (read p))])) - -;; replaced when "cmacros.ss" is loaded: -(define (libspec? x) (vector? x)) - -(define-syntax-rule (on-reset oops e1 e2 ...) - (let () e1 e2 ...)) - -(define ($pass-time name thunk) (thunk)) - -(define (disable-interrupts) (void)) -(define (enable-interrupts) (void)) -(define $tc-mutex 'tc-mutex) -(define (mutex-acquire m) (void)) -(define (mutex-release m) (void)) - -(define $c-bufsiz 4096) - -(define-syntax ($foreign-procedure stx) - (syntax-case stx () - [(_ _ name . _) #'name])) - -(define (make-guardian) - (case-lambda - [() #f] - [(v) (void)] - [(v rep) (void)])) diff --git a/racket/src/cs/bootstrap/scheme-readtable.rkt b/racket/src/cs/bootstrap/scheme-readtable.rkt deleted file mode 100644 index 476cbb9144..0000000000 --- a/racket/src/cs/bootstrap/scheme-readtable.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/cs/bootstrap/scheme-struct.rkt b/racket/src/cs/bootstrap/scheme-struct.rkt deleted file mode 100644 index 094d2ba3b9..0000000000 --- a/racket/src/cs/bootstrap/scheme-struct.rkt +++ /dev/null @@ -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}|) diff --git a/racket/src/cs/bootstrap/strip.rkt b/racket/src/cs/bootstrap/strip.rkt deleted file mode 100644 index 22dd35cee2..0000000000 --- a/racket/src/cs/bootstrap/strip.rkt +++ /dev/null @@ -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])) diff --git a/racket/src/cs/bootstrap/symbol.rkt b/racket/src/cs/bootstrap/symbol.rkt deleted file mode 100644 index 3e5480862d..0000000000 --- a/racket/src/cs/bootstrap/symbol.rkt +++ /dev/null @@ -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")))) diff --git a/racket/src/cs/bootstrap/syntax-mode.rkt b/racket/src/cs/bootstrap/syntax-mode.rkt deleted file mode 100644 index 070b26396f..0000000000 --- a/racket/src/cs/bootstrap/syntax-mode.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in index fa0d9c555d..51f0aa740b 100644 --- a/racket/src/cs/c/Makefile.in +++ b/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 diff --git a/racket/src/worksp/csbuild.rkt b/racket/src/worksp/csbuild.rkt index e6f6b67a6e..80f263cdf9 100644 --- a/racket/src/worksp/csbuild.rkt +++ b/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)