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

cs-bootstrap: additions to work on latest Chez Scheme

Browse Source
This commit is contained in:
Matthew Flatt 2020-05-20 10:46:57 -06:00
parent 9ba5fd6a0f
commit 08d4698934
3 changed files with 38 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
racket/src/cs/bootstrap/make-boot.rkt
View File

@ -192,10 +192,15 @@
(call-with-expressions
(build-path scheme-dir "s/syntax.ss")
(lambda (e)
(when (and (pair? e)
(eq? 'define-syntax (car e)))
((current-expand) `(define-syntax ,(cadr e)
',(orig-eval (caddr e)))))))
(let loop ([e e])
(cond
[(and (pair? e)
(eq? 'define-syntax (car e)))
((current-expand) `(define-syntax ,(cadr e)
',(orig-eval (caddr e))))]
[(and (pair? e)
(eq? 'begin (car e)))
(for-each loop (cdr e))]))))
(status "Install evaluator")
(current-eval
(let ([e (current-eval)])
@ -280,6 +285,8 @@
(match e
[`(let () ,es ...)
(for-each loop es)]
[`(begin ,es ...)
(for-each loop es)]
[`(define-syntax ,id . ,_)
(when (want-syntax? id)
(eval e))]
@ -296,6 +303,8 @@
(match e
[`(let () ,es ...)
(for-each loop es)]
[`(begin ,es ...)
(for-each loop es)]
[`(set-who! $fasl-strip-options . ,_)
(eval e)]
[`(set-who! $make-fasl-strip-options . ,_)
@ -308,6 +317,10 @@
(lambda (e)
(let loop ([e e])
(match e
[`(let () ,es ...)
(for-each loop es)]
[`(begin ,es ...)
(for-each loop es)]
[`(define $format-scheme-version . ,_)
(eval e)]
[`(define ($compiled-file-header? . ,_) . ,_)
@ -319,14 +332,16 @@
(build-path scheme-dir "s/front.ss")
(lambda (e)
;; Skip `package-stubs`, which would undo "syntax.ss" definitions
(match e
[`(package-stubs . ,_) (void)]
[`(define-who make-parameter . ,_) (void)]
[_ (eval e)])))
(let loop ([e e])
(match e
[`(package-stubs . ,_) (void)]
[`(define-who make-parameter . ,_) (void)]
[`(begin . ,es) (for-each loop es)]
[_ (eval e)]))))
((orig-eval 'current-eval) eval)
((orig-eval 'current-expand) (current-expand))
((orig-eval 'enable-type-recovery) #f)
(status "Define $filter-foreign-type")
(eval `(define $filter-foreign-type
(lambda (ty)
@ -376,6 +391,8 @@
(status (format "Load ~a" s))
(load-ss (build-path scheme-dir "s" s)))
((orig-eval 'fasl-compressed) #f)
(let ([failed? #f])
(for ([src (append petite-sources scheme-sources)])
(let ([dest (path->string (path->complete-path (build-path out-subdir (path-replace-suffix src #".so"))))])

10
racket/src/cs/bootstrap/r6rs-lang.rkt
View File

@ -135,6 +135,8 @@
fixnum-width
set-car!
set-cdr!
bytevector-copy!
call-with-bytevector-output-port
make-compile-time-value
optimize-level)
@ -772,6 +774,14 @@
(define (set-cdr! p v) (unsafe-set-mcdr! p v)))])]))
(define-mutable-pair-hacks set-car! set-cdr!)
(define (bytevector-copy! src src-start dst dst-start n)
(bytes-copy! dst dst-start src src-start (+ src-start n)))
(define (call-with-bytevector-output-port proc)
(define o (open-output-bytes))
(proc o)
(get-output-bytes o))
(define (fixnum-width) (or fixnum-bits 63))
(define low-fixnum (- (expt 2 (sub1 (fixnum-width)))))

2
racket/src/cs/bootstrap/scheme-lang.rkt
View File

@ -267,6 +267,7 @@
enable-cross-library-optimization
enable-arithmetic-left-associative
enable-type-recovery
fasl-compressed
current-expand
current-generate-id
internal-defines-as-letrec*
@ -1079,6 +1080,7 @@
(define enable-cross-library-optimization (make-parameter #t))
(define enable-arithmetic-left-associative (make-parameter #f))
(define enable-type-recovery (make-parameter #t))
(define fasl-compressed (make-parameter #f))
(define current-generate-id (make-parameter gensym))