(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)))])))