b0043b013b
Remaining are: - parts of unit200 that Matthew plans to remove. - the `mzscheme` implementation itself. The implementation of `mzscheme` has been moved to the `mzscheme` collection (from the `racket` and `scheme` collections). The `scheme/mzscheme` language, which was undocumented, has been removed. This is slightly backwards-incompatible, because the `xform` handling of precompiled headers now evaluates code in a `racket/base`-like namespace, instead of in a `mzscheme`-like namespace. original commit: d54c1e4e4942c26dcbaaebcc43d5c92d507a8112
128 lines
4.9 KiB
Racket
128 lines
4.9 KiB
Racket
|
|
(module old-procs '#%kernel
|
|
(#%require racket/private/small-scheme
|
|
racket/private/more-scheme
|
|
racket/private/define
|
|
racket/private/member
|
|
(only racket/private/misc collection-path collection-file-path))
|
|
|
|
(#%provide make-namespace
|
|
free-identifier=?*
|
|
namespace-transformer-require
|
|
transcript-on
|
|
transcript-off
|
|
(rename new:collection-path collection-path)
|
|
(rename new:collection-file-path collection-file-path)
|
|
make-hash-table
|
|
make-immutable-hash-table
|
|
hash-table?)
|
|
|
|
(define reflect-var #f)
|
|
|
|
(define new:collection-path
|
|
(let ([collection-path (lambda (collection . collections)
|
|
(apply collection-path
|
|
(lambda (s)
|
|
(raise
|
|
(exn:fail:filesystem
|
|
(string-append "collection-path: " s)
|
|
(current-continuation-marks))))
|
|
collection collections))])
|
|
collection-path))
|
|
|
|
(define new:collection-file-path
|
|
(let ([collection-file-path (lambda (file-name collection . collections)
|
|
(apply collection-file-path
|
|
(lambda (s)
|
|
(raise
|
|
(exn:fail:filesystem
|
|
(string-append "collection-file-path: " s)
|
|
(current-continuation-marks))))
|
|
file-name collection collections))])
|
|
collection-file-path))
|
|
|
|
|
|
(define make-namespace
|
|
(case-lambda
|
|
[() (make-namespace 'initial)]
|
|
[(flag)
|
|
(unless (memq flag '(initial empty))
|
|
(raise-syntax-error 'make-namespace
|
|
"'initial or 'empty"
|
|
flag))
|
|
(let* ([old (variable-reference->empty-namespace (#%variable-reference reflect-var))]
|
|
[new (parameterize ([current-namespace old])
|
|
(make-empty-namespace))])
|
|
(namespace-attach-module old 'mzscheme new)
|
|
(unless (eq? flag 'empty)
|
|
(parameterize ([current-namespace new])
|
|
(namespace-require/copy 'mzscheme)))
|
|
new)]))
|
|
|
|
(define (free-identifier=?* a b)
|
|
(and (eq? (syntax-e a)
|
|
(syntax-e b))
|
|
(free-identifier=? a b)))
|
|
|
|
(define (namespace-transformer-require qrs)
|
|
(namespace-require `(for-syntax ,qrs)))
|
|
|
|
(define (transcript-on filename)
|
|
(error 'transcript-on "unsupported"))
|
|
(define (transcript-off)
|
|
(error 'transcript-off "unsupported"))
|
|
|
|
(define make-hash-table
|
|
(case-lambda
|
|
[() (make-hasheq)]
|
|
[(a) (if (eq? a 'equal)
|
|
(make-hash)
|
|
(if (eq? a 'weak)
|
|
(make-weak-hasheq)
|
|
(if (eq? a 'eqv)
|
|
(make-hasheqv)
|
|
(raise-mismatch-error 'make-hash-table "bad argument: " a))))]
|
|
[(a b) (if (or (and (or (eq? a 'equal)
|
|
(eq? a 'eqv))
|
|
(eq? b 'weak))
|
|
(and (eq? a 'weak)
|
|
(or (eq? b 'equal)
|
|
(eq? b 'eqv))))
|
|
(if (or (eq? a 'eqv) (eq? b 'eqv))
|
|
(make-weak-hasheqv)
|
|
(make-weak-hash))
|
|
(raise-mismatch-error 'make-hash-table "bad arguments: " (list a b)))]))
|
|
|
|
(define make-immutable-hash-table
|
|
(case-lambda
|
|
[(l) (make-immutable-hasheq l)]
|
|
[(l a) (if (eq? a 'equal)
|
|
(make-immutable-hash l)
|
|
(if (eq? a 'eqv)
|
|
(make-immutable-hasheqv l)
|
|
(raise-mismatch-error 'make-immutable-hash-table "bad argument: " a)))]))
|
|
|
|
(define hash-table?
|
|
(case-lambda
|
|
[(v) (hash? v)]
|
|
[(v a) (if (eq? a 'equal)
|
|
(and (hash? v)
|
|
(not (hash-eq? v))
|
|
(not (hash-eqv? v)))
|
|
(if (eq? a 'weak)
|
|
(and (hash? v)
|
|
(hash-weak? v))
|
|
(if (eq? a 'eqv)
|
|
(hash-eqv? v)
|
|
(raise-mismatch-error 'hash-table? "bad argument: " a))))]
|
|
[(v a b) (if (or (and (or (eq? a 'equal) (eq? a 'eqv))
|
|
(eq? b 'weak))
|
|
(and (eq? a 'weak)
|
|
(or (eq? b 'equal) (eq? b 'eqv))))
|
|
(and (hash? v)
|
|
(if (or (eq? a 'eqv) (eq? b 'eqv))
|
|
(hash-eqv? v)
|
|
(not (or (hash-eq? v) (hash-eqv? v))))
|
|
(hash-weak? v))
|
|
(raise-mismatch-error 'hash-table? "bad arguments: " (list a b)))])))
|