From e337c65204402ef4faf09f6a848d2d873d0e63a7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Apr 2019 13:32:29 -0600 Subject: [PATCH] implement bootstrap of Chez Scheme using Racket Provide a way to build Chez Scheme from source using Racket. In the short run, this lets us distribute source that ultimately depends only on a C compiler (since a variant of Racket can be built from source using just a C compiler). --- racket/src/cs/README.txt | 5 + racket/src/cs/bootstrap/Makefile | 6 + racket/src/cs/bootstrap/README.txt | 19 + racket/src/cs/bootstrap/config.rkt | 28 + racket/src/cs/bootstrap/constant.rkt | 61 ++ racket/src/cs/bootstrap/define-datatype.rkt | 78 ++ racket/src/cs/bootstrap/format.rkt | 162 ++++ racket/src/cs/bootstrap/gensym.rkt | 57 ++ racket/src/cs/bootstrap/hand-coded.rkt | 29 + racket/src/cs/bootstrap/immediate.rkt | 16 + racket/src/cs/bootstrap/make-boot.rkt | 305 ++++++ racket/src/cs/bootstrap/nanopass-patch.rkt | 31 + racket/src/cs/bootstrap/parse-makefile.rkt | 16 + racket/src/cs/bootstrap/primdata.rkt | 87 ++ racket/src/cs/bootstrap/r6rs-lang.rkt | 777 +++++++++++++++ racket/src/cs/bootstrap/r6rs-readtable.rkt | 13 + racket/src/cs/bootstrap/record.rkt | 506 ++++++++++ racket/src/cs/bootstrap/scheme-lang.rkt | 963 +++++++++++++++++++ racket/src/cs/bootstrap/scheme-readtable.rkt | 150 +++ racket/src/cs/bootstrap/scheme-struct.rkt | 20 + racket/src/cs/bootstrap/symbol.rkt | 52 + racket/src/cs/bootstrap/syntax-mode.rkt | 7 + 22 files changed, 3388 insertions(+) create mode 100644 racket/src/cs/bootstrap/Makefile create mode 100644 racket/src/cs/bootstrap/README.txt create mode 100644 racket/src/cs/bootstrap/config.rkt create mode 100644 racket/src/cs/bootstrap/constant.rkt create mode 100644 racket/src/cs/bootstrap/define-datatype.rkt create mode 100644 racket/src/cs/bootstrap/format.rkt create mode 100644 racket/src/cs/bootstrap/gensym.rkt create mode 100644 racket/src/cs/bootstrap/hand-coded.rkt create mode 100644 racket/src/cs/bootstrap/immediate.rkt create mode 100644 racket/src/cs/bootstrap/make-boot.rkt create mode 100644 racket/src/cs/bootstrap/nanopass-patch.rkt create mode 100644 racket/src/cs/bootstrap/parse-makefile.rkt create mode 100644 racket/src/cs/bootstrap/primdata.rkt create mode 100644 racket/src/cs/bootstrap/r6rs-lang.rkt create mode 100644 racket/src/cs/bootstrap/r6rs-readtable.rkt create mode 100644 racket/src/cs/bootstrap/record.rkt create mode 100644 racket/src/cs/bootstrap/scheme-lang.rkt create mode 100644 racket/src/cs/bootstrap/scheme-readtable.rkt create mode 100644 racket/src/cs/bootstrap/scheme-struct.rkt create mode 100644 racket/src/cs/bootstrap/symbol.rkt create mode 100644 racket/src/cs/bootstrap/syntax-mode.rkt diff --git a/racket/src/cs/README.txt b/racket/src/cs/README.txt index 2890e05ded..86cb5c7ffc 100644 --- a/racket/src/cs/README.txt +++ b/racket/src/cs/README.txt @@ -10,6 +10,11 @@ organized into two layers: wrapper executables that combine Chez Scheme with the Racket functionality implemented in this immediate directory. +In addition, "bootstrap" implements a simulation of Chez Scheme in +Racket that can be used to bootstrap Chez Scheme from source (i.e., +using an existing Racketbuild, but without an existing Chez Scheme +build). + ======================================================================== Requirements diff --git a/racket/src/cs/bootstrap/Makefile b/racket/src/cs/bootstrap/Makefile new file mode 100644 index 0000000000..78f1bb23f9 --- /dev/null +++ b/racket/src/cs/bootstrap/Makefile @@ -0,0 +1,6 @@ +RACKET=racket + +SCHEME_DIR=../../build/ChezScheme + +boot: + env SCHEME_DIR="$(SCHEME_DIR)" $(RACKET) make-boot.rkt diff --git a/racket/src/cs/bootstrap/README.txt b/racket/src/cs/bootstrap/README.txt new file mode 100644 index 0000000000..e939564a7d --- /dev/null +++ b/racket/src/cs/bootstrap/README.txt @@ -0,0 +1,19 @@ +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 "compiled", but copy the files +to "/boot/" in a Chez Scheme source directory before +`configure` to `make` to boostrap 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 accomodate some Chez Scheme changes. diff --git a/racket/src/cs/bootstrap/config.rkt b/racket/src/cs/bootstrap/config.rkt new file mode 100644 index 0000000000..fde88727f7 --- /dev/null +++ b/racket/src/cs/bootstrap/config.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require ffi/unsafe/global) + +(provide scheme-dir + target-machine) + +(define ht (get-place-table)) + +(define scheme-dir (or (hash-ref ht 'make-boot-scheme-dir #f) + (simplify-path + (path->complete-path + (or (getenv "SCHEME_DIR") + (error "set `SCHEME_DIR` environment variable")))))) +(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 + (error "set `MACH` environment variable")]))) + +(hash-set! ht 'make-boot-targate-machine target-machine) diff --git a/racket/src/cs/bootstrap/constant.rkt b/racket/src/cs/bootstrap/constant.rkt new file mode 100644 index 0000000000..da4c814cbb --- /dev/null +++ b/racket/src/cs/bootstrap/constant.rkt @@ -0,0 +1,61 @@ +#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 ,v) + (when (exact-integer? v) + (hash-set! ht id v))] + [_ (void)]) + (loop))))) + +(call-with-input-file + (build-path scheme-dir "s" (string-append target-machine ".def")) + read-constants) + +(call-with-input-file + (build-path scheme-dir "s" "cmacros.ss") + read-constants) + +(define-syntax-rule (define-constant id ...) + (begin + (provide id ...) + (define id (hash-ref ht 'id)) ...)) + +(hash-set! ht 'ptr-bytes (* 8 (hash-ref ht 'ptr-bits))) + +(define-constant + ptr-bytes + fixnum-bits + annotation-debug + annotation-profile + visit-tag + revisit-tag + prelex-is-flags-offset + prelex-was-flags-offset + prelex-sticky-mask + prelex-is-mask) + + diff --git a/racket/src/cs/bootstrap/define-datatype.rkt b/racket/src/cs/bootstrap/define-datatype.rkt new file mode 100644 index 0000000000..bbb090f617 --- /dev/null +++ b/racket/src/cs/bootstrap/define-datatype.rkt @@ -0,0 +1,78 @@ +#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 new file mode 100644 index 0000000000..9ce0cb9d2d --- /dev/null +++ b/racket/src/cs/bootstrap/format.rkt @@ -0,0 +1,162 @@ +#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 new file mode 100644 index 0000000000..39274538ad --- /dev/null +++ b/racket/src/cs/bootstrap/gensym.rkt @@ -0,0 +1,57 @@ +#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) + +(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) diff --git a/racket/src/cs/bootstrap/hand-coded.rkt b/racket/src/cs/bootstrap/hand-coded.rkt new file mode 100644 index 0000000000..f4e65a9d77 --- /dev/null +++ b/racket/src/cs/bootstrap/hand-coded.rkt @@ -0,0 +1,29 @@ +#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 new file mode 100644 index 0000000000..ac38615cc2 --- /dev/null +++ b/racket/src/cs/bootstrap/immediate.rkt @@ -0,0 +1,16 @@ +#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/make-boot.rkt b/racket/src/cs/bootstrap/make-boot.rkt new file mode 100644 index 0000000000..2c5fb5617b --- /dev/null +++ b/racket/src/cs/bootstrap/make-boot.rkt @@ -0,0 +1,305 @@ +#lang racket/base +(require racket/runtime-path + racket/match + racket/file + (only-in "r6rs-lang.rkt") + (only-in "scheme-lang.rkt" + current-expand) + (submod "scheme-lang.rkt" callback) + "syntax-mode.rkt" + "r6rs-readtable.rkt" + "scheme-readtable.rkt" + "parse-makefile.rkt" + "config.rkt") + +;; Writes ".boot" and ".h" files to a "compiled" subdirectory of the +;; current directory. + +;; Set `SCHEME_DIR` and `MACH` to specify the ChezScheme source +;; directory and the target machine. + +(define nano-dir (build-path scheme-dir "nanopass")) + +(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 (status msg) + (printf "~a\n" msg) + (flush-output)) + +(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/copy r6rs-lang-mod ns) ; get `library` + +(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/copy ''nanopass ns) + +(namespace-require/copy scheme-lang-mod ns) + +(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 orig-eval (current-eval)) + +(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))))] + [_ (void)]))) + + (set-current-expand-set-callback! + (lambda () + (start-fully-unwrapping-syntax!) + (status "Load expander") + (define $uncprep (orig-eval '$uncprep)) + (current-eval + (lambda (stx) + (syntax-case stx () + [("noexpand" form) + (orig-eval ($uncprep (syntax-e #'form)))] + [_ + (orig-eval stx)]))) + (call-with-expressions + (build-path scheme-dir "s/syntax.ss") + (lambda (e) + (when (and (pair? e) + (eq? 'define-syntax (car e))) + ((current-expand) `(define-syntax ,(cadr e) + ',(orig-eval (caddr e))))))) + (status "Install evaluator") + (current-eval + (let ([e (current-eval)]) + (lambda (stx) + (define ex ((current-expand) + (syntax->datum + (let loop ([stx stx]) + (syntax-case* stx (#%top-interaction eval-when compile) (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)] + [_ stx]))))) + (define r (if (struct? ex) + ($uncprep ex) + ex)) + (e r)))) + (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)] + [`(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)] + [`(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 + [`(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 + (match e + [`(package-stubs . ,_) (void)] + [`(define-who make-parameter . ,_) (void)] + [_ (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)))) + + (status "Load mkheader") + (load-ss (build-path scheme-dir "s/mkheader.ss")) + (status "Generate headers") + (eval `(mkscheme.h "compiled/scheme.h" ,target-machine)) + (eval `(mkequates.h "compiled/equates.h")) + + (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))) + + (make-directory* "compiled") + + (let ([failed? #f]) + (for ([src (append petite-sources scheme-sources)]) + (let ([dest (path->string (path->complete-path (build-path "compiled" (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))]) + ((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 "compiled" (path-replace-suffix src #".so"))))]) + (status "Writing petite.boot") + (eval `($make-boot-file "compiled/petite.boot" ',(string->symbol target-machine) '() + ,@(map src->so petite-sources))) + (status "Writing scheme.boot") + (eval `($make-boot-file "compiled/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 new file mode 100644 index 0000000000..ee04ced0c5 --- /dev/null +++ b/racket/src/cs/bootstrap/nanopass-patch.rkt @@ -0,0 +1,31 @@ +#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 "Nanopass patch applied\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 new file mode 100644 index 0000000000..f3ae0b54b7 --- /dev/null +++ b/racket/src/cs/bootstrap/parse-makefile.rkt @@ -0,0 +1,16 @@ +#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") + (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 new file mode 100644 index 0000000000..8f9a147ae8 --- /dev/null +++ b/racket/src/cs/bootstrap/primdata.rkt @@ -0,0 +1,87 @@ +#lang racket/base +(require racket/match + "scheme-readtable.rkt" + "symbol.rkt") + +(provide get-primdata + (struct-out priminfo)) + +(struct primref (name flags arity signatures) #:prefab #:mutable + #:reflection-name '|{primref a0xltlrcpeygsahopkplcn-3}|) + +(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 + (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)]))))) + (define priminfos (make-hasheq)) + (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 pr (primref plain-id flag-bits (map sig->interface sigs) sigs)) + (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 flags->bits + (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 new file mode 100644 index 0000000000..730b6f44ce --- /dev/null +++ b/racket/src/cs/bootstrap/r6rs-lang.rkt @@ -0,0 +1,777 @@ +#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" + (only-in "record.rkt" + do-$make-record-type + register-rtd-name! + register-rtd-fields! + s:struct-type?) + (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) + 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]) + 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-constructor-descriptor + (rename-out [s:struct-type? record-type-descriptor?]) + record-constructor-descriptor + record-constructor + (rename-out [record-constructor r6rs:record-constructor]) + 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! + 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])) + +(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) + (define rtd (rec-cons-desc-rtd rcd)) + (define ctr (struct-type-make-constructor rtd)) + ((record-constructor-generator rcd) ctr)])) + +(define (record-constructor-generator rcd) + (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) + (lambda (ctr) + (p ((record-constructor-generator p-rcd) + (lambda args1 + (lambda args2 + (apply ctr (append args1 args2))))))))] + [super + (define parent-p (lookup-protocol super)) + (lambda (ctr) + (p (parent-p + (lambda args1 + (lambda args2 + (apply ctr (append args1 args2)))))))] + [else p])) + +(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-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 (set-car! p v) (unsafe-set-mcar! p v)) +(define (set-cdr! p v) (unsafe-set-mcdr! p v)) + +(define (fixnum-width) fixnum-bits) + +(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) + (let ([w (fixnum-width)]) + (<= low-fixnum x high-fixnum)))) + +(define (make-compile-time-value v) v) + +(define optimize-level (make-parameter 2)) diff --git a/racket/src/cs/bootstrap/r6rs-readtable.rkt b/racket/src/cs/bootstrap/r6rs-readtable.rkt new file mode 100644 index 0000000000..461a8d82f5 --- /dev/null +++ b/racket/src/cs/bootstrap/r6rs-readtable.rkt @@ -0,0 +1,13 @@ +#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/record.rkt b/racket/src/cs/bootstrap/record.rkt new file mode 100644 index 0000000000..7fd0319e05 --- /dev/null +++ b/racket/src/cs/bootstrap/record.rkt @@ -0,0 +1,506 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/unsafe/ops + racket/vector + racket/list + "immediate.rkt" + "symbol.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 + 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 + csv7:record-type-field-names + 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 [uid #f]) + (define name (if (string? in-name) (string->symbol in-name) in-name)) + (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) ; gets replaced + +(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) 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)))])) + +;; `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 mutators (make-weak-hasheq)) + +;; `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 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) #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) + (* (add1 (length ((csv7:record-field-accessor base-rtd 'flds) rtd))) + 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))])) + +;; 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))])) + +(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 (add1 fld-byte-value)]) + (unless (null? flds) + (set-fld-byte! (car flds) offset) + (loop (cdr flds) (+ offset fld-byte-value)))) + flds) + +(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 (add1 fld-byte-value)) fld-byte-value)) + (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 new file mode 100644 index 0000000000..d99096479f --- /dev/null +++ b/racket/src/cs/bootstrap/scheme-lang.rkt @@ -0,0 +1,963 @@ +#lang racket/base +(require (for-syntax racket/base) + (prefix-in r: racket/include) + racket/fixnum + racket/vector + racket/splicing + racket/pretty + "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" + (only-in "r6rs-lang.rkt" + make-record-constructor-descriptor + set-car! + set-cdr!) + (submod "r6rs-lang.rkt" hash-pair)) + +(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] + [letrec letrec*] + [s:dynamic-wind dynamic-wind]) + set-who! + import + include + when-feature + fluid-let + putprop getprop remprop + $sputprop $sgetprop $sremprop + prim-mask + $primitive + $tc $tc-field $thread-tc + enumerate + $make-record-type + $make-record-type-descriptor + $make-record-constructor-descriptor + $record + $record? + $primitive + $unbound-object? + (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 + record-predicate + record-accessor + record-mutator + 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 + csv7:record-type-field-names + csv7:record-type-field-decls + (rename-out [record-rtd $record-type-descriptor]) + record? + record-type-uid + $object-ref + (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 + $optimize-closures + $profile-block-data? + run-cp0 + generate-interrupt-trap + $track-dynamic-closure-counts + $suppress-primitive-inlining + debug-level + scheme-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-] + [< $fxu<] + [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 fxsrl] + [bitwise-not lognot] + [bitwise-ior logor] + [bitwise-xor logxor] + [bitwise-ior logior] + [bitwise-and logand] + [bitwise-bit-set? fxbit-set?] + [integer-length bitwise-length] + [+ 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] + [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]) + fxbit-field + 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 hashtable-ref] + [hash-ref/pair eq-hashtable-ref] + [hash-ref-cell eq-hashtable-cell] + [hash-set!/pair hashtable-set!] + [hash-remove! eq-hashtable-delete!] + [equal-hash-code string-hash] + [hash-set!/pair symbol-hashtable-set!] + [hash-has-key? symbol-hashtable-contains?] + [hash-has-key? eq-hashtable-contains?] + [hash-ref/pair 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 + 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 + 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)))])) + +(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 s:dynamic-wind + (case-lambda + [(pre thunk post) (dynamic-wind pre thunk post)] + [(critical? pre thunk post) (dynamic-wind pre thunk post)])) + +(define-values (prim-flags->bits primvec get-priminfo) + (get-primdata $sputprop scheme-dir)) + +(define-syntax prim-mask + (syntax-rules (or) + [(_ (or flag ...)) + (prim-flags->bits '(flag ...))] + [(_ flag) + (prim-flags->bits '(flag))])) + +(define-syntax $primitive + (syntax-rules () + [(_ name) name] + [(_ opt name) name])) + +(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-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-each proc (vector->list vec))] + [(proc vec1 vec2) + (for-each proc (vector->list vec1) (vector->list vec2))] + [(proc . vecs) + (apply for-each proc (map vector->list vecs))])) + +(define vector-map + (case-lambda + [(proc vec) + (list->vector (map proc (vector->list vec)))] + [(proc . vecs) + (list->vector (apply map proc (map vector->list vecs)))])) + +(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 (fxbit-field fx1 fx2 fx3) + (fxand (fxrshift fx1 fx2) (fx- (fxlshift 1 (- fx3 fx2)) 1))) + +(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 $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) (values 9 5 3)) + +(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 + (error 'make-hashtable + "??? ~s ~s" hash eql?)])) + +(define (make-weak-eq-hashtable) + (make-weak-hasheq)) + +(define (hashtable-keys ht) + (list->vector (hash-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 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) + (define p (open-output-bytes)) + (values p + (lambda () (get-output-bytes p)))) + +(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 new file mode 100644 index 0000000000..2d92b34e51 --- /dev/null +++ b/racket/src/cs/bootstrap/scheme-readtable.rkt @@ -0,0 +1,150 @@ +#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-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) + (read-syntax/recursive src 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-graph + #\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 new file mode 100644 index 0000000000..970e10bfc2 --- /dev/null +++ b/racket/src/cs/bootstrap/scheme-struct.rkt @@ -0,0 +1,20 @@ +#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}|) diff --git a/racket/src/cs/bootstrap/symbol.rkt b/racket/src/cs/bootstrap/symbol.rkt new file mode 100644 index 0000000000..3e5480862d --- /dev/null +++ b/racket/src/cs/bootstrap/symbol.rkt @@ -0,0 +1,52 @@ +#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 new file mode 100644 index 0000000000..070b26396f --- /dev/null +++ b/racket/src/cs/bootstrap/syntax-mode.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide fully-unwrap? + start-fully-unwrapping-syntax!) + +(define fully-unwrap? #f) +(define (start-fully-unwrapping-syntax!) (set! fully-unwrap? #t))