remove "cs-bootstrap" package
The "cs-bootstrap" package is now in the `racket/ChezScheme` repo, because it needs to track the Chez Scheme implementation instead of the Racket implementation.
This commit is contained in:
Matthew Flatt
parent
914db0b549
commit
efc95c2e19
2
Makefile
2
Makefile
|
|
@ -705,7 +705,7 @@ PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata -
|
|||
PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt
|
||||
|
||||
pkgs-catalog:
|
||||
$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander racket/src/cs/bootstrap
|
||||
$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander
|
||||
$(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)"
|
||||
$(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +0,0 @@
|
|||
RACKET=racket
|
||||
|
||||
SCHEME_SRC=../../build/ChezScheme
|
||||
|
||||
boot:
|
||||
env SCHEME_SRC="$(SCHEME_SRC)" $(RACKET) make-boot.rkt
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
This directory constains enough of a Chez Scheme simulation to load
|
||||
the Chez Scheme compiler purely from source into Racket and apply the
|
||||
compiler to itself, thus bootstrapping Chez Scheme. (So, using an
|
||||
existing Racket build, but without using an existing Chez Scheme
|
||||
build.)
|
||||
|
||||
The "make-boot.rkt" programs builds Chez Scheme ".boot" and ".h" files
|
||||
from source. The output is written to "<machine>/boot/<machine>" in a
|
||||
Chez Scheme source directory. Build boot files that way before
|
||||
`configure` and `make` to bootstrap the build.
|
||||
|
||||
The Chez Scheme simulation hasn't been made especially fast, so expect
|
||||
the bootstrap process to take 5-10 times as long as using an existing
|
||||
Chez Scheme.
|
||||
|
||||
While the similation of Chez Scheme should be robust to common Chez
|
||||
Scheme changes, it does rely on details of the Chez Scheme
|
||||
implementation and source, So, the simulation will have to be updated
|
||||
to accommodate some Chez Scheme changes.
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe/global)
|
||||
|
||||
(provide scheme-dir
|
||||
target-machine
|
||||
optimize-level-init)
|
||||
|
||||
(define ht (get-place-table))
|
||||
|
||||
(define scheme-dir (or (hash-ref ht 'make-boot-scheme-dir #f)
|
||||
(let ([scheme-dir
|
||||
(getenv "SCHEME_SRC")])
|
||||
(and scheme-dir
|
||||
(simplify-path
|
||||
(path->complete-path scheme-dir))))))
|
||||
(hash-set! ht 'make-boot-scheme-dir scheme-dir)
|
||||
|
||||
(define target-machine (or (hash-ref ht 'make-boot-targate-machine #f)
|
||||
(getenv "MACH")
|
||||
(case (system-type)
|
||||
[(macosx) (if (eqv? 64 (system-type 'word))
|
||||
"ta6osx"
|
||||
"ti3osx")]
|
||||
[(windows) (if (eqv? 64 (system-type 'word))
|
||||
"ta6nt"
|
||||
"ti3nt")]
|
||||
[else
|
||||
(case (path->string (system-library-subpath #f))
|
||||
[("x86_64-linux") "ta6le"]
|
||||
[("i386-linux") "ti3le"]
|
||||
[else #f])])))
|
||||
(hash-set! ht 'make-boot-targate-machine target-machine)
|
||||
|
||||
(define optimize-level-init 3)
|
||||
|
|
@ -1,92 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/match
|
||||
"scheme-readtable.rkt"
|
||||
"config.rkt")
|
||||
|
||||
;; Extract constants that we need to get started by reading
|
||||
;; "cmacros.ss" and the machine ".def" file (without trying to run or
|
||||
;; expand the files)
|
||||
|
||||
(define ht (make-hasheq))
|
||||
|
||||
(define (read-constants i)
|
||||
(parameterize ([current-readtable scheme-readtable])
|
||||
(let loop ()
|
||||
(define e (read i))
|
||||
(unless (eof-object? e)
|
||||
(match e
|
||||
[`(define-constant ,id2 (case (constant ,id1)
|
||||
[(,v1) ,rv1]
|
||||
[(,v2) ,rv2]
|
||||
. ,_))
|
||||
(define v (hash-ref ht id1))
|
||||
(hash-set! ht id2
|
||||
(cond
|
||||
[(eqv? v v1) rv1]
|
||||
[(eqv? v v2) rv2]
|
||||
[else (error "unknown")]))]
|
||||
[`(define-constant ,id ,e)
|
||||
(let/cc esc
|
||||
(hash-set! ht id (constant-eval e esc)))]
|
||||
[`(define-constant-default ,id ,e)
|
||||
(hash-ref ht id
|
||||
(lambda ()
|
||||
(let/cc esc
|
||||
(hash-set! ht id (constant-eval e esc)))))]
|
||||
[`(include ,fn)
|
||||
(unless (equal? fn "machine.def")
|
||||
(read-constants-from-file fn))]
|
||||
[_ (void)])
|
||||
(loop)))))
|
||||
|
||||
(define (constant-eval e esc)
|
||||
(cond
|
||||
[(pair? e)
|
||||
(case (car e)
|
||||
[(if)
|
||||
(if (constant-eval (cadr e) esc)
|
||||
(constant-eval (caddr e) esc)
|
||||
(constant-eval (cadddr e) esc))]
|
||||
[(constant)
|
||||
(hash-ref ht (cadr e) esc)]
|
||||
[(=)
|
||||
(= (constant-eval (cadr e) ht)
|
||||
(constant-eval (caddr e) ht))]
|
||||
[(quote)
|
||||
(cadr e)]
|
||||
[else (esc)])]
|
||||
[else e]))
|
||||
|
||||
(define (read-constants-from-file fn)
|
||||
(call-with-input-file
|
||||
(build-path scheme-dir "s" fn)
|
||||
read-constants))
|
||||
|
||||
(when scheme-dir
|
||||
(read-constants-from-file
|
||||
(string-append target-machine ".def"))
|
||||
(read-constants-from-file "cmacros.ss"))
|
||||
|
||||
(define-syntax-rule (define-constant id ...)
|
||||
(begin
|
||||
(provide id ...)
|
||||
(define id (hash-ref ht 'id #f)) ...))
|
||||
|
||||
(hash-set! ht 'ptr-bytes (/ (hash-ref ht 'ptr-bits 64) 8))
|
||||
|
||||
(define-constant
|
||||
ptr-bytes
|
||||
fixnum-bits
|
||||
max-float-alignment
|
||||
annotation-debug
|
||||
annotation-profile
|
||||
visit-tag
|
||||
revisit-tag
|
||||
prelex-is-flags-offset
|
||||
prelex-was-flags-offset
|
||||
prelex-sticky-mask
|
||||
prelex-is-mask
|
||||
scheme-version)
|
||||
|
||||
(provide record-ptr-offset)
|
||||
(define record-ptr-offset 1)
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide define-datatype)
|
||||
|
||||
(define-syntax define-datatype
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (variant field ...) ...)
|
||||
(identifier? #'name)
|
||||
#'(define-datatype (name) (variant field ...) ...)]
|
||||
[(_ (name base-field ...) (variant field ...) ...)
|
||||
(let ([clean (lambda (l)
|
||||
(map (lambda (f)
|
||||
(syntax-case f ()
|
||||
[(_ id) #'id]
|
||||
[id #'id]))
|
||||
(syntax->list l)))])
|
||||
(with-syntax ([(base-field ...) (clean #'(base-field ...))]
|
||||
[((field ...) ...) (map clean
|
||||
(syntax->list #'((field ...) ...)))]
|
||||
[(name-variant ...) (for/list ([variant (in-list (syntax->list #'(variant ...)))])
|
||||
(format-id variant "~a-~a" #'name variant))]
|
||||
[([set-name-base-field! name-base-field-set!] ...)
|
||||
(for/list ([base-field (in-list (syntax->list #'(base-field ...)))])
|
||||
(define field (syntax-case base-field ()
|
||||
[(_ id) #'id]
|
||||
[id #'id]))
|
||||
(list (format-id field "set-~a-~a!" #'name field)
|
||||
(format-id field "~a-~a-set!" #'name field)))]
|
||||
[name-case (format-id #'name "~a-case" #'name)])
|
||||
#'(begin
|
||||
(define-struct name (base-field ...) #:mutable)
|
||||
(define name-base-field-set! set-name-base-field!) ...
|
||||
(define-struct (name-variant name) (field ...))
|
||||
...
|
||||
(define-syntax (name-case stx)
|
||||
(generate-case stx #'[(name base-field ...)
|
||||
(variant field ...) ...])))))])))
|
||||
|
||||
(define-for-syntax (generate-case stx spec)
|
||||
(syntax-case spec ()
|
||||
[[(name base-field ...) (variant field ...) ...]
|
||||
(let ([variants (syntax->list #'(variant ...))]
|
||||
[fieldss (syntax->list #'((field ...) ...))])
|
||||
(syntax-case stx ()
|
||||
[(_ expr clause ...)
|
||||
(with-syntax ([([lhs rhs ...] ...)
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))])
|
||||
(syntax-case clause (else)
|
||||
[[else . _] clause]
|
||||
[[c-variant (c-field ...) rhs ...]
|
||||
(or (for/or ([variant (in-list variants)]
|
||||
[fields (in-list fieldss)]
|
||||
#:when (eq? (syntax-e #'c-variant) (syntax-e variant)))
|
||||
(with-syntax ([variant? (format-id variant "~a-~a?" #'name variant)]
|
||||
[(field-ref ...) (for/list ([field (in-list (syntax->list fields))])
|
||||
(format-id field "~a-~a-~a" #'name variant field))])
|
||||
#`[(variant? v)
|
||||
(let ([c-field (field-ref v)] ...)
|
||||
rhs ...)]))
|
||||
(raise-syntax-error #f
|
||||
"no matching variant"
|
||||
stx
|
||||
clause))]
|
||||
[_ (raise-syntax-error #f
|
||||
"unrecognized clause"
|
||||
stx
|
||||
clause)]))])
|
||||
#'(let ([v expr])
|
||||
(cond
|
||||
[lhs rhs ...] ...)))]))]))
|
||||
|
||||
(define-for-syntax (format-id ctx fmt . args)
|
||||
(datum->syntax
|
||||
ctx
|
||||
(string->symbol
|
||||
(apply format fmt (map syntax-e args)))))
|
||||
|
|
@ -1,162 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "gensym.rkt")
|
||||
|
||||
(provide s:format
|
||||
s:printf
|
||||
s:fprintf
|
||||
s:error)
|
||||
|
||||
(define (s:format fmt . args)
|
||||
(define o (open-output-string))
|
||||
(do-printf o fmt args)
|
||||
(get-output-string o))
|
||||
|
||||
(define (s:printf fmt . args)
|
||||
(do-printf (current-output-port) fmt args))
|
||||
|
||||
(define (s:fprintf o fmt . args)
|
||||
(do-printf o fmt args))
|
||||
|
||||
(define (s:error sym fmt . args)
|
||||
(define o (open-output-string))
|
||||
(do-printf o fmt args)
|
||||
(error sym "~a" (get-output-string o)))
|
||||
|
||||
(define (do-printf o fmt args)
|
||||
(cond
|
||||
[(and (equal? fmt "~s")
|
||||
(not (print-gensym))
|
||||
(and (pair? args)
|
||||
(gensym? (car args))))
|
||||
(write-string (gensym->pretty-string (car args)) o)]
|
||||
[(and (let loop ([i 0])
|
||||
(cond
|
||||
[(= i (string-length fmt))
|
||||
#t]
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(< i (sub1 (string-length fmt))))
|
||||
(define c (string-ref fmt (add1 i)))
|
||||
(if (or (char=? c #\a)
|
||||
(char=? c #\s)
|
||||
(char=? c #\v)
|
||||
(char=? c #\e))
|
||||
(loop (+ i 2))
|
||||
#f)]
|
||||
[else (loop (add1 i))]))
|
||||
(or (null? args)
|
||||
(not (bytes? (car args)))))
|
||||
(apply fprintf o fmt args)]
|
||||
[else
|
||||
;; implement additional format functionality
|
||||
(let loop ([i 0] [args args] [mode '()])
|
||||
(cond
|
||||
[(= i (string-length fmt))
|
||||
(unless (null? args) (error 'format "leftover args"))]
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(< i (sub1 (string-length fmt))))
|
||||
(define c (string-ref fmt (add1 i)))
|
||||
(case c
|
||||
[(#\a #\d)
|
||||
(define v (car args))
|
||||
(cond
|
||||
[(and (gensym? v)
|
||||
(not (print-gensym)))
|
||||
(display (gensym->pretty-string v) o)]
|
||||
[(bytes? v)
|
||||
(begin
|
||||
(write-bytes #"#vu8" o)
|
||||
(display (bytes->list v) o))]
|
||||
[else
|
||||
(display (if (memq 'upcase mode)
|
||||
(string-upcase v)
|
||||
v)
|
||||
o)])
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[(#\s #\v #\e)
|
||||
(define v (car args))
|
||||
(if (bytes? v)
|
||||
(begin
|
||||
(write-bytes #"#vu8" o)
|
||||
(display (bytes->list v) o))
|
||||
(write v o))
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[(#\x)
|
||||
(display (string-upcase (number->string (car args) 16)) o)
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[(#\: #\@)
|
||||
(case (string-ref fmt (+ i 2))
|
||||
[(#\[)
|
||||
(define (until i char print?)
|
||||
(let loop ([i i])
|
||||
(define c (string-ref fmt i))
|
||||
(cond
|
||||
[(and (char=? c #\~)
|
||||
(char=? char (string-ref fmt (add1 i))))
|
||||
(+ i 2)]
|
||||
[print?
|
||||
(write-char c o)
|
||||
(loop (add1 i))]
|
||||
[else (loop (add1 i))])))
|
||||
(define next-i (+ i 3))
|
||||
(case c
|
||||
[(#\@)
|
||||
(cond
|
||||
[(car args)
|
||||
(define-values (close-i rest-args) (loop next-i args mode))
|
||||
(loop close-i rest-args mode)]
|
||||
[else
|
||||
(define close-i (until next-i #\] #f))
|
||||
(loop close-i (cdr args) mode)])]
|
||||
[else
|
||||
(define sep-i (until next-i #\; (not (car args))))
|
||||
(define close-i (until sep-i #\] (car args)))
|
||||
(loop close-i (cdr args) mode)])]
|
||||
[(#\:)
|
||||
(case (string-ref fmt (+ i 3))
|
||||
[(#\()
|
||||
(define-values (close-i rest-args) (loop (+ i 4) args (cons 'upcase mode)))
|
||||
(loop close-i rest-args mode)]
|
||||
[else
|
||||
(error "unexpected after @:" (string-ref fmt (+ i 3)))])]
|
||||
[else
|
||||
(error "unexpected after : or @" (string-ref fmt (+ i 2)))])]
|
||||
[(#\{)
|
||||
(define lst (car args))
|
||||
(cond
|
||||
[(null? lst)
|
||||
(let eloop ([i (+ i 2)])
|
||||
(cond
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(char=? #\} (string-ref fmt (add1 i))))
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[else (eloop (add1 i))]))]
|
||||
[else
|
||||
(define-values (next-i rest-args)
|
||||
(for/fold ([next-i (+ i 2)] [args (append lst (cdr args))]) ([x (in-list lst)])
|
||||
(loop (+ i 2) args mode)))
|
||||
(loop next-i rest-args mode)])]
|
||||
[(#\} #\] #\))
|
||||
;; assume we're in a loop via `~{` or `~[` or `~(`
|
||||
(values (+ i 2) args)]
|
||||
[(#\?)
|
||||
(do-printf o (car args) (cadr args))
|
||||
(loop (+ i 2) (cddr args) mode)]
|
||||
[(#\%)
|
||||
(newline o)
|
||||
(loop (+ i 2) args mode)]
|
||||
[(#\^)
|
||||
(if (null? args)
|
||||
(let eloop ([i (+ i 2)])
|
||||
(cond
|
||||
[(= i (string-length fmt))
|
||||
(values i args)]
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(char=? #\} (string-ref fmt (add1 i))))
|
||||
(values (+ i 2) args)]
|
||||
[else (eloop (add1 i))]))
|
||||
(loop (+ i 2) args mode))]
|
||||
[else
|
||||
(error "unexpected" fmt)])]
|
||||
[else
|
||||
(write-char (string-ref fmt i) o)
|
||||
(loop (add1 i) args mode)]))]))
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (only-in racket/base
|
||||
[gensym r:gensym]))
|
||||
|
||||
;; Represent a gensym as a symbol of the form |{....}| where the
|
||||
;; "pretty name" must not contain spaces.
|
||||
|
||||
(provide print-gensym
|
||||
gensym
|
||||
$intern3
|
||||
gensym?
|
||||
gensym->unique-string
|
||||
gensym->pretty-string
|
||||
hash-curly
|
||||
uninterned-symbol?)
|
||||
|
||||
(define print-gensym (make-parameter #t))
|
||||
|
||||
(define gensym
|
||||
(case-lambda
|
||||
[() (gensym (r:gensym))]
|
||||
[(pretty-name)
|
||||
(gensym pretty-name (r:gensym "unique"))]
|
||||
[(pretty-name unique-name)
|
||||
(string->symbol
|
||||
(format "{~a ~a}" pretty-name unique-name))]))
|
||||
|
||||
(define ($intern3 gstring pretty-len full-len)
|
||||
(gensym (substring gstring 0 pretty-len) gstring))
|
||||
|
||||
(define (gensym? s)
|
||||
(and (symbol? s)
|
||||
(let ([str (symbol->string s)])
|
||||
(define len (string-length str))
|
||||
(and (positive? len)
|
||||
(char=? #\{ (string-ref str 0))
|
||||
(char=? #\} (string-ref str (sub1 len)))))))
|
||||
|
||||
(define (gensym->unique-string s)
|
||||
(cadr (regexp-match #rx"^{[^ ]* (.*)}$" (symbol->string s))))
|
||||
|
||||
(define (gensym->pretty-string s)
|
||||
(cadr (regexp-match #rx"^{([^ ]*) .*}$" (symbol->string s))))
|
||||
|
||||
(define (hash-curly c in src line col pos)
|
||||
(define sym
|
||||
(string->symbol
|
||||
(list->string
|
||||
(cons
|
||||
#\{
|
||||
(let loop ()
|
||||
(define ch (read-char in))
|
||||
(if (eqv? ch #\})
|
||||
'(#\})
|
||||
(cons ch (loop))))))))
|
||||
(when (regexp-match? #rx"[|]" (symbol->string sym))
|
||||
(error "here"))
|
||||
sym)
|
||||
|
||||
(define (uninterned-symbol? v)
|
||||
(and (symbol? v)
|
||||
(not (or (symbol-interned? v)
|
||||
(symbol-unreadable? v)))))
|
||||
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide $hand-coded)
|
||||
|
||||
(define ($hand-coded sym)
|
||||
(case sym
|
||||
[($install-library-entry-procedure)
|
||||
(lambda (key val)
|
||||
(hash-set! library-entries key val))]
|
||||
[($foreign-entry-procedure) void]
|
||||
[(callcc call1cc) call/cc]
|
||||
[(scan-remembered-set
|
||||
get-room
|
||||
call-error
|
||||
dooverflood
|
||||
dooverflow
|
||||
dorest0 dorest1 dorest2 dorest3 dorest4 dorest5 doargerr
|
||||
dounderflow nuate reify-cc
|
||||
dofargint32 dofretint32 dofretuns32 dofargint64 dofretint64
|
||||
dofretuns64 dofretu8* dofretu16* dofretu32* domvleterr
|
||||
values-error $shift-attachment)
|
||||
void]
|
||||
[(bytevector=?) equal?]
|
||||
[($wrapper-apply wrapper-apply arity-wrapper-apply) void]
|
||||
[(nonprocedure-code) (lambda args (error "not a procedure"))]
|
||||
[else
|
||||
(error '$hand-coded "missing ~s" sym)]))
|
||||
|
||||
(define library-entries (make-hasheqv))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(define-syntax-rule (immediate name name?)
|
||||
(begin
|
||||
(provide (rename-out [value name])
|
||||
name?)
|
||||
|
||||
;; mutable preserves `eq?` in datum->syntax->datum conversion
|
||||
(struct name ([v #:mutable]) #:prefab)
|
||||
|
||||
(define value (name #f))))
|
||||
|
||||
(immediate base-rtd base-rtd?)
|
||||
(immediate bwp bwp?)
|
||||
(immediate black-hole black-hole?)
|
||||
(immediate $unbound-object $unbound-object?)
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection "cs-bootstrap")
|
||||
(define pkg-name "cs-bootstrap") ; for `create-dirs-catalog`
|
||||
|
||||
(define deps '("base"))
|
||||
|
||||
(define pkg-desc "Creates Chez Scheme boot files from source")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
racket/runtime-path)
|
||||
|
||||
;; Wrapper around "make-boot.rkt" to make it work in a more normal way
|
||||
;; with command-line arguments, instead of environment variables.
|
||||
|
||||
(define scheme-src #f)
|
||||
(define mach #f)
|
||||
|
||||
(command-line
|
||||
#:once-each
|
||||
[("--scheme-src") dir "Select the directory (defaults to current directory)"
|
||||
(set! scheme-src dir)]
|
||||
[("--machine") machine "Select the machine type (defaults to inferred)"
|
||||
(set! mach machine)])
|
||||
|
||||
(unless scheme-src
|
||||
(printf "Assuming current directory has Chez Scheme sources\n")
|
||||
(flush-output))
|
||||
|
||||
(void (putenv "SCHEME_SRC" (or scheme-src ".")))
|
||||
(when mach
|
||||
(void (putenv "MACH" mach)))
|
||||
|
||||
;; Dynamic, so that environment variables are visible to
|
||||
;; compile-time instantiation of `make-boot`:
|
||||
(define-runtime-path make-boot "make-boot.rkt")
|
||||
(dynamic-require make-boot #f)
|
||||
|
|
@ -1,435 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/runtime-path
|
||||
racket/match
|
||||
racket/file
|
||||
racket/pretty
|
||||
(only-in "r6rs-lang.rkt"
|
||||
optimize-level)
|
||||
(only-in "scheme-lang.rkt"
|
||||
current-expand
|
||||
with-source-path)
|
||||
(submod "scheme-lang.rkt" callback)
|
||||
"syntax-mode.rkt"
|
||||
"r6rs-readtable.rkt"
|
||||
"scheme-readtable.rkt"
|
||||
"parse-makefile.rkt"
|
||||
"config.rkt"
|
||||
"strip.rkt")
|
||||
|
||||
;; Set `SCHEME_SRC` and `MACH` to specify the ChezScheme source
|
||||
;; directory and the target machine. Set the `MAKE_BOOT_FOR_CROSS`
|
||||
;; environment variable to generate just enough to run `configure`
|
||||
;; for a corss build.
|
||||
|
||||
(unless scheme-dir
|
||||
(error "set `SCHEME_SRC` environment variable"))
|
||||
(unless target-machine
|
||||
(error "set `MACH` environment variable"))
|
||||
|
||||
;; Writes ".boot" and ".h" files to a "boot" subdirectory of
|
||||
;; `SCHEME_SRC`.
|
||||
|
||||
(define-runtime-path here-dir ".")
|
||||
(define out-subdir (build-path scheme-dir "boot" target-machine))
|
||||
(define nano-dir (build-path scheme-dir "nanopass"))
|
||||
|
||||
(define (status msg)
|
||||
(printf "~a\n" msg)
|
||||
(flush-output))
|
||||
|
||||
(define sources-date
|
||||
(for/fold ([d 0]) ([dir (in-list (list here-dir
|
||||
nano-dir
|
||||
(build-path scheme-dir "s")))])
|
||||
(status (format "Use ~a" dir))
|
||||
(for/fold ([d d]) ([f (in-list (directory-list dir))]
|
||||
#:when (regexp-match? #rx"[.](?:rkt|ss|sls)$" f))
|
||||
(max d (file-or-directory-modify-seconds (build-path dir f))))))
|
||||
|
||||
(status (format "Check ~a" out-subdir))
|
||||
(when (for/and ([f (in-list (list "scheme.h"
|
||||
"equates.h"
|
||||
"petite.boot"
|
||||
"scheme.boot"))])
|
||||
(define d (file-or-directory-modify-seconds (build-path out-subdir f) #f (lambda () #f)))
|
||||
(and d (d . >= . sources-date)))
|
||||
(status "Up-to-date")
|
||||
(exit))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-runtime-module-path r6rs-lang-mod "r6rs-lang.rkt")
|
||||
(define-runtime-module-path scheme-lang-mod "scheme-lang.rkt")
|
||||
|
||||
(define-values (petite-sources scheme-sources)
|
||||
(get-sources-from-makefile scheme-dir))
|
||||
|
||||
(define ns (make-base-empty-namespace))
|
||||
(namespace-attach-module (current-namespace) r6rs-lang-mod ns)
|
||||
(namespace-attach-module (current-namespace) scheme-lang-mod ns)
|
||||
|
||||
(namespace-require r6rs-lang-mod ns) ; get `library`
|
||||
|
||||
;; Change some bindings from imported to top-level references so that
|
||||
;; expressions are compiled to reference variables that are updated by
|
||||
;; loading the Chez Scheme compiler. This approach is better than
|
||||
;; using `namespace-require/copy`, because we want most primitives to
|
||||
;; be referenced directly to make the compiler run faster.
|
||||
(define (reset-toplevels [more '()])
|
||||
(for-each (lambda (sym)
|
||||
(eval `(define ,sym ,sym) ns))
|
||||
(append
|
||||
more
|
||||
'(identifier?
|
||||
datum->syntax
|
||||
syntax->list
|
||||
syntax->datum
|
||||
generate-temporaries
|
||||
free-identifier=?
|
||||
bound-identifier=?
|
||||
make-compile-time-value
|
||||
current-eval
|
||||
eval
|
||||
expand
|
||||
compile
|
||||
error
|
||||
format))))
|
||||
|
||||
(reset-toplevels)
|
||||
|
||||
(status "Load nanopass")
|
||||
(define (load-nanopass)
|
||||
(load/cd (build-path nano-dir "nanopass/helpers.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/syntaxconvert.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/records.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/meta-syntax-dispatch.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/meta-parser.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/pass.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/language-node-counter.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/unparser.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/language-helpers.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/language.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/nano-syntax-dispatch.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/parser.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass.ss")))
|
||||
(parameterize ([current-namespace ns]
|
||||
[current-readtable r6rs-readtable])
|
||||
(load/cd (build-path nano-dir "nanopass/implementation-helpers.ikarus.ss"))
|
||||
(load-nanopass))
|
||||
|
||||
(namespace-require ''nanopass ns)
|
||||
|
||||
(namespace-require scheme-lang-mod ns)
|
||||
|
||||
(reset-toplevels '(run-cp0
|
||||
errorf
|
||||
$oops
|
||||
$undefined-violation
|
||||
generate-interrupt-trap))
|
||||
|
||||
(namespace-require `(for-syntax ,r6rs-lang-mod) ns)
|
||||
(namespace-require `(for-syntax ,scheme-lang-mod) ns)
|
||||
(namespace-require `(for-meta 2 ,r6rs-lang-mod) ns)
|
||||
(namespace-require `(for-meta 2 ,scheme-lang-mod) ns)
|
||||
|
||||
(namespace-require `(only (submod (file ,(path->string (resolved-module-path-name r6rs-lang-mod))) ikarus) with-implicit)
|
||||
ns)
|
||||
|
||||
(define show? #f)
|
||||
(define orig-eval (let ([e (current-eval)])
|
||||
(lambda args
|
||||
(when show? (pretty-write args))
|
||||
(apply e args))))
|
||||
|
||||
(define (call-with-expressions path proc)
|
||||
(call-with-input-file*
|
||||
path
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define e (read i))
|
||||
(unless (eof-object? e)
|
||||
(proc e)
|
||||
(loop))))))
|
||||
|
||||
(define (load-ss path)
|
||||
(define-values (base name dir) (split-path (path->complete-path path)))
|
||||
(parameterize ([current-directory base])
|
||||
(call-with-expressions path eval)))
|
||||
|
||||
(parameterize ([current-namespace ns]
|
||||
[current-readtable scheme-readtable]
|
||||
[compile-allow-set!-undefined #t]
|
||||
[current-eval (current-eval)])
|
||||
|
||||
(status "Load cmacro parts")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/cmacros.ss")
|
||||
(lambda (e)
|
||||
(define (define-macro? m)
|
||||
(memq m '(define-syntactic-monad define-flags set-flags)))
|
||||
(define (define-for-syntax? m)
|
||||
(memq m '(lookup-constant flag->mask)))
|
||||
(match e
|
||||
[`(define-syntax ,m . ,_)
|
||||
(when (define-macro? m)
|
||||
(orig-eval e))]
|
||||
[`(eval-when ,_ (define ,m . ,rhs))
|
||||
(when (define-for-syntax? m)
|
||||
(orig-eval `(begin-for-syntax (define ,m . ,rhs))))]
|
||||
[`(define-flags . ,_)
|
||||
(orig-eval e)]
|
||||
[_ (void)])))
|
||||
|
||||
(set-current-expand-set-callback!
|
||||
(lambda ()
|
||||
(start-fully-unwrapping-syntax!)
|
||||
(define $uncprep (orig-eval '$uncprep))
|
||||
(current-eval
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[("noexpand" form)
|
||||
(orig-eval (strip-$app (strip-$primitive ($uncprep (syntax-e #'form)))))]
|
||||
[_
|
||||
(orig-eval stx)])))
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/syntax.ss")
|
||||
(lambda (e)
|
||||
(let loop ([e e])
|
||||
(cond
|
||||
[(and (pair? e)
|
||||
(eq? 'define-syntax (car e)))
|
||||
((current-expand) `(define-syntax ,(cadr e)
|
||||
',(orig-eval (caddr e))))]
|
||||
[(and (pair? e)
|
||||
(eq? 'begin (car e)))
|
||||
(for-each loop (cdr e))]))))
|
||||
(status "Install evaluator")
|
||||
(current-eval
|
||||
(let ([e (current-eval)])
|
||||
(lambda (stx)
|
||||
(define (go ex)
|
||||
(define r (strip-$app
|
||||
(strip-$primitive
|
||||
(if (struct? ex)
|
||||
($uncprep ex)
|
||||
ex))))
|
||||
(e r))
|
||||
(let loop ([stx stx])
|
||||
(syntax-case* stx (#%top-interaction
|
||||
eval-when compile
|
||||
begin
|
||||
include) (lambda (a b)
|
||||
(eq? (syntax-e a) (syntax-e b)))
|
||||
[(#%top-interaction . rest) (loop #'rest)]
|
||||
[(eval-when (compile) . rest)
|
||||
#'(eval-when (compile eval load) . rest)]
|
||||
[(begin e ...)
|
||||
(for-each loop (syntax->list #'(e ...)))]
|
||||
[(include fn)
|
||||
(loop
|
||||
#`(begin #,@(with-source-path 'include (syntax->datum #'fn)
|
||||
(lambda (n)
|
||||
(call-with-input-file*
|
||||
n
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define r (read-syntax n i))
|
||||
(if (eof-object? r)
|
||||
'()
|
||||
(cons r (loop))))))))))]
|
||||
[_ (go ((current-expand) (syntax->datum stx)))])))))
|
||||
(status "Load cmacros using expander")
|
||||
(load-ss (build-path scheme-dir "s/cmacros.ss"))
|
||||
(status "Continue loading expander")))
|
||||
|
||||
(status "Load enum")
|
||||
(load-ss (build-path scheme-dir "s/enum.ss"))
|
||||
(eval '(define $annotation-options (make-enumeration '(debug profile))))
|
||||
(eval '(define $make-annotation-options (enum-set-constructor $annotation-options)))
|
||||
(eval
|
||||
'(define-syntax-rule (library-requirements-options id ...)
|
||||
(with-syntax ([members ($enum-set-members ($make-library-requirements-options (datum (id ...))))])
|
||||
#'($record (record-rtd $library-requirements-options) members))))
|
||||
|
||||
(status "Load cprep")
|
||||
(load-ss (build-path scheme-dir "s/cprep.ss"))
|
||||
|
||||
(status "Load expander")
|
||||
(load-ss (build-path scheme-dir "s/syntax.ss"))
|
||||
|
||||
(status "Initialize system libraries")
|
||||
(define (init-libraries)
|
||||
(eval '($make-base-modules))
|
||||
(eval '($make-rnrs-libraries))
|
||||
(eval '(library-search-handler (lambda args (values #f #f #f))))
|
||||
(eval '(define-syntax guard
|
||||
(syntax-rules (else)
|
||||
[(_ (var clause ... [else e1 e2 ...]) b1 b2 ...)
|
||||
($guard #f (lambda (var) (cond clause ... [else e1 e2 ...]))
|
||||
(lambda () b1 b2 ...))]
|
||||
[(_ (var clause1 clause2 ...) b1 b2 ...)
|
||||
($guard #t (lambda (var p) (cond clause1 clause2 ... [else (p)]))
|
||||
(lambda () b1 b2 ...))]))))
|
||||
(init-libraries)
|
||||
|
||||
(status "Load nanopass using expander")
|
||||
(load-ss (build-path nano-dir "nanopass/implementation-helpers.chezscheme.sls"))
|
||||
(load-nanopass)
|
||||
|
||||
(status "Load priminfo and primvars")
|
||||
(load-ss (build-path scheme-dir "s/priminfo.ss"))
|
||||
(load-ss (build-path scheme-dir "s/primvars.ss"))
|
||||
|
||||
(status "Load expander using expander")
|
||||
(set-current-expand-set-callback! void)
|
||||
(load-ss (build-path scheme-dir "s/syntax.ss"))
|
||||
|
||||
(status "Initialize system libraries in bootstrapped expander")
|
||||
(init-libraries)
|
||||
|
||||
(status "Declare nanopass in bootstrapped expander")
|
||||
(load-ss (build-path nano-dir "nanopass/implementation-helpers.chezscheme.sls"))
|
||||
(load-nanopass)
|
||||
|
||||
(status "Load some io.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/io.ss")
|
||||
(lambda (e)
|
||||
(define (want-syntax? id)
|
||||
(memq id '(file-options-list eol-style-list error-handling-mode-list)))
|
||||
(define (want-val? id)
|
||||
(memq id '($file-options $make-file-options $eol-style? buffer-mode? $error-handling-mode?)))
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(let () ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(begin ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(define-syntax ,id . ,_)
|
||||
(when (want-syntax? id)
|
||||
(eval e))]
|
||||
[`(set-who! ,id . ,_)
|
||||
(when (want-val? id)
|
||||
(eval e))]
|
||||
[_ (void)]))))
|
||||
|
||||
(status "Load some strip.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/strip.ss")
|
||||
(lambda (e)
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(let () ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(begin ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(set-who! $fasl-strip-options . ,_)
|
||||
(eval e)]
|
||||
[`(set-who! $make-fasl-strip-options . ,_)
|
||||
(eval e)]
|
||||
[_ (void)]))))
|
||||
|
||||
(status "Load some 7.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/7.ss")
|
||||
(lambda (e)
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(let () ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(begin ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(define $format-scheme-version . ,_)
|
||||
(eval e)]
|
||||
[`(define ($compiled-file-header? . ,_) . ,_)
|
||||
(eval e)]
|
||||
[_ (void)]))))
|
||||
|
||||
(status "Load most front.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/front.ss")
|
||||
(lambda (e)
|
||||
;; Skip `package-stubs`, which would undo "syntax.ss" definitions
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(package-stubs . ,_) (void)]
|
||||
[`(define-who make-parameter . ,_) (void)]
|
||||
[`(begin . ,es) (for-each loop es)]
|
||||
[_ (eval e)]))))
|
||||
((orig-eval 'current-eval) eval)
|
||||
((orig-eval 'current-expand) (current-expand))
|
||||
((orig-eval 'enable-type-recovery) #f)
|
||||
|
||||
(status "Define $filter-foreign-type")
|
||||
(eval `(define $filter-foreign-type
|
||||
(lambda (ty)
|
||||
(filter-foreign-type ty))))
|
||||
|
||||
(make-directory* out-subdir)
|
||||
|
||||
(status "Load mkheader")
|
||||
(load-ss (build-path scheme-dir "s/mkheader.ss"))
|
||||
(status "Generate headers")
|
||||
(eval `(mkscheme.h ,(path->string (build-path out-subdir "scheme.h")) ,target-machine))
|
||||
(eval `(mkequates.h ,(path->string (build-path out-subdir "equates.h"))))
|
||||
(plumber-flush-all (current-plumber))
|
||||
|
||||
(let ([mkgc.ss (build-path scheme-dir "s/mkgc.ss")])
|
||||
(when (file-exists? mkgc.ss)
|
||||
(status "Load mkgc")
|
||||
(load-ss (build-path scheme-dir "s/mkgc.ss"))
|
||||
(status "Generate GC")
|
||||
(eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc"))))
|
||||
(eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc"))))
|
||||
(eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc"))))
|
||||
(plumber-flush-all (current-plumber))))
|
||||
|
||||
(when (getenv "MAKE_BOOT_FOR_CROSS")
|
||||
;; Working bootfiles are not needed for a cross build (only the
|
||||
;; ".h" files are needed), so just make dummy files in that case
|
||||
;; to let `configure` work
|
||||
(define (touch p)
|
||||
(unless (file-exists? p) (call-with-output-file* p void)))
|
||||
(touch (build-path out-subdir "petite.boot"))
|
||||
(touch (build-path out-subdir "scheme.boot"))
|
||||
(exit))
|
||||
|
||||
(for ([s (in-list '("ftype.ss"
|
||||
"fasl.ss"
|
||||
"reloc.ss"
|
||||
"format.ss"
|
||||
"cp0.ss"
|
||||
"cpvalid.ss"
|
||||
"cpcheck.ss"
|
||||
"cpletrec.ss"
|
||||
"cpcommonize.ss"
|
||||
"cpnanopass.ss"
|
||||
"compile.ss"
|
||||
"back.ss"))])
|
||||
(status (format "Load ~a" s))
|
||||
(load-ss (build-path scheme-dir "s" s)))
|
||||
|
||||
((orig-eval 'fasl-compressed) #f)
|
||||
|
||||
(let ([failed? #f])
|
||||
(for ([src (append petite-sources scheme-sources)])
|
||||
(let ([dest (path->string (path->complete-path (build-path out-subdir (path-replace-suffix src #".so"))))])
|
||||
(parameterize ([current-directory (build-path scheme-dir "s")])
|
||||
;; (status (format "Compile ~a" src)) - Chez Scheme prints its own message
|
||||
(with-handlers (#;[exn:fail? (lambda (exn)
|
||||
(eprintf "ERROR: ~s\n" (exn-message exn))
|
||||
(set! failed? #t))])
|
||||
(time ((orig-eval 'compile-file) src dest))))))
|
||||
(when failed?
|
||||
(raise-user-error 'make-boot "compilation failure(s)")))
|
||||
|
||||
(let ([src->so (lambda (src)
|
||||
(path->string (build-path out-subdir (path-replace-suffix src #".so"))))])
|
||||
(status "Writing petite.boot")
|
||||
(eval `($make-boot-file ,(path->string (build-path out-subdir "petite.boot"))
|
||||
',(string->symbol target-machine) '()
|
||||
,@(map src->so petite-sources)))
|
||||
(status "Writing scheme.boot")
|
||||
(eval `($make-boot-file ,(path->string (build-path out-subdir "scheme.boot"))
|
||||
',(string->symbol target-machine) '("petite")
|
||||
,@(map src->so scheme-sources)))))
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
;; To load the R6RS nanopass framework into Racket, we need to make
|
||||
;; an adjustment to the use of `datum->syntax` in `make-in-context-transformer`.
|
||||
;; This same adjustment appears in the Racket version of nanopass.
|
||||
|
||||
(provide patch:define)
|
||||
|
||||
(define-syntax (patch:define stx)
|
||||
(syntax-case stx (make-in-context-transformer lambda x quote)
|
||||
[(...
|
||||
(_ id
|
||||
(lambda args
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ . pat-rest)
|
||||
(with-syntax ([qq (datum->syntax _ 'quasiquote)])
|
||||
body)])))))
|
||||
(free-identifier=? #'id #'make-in-context-transformer)
|
||||
(begin
|
||||
(printf "Apply nanopass patch\n")
|
||||
#'(...
|
||||
(define id
|
||||
(lambda args
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(me . pat-rest)
|
||||
(with-syntax ([qq (datum->syntax #'me 'quasiquote)])
|
||||
body)]))))))]
|
||||
[(_ . rest) #'(define . rest)]))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/string)
|
||||
|
||||
(provide get-sources-from-makefile)
|
||||
|
||||
(define (get-sources-from-makefile scheme-dir)
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s" "Mf-base")
|
||||
#:mode 'text
|
||||
(lambda (i)
|
||||
(define (extract-files m)
|
||||
(string-split (regexp-replace* #rx"\\\\" (bytes->string/utf-8 (cadr m)) "")))
|
||||
(define bases (extract-files (regexp-match #rx"basesrc =((?:[^\\\n]*\\\\\n)*[^\\\n]*)\n" i)))
|
||||
(define compilers (extract-files (regexp-match #rx"compilersrc =((?:[^\\\n]*\\\\\n)*[^\\\n]*)\n" i)))
|
||||
(values bases compilers))))
|
||||
|
||||
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/match
|
||||
"scheme-struct.rkt"
|
||||
"scheme-readtable.rkt"
|
||||
"symbol.rkt")
|
||||
|
||||
(provide get-primdata
|
||||
(struct-out priminfo))
|
||||
|
||||
(struct priminfo (unprefixed libraries mask signatures arity))
|
||||
|
||||
;; Returns flags->bits for prim flags, `primvec` function, and `get-priminfo` function
|
||||
(define (get-primdata $sputprop scheme-dir)
|
||||
(define flags->bits
|
||||
(cond
|
||||
[scheme-dir
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s/cmacros.ss")
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define l (parameterize ([current-readtable scheme-readtable])
|
||||
(read i)))
|
||||
(match l
|
||||
[`(define-flags prim-mask ,specs ...)
|
||||
(define bits
|
||||
(for/fold ([bits #hasheq()]) ([spec (in-list specs)])
|
||||
(define (get-val v)
|
||||
(if (number? v) v (hash-ref bits v)))
|
||||
(match spec
|
||||
[`(,name (or ,vals ...))
|
||||
(hash-set bits name (apply bitwise-ior (map get-val vals)))]
|
||||
[`(,name ,val)
|
||||
(hash-set bits name (get-val val))])))
|
||||
(lambda (flags)
|
||||
(apply bitwise-ior (for/list ([flag (in-list flags)])
|
||||
(hash-ref bits flag))))]
|
||||
[_ (loop)]))))]
|
||||
[else #hasheq()]))
|
||||
(define primref-variant
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s/primref.ss")
|
||||
(lambda (i)
|
||||
(define decl (parameterize ([current-readtable scheme-readtable])
|
||||
(read i)))
|
||||
(match decl
|
||||
[`(define-record-type primref
|
||||
(nongenerative ,variant)
|
||||
. ,_)
|
||||
variant]
|
||||
[_
|
||||
(error "cannot parse content of s/primref.ss")]))))
|
||||
(define priminfos (make-hasheq))
|
||||
(when scheme-dir
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s/primdata.ss")
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define l (parameterize ([current-readtable #f])
|
||||
(read i)))
|
||||
(unless (eof-object? l)
|
||||
(match l
|
||||
[`(,def-sym-flags
|
||||
([libraries ,libs ...] [flags ,group-flags ...])
|
||||
,clauses ...)
|
||||
(for ([clause (in-list clauses)])
|
||||
(match clause
|
||||
[`(,id ,specs ...)
|
||||
(define-values (flags sigs)
|
||||
(for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)])
|
||||
(match spec
|
||||
[`[sig ,sigs ...] (values flags sigs )]
|
||||
[`[flags ,flags ...] (values (append flags group-flags) sigs)]
|
||||
[`[feature ,features ...] (values flags sigs)])))
|
||||
(define plain-id (if (pair? id)
|
||||
(string->symbol (format "~a~a"
|
||||
(car id)
|
||||
(cadr id)))
|
||||
id))
|
||||
(define flag-bits (flags->bits flags))
|
||||
(define interface (map sig->interface sigs))
|
||||
(define pr (case primref-variant
|
||||
[(|{primref a0xltlrcpeygsahopkplcn-3}|)
|
||||
(primref3 plain-id flag-bits interface sigs)]
|
||||
[(|{primref a0xltlrcpeygsahopkplcn-2}|)
|
||||
(primref2 plain-id flag-bits interface)]
|
||||
[else (error "unrecognized primref variant in s/primref.ss"
|
||||
primref-variant)]))
|
||||
(register-symbols plain-id)
|
||||
($sputprop plain-id '*prim2* pr)
|
||||
($sputprop plain-id '*prim3* pr)
|
||||
($sputprop plain-id '*flags* flag-bits)
|
||||
(hash-set! priminfos plain-id (priminfo (if (pair? id) (cadr id) id)
|
||||
libs
|
||||
flag-bits
|
||||
sigs
|
||||
(map sig->interface sigs)))]))])
|
||||
(loop))))))
|
||||
(values (lambda () (list->vector (hash-keys priminfos)))
|
||||
(lambda (sym) (hash-ref priminfos sym #f))))
|
||||
|
||||
(define (sig->interface sig)
|
||||
(match sig
|
||||
[`((,args ... ,'...) ,ress ...)
|
||||
(- -1 (length args))]
|
||||
[`((,args ... ,'... ,last-arg) ,ress ...)
|
||||
(- -2 (length args))]
|
||||
[`((,args ...) ,ress ...)
|
||||
(length args)]))
|
||||
|
|
@ -1,813 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
(for-template racket/base)
|
||||
racket/fixnum
|
||||
racket/flonum
|
||||
racket/pretty
|
||||
racket/list
|
||||
racket/splicing
|
||||
racket/unsafe/ops
|
||||
"nanopass-patch.rkt"
|
||||
"gensym.rkt"
|
||||
"format.rkt"
|
||||
"syntax-mode.rkt"
|
||||
"constant.rkt"
|
||||
"config.rkt"
|
||||
"rcd.rkt"
|
||||
(only-in "record.rkt"
|
||||
do-$make-record-type
|
||||
register-rtd-name!
|
||||
register-rtd-fields!
|
||||
s:struct-type?
|
||||
record-predicate
|
||||
record-accessor
|
||||
record-mutator)
|
||||
(only-in "immediate.rkt"
|
||||
base-rtd)
|
||||
(only-in "scheme-struct.rkt"
|
||||
syntax-object syntax-object? syntax-object-e syntax-object-ctx
|
||||
rec-cons-desc rec-cons-desc? rec-cons-desc-rtd rec-cons-desc-parent-rcd rec-cons-desc-protocol
|
||||
top-ribcage))
|
||||
|
||||
(provide (except-out (all-from-out racket/base
|
||||
racket/fixnum
|
||||
racket/flonum)
|
||||
define
|
||||
syntax
|
||||
syntax-case
|
||||
syntax-rules
|
||||
with-syntax
|
||||
quasisyntax
|
||||
define-syntax
|
||||
syntax->datum
|
||||
module
|
||||
let-syntax
|
||||
letrec-syntax
|
||||
symbol->string
|
||||
format error
|
||||
if
|
||||
sort
|
||||
fixnum?
|
||||
open-output-file
|
||||
dynamic-wind)
|
||||
library import export
|
||||
(rename-out [patch:define define]
|
||||
[s:syntax syntax]
|
||||
[s:syntax-case syntax-case]
|
||||
[s:syntax-rules syntax-rules]
|
||||
[s:with-syntax with-syntax]
|
||||
[s:quasisyntax quasisyntax]
|
||||
[s:define-syntax define-syntax]
|
||||
[s:syntax->datum syntax->datum]
|
||||
[s:if if]
|
||||
[lambda trace-lambda]
|
||||
[define-syntax trace-define-syntax]
|
||||
[s:splicing-let-syntax let-syntax]
|
||||
[s:splicing-letrec-syntax letrec-syntax]
|
||||
[let trace-let]
|
||||
[define trace-define]
|
||||
[s:dynamic-wind dynamic-wind])
|
||||
guard
|
||||
identifier-syntax
|
||||
(for-syntax datum)
|
||||
assert
|
||||
(rename-out [zero? fxzero?])
|
||||
gensym gensym? gensym->unique-string
|
||||
(rename-out [s:symbol->string symbol->string])
|
||||
pretty-print
|
||||
with-input-from-string with-output-to-string
|
||||
define-record-type
|
||||
record-type-descriptor
|
||||
make-record-type-descriptor
|
||||
make-record-type-descriptor*
|
||||
make-record-constructor-descriptor
|
||||
(rename-out [s:struct-type? record-type-descriptor?])
|
||||
record-constructor-descriptor
|
||||
record-constructor
|
||||
(rename-out [record-constructor r6rs:record-constructor])
|
||||
record-predicate
|
||||
record-accessor
|
||||
record-mutator
|
||||
record-constructor-descriptor?
|
||||
syntax-violation
|
||||
port-position
|
||||
close-port
|
||||
eof-object
|
||||
struct-name struct-ref
|
||||
make-list memp partition fold-left fold-right find remp remv
|
||||
(rename-out [andmap for-all]
|
||||
[ormap exists]
|
||||
[list* cons*]
|
||||
[s:fixnum? fixnum?]
|
||||
[fx= fx=?]
|
||||
[fx< fx<?]
|
||||
[fx> fx>?]
|
||||
[fx<= fx<=?]
|
||||
[fx>= fx>=?]
|
||||
[fxlshift fxarithmetic-shift-left]
|
||||
[fxnot fxlognot]
|
||||
[odd? fxodd?]
|
||||
[even? fxeven?]
|
||||
[div fxdiv]
|
||||
[mod fxmod]
|
||||
[div-and-mod fxdiv-and-mod]
|
||||
[integer-length fxlength]
|
||||
[exact->inexact inexact]
|
||||
[inexact->exact exact]
|
||||
[bitwise-reverse-bit-field fxreverse-bit-field]
|
||||
[bitwise-copy-bit-field fxcopy-bit-field]
|
||||
[bitwise-copy-bit fxcopy-bit]
|
||||
[make-hasheq make-eq-hashtable]
|
||||
[hash-ref/pair hashtable-ref]
|
||||
[hash-set!/pair hashtable-set!]
|
||||
[hash-set!/pair eq-hashtable-set!]
|
||||
[hash-ref-cell hashtable-cell]
|
||||
[equal-hash-code equal-hash]
|
||||
[s:format format]
|
||||
[s:error error])
|
||||
most-positive-fixnum
|
||||
most-negative-fixnum
|
||||
bitwise-copy-bit-field
|
||||
bitwise-copy-bit
|
||||
bitwise-first-bit-set
|
||||
bitwise-if
|
||||
div mod div-and-mod
|
||||
fixnum-width
|
||||
set-car!
|
||||
set-cdr!
|
||||
bytevector-copy!
|
||||
bytevector-ieee-double-native-set!
|
||||
bytevector-ieee-double-native-ref
|
||||
bytevector-u64-native-set!
|
||||
bytevector-u64-native-ref
|
||||
call-with-bytevector-output-port
|
||||
make-compile-time-value
|
||||
optimize-level)
|
||||
|
||||
(module+ ikarus
|
||||
(provide print-gensym
|
||||
annotation? annotation-source
|
||||
source-information-type
|
||||
source-information-position-line
|
||||
source-information-position-column
|
||||
source-information-source-file
|
||||
source-information-byte-offset-start
|
||||
source-information-byte-offset-end
|
||||
source-information-char-offset-start
|
||||
source-information-char-offset-end
|
||||
syntax->source-information
|
||||
(rename-out [s:module module])
|
||||
indirect-export
|
||||
(for-syntax with-implicit)))
|
||||
|
||||
(module+ hash-pair
|
||||
(provide hash-ref/pair
|
||||
hash-set!/pair
|
||||
hash-ref-cell
|
||||
s:fixnum?))
|
||||
|
||||
(begin-for-syntax
|
||||
(define here-path
|
||||
(let ([p (resolved-module-path-name
|
||||
(module-path-index-resolve
|
||||
(variable-reference->module-path-index
|
||||
(#%variable-reference))))])
|
||||
(if (path? p)
|
||||
(path->string p)
|
||||
`(quote ,p)))))
|
||||
|
||||
(define-syntax (library stx)
|
||||
(syntax-case stx (nanopass export import)
|
||||
[(library (nanopass name)
|
||||
(export out ...)
|
||||
(import in ...)
|
||||
body ...)
|
||||
(with-syntax ([here (datum->syntax #'name `(file ,here-path))])
|
||||
#'(module name here
|
||||
(require (for-syntax here)
|
||||
(except-in (for-template here) datum))
|
||||
(export out) ...
|
||||
(import in) ...
|
||||
body ...))]
|
||||
[(library (nanopass) . rest)
|
||||
(syntax-case stx ()
|
||||
[(_ (np) . _)
|
||||
#'(library (np np) . rest)])]))
|
||||
|
||||
(define-syntax-rule (export id)
|
||||
(provide id))
|
||||
|
||||
(define-syntax-rule (indirect-export . _)
|
||||
(begin))
|
||||
|
||||
(define-syntax (import stx)
|
||||
(syntax-case stx (rnrs ikarus nanopass only chezscheme)
|
||||
[(import (rnrs _ ...))
|
||||
#'(begin)]
|
||||
[(import (ikarus))
|
||||
(syntax-case stx ()
|
||||
[(_ (name))
|
||||
(with-syntax ([ref (datum->syntax #'name `(submod (file ,here-path) ikarus))])
|
||||
#`(require ref))])]
|
||||
[(import (nanopass name))
|
||||
(with-syntax ([ref (datum->syntax #'name (list 'quote #'name))])
|
||||
#`(require ref (for-syntax ref) (for-template ref)))]
|
||||
[(import (only (chezscheme) . _))
|
||||
#'(begin)]))
|
||||
|
||||
(define-syntax (s:syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
#`(unwrap-a-bit (syntax #,(mark-original #'e)))]))
|
||||
|
||||
(define-syntax (s:syntax-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e lits . rest)
|
||||
#'(syntax-case* (strip-outer-struct e) lits s:free-identifier=? . rest)]))
|
||||
|
||||
(define-syntax-rule (s:syntax-rules lits [a ... b] ...)
|
||||
(lambda (stx)
|
||||
(s:syntax-case stx lits
|
||||
[a ... (s:syntax b)]
|
||||
...)))
|
||||
|
||||
(define-syntax (s:with-syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([pat e] ...) . rest)
|
||||
#'(with-syntax ([pat (strip-outer-struct e)] ...) . rest)]))
|
||||
|
||||
(define-syntax (s:quasisyntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
(with-syntax ([qs #'quasisyntax])
|
||||
#`(unwrap-a-bit (qs #,(mark-original #`e))))]))
|
||||
|
||||
(define-for-syntax (mark-original e)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(define v (syntax-e e))
|
||||
(cond
|
||||
[(pair? v)
|
||||
(datum->syntax e
|
||||
(cons (mark-original (car v))
|
||||
(mark-original (cdr v)))
|
||||
e
|
||||
e)]
|
||||
[(vector? v)
|
||||
(for/vector #:length (vector-length v) ([i (in-vector v)])
|
||||
(mark-original i))]
|
||||
[(identifier? e) (syntax-property e 'original-in-syntax #t)]
|
||||
[else e])]
|
||||
[(pair? e)
|
||||
(cons (mark-original (car e))
|
||||
(mark-original (cdr e)))]
|
||||
[else e]))
|
||||
|
||||
(define (unwrap-a-bit e)
|
||||
(cond
|
||||
[fully-unwrap?
|
||||
;; Support use of `syntax-case` in expander implementation
|
||||
;; after the expander itself is expanded.
|
||||
(let loop ([e e])
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(cond
|
||||
[(and (identifier? e)
|
||||
(syntax-property e 'original-in-syntax))
|
||||
(syntax-object (syntax-e e)
|
||||
(cons '(top) (list (top-ribcage '*system* #f))))]
|
||||
[else
|
||||
(define v (loop (syntax-e e)))
|
||||
(define p (syntax-property e 'save-context))
|
||||
(if p
|
||||
(syntax-object v p)
|
||||
v)])]
|
||||
[(pair? e)
|
||||
(cons (loop (car e))
|
||||
(loop (cdr e)))]
|
||||
[(vector? e)
|
||||
(for/vector #:length (vector-length e) ([i (in-vector e)])
|
||||
(loop i))]
|
||||
[else e]))]
|
||||
[else
|
||||
;; Simulate R6RS well enough
|
||||
(or (syntax->list e)
|
||||
e)]))
|
||||
|
||||
;; Also to support use of `syntax-case` in expander implementation
|
||||
;; after the expander itself is expanded:
|
||||
(define strip-outer-struct
|
||||
(let ()
|
||||
(lambda (e)
|
||||
(let loop ([e e] [w empty-wraps])
|
||||
(cond
|
||||
[(syntax-object? e)
|
||||
(define v (syntax-object-e e))
|
||||
(define new-w (join-wraps w (syntax-object-ctx e)))
|
||||
(cond
|
||||
[(pair? v)
|
||||
(cons (loop (car v) new-w)
|
||||
(loop (cdr v) new-w))]
|
||||
[(null? v) v]
|
||||
[else
|
||||
(syntax-property (datum->syntax #f v) 'save-context new-w)])]
|
||||
[(pair? e)
|
||||
(cons (loop (car e) w)
|
||||
(loop (cdr e) w))]
|
||||
[(vector? e)
|
||||
(for/vector #:length (vector-length e) ([i (in-vector e)])
|
||||
(loop i w))]
|
||||
[(box? e)
|
||||
(box (loop (unbox e) w))]
|
||||
[(symbol? e)
|
||||
(if (equal? w empty-wraps)
|
||||
e
|
||||
(syntax-property (datum->syntax #f e) 'save-context w))]
|
||||
[else e])))))
|
||||
|
||||
(define (s:free-identifier=? a b)
|
||||
(if fully-unwrap?
|
||||
(eq? (syntax-e a) (syntax-e b))
|
||||
(free-identifier=? a b)))
|
||||
|
||||
(define empty-wraps '(() . ()))
|
||||
|
||||
(define (join-wraps w1 w2)
|
||||
(define a (join (car w1) (car w2)))
|
||||
(define d (join (cdr w1) (cdr w2)))
|
||||
(cond
|
||||
[(and (eq? a (car w1))
|
||||
(eq? d (cdr w1)))
|
||||
w1]
|
||||
[(and (eq? a (car w2))
|
||||
(eq? d (cdr w2)))
|
||||
w2]
|
||||
[else (cons a d)]))
|
||||
|
||||
(define (join l1 l2)
|
||||
(cond
|
||||
[(null? l1) l2]
|
||||
[(null? l2) l1]
|
||||
[else (append l1 l2)]))
|
||||
|
||||
(define (s:syntax->datum s)
|
||||
(syntax->datum (datum->syntax #f s)))
|
||||
|
||||
(define-syntax-rule (s:define-syntax id rhs)
|
||||
(define-syntax id
|
||||
(wrap-transformer rhs)))
|
||||
|
||||
(define-syntax-rule (s:splicing-let-syntax ([id rhs] ...) body ...)
|
||||
(splicing-let-syntax ([id (wrap-transformer rhs)] ...) body ...))
|
||||
|
||||
(define-syntax-rule (s:splicing-letrec-syntax ([id rhs] ...) body ...)
|
||||
(splicing-letrec-syntax ([id (wrap-transformer rhs)] ...) body ...))
|
||||
|
||||
(define-for-syntax (wrap-transformer proc)
|
||||
(if (procedure? proc)
|
||||
(lambda (stx)
|
||||
(let loop ([result (proc stx)])
|
||||
(if (procedure? result)
|
||||
;; Chez/Ikarus protocol to get syntax-local-value:
|
||||
(loop (result syntax-local-value))
|
||||
(datum->syntax #'here result))))
|
||||
proc))
|
||||
|
||||
(define-syntax s:if
|
||||
(syntax-rules ()
|
||||
[(_ tst thn els) (if tst thn els)]
|
||||
[(_ tst thn) (if tst thn (void))]))
|
||||
|
||||
(define-syntax-rule (guard (id [tst rslt ...] ...) body ...)
|
||||
(with-handlers ([(lambda (id) (else-to-true tst)) (lambda (id) rslt ...)] ...)
|
||||
body ...))
|
||||
|
||||
(define-syntax else-to-true
|
||||
(syntax-rules (else)
|
||||
[(_ else) #t]
|
||||
[(_ e) e]))
|
||||
|
||||
(define s:dynamic-wind
|
||||
(case-lambda
|
||||
[(pre thunk post) (dynamic-wind pre thunk post)]
|
||||
[(critical? pre thunk post) (dynamic-wind pre thunk post)]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (with-implicit (tid id ...) body ...)
|
||||
(with-syntax ([id (datum->syntax (syntax tid) 'id)] ...)
|
||||
body ...)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (datum e)
|
||||
(syntax->datum (syntax e))))
|
||||
|
||||
(define-syntax (identifier-syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(identifier? #'id)
|
||||
#'(make-rename-transformer #'id)]
|
||||
[(_ e)
|
||||
#'(lambda (stx)
|
||||
(if (identifier? stx)
|
||||
#'e
|
||||
(syntax-case stx ()
|
||||
[(_ arg (... ...))
|
||||
#'(e arg (... ...))])))]))
|
||||
|
||||
(define-syntax-rule (s:module (id ...) body ...)
|
||||
(begin
|
||||
body ...))
|
||||
|
||||
(define-syntax-rule (assert e)
|
||||
(unless e
|
||||
(error 'assert "failed: ~s" 'e)))
|
||||
|
||||
(define (syntax->source-information stx) #f)
|
||||
(define (source-information-type si) #f)
|
||||
(define (source-information-position-line si) #f)
|
||||
(define (source-information-position-column si) #f)
|
||||
(define (source-information-source-file si) #f)
|
||||
(define (source-information-byte-offset-start si) #f)
|
||||
(define (source-information-byte-offset-end si) #f)
|
||||
(define (source-information-char-offset-start si) #f)
|
||||
(define (source-information-char-offset-end si) #f)
|
||||
|
||||
(define (syntax-violation . args)
|
||||
(apply error args))
|
||||
|
||||
(define (s:symbol->string s)
|
||||
(if (gensym? s)
|
||||
(gensym->pretty-string s)
|
||||
(symbol->string s)))
|
||||
|
||||
(define (with-input-from-string str proc)
|
||||
(parameterize ([current-input-port (open-input-string str)])
|
||||
(proc)))
|
||||
|
||||
(define (with-output-to-string proc)
|
||||
(define o (open-output-string))
|
||||
(parameterize ([current-output-port o])
|
||||
(proc))
|
||||
(get-output-string o))
|
||||
|
||||
(define protocols (make-hasheq))
|
||||
(define (install-protocol! rtd protocol)
|
||||
(hash-set! protocols rtd protocol))
|
||||
(define (lookup-protocol rtd)
|
||||
(hash-ref protocols rtd))
|
||||
|
||||
(define-syntax (define-record-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name make-name name?) clause ...)
|
||||
(let loop ([clauses #'(clause ...)] [fs #'()] [p #f] [super #f] [uid #f] [o? #f] [s? #f])
|
||||
(syntax-case clauses (nongenerative sealed fields protocol parent opaque sealed)
|
||||
[((nongenerative uid) clause ...)
|
||||
(loop #'(clause ...) fs p super #'uid o? s?)]
|
||||
[((nongenerative . _) clause ...)
|
||||
(loop #'(clause ...) fs p super uid o? s?)]
|
||||
[((sealed _) clause ...)
|
||||
(loop #'(clause ...) fs p super uid o? s?)]
|
||||
[((fields field ...) clause ...)
|
||||
(loop #'(clause ...) #'(field ...) p super uid o? s?)]
|
||||
[((protocol proc) clause ...)
|
||||
(loop #'(clause ...) fs #'proc super uid o? s?)]
|
||||
[((parent super) clause ...)
|
||||
(loop #'(clause ...) fs p #'super uid o? s?)]
|
||||
[((opaque #t) clause ...)
|
||||
(loop #'(clause ...) fs p super uid #t s?)]
|
||||
[((sealed #t) clause ...)
|
||||
(loop #'(clause ...) fs p super uid o? #t)]
|
||||
[()
|
||||
(let ()
|
||||
(define (format-id ctx fmt . args)
|
||||
(datum->syntax ctx (string->symbol
|
||||
(apply format fmt (map syntax-e args)))))
|
||||
(define (normalize-fields l)
|
||||
(for/list ([f (in-list (syntax->list l))])
|
||||
(syntax-case f (mutable immutable)
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(list #'id (format-id #'id "~a-~a" #'name #'id))]
|
||||
[(mutable id)
|
||||
(list #'id
|
||||
(format-id #'id "~a-~a" #'name #'id)
|
||||
(format-id #'id "~a-~a-set!" #'name #'id))]
|
||||
[(immutable id)
|
||||
(list #'id (format-id #'id "~a-~a" #'name #'id))]
|
||||
[(mutable id ref set)
|
||||
(list #'id #'ref #'set)]
|
||||
[(immutable id ref)
|
||||
(list #'id #'ref)])))
|
||||
(define all-fs (normalize-fields fs))
|
||||
(define fs-ids (for/list ([f (in-list all-fs)])
|
||||
(syntax-case f ()
|
||||
[(id . _) #'id])))
|
||||
(define parent-info (and super (syntax-local-value super)))
|
||||
(with-syntax ([num-fields (length all-fs)]
|
||||
[protocol (or p
|
||||
(if super
|
||||
#`(lambda (parent-maker)
|
||||
(lambda (#,@(list-ref parent-info 3) #,@fs-ids)
|
||||
((parent-maker #,@(list-ref parent-info 3)) #,@fs-ids)))
|
||||
#'(lambda (p) p)))]
|
||||
[maker (if super
|
||||
#`(let ([parent-protocol (lookup-protocol #,(car parent-info))])
|
||||
(lambda args
|
||||
(apply (parent-protocol
|
||||
(lambda #,(list-ref parent-info 3)
|
||||
(lambda #,fs-ids
|
||||
(create-name #,@(list-ref parent-info 3) #,@fs-ids))))
|
||||
args)))
|
||||
#'create-name)]
|
||||
[(getter ...)
|
||||
(for/list ([f (in-list all-fs)]
|
||||
[pos (in-naturals)])
|
||||
(syntax-case f ()
|
||||
[(id ref . _) (list #'ref
|
||||
#`(make-struct-field-accessor name-ref #,pos 'id))]))]
|
||||
[(setter ...)
|
||||
(for/list ([f (in-list all-fs)]
|
||||
[pos (in-naturals)]
|
||||
#:when (syntax-case f ()
|
||||
[(_ _ _) #t]
|
||||
[_ #f]))
|
||||
(syntax-case f ()
|
||||
[(id _ set) (list #'set
|
||||
#`(make-struct-field-mutator name-set! #,pos 'id))]))]
|
||||
[super (if super
|
||||
(car (syntax-local-value super))
|
||||
#'#f)]
|
||||
[struct:name (format-id #'name "struct:~a" #'name)]
|
||||
[uid (or uid #'name)]
|
||||
[maybe-prefab (if uid #''prefab #'#f)]
|
||||
[fields-vec (list->vector (syntax-e fs))])
|
||||
(with-syntax ([(all-getter-id ...)
|
||||
(append (for/list ([getter (in-list (reverse (syntax->list #'(getter ...))))])
|
||||
(syntax-case getter ()
|
||||
[(id . _) #'id]))
|
||||
(if parent-info
|
||||
(list-ref parent-info 3)
|
||||
null))])
|
||||
#`(begin
|
||||
(define-syntax name
|
||||
(list (quote-syntax struct:name)
|
||||
(quote-syntax create-name)
|
||||
(quote-syntax name?)
|
||||
(list (quote-syntax all-getter-id) ...)
|
||||
#f
|
||||
#f))
|
||||
(define-values (struct:name create-name name? name-ref name-set!)
|
||||
(make-struct-type 'uid super num-fields 0 #f null maybe-prefab))
|
||||
(define name-protocol protocol)
|
||||
(install-protocol! struct:name name-protocol)
|
||||
(register-rtd-name! struct:name 'name)
|
||||
(register-rtd-fields! struct:name 'fields-vec)
|
||||
(define make-name (name-protocol maker))
|
||||
(define . getter) ...
|
||||
(define . setter) ...))))]))]
|
||||
[(_ name clause ...)
|
||||
(with-syntax ([make-name (datum->syntax #'name
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e #'name)))
|
||||
#'name)]
|
||||
[name? (datum->syntax #'name
|
||||
(string->symbol
|
||||
(format "~a?" (syntax-e #'name)))
|
||||
#'name)])
|
||||
#`(define-record-type (name make-name name?) clause ...))]))
|
||||
|
||||
(define-syntax (record-type-descriptor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(car (syntax-local-value #'id))]))
|
||||
|
||||
(define-syntax (record-constructor-descriptor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#`(rtd->rcd #,(car (syntax-local-value #'id)))]))
|
||||
|
||||
(define record-constructor-descriptor? rec-cons-desc?)
|
||||
|
||||
(define (rtd->rcd rtd)
|
||||
(rec-cons-desc rtd #f (lookup-protocol rtd)))
|
||||
|
||||
(define (record-constructor rcd)
|
||||
(cond
|
||||
[(s:struct-type? rcd)
|
||||
;; For Chez Scheme's legacy procedure
|
||||
(struct-type-make-constructor rcd)]
|
||||
[(rec-cons-desc? rcd)
|
||||
(rcd->constructor rcd lookup-protocol)]))
|
||||
|
||||
(define (make-record-type-descriptor name parent uid s? o? fields)
|
||||
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
|
||||
|
||||
(define (make-record-type-descriptor* name parent uid s? o? num-fields mutability-mask)
|
||||
(define fields (for ([i (in-range num-fields)])
|
||||
(list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable)
|
||||
(string->symbol (format "f~a" i)))))
|
||||
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
|
||||
|
||||
(define (make-record-constructor-descriptor rtd parent-rcd protocol)
|
||||
(rec-cons-desc rtd parent-rcd protocol))
|
||||
|
||||
(define (annotation? a) #f)
|
||||
(define (annotation-source a) #f)
|
||||
|
||||
(define (port-position ip) (file-position ip))
|
||||
|
||||
(define (close-port p)
|
||||
(if (input-port? p)
|
||||
(close-input-port p)
|
||||
(close-output-port p)))
|
||||
|
||||
(define (eof-object)
|
||||
eof)
|
||||
|
||||
(define (struct-name a) (substring (symbol->string (vector-ref (struct->vector a) 0))
|
||||
;; drop "struct:"
|
||||
7))
|
||||
(define (struct-ref s i) (error 'struct-ref "oops"))
|
||||
|
||||
(define (make-list n [v #f])
|
||||
(vector->list (make-vector n v)))
|
||||
|
||||
(define (memp pred l)
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(pred (car l)) l]
|
||||
[else (memp pred (cdr l))]))
|
||||
|
||||
(define (remp pred l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[(pred (car l)) (remp pred (cdr l))]
|
||||
[else (cons (car l) (remp pred (cdr l)))]))
|
||||
|
||||
(define (remv v l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[(eqv? v (car l)) (remv v (cdr l))]
|
||||
[else (cons (car l) (remv v (cdr l)))]))
|
||||
|
||||
(define (partition proc list)
|
||||
(let loop ((list list) (yes '()) (no '()))
|
||||
(cond ((null? list)
|
||||
(values (reverse yes) (reverse no)))
|
||||
((proc (car list))
|
||||
(loop (cdr list) (cons (car list) yes) no))
|
||||
(else
|
||||
(loop (cdr list) yes (cons (car list) no))))))
|
||||
|
||||
(define (fold-left combine nil the-list . the-lists)
|
||||
(if (null? the-lists)
|
||||
(fold-left1 combine nil the-list)
|
||||
(let loop ((accum nil) (list the-list) (lists the-lists))
|
||||
(if (null? list)
|
||||
accum
|
||||
(loop (apply combine accum (car list) (map car lists))
|
||||
(cdr list)
|
||||
(map cdr lists))))))
|
||||
|
||||
(define (fold-left1 combine nil list)
|
||||
(let loop ((accum nil) (list list))
|
||||
(if (null? list)
|
||||
accum
|
||||
(loop (combine accum (car list))
|
||||
(cdr list)))))
|
||||
|
||||
(define (fold-right combine nil the-list . the-lists)
|
||||
(if (null? the-lists)
|
||||
(fold-right1 combine nil the-list)
|
||||
(let recur ((list the-list) (lists the-lists))
|
||||
(if (null? list)
|
||||
nil
|
||||
(apply combine
|
||||
(car list)
|
||||
(append (map car lists)
|
||||
(cons (recur (cdr list) (map cdr lists))
|
||||
'())))))))
|
||||
|
||||
(define (fold-right1 combine nil list)
|
||||
(let recur ((list list))
|
||||
(if (null? list)
|
||||
nil
|
||||
(combine (car list) (recur (cdr list))))))
|
||||
|
||||
(define (find proc list)
|
||||
(let loop ((list list))
|
||||
(cond
|
||||
((null? list) #f)
|
||||
((proc (car list)) (car list))
|
||||
(else (loop (cdr list))))))
|
||||
|
||||
(define (bitwise-if a b c)
|
||||
(bitwise-ior (bitwise-and a b)
|
||||
(bitwise-and (bitwise-not a) c)))
|
||||
|
||||
(define (bitwise-reverse-bit-field n start end)
|
||||
(let ([field (bitwise-bit-field n start end)]
|
||||
[width (- end start)])
|
||||
(let loop ([old field][new 0][width width])
|
||||
(cond
|
||||
[(zero? width) (bitwise-copy-bit-field n start end new)]
|
||||
[else (loop (arithmetic-shift old -1)
|
||||
(bitwise-ior (arithmetic-shift new 1)
|
||||
(bitwise-and old 1))
|
||||
(sub1 width))]))))
|
||||
|
||||
(define (bitwise-copy-bit-field to start end from)
|
||||
(let* ([mask1 (arithmetic-shift -1 start)]
|
||||
[mask2 (bitwise-not (arithmetic-shift -1 end))]
|
||||
[mask (bitwise-and mask1 mask2)])
|
||||
(bitwise-if mask
|
||||
(arithmetic-shift from start)
|
||||
to)))
|
||||
|
||||
(define (bitwise-first-bit-set b)
|
||||
(if (zero? b)
|
||||
-1
|
||||
(let loop ([b b][pos 0])
|
||||
(if (zero? (bitwise-and b 1))
|
||||
(loop (arithmetic-shift b -1) (add1 pos))
|
||||
pos))))
|
||||
|
||||
(define (bitwise-copy-bit b n bit)
|
||||
(if (eq? bit 1)
|
||||
(bitwise-ior b (arithmetic-shift 1 n))
|
||||
(bitwise-and b (bitwise-not (arithmetic-shift 1 n)))))
|
||||
|
||||
(define (div x y)
|
||||
(quotient x y))
|
||||
|
||||
(define (mod x y)
|
||||
(modulo x y))
|
||||
|
||||
(define (div-and-mod x y)
|
||||
(values (div x y) (mod x y)))
|
||||
|
||||
(define (hash-ref/pair ht key def-v)
|
||||
(cdr (hash-ref ht key (cons #f def-v))))
|
||||
|
||||
(define (hash-set!/pair ht key val)
|
||||
(hash-set! ht key (cons (and (not (hash-weak? ht)) key) val)))
|
||||
|
||||
(define (hash-ref-cell ht key def-v)
|
||||
(or (hash-ref ht key #f)
|
||||
(begin
|
||||
(hash-set!/pair ht key def-v)
|
||||
(hash-ref-cell ht key def-v))))
|
||||
|
||||
;; HACK!
|
||||
(define-syntax (define-mutable-pair-hacks stx)
|
||||
(syntax-case stx ()
|
||||
[(_ set-car! set-cdr!)
|
||||
(cond
|
||||
[(eq? 'chez-scheme (system-type 'vm))
|
||||
#'(begin
|
||||
(require racket/linklet)
|
||||
(define chez-eval (instantiate-linklet
|
||||
(compile-linklet '(linklet () () eval))
|
||||
null
|
||||
(make-instance 'scheme)))
|
||||
(define set-car! (chez-eval 'set-car!))
|
||||
(define set-cdr! (chez-eval 'set-cdr!)))]
|
||||
[else
|
||||
#'(begin
|
||||
(define (set-car! p v) (unsafe-set-mcar! p v))
|
||||
(define (set-cdr! p v) (unsafe-set-mcdr! p v)))])]))
|
||||
(define-mutable-pair-hacks set-car! set-cdr!)
|
||||
|
||||
(define (bytevector-copy! src src-start dst dst-start n)
|
||||
(bytes-copy! dst dst-start src src-start (+ src-start n)))
|
||||
|
||||
(define (bytevector-ieee-double-native-set! bv pos val)
|
||||
(real->floating-point-bytes val 8 (system-big-endian?) bv pos))
|
||||
(define (bytevector-ieee-double-native-ref bv pos)
|
||||
(floating-point-bytes->real bv (system-big-endian?) pos (+ pos 8)))
|
||||
|
||||
(define (bytevector-u64-native-set! bv pos val)
|
||||
(integer->integer-bytes val 8 #f (system-big-endian?) bv pos))
|
||||
(define (bytevector-u64-native-ref bv pos)
|
||||
(integer-bytes->integer bv #f (system-big-endian?) pos (+ pos 8)))
|
||||
|
||||
(define (call-with-bytevector-output-port proc)
|
||||
(define o (open-output-bytes))
|
||||
(proc o)
|
||||
(get-output-bytes o))
|
||||
|
||||
(define (fixnum-width) (or fixnum-bits 63))
|
||||
|
||||
(define low-fixnum (- (expt 2 (sub1 (fixnum-width)))))
|
||||
(define high-fixnum (sub1 (expt 2 (sub1 (fixnum-width)))))
|
||||
|
||||
(define (most-positive-fixnum) high-fixnum)
|
||||
(define (most-negative-fixnum) low-fixnum)
|
||||
|
||||
(define (s:fixnum? x)
|
||||
(and (fixnum? x)
|
||||
(<= low-fixnum x high-fixnum)))
|
||||
|
||||
(define (make-compile-time-value v) v)
|
||||
|
||||
(define optimize-level (make-parameter optimize-level-init))
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "gensym.rkt")
|
||||
|
||||
(provide r6rs-readtable)
|
||||
|
||||
(define (hash-bang c in src line col pos)
|
||||
(make-special-comment (read-syntax/recursive src in)))
|
||||
|
||||
(define r6rs-readtable
|
||||
(make-readtable
|
||||
#f
|
||||
#\! 'dispatch-macro hash-bang
|
||||
#\{ 'dispatch-macro hash-curly))
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "scheme-struct.rkt"
|
||||
(for-template racket/base))
|
||||
|
||||
(provide rcd->constructor
|
||||
(struct-out rcd-info)
|
||||
rcd->rcdi)
|
||||
|
||||
(define (rcd->constructor rcd lookup-protocol)
|
||||
(define rtd (rec-cons-desc-rtd rcd))
|
||||
(define ctr (struct-type-make-constructor rtd))
|
||||
((record-constructor-generator rcd lookup-protocol) ctr))
|
||||
|
||||
(define (record-constructor-generator rcd lookup-protocol)
|
||||
(define rtd (rec-cons-desc-rtd rcd))
|
||||
(define p (rec-cons-desc-protocol rcd))
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(cond
|
||||
[(not p) (lambda (ctr) ctr)]
|
||||
[(rec-cons-desc-parent-rcd rcd)
|
||||
=> (lambda (p-rcd)
|
||||
(define p-gen (record-constructor-generator p-rcd lookup-protocol))
|
||||
(and p-gen
|
||||
(lambda (ctr)
|
||||
(p (p-gen
|
||||
(lambda args1
|
||||
(lambda args2
|
||||
(apply ctr (append args1 args2)))))))))]
|
||||
[(and super (not lookup-protocol)) #f]
|
||||
[super
|
||||
(define parent-p (lookup-protocol super))
|
||||
(lambda (ctr)
|
||||
(p (parent-p
|
||||
(lambda args1
|
||||
(lambda args2
|
||||
(apply ctr (append args1 args2)))))))]
|
||||
[else p]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(struct rcd-info (rtd proto-expr base-rcdi init-cnt)
|
||||
#:transparent)
|
||||
|
||||
(define (rcd->rcdi rcd)
|
||||
(cond
|
||||
[(rec-cons-desc-parent-rcd rcd)
|
||||
=> (lambda (p-rcd)
|
||||
(define p-rcdi (rcd->rcdi p-rcd))
|
||||
(and p-rcdi
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info (rec-cons-desc-rtd rcd)))
|
||||
(define proto (rec-cons-desc-protocol rcd))
|
||||
(rcd-info (rec-cons-desc-rtd rcd)
|
||||
proto
|
||||
p-rcdi
|
||||
(+ init-cnt
|
||||
(rcd-info-init-cnt p-rcdi))))))]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info (rec-cons-desc-rtd rcd)))
|
||||
(define proto (rec-cons-desc-protocol rcd))
|
||||
(and (not super)
|
||||
(rcd-info (rec-cons-desc-rtd rcd)
|
||||
proto
|
||||
#f
|
||||
init-cnt))]))
|
||||
|
|
@ -1,583 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/unsafe/ops
|
||||
racket/vector
|
||||
racket/list
|
||||
"immediate.rkt"
|
||||
"symbol.rkt"
|
||||
"gensym.rkt"
|
||||
"constant.rkt")
|
||||
|
||||
(provide do-$make-record-type
|
||||
register-rtd-name!
|
||||
register-rtd-fields!
|
||||
s:struct-type?
|
||||
|
||||
$make-record-type
|
||||
$make-record-type-descriptor
|
||||
$record
|
||||
make-record-type
|
||||
type-descriptor
|
||||
record-predicate
|
||||
record-accessor
|
||||
record-mutator
|
||||
compile-time-record-predicate
|
||||
compile-time-record-accessor
|
||||
compile-time-record-mutator
|
||||
csv7:record-field-accessor
|
||||
csv7:record-field-mutator
|
||||
csv7:record-field-mutable?
|
||||
record-rtd
|
||||
record?
|
||||
$record?
|
||||
record-type-uid
|
||||
record-type-name
|
||||
record-type-sealed?
|
||||
record-type-opaque?
|
||||
record-type-parent
|
||||
record-type-field-names
|
||||
record-type-field-indices
|
||||
csv7:record-type-field-names
|
||||
csv7:record-type-field-indices
|
||||
csv7:record-type-field-decls
|
||||
record-writer
|
||||
$object-ref)
|
||||
|
||||
(define (s:struct-type? v)
|
||||
(or (struct-type? v)
|
||||
(base-rtd? v)))
|
||||
|
||||
;; For rtds based on subtypes of #!base-rtd, the subtype instance
|
||||
;; that effectively extends the struct type with more fields:
|
||||
(define rtd-extensions (make-weak-hasheq))
|
||||
|
||||
;; For structure types that extend #!base-rtd:
|
||||
(struct base-rtd-subtype () #:prefab)
|
||||
|
||||
(define (subtype-of-base-rtd? rtd)
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(and super
|
||||
(or (eq? struct:base-rtd-subtype super)
|
||||
(and (subtype-of-base-rtd? super)))))
|
||||
|
||||
|
||||
(define (do-$make-record-type in-base-rtd in-super in-name fields sealed? opaque? more
|
||||
#:uid [in-uid #f])
|
||||
(define name (cond
|
||||
[(string? in-name) (string->symbol in-name)]
|
||||
[(gensym? in-name) (string->symbol (gensym->pretty-string in-name))]
|
||||
[else in-name]))
|
||||
(define uid (or in-uid
|
||||
(cond
|
||||
[(gensym? in-name) in-name]
|
||||
[else #f])))
|
||||
(define super
|
||||
(cond
|
||||
[(base-rtd? in-super) struct:base-rtd-subtype]
|
||||
[else in-super]))
|
||||
(define num-fields (if (vector? fields) (vector-length fields) (length fields)))
|
||||
(define-values (struct:name make-name name? name-ref name-values)
|
||||
(make-struct-type (or uid name) super num-fields 0 #f null (and uid 'prefab)))
|
||||
(unless (base-rtd? in-base-rtd)
|
||||
(hash-set! rtd-extensions struct:name (apply (struct-type-make-constructor in-base-rtd) more)))
|
||||
(register-rtd-name! struct:name name)
|
||||
(register-rtd-fields! struct:name fields)
|
||||
(when sealed? (hash-set! rtd-sealed?s struct:name #t))
|
||||
(when (or opaque?
|
||||
(and super (hash-ref rtd-opaque?s super #f)))
|
||||
(hash-set! rtd-opaque?s struct:name #t))
|
||||
struct:name)
|
||||
|
||||
(define ($make-record-type in-base-rtd super in-name fields sealed? opaque? . more)
|
||||
(do-$make-record-type in-base-rtd super in-name fields sealed? opaque? more))
|
||||
|
||||
(define ($make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields who . extras)
|
||||
(do-$make-record-type base-rtd parent name (vector->list fields) sealed? opaque? extras #:uid uid))
|
||||
|
||||
(define ($record rtd . args)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(error "here")]
|
||||
[(subtype-of-base-rtd? rtd)
|
||||
(error "here, too" rtd args)]
|
||||
[else
|
||||
(apply (struct-type-make-constructor rtd) args)]))
|
||||
|
||||
(define make-record-type
|
||||
(case-lambda
|
||||
[(parent in-name fields)
|
||||
($make-record-type base-rtd parent in-name fields #f #f)]
|
||||
[(name fields)
|
||||
(make-record-type #f name fields)]))
|
||||
|
||||
|
||||
(define rtd-names (make-weak-hasheq))
|
||||
|
||||
(define (register-rtd-name! struct:name name)
|
||||
(hash-set! rtd-names struct:name name))
|
||||
|
||||
|
||||
(define rtd-fields (make-weak-hasheq))
|
||||
|
||||
;; Must match "cmacro.ss"
|
||||
(define (fld-name fld) (vector-ref fld 1))
|
||||
(define (fld-mutable? fld) (vector-ref fld 2))
|
||||
(define (fld-type fld) (vector-ref fld 3))
|
||||
(define (fld-byte fld) (vector-ref fld 4))
|
||||
(define (set-fld-byte! fld v) (vector-set! fld 4 v))
|
||||
(define fld-byte-value 0) ; doesn't matter; gets replaced in field vectors
|
||||
|
||||
(define (register-rtd-fields! struct:name fields)
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info struct:name))
|
||||
(hash-set! rtd-fields struct:name (append
|
||||
(cond
|
||||
[(not super) null]
|
||||
[(or (base-rtd? super)
|
||||
(eq? super struct:base-rtd-subtype))
|
||||
;; fields added in `csv7:record-field-accessor`
|
||||
null]
|
||||
[else (hash-ref rtd-fields super)])
|
||||
(normalize-fields
|
||||
(if (vector? fields)
|
||||
(for/list ([e (in-vector fields)])
|
||||
(cond
|
||||
[(symbol? e) (list 'immutable e)]
|
||||
[(pair? (cdr e)) (list (car e) (cadr e))]
|
||||
[else e]))
|
||||
fields)))))
|
||||
|
||||
(define (normalize-fields fields)
|
||||
(unless (list? fields)
|
||||
(error 'normalize-fields "not a list: ~s" fields))
|
||||
(define (check-type t)
|
||||
(case t
|
||||
[(scheme-object uptr ptr double) t]
|
||||
[else
|
||||
(error 'make-struct-type "unsupported type ~s" t)]))
|
||||
(define (is-mut? m)
|
||||
(case m
|
||||
[(mutable) #t]
|
||||
[(immutable) #f]
|
||||
[else (error 'make-struct-type "unrecognized mutability ~s" m)]))
|
||||
(for/list ([field (in-list fields)])
|
||||
(cond
|
||||
[(and (vector? field)
|
||||
(= 3 (vector-length field)))
|
||||
(vector 'fld (vector-ref field 2) (is-mut? (vector-ref field 1)) (check-type (vector-ref field 0)) fld-byte-value)]
|
||||
[(and (list? field)
|
||||
(= 3 (length field)))
|
||||
(vector 'fld (list-ref field 2) (is-mut? (list-ref field 0)) (check-type (list-ref field 1)) fld-byte-value)]
|
||||
[(symbol? field)
|
||||
(vector 'fld field #t 'scheme-object fld-byte-value)]
|
||||
[(and (list? field)
|
||||
(= 2 (length field)))
|
||||
(vector 'fld (cadr field) (is-mut? (car field)) 'scheme-object fld-byte-value)]
|
||||
[else
|
||||
(error 'normalize-fields "unrecognized field format: ~s" field)])))
|
||||
|
||||
(define-syntax (type-descriptor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(car (syntax-local-value #'id))]))
|
||||
|
||||
(define (record-predicate rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(lambda (v)
|
||||
(or (base-rtd? v)
|
||||
(base-rtd-subtype? v)))]
|
||||
[else
|
||||
(define pred (struct-type-make-predicate rtd))
|
||||
(lambda (v)
|
||||
(if (struct-type? v)
|
||||
(pred (hash-ref rtd-extensions v #f))
|
||||
(pred v)))]))
|
||||
|
||||
(define (compile-time-record-predicate rtd)
|
||||
(and (not (base-rtd-subtype-rtd? rtd))
|
||||
(struct-type-make-predicate rtd)))
|
||||
|
||||
(define (base-rtd-subtype-rtd? rtd)
|
||||
(or (eq? struct:base-rtd-subtype rtd)
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(if super
|
||||
(base-rtd-subtype-rtd? super)
|
||||
#f))))
|
||||
|
||||
;; `i` does not count parent fields
|
||||
(define (record-accessor rtd i [name #f])
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(error 'record-accessor "#!base-rtd not directly supported")]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(define acc (make-struct-field-accessor ref i (or name (string->symbol (number->string i)))))
|
||||
(if (subtype-of-base-rtd? rtd)
|
||||
(lambda (rtd/ext)
|
||||
(acc (if (struct-type? rtd/ext)
|
||||
(hash-ref rtd-extensions rtd/ext)
|
||||
rtd/ext)))
|
||||
acc)]))
|
||||
|
||||
(define (compile-time-record-accessor rtd i)
|
||||
(and (not (base-rtd-subtype-rtd? rtd))
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(make-struct-field-accessor ref i))))
|
||||
|
||||
;; `i` does not count parent fields
|
||||
(define (record-mutator rtd i [name #f])
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(make-struct-field-mutator set i name))
|
||||
|
||||
(define (compile-time-record-mutator rtd i)
|
||||
(and (not (base-rtd-subtype-rtd? rtd))
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(make-struct-field-mutator set i))))
|
||||
|
||||
(define base-rtd-fields
|
||||
(map vector-copy
|
||||
'(#(fld parent #f scheme-object 9)
|
||||
#(fld size #f scheme-object 17)
|
||||
#(fld pm #f scheme-object 25)
|
||||
#(fld mpm #f scheme-object 33)
|
||||
#(fld name #f scheme-object 41)
|
||||
#(fld flds #f scheme-object 49)
|
||||
#(fld flags #f scheme-object 57)
|
||||
#(fld uid #f scheme-object 65)
|
||||
#(fld counts #f scheme-object 73))))
|
||||
|
||||
;; If `sym/i` is an integer, it *does* count parent fields
|
||||
(define (csv7:record-field-accessor/mutator rtd sym/i mut?)
|
||||
(define (lookup-field-by-name rtd sym)
|
||||
(define fields (hash-ref rtd-fields rtd))
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(or (for/or ([field (in-list fields)]
|
||||
[i (in-naturals)])
|
||||
(define name (fld-name field))
|
||||
(and (eq? sym name)
|
||||
(lookup-field-by-pos rtd i name)))
|
||||
(error 'csv7:record-field-accessor
|
||||
"cannot find ~a ~s in ~s"
|
||||
(if mut? "mutator" "accessor")
|
||||
sym
|
||||
fields)))
|
||||
;; returns either a procedure or a number for a count of fields (less than `i`)
|
||||
(define (lookup-field-by-pos rtd i [name #f] #:must-proc? [must-proc? #f])
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(cond
|
||||
[(not super)
|
||||
(if (i . >= . init-cnt)
|
||||
(if must-proc?
|
||||
(error 'csv7:record-field-accessor/mutator "field count too large: ~a" i)
|
||||
init-cnt)
|
||||
(if mut?
|
||||
(make-struct-field-mutator set i name)
|
||||
(make-struct-field-accessor ref i name)))]
|
||||
[else
|
||||
(define s-proc (lookup-field-by-pos super i name))
|
||||
(cond
|
||||
[(integer? s-proc)
|
||||
(if (i . >= . (+ s-proc init-cnt))
|
||||
(if must-proc?
|
||||
(error 'csv7:record-field-accessor/mutator "field count too large: ~a" i)
|
||||
(+ s-proc init-cnt))
|
||||
(if mut?
|
||||
(make-struct-field-mutator set (- i s-proc) name)
|
||||
(make-struct-field-accessor ref (- i s-proc) name)))]
|
||||
[else s-proc])]))
|
||||
(define (ptr-type? t)
|
||||
(case t
|
||||
[(scheme-object ptr) #t]
|
||||
[(uptr double) #f]
|
||||
[else (error "unrecognized type")]))
|
||||
(define (assert-accessor)
|
||||
(when mut? (error 'csv7:record-field-mutator "immutable base-rtd field")))
|
||||
(cond
|
||||
[(or (base-rtd? rtd)
|
||||
(subtype-of-base-rtd? rtd))
|
||||
(case sym/i
|
||||
[(flds)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(fix-offsets
|
||||
(append
|
||||
(if (or (base-rtd? rtd)
|
||||
(subtype-of-base-rtd? rtd))
|
||||
base-rtd-fields
|
||||
null)
|
||||
(if (base-rtd? rtd)
|
||||
null
|
||||
(hash-ref rtd-fields rtd)))))]
|
||||
[(parent)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) #f]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(if (eq? super struct:base-rtd-subtype)
|
||||
base-rtd
|
||||
super)]))]
|
||||
[(size)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(let loop ([flds ((csv7:record-field-accessor base-rtd 'flds) rtd)] [x ptr-bytes])
|
||||
(cond
|
||||
[(null? flds) x]
|
||||
[(eq? (fld-type (car flds)) 'double)
|
||||
(let ([x (if (zero? (modulo x max-float-alignment))
|
||||
x
|
||||
(+ x (- 8 (modulo x max-float-alignment))))])
|
||||
(loop (cdr flds) (+ x 8)))]
|
||||
[else (loop (cdr flds) (+ x ptr-bytes))])))]
|
||||
[(pm)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(define flds ((csv7:record-field-accessor base-rtd 'flds) rtd))
|
||||
(cond
|
||||
[(for/and ([fld (in-list flds)])
|
||||
(ptr-type? (fld-type fld)))
|
||||
-1]
|
||||
[else
|
||||
(for/fold ([m 1]) ([fld (in-list flds)]
|
||||
[i (in-naturals 1)]) ; start after base rtd
|
||||
(if (ptr-type? (fld-type fld))
|
||||
(bitwise-ior m (arithmetic-shift 1 i))
|
||||
m))]))]
|
||||
[(mpm)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(for/fold ([m 0]) ([fld (in-list ((csv7:record-field-accessor base-rtd 'flds) rtd))]
|
||||
[i (in-naturals 1)]) ; start after base rtd
|
||||
(if (and (fld-mutable? fld)
|
||||
(ptr-type? (fld-type fld)))
|
||||
(bitwise-ior m (arithmetic-shift 1 i))
|
||||
m)))]
|
||||
[(name)
|
||||
(assert-accessor)
|
||||
record-type-name]
|
||||
[(uid)
|
||||
(assert-accessor)
|
||||
record-type-uid]
|
||||
[(flags)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(bitwise-ior
|
||||
(if (hash-ref rtd-opaque?s rtd #f)
|
||||
(lookup-constant 'rtd-opaque)
|
||||
0)
|
||||
(if (hash-ref rtd-sealed?s rtd #f)
|
||||
(lookup-constant 'rtd-sealed)
|
||||
0)))]
|
||||
[(counts)
|
||||
(assert-accessor)
|
||||
(lambda (rtd) #f)]
|
||||
[else
|
||||
(cond
|
||||
[(and (integer? sym/i)
|
||||
(base-rtd? rtd))
|
||||
(assert-accessor)
|
||||
(csv7:record-field-accessor rtd (fld-name (list-ref base-rtd-fields sym/i)))]
|
||||
[(not (base-rtd? rtd))
|
||||
(define proc (if (integer? sym/i)
|
||||
(lookup-field-by-pos rtd (- sym/i (length base-rtd-fields)) #:must-proc? #t)
|
||||
(lookup-field-by-name rtd sym/i)))
|
||||
(if mut?
|
||||
(lambda (rtd/ext v)
|
||||
(proc (if (struct-type? rtd/ext)
|
||||
(hash-ref rtd-extensions rtd/ext)
|
||||
rtd/ext)
|
||||
v))
|
||||
(lambda (rtd/ext)
|
||||
(proc (if (struct-type? rtd/ext)
|
||||
(hash-ref rtd-extensions rtd/ext)
|
||||
rtd/ext))))]
|
||||
[else
|
||||
(error "unknown base-rtd field:" sym/i)])])]
|
||||
[(integer? sym/i)
|
||||
(lookup-field-by-pos rtd sym/i #:must-proc? #t)]
|
||||
[else
|
||||
(lookup-field-by-name rtd sym/i)]))
|
||||
|
||||
;; If `sym/i` is an integer, it *does* count parent fields
|
||||
(define (csv7:record-field-accessor rtd sym/i)
|
||||
(csv7:record-field-accessor/mutator rtd sym/i #f))
|
||||
|
||||
;; If `sym/i` is an integer, it *does* count parent fields
|
||||
(define (csv7:record-field-mutator rtd sym/i)
|
||||
(csv7:record-field-accessor/mutator rtd sym/i #t))
|
||||
|
||||
;; `i` *does* count parent fields
|
||||
(define (csv7:record-field-mutable? rtd i)
|
||||
(cond
|
||||
[(or (base-rtd? rtd)
|
||||
(subtype-of-base-rtd? rtd))
|
||||
(error 'csv7:record-field-mutable? "not yet supported")]
|
||||
[else
|
||||
(define fields (hash-ref rtd-fields rtd))
|
||||
(define f (list-ref fields i))
|
||||
(fld-mutable? f)]))
|
||||
|
||||
(define (record-rtd v)
|
||||
(cond
|
||||
[(base-rtd? v) base-rtd]
|
||||
[(struct? v)
|
||||
(define-values (s skipped?) (struct-info v))
|
||||
s]
|
||||
[(hash-ref rtd-extensions v #f)
|
||||
=> (lambda (ext)
|
||||
(define-values (rtd skipped?) (struct-info ext))
|
||||
rtd)]
|
||||
[(struct-type? v) base-rtd]
|
||||
[else (error 'record-rtd "not a record: ~s" v)]))
|
||||
|
||||
(define record?
|
||||
(case-lambda
|
||||
[(v)
|
||||
(and (not (bwp? v))
|
||||
(not (black-hole? v))
|
||||
(not ($unbound-object? v))
|
||||
(or (struct? v)
|
||||
(struct-type? v)
|
||||
(base-rtd? v)))]
|
||||
[(v rtd)
|
||||
(and (or (struct? v)
|
||||
(struct-type? v)
|
||||
(base-rtd? v))
|
||||
((record-predicate rtd) v))]))
|
||||
|
||||
(define ($record? v)
|
||||
(record? v))
|
||||
|
||||
(define (record-type-uid rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) '$base-rtd]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
r-name]))
|
||||
|
||||
(define (record-type-name rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
'$base-rtd]
|
||||
[else
|
||||
(hash-ref rtd-names rtd)]))
|
||||
|
||||
(define (record-type-parent rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) #f]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
super]))
|
||||
|
||||
;; all fields, including from parent
|
||||
(define (csv7:record-type-field-names rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(map fld-name base-rtd-fields)]
|
||||
[else
|
||||
(map fld-name (hash-ref rtd-fields rtd))]))
|
||||
|
||||
;; all fields, including from parent
|
||||
(define (csv7:record-type-field-indices rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(for/list ([f (in-list base-rtd-fields)]
|
||||
[i (in-naturals)])
|
||||
i)]
|
||||
[else
|
||||
(for/list ([f (in-list (hash-ref rtd-fields rtd))]
|
||||
[i (in-naturals)])
|
||||
i)]))
|
||||
|
||||
;; does not include parent fields
|
||||
(define (record-type-field-names rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(list->vector (csv7:record-type-field-names rtd))]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(define all-fields (hash-ref rtd-fields rtd))
|
||||
(define fields (reverse (take (reverse all-fields) init-cnt)))
|
||||
(list->vector (map fld-name fields))]))
|
||||
|
||||
;; does not include parent fields
|
||||
(define (record-type-field-indices rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(list->vector (csv7:record-type-field-indices rtd))]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(for/vector ([i (in-range init-cnt)])
|
||||
i)]))
|
||||
|
||||
(define (csv7:record-type-field-decls rtd)
|
||||
(map (lambda (v) (list (if (fld-mutable? v) 'mutable 'immutable) (fld-type v) (fld-name v)))
|
||||
(hash-ref rtd-fields rtd)))
|
||||
|
||||
(define rtd-sealed?s (make-weak-hasheq))
|
||||
(define (record-type-sealed? rtd)
|
||||
(hash-ref rtd-sealed?s rtd #f))
|
||||
|
||||
(define rtd-opaque?s (make-weak-hasheq))
|
||||
(define (record-type-opaque? rtd)
|
||||
(hash-ref rtd-opaque?s rtd #f))
|
||||
|
||||
(define (record-writer . args)
|
||||
(void))
|
||||
|
||||
(define (fix-offsets flds)
|
||||
(let loop ([flds flds] [offset ptr-bytes])
|
||||
(unless (null? flds)
|
||||
(cond
|
||||
[(eq? (fld-type (car flds)) 'double)
|
||||
(let ([offset (if (zero? (modulo offset max-float-alignment))
|
||||
offset
|
||||
(+ offset (- 8 (modulo offset max-float-alignment))))])
|
||||
(set-fld-byte! (car flds) (+ record-ptr-offset offset))
|
||||
(loop (cdr flds) (+ offset 8)))]
|
||||
[else
|
||||
(set-fld-byte! (car flds) (+ record-ptr-offset offset))
|
||||
(loop (cdr flds) (+ offset ptr-bytes))])))
|
||||
flds)
|
||||
|
||||
;; assumes that `v` has only pointer-sized fields
|
||||
(define ($object-ref type v offset)
|
||||
(cond
|
||||
[(flonum? v)
|
||||
(case type
|
||||
[(unsigned-64)
|
||||
(integer-bytes->integer (real->floating-point-bytes v 8) #f)]
|
||||
[else (error "unrecognized floating-point access" type offset)])]
|
||||
[else
|
||||
(unless (or (eq? type 'scheme-object)
|
||||
(eq? type 'ptr))
|
||||
(error '$object-ref "unrecognized type: ~e" type))
|
||||
(define i (quotient (- offset (+ record-ptr-offset ptr-bytes)) ptr-bytes))
|
||||
(cond
|
||||
[(struct-type? v)
|
||||
(cond
|
||||
[(i . < . (length base-rtd-fields))
|
||||
((csv7:record-field-accessor/mutator base-rtd i #f) v)]
|
||||
[else
|
||||
(error '$object-ref "not yet supported for base-rtd subtypes")])]
|
||||
[(base-rtd? v)
|
||||
((csv7:record-field-accessor/mutator base-rtd i #f) v)]
|
||||
[else (unsafe-struct-ref v i)])]))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,168 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/fixnum
|
||||
racket/port
|
||||
"immediate.rkt"
|
||||
"gensym.rkt")
|
||||
|
||||
(provide scheme-readtable)
|
||||
|
||||
(define (hash-three c in src line col pos)
|
||||
(define got-c (peek-char in))
|
||||
(cond
|
||||
[(eqv? #\% got-c)
|
||||
(read-char in)
|
||||
`($primitive 3 ,(read/recursive in))]
|
||||
[else
|
||||
(hash-graph #\3 in src line col pos)]))
|
||||
|
||||
(define (hash-two c in src line col pos)
|
||||
(define got-c (peek-char in))
|
||||
(cond
|
||||
[(eqv? #\% got-c)
|
||||
(read-char in)
|
||||
`($primitive 2 ,(read/recursive in))]
|
||||
[else
|
||||
(hash-graph #\2 in src line col pos)]))
|
||||
|
||||
(define (hash-one c in src line col pos)
|
||||
(define got-c (peek-char in))
|
||||
(cond
|
||||
[(eqv? #\# got-c)
|
||||
;; "read.ss" has a `#1#` reference before the
|
||||
;; `#1=...` definition; it's going to turn out
|
||||
;; to be `black-hole`
|
||||
(define name (object-name in))
|
||||
(cond
|
||||
[(and (or (string? name) (path? name))
|
||||
(regexp-match? #rx"read[.]ss$" name))
|
||||
(read-char in)
|
||||
black-hole]
|
||||
[else
|
||||
(hash-graph #\1 in src line col pos)])]
|
||||
[else
|
||||
(hash-graph #\1 in src line col pos)]))
|
||||
|
||||
(define (hash-graph c in src line col pos)
|
||||
(cond
|
||||
[(and (eqv? (peek-char in) #\=)
|
||||
(eqv? (peek-char in 1) #\#)
|
||||
(eqv? (peek-char in 2) c)
|
||||
(eqv? (peek-char in 3) #\#))
|
||||
(read-string 4 in)
|
||||
black-hole]
|
||||
[else
|
||||
(define new-in (input-port-append #f (open-input-string (string #\# c)) in))
|
||||
(read/recursive new-in #f #f #t)]))
|
||||
|
||||
(define (hash-percent c in src line col pos)
|
||||
`($primitive ,(read/recursive in)))
|
||||
|
||||
(define (hash-bang c in src line col pos)
|
||||
(define sym (read/recursive in))
|
||||
(case sym
|
||||
[(eof) eof]
|
||||
[(base-rtd) base-rtd]
|
||||
[(bwp) bwp]
|
||||
[(chezscheme) (make-special-comment 'chezscheme)]
|
||||
[else (error 'hash-bang "unrecognized ~s" sym)]))
|
||||
|
||||
(define ((paren closer) c in src line col pos)
|
||||
;; parse a list, but allow an eof element as produced by #!eof
|
||||
(let loop ()
|
||||
(define c (peek-char in))
|
||||
(cond
|
||||
[(eqv? closer c)
|
||||
(read-char in)
|
||||
null]
|
||||
[(char-whitespace? c)
|
||||
(read-char in)
|
||||
(loop)]
|
||||
[(and (eqv? #\. c)
|
||||
(char-whitespace? (peek-char in 1)))
|
||||
(read-char in)
|
||||
(begin0
|
||||
(read/recursive in)
|
||||
(let loop ()
|
||||
(define c (read-char in))
|
||||
(cond
|
||||
[(char-whitespace? c) (loop)]
|
||||
[(eqv? c closer) (void)]
|
||||
[else (error 'parens "unexpected: ~s" c)])))]
|
||||
[else
|
||||
(define v (read/recursive in))
|
||||
(if (special-comment? v)
|
||||
(loop)
|
||||
(cons v (loop)))])))
|
||||
|
||||
(define (hash-backslash c in src line col pos)
|
||||
(define next-c (peek-char in))
|
||||
(cond
|
||||
[(or (char-alphabetic? next-c)
|
||||
(char-numeric? next-c))
|
||||
(define sym (read/recursive in))
|
||||
(case sym
|
||||
[(newline) #\newline]
|
||||
[(return) #\return]
|
||||
[(nel) #\u85]
|
||||
[(ls) #\u2028]
|
||||
[(space) #\space]
|
||||
[(nul) #\nul]
|
||||
[(tab) #\tab]
|
||||
[(vtab vt) #\vtab]
|
||||
[(page) #\page]
|
||||
[(alarm bel) #\u7]
|
||||
[(backspace) #\backspace]
|
||||
[(esc) #\u1b]
|
||||
[(delete) #\u7F]
|
||||
[(rubout) #\rubout]
|
||||
[(linefeed) #\linefeed]
|
||||
[(0 1 2 3 4 5 6 7 8 9)
|
||||
(integer->char (+ sym (char->integer #\0)))]
|
||||
[else
|
||||
(define str (symbol->string sym))
|
||||
(cond
|
||||
[(= 1 (string-length str))
|
||||
(string-ref str 0)]
|
||||
[(eqv? #\x (string-ref str 0))
|
||||
(integer->char (string->number (substring str 1) 16))]
|
||||
[else
|
||||
(error 'hash-backslash "unrecognized ~s" str)])])]
|
||||
[else (read-char in)]))
|
||||
|
||||
(define (hash-vee c in src line col pos)
|
||||
(case (read-char in)
|
||||
[(#\u)
|
||||
(unless (eqv? #\8 (read-char in)) (error 'hash-vee "not 8"))
|
||||
(define l (read/recursive in))
|
||||
(list->bytes l)]
|
||||
[(#\f)
|
||||
(unless (eqv? #\x (read-char in)) (error 'hash-vee "not 8"))
|
||||
(define l (read/recursive in))
|
||||
(apply fxvector l)]
|
||||
[else (error 'hash-vee "unexpected")]))
|
||||
|
||||
(define (as-symbol c in src line col pos)
|
||||
(string->symbol (string c)))
|
||||
|
||||
(define scheme-readtable
|
||||
(make-readtable
|
||||
#f
|
||||
#\0 'dispatch-macro hash-graph
|
||||
#\1 'dispatch-macro hash-one
|
||||
#\2 'dispatch-macro hash-two
|
||||
#\3 'dispatch-macro hash-three
|
||||
#\4 'dispatch-macro hash-graph
|
||||
#\5 'dispatch-macro hash-graph
|
||||
#\6 'dispatch-macro hash-graph
|
||||
#\7 'dispatch-macro hash-graph
|
||||
#\8 'dispatch-macro hash-graph
|
||||
#\9 'dispatch-macro hash-graph
|
||||
#\% 'dispatch-macro hash-percent
|
||||
#\! 'dispatch-macro hash-bang
|
||||
#\{ 'dispatch-macro hash-curly
|
||||
#\{ 'terminating-macro as-symbol
|
||||
#\} 'terminating-macro as-symbol
|
||||
#\[ 'terminating-macro (paren #\])
|
||||
#\( 'terminating-macro (paren #\))
|
||||
#\\ 'dispatch-macro hash-backslash
|
||||
#\v 'dispatch-macro hash-vee))
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(struct syntax-object (e ctx) #:prefab #:mutable
|
||||
#:reflection-name '|{syntax-object bdehkef6almh6ypb-a}|)
|
||||
|
||||
(struct top-ribcage (x y) #:prefab #:mutable
|
||||
#:reflection-name '|{top-ribcage fxdfzth2q3h88vd-a}|)
|
||||
|
||||
(struct fixed-ribcage (x y z) #:prefab #:mutable
|
||||
#:reflection-name '|{fixed-ribcage cqxefau3fa3vz4m0-0}|)
|
||||
|
||||
(struct extensible-ribcage (chunks) #:prefab #:mutable
|
||||
#:reflection-name '|{extensible-ribcage cqxefau3fa3vz4m0-1}|)
|
||||
|
||||
(struct local-label (binding level) #:prefab #:mutable)
|
||||
|
||||
(struct rec-cons-desc (rtd parent-rcd protocol) #:prefab #:mutable
|
||||
#:reflection-name '|{rcd qh0yzh5qyrxmz2l-a}|)
|
||||
|
||||
(struct primref2 (name flags arity) #:prefab #:mutable
|
||||
#:reflection-name '|{primref a0xltlrcpeygsahopkplcn-2}|)
|
||||
|
||||
(struct primref3 (name flags arity signatures) #:prefab #:mutable
|
||||
#:reflection-name '|{primref a0xltlrcpeygsahopkplcn-3}|)
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide strip-$primitive
|
||||
strip-$app)
|
||||
|
||||
(define (strip-$primitive e)
|
||||
(cond
|
||||
[(and (pair? e)
|
||||
(eq? (car e) 'quote))
|
||||
e]
|
||||
[(and (pair? e)
|
||||
(eq? (car e) '$primitive))
|
||||
(if (pair? (cddr e))
|
||||
(caddr e)
|
||||
(cadr e))]
|
||||
[(list? e)
|
||||
(map strip-$primitive e)]
|
||||
[else e]))
|
||||
|
||||
(define (strip-$app e)
|
||||
(cond
|
||||
[(and (pair? e)
|
||||
(eq? (car e) 'quote))
|
||||
e]
|
||||
[(and (pair? e)
|
||||
(eq? (car e) '$app))
|
||||
(strip-$app (cdr e))]
|
||||
[(list? e)
|
||||
(map strip-$app e)]
|
||||
[else e]))
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide oblist
|
||||
s:string->symbol
|
||||
register-symbols
|
||||
|
||||
putprop getprop remprop
|
||||
$sputprop $sgetprop $sremprop
|
||||
|
||||
lookup-constant)
|
||||
|
||||
(define syms (make-hasheq))
|
||||
|
||||
(define (oblist)
|
||||
(hash-keys syms))
|
||||
|
||||
(define (s:string->symbol str)
|
||||
(define s (string->symbol str))
|
||||
(hash-set! syms s #t)
|
||||
s)
|
||||
|
||||
(define (register-symbols v)
|
||||
(cond
|
||||
[(symbol? v) (hash-set! syms v #t)]
|
||||
[(pair? v)
|
||||
(register-symbols (car v))
|
||||
(register-symbols (cdr v))]
|
||||
[(box? v)
|
||||
(register-symbols (unbox v))]
|
||||
[(vector? v)
|
||||
(for ([i (in-vector v)])
|
||||
(register-symbols v))]))
|
||||
|
||||
|
||||
(define (make-put-get ht)
|
||||
(values
|
||||
(lambda (sym key val)
|
||||
(hash-set! syms sym #t)
|
||||
(hash-update! ht sym (lambda (ht) (hash-set ht key val)) #hasheq()))
|
||||
(lambda (sym key [def-val #f])
|
||||
(hash-ref (hash-ref ht sym #hasheq()) key def-val))
|
||||
(lambda (sym key)
|
||||
(hash-update! ht sym (lambda (ht) (hash-remove ht key)) #hasheq()))))
|
||||
|
||||
(define-values (putprop getprop remprop) (make-put-get (make-hasheq)))
|
||||
(define-values ($sputprop $sgetprop $sremprop) (make-put-get (make-hasheq)))
|
||||
|
||||
(define (lookup-constant key [fail #f])
|
||||
(or (getprop key '*constant* #f)
|
||||
(if fail
|
||||
(fail)
|
||||
(error key "cannot find value"))))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide fully-unwrap?
|
||||
start-fully-unwrapping-syntax!)
|
||||
|
||||
(define fully-unwrap? #f)
|
||||
(define (start-fully-unwrapping-syntax!) (set! fully-unwrap? #t))
|
||||
|
|
@ -152,7 +152,7 @@ SCHEME_CONFIG_VARS = CC="$(CC)" CFLAGS="$(BASE_CFLAGS)" LDFLAGS="$(LDFLAGS)" \
|
|||
WINDRES="$(WINDRES)"
|
||||
|
||||
scheme-make-finish:
|
||||
env SCHEME_SRC="$(SCHEME_SRC)" MACH="$(MACH)" $(BOOTSTRAP_RACKET) $(srcdir)/../bootstrap/make-boot.rkt
|
||||
env SCHEME_SRC="$(SCHEME_SRC)" MACH="$(MACH)" $(BOOTSTRAP_RACKET) "$(SCHEME_SRC)"/rktboot/make-boot.rkt
|
||||
cd $(SCHEME_SRC) && ./configure @SCHEME_CONFIG_ARGS@ $(SCHEME_CONFIG_VARS)
|
||||
$(MAKE) sync-bootfiles
|
||||
cd $(SCHEME_SRC) && $(MAKE)
|
||||
|
|
@ -185,7 +185,7 @@ $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/scheme.boot: $(SCHEME_SRC)/boot/$(MACH)/schem
|
|||
|
||||
scheme-cross:
|
||||
cd $(SCHEME_SRC) && git submodule -q init && git submodule -q update
|
||||
env MAKE_BOOT_FOR_CROSS=yes SCHEME_SRC="$(SCHEME_SRC)" MACH="$(TARGET_MACH)" $(BOOTSTRAP_RACKET) $(srcdir)/../bootstrap/make-boot.rkt
|
||||
env MAKE_BOOT_FOR_CROSS=yes SCHEME_SRC="$(SCHEME_SRC)" MACH="$(TARGET_MACH)" $(BOOTSTRAP_RACKET) "$(SCHEME_SRC)"/rktboot/make-boot.rkt
|
||||
$(MAKE) sync-bootfiles MACH="$(TARGET_MACH)"
|
||||
cd $(SCHEME_SRC) && ./configure @SCHEME_CROSS_CONFIG_ARGS@ $(SCHEME_CONFIG_VARS)
|
||||
cd $(SCHEME_SRC)/$(TARGET_MACH)/c && $(MAKE) o=o cross=t
|
||||
|
|
|
|||
|
|
@ -125,7 +125,7 @@
|
|||
(orig-exit v))))])
|
||||
(putenv "SCHEME_SRC" (path->string scheme-dir))
|
||||
(putenv "MACH" machine)
|
||||
(dynamic-require (build-path here 'up "cs" "bootstrap" "make-boot.rkt") #f)))
|
||||
(dynamic-require (build-path scheme-dir "rktboot" "make-boot.rkt") #f)))
|
||||
|
||||
;; Prepare to use Chez Scheme makefile
|
||||
(prep-chez-scheme scheme-dir machine)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user