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

cs-bootstrap: support nested include and define-constant-default

Browse Source
This commit is contained in:
Matthew Flatt 2020-07-25 12:40:21 -06:00
parent a69111c1bd
commit 914db0b549
2 changed files with 69 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
racket/src/cs/bootstrap/constant.rkt
View File

@ -25,21 +25,48 @@
[(eqv? v v1) rv1]
[(eqv? v v2) rv2]
[else (error "unknown")]))]
[`(define-constant ,id ,v)
(when (exact-integer? v)
(hash-set! ht id v))]
[`(define-constant ,id ,e)
(let/cc esc
(hash-set! ht id (constant-eval e esc)))]
[`(define-constant-default ,id ,e)
(hash-ref ht id
(lambda ()
(let/cc esc
(hash-set! ht id (constant-eval e esc)))))]
[`(include ,fn)
(unless (equal? fn "machine.def")
(read-constants-from-file fn))]
[_ (void)])
(loop)))))
(when scheme-dir
(define (constant-eval e esc)
(cond
[(pair? e)
(case (car e)
[(if)
(if (constant-eval (cadr e) esc)
(constant-eval (caddr e) esc)
(constant-eval (cadddr e) esc))]
[(constant)
(hash-ref ht (cadr e) esc)]
[(=)
(= (constant-eval (cadr e) ht)
(constant-eval (caddr e) ht))]
[(quote)
(cadr e)]
[else (esc)])]
[else e]))
(define (read-constants-from-file fn)
(call-with-input-file
(build-path scheme-dir "s" (string-append target-machine ".def"))
read-constants)
(call-with-input-file
(build-path scheme-dir "s" "cmacros.ss")
(build-path scheme-dir "s" fn)
read-constants))
(when scheme-dir
(read-constants-from-file
(string-append target-machine ".def"))
(read-constants-from-file "cmacros.ss"))
(define-syntax-rule (define-constant id ...)
(begin
(provide id ...)

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

@ -6,7 +6,8 @@
(only-in "r6rs-lang.rkt"
optimize-level)
(only-in "scheme-lang.rkt"
current-expand)
current-expand
with-source-path)
(submod "scheme-lang.rkt" callback)
"syntax-mode.rkt"
"r6rs-readtable.rkt"
@ -206,21 +207,37 @@
(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 (strip-$app
(strip-$primitive
(if (struct? ex)
($uncprep ex)
ex))))
(e r))))
(define (go ex)
(define r (strip-$app
(strip-$primitive
(if (struct? ex)
($uncprep ex)
ex))))
(e r))
(let loop ([stx stx])
(syntax-case* stx (#%top-interaction
eval-when compile
begin
include) (lambda (a b)
(eq? (syntax-e a) (syntax-e b)))
[(#%top-interaction . rest) (loop #'rest)]
[(eval-when (compile) . rest)
#'(eval-when (compile eval load) . rest)]
[(begin e ...)
(for-each loop (syntax->list #'(e ...)))]
[(include fn)
(loop
#`(begin #,@(with-source-path 'include (syntax->datum #'fn)
(lambda (n)
(call-with-input-file*
n
(lambda (i)
(let loop ()
(define r (read-syntax n i))
(if (eof-object? r)
'()
(cons r (loop))))))))))]
[_ (go ((current-expand) (syntax->datum stx)))])))))
(status "Load cmacros using expander")
(load-ss (build-path scheme-dir "s/cmacros.ss"))
(status "Continue loading expander")))