aa9bba9328
Move "racket/src/cs/bootstrap" from the Racket source repository to this one, because the bootstrapping implementation needs to track the Chez Scheme source much more closely than the Racket implementation. Currently, any Racket v7.1 or later works. Also update "README.md" and "BUILDING" to get all the information consistent and in sync with revised build options. original commit: a9e6e99ea414b4625fe9705e4f3cfd62bbf38ae2
814 lines
28 KiB
Racket
814 lines
28 KiB
Racket
#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))
|