suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

implement bootstrap of Chez Scheme using Racket

Browse Source 
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).
This commit is contained in:
Matthew Flatt 2019-04-19 13:32:29 -06:00
parent 7e9d167101
commit e337c65204
22 changed files with 3388 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
racket/src/cs/README.txt
View File

@ -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

6
racket/src/cs/bootstrap/Makefile Normal file
View File

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

19
racket/src/cs/bootstrap/README.txt Normal file
View File

@ -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 "<machine>/boot/<machine>" 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.

28
racket/src/cs/bootstrap/config.rkt Normal file
View File

@ -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)

61
racket/src/cs/bootstrap/constant.rkt Normal file
View File

@ -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)

78
racket/src/cs/bootstrap/define-datatype.rkt Normal file
View File

@ -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)))))

162
racket/src/cs/bootstrap/format.rkt Normal file
View File

@ -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)]))]))

57
racket/src/cs/bootstrap/gensym.rkt Normal file
View File

@ -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)

29
racket/src/cs/bootstrap/hand-coded.rkt Normal file
View File

@ -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))

16
racket/src/cs/bootstrap/immediate.rkt Normal file
View File

@ -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?)

305
racket/src/cs/bootstrap/make-boot.rkt Normal file
View File

@ -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)))))

31
racket/src/cs/bootstrap/nanopass-patch.rkt Normal file
View File

@ -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)]))

16
racket/src/cs/bootstrap/parse-makefile.rkt Normal file
View File

@ -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))))

87
racket/src/cs/bootstrap/primdata.rkt Normal file
View File

@ -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)]))

777
racket/src/cs/bootstrap/r6rs-lang.rkt Normal file
View File

@ -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>= 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))

13
racket/src/cs/bootstrap/r6rs-readtable.rkt Normal file
View File

@ -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))

506
racket/src/cs/bootstrap/record.rkt Normal file
View File

@ -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)])]))

963
racket/src/cs/bootstrap/scheme-lang.rkt Normal file
View File

@ -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)]))

150
racket/src/cs/bootstrap/scheme-readtable.rkt Normal file
View File

@ -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))

20
racket/src/cs/bootstrap/scheme-struct.rkt Normal file
View File

@ -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}|)

52
racket/src/cs/bootstrap/symbol.rkt Normal file
View File

@ -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"))))

7
racket/src/cs/bootstrap/syntax-mode.rkt Normal file
View File

@ -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))