diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 0888458..f703344 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -5,7 +5,7 @@ (require "private/class-internal.ss") (provide class - class* class*/names + class* class? interface interface? object% object? @@ -35,4 +35,5 @@ public-final override-final augment-final field init init-field rename-super rename-inner inherit - super inner)) \ No newline at end of file + this super inner + super-make-object super-instantiate super-new)) \ No newline at end of file diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index bcf3481..d30eff0 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -549,6 +549,8 @@ (get-output-string p)) col))) + ((and display? (path? obj)) (out (path->string obj) col)) + ;; Let symbol get printed by default case to get proper quoting ;; ((symbol? obj) (out (symbol->string obj) col)) diff --git a/collects/mzlib/private/stxparamkey.ss b/collects/mzlib/private/stxparamkey.ss new file mode 100644 index 0000000..d5bd2eb --- /dev/null +++ b/collects/mzlib/private/stxparamkey.ss @@ -0,0 +1,5 @@ + +(module stxparamkey mzscheme + (define-struct syntax-parameter (target)) + (provide (struct syntax-parameter (target)))) + diff --git a/collects/mzlib/stxparam.ss b/collects/mzlib/stxparam.ss new file mode 100644 index 0000000..e6c107c --- /dev/null +++ b/collects/mzlib/stxparam.ss @@ -0,0 +1,88 @@ + +(module stxparam mzscheme + (require-for-syntax "private/stxparamkey.ss") + + (provide define-syntax-parameter + syntax-parameterize) + + (define-syntax (define-syntax-parameter stx) + (syntax-case stx () + [(_ id init-val) + (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) + #'(begin + (define-syntax gen-id init-val) + (define-syntax id (make-syntax-parameter #'gen-id))))])) + + (define-syntax (syntax-parameterize stx) + (syntax-case stx () + [(_ ([id val] ...) body0 body ...) + (let ([ids (syntax->list #'(id ...))]) + (with-syntax ([(gen-id ...) + (map (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier" + stx + id)) + (let ([rt (syntax-local-value id (lambda () #f))]) + (unless (syntax-parameter? rt) + (raise-syntax-error + #f + "not bound as a syntax parameter" + stx + id)) + (syntax-local-get-shadower + (syntax-local-introduce (syntax-parameter-target rt))))) + ids)]) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error + #f + "duplicate binding" + stx + dup))) + #'(let-syntax ([gen-id val] ...) + body0 body ...)))])) + + ;; ---------------------------------------- + + (require "private/stxparamkey.ss") + (require-for-template mzscheme) + + (provide make-parameter-rename-transformer + syntax-parameter-value) + + (define (make-parameter-rename-transformer id) + (make-set!-transformer + (lambda (stx) + (let ([v (syntax-parameter-value (syntax-local-introduce id))]) + (cond + [(set!-transformer? v) ((set!-transformer-procedure v) stx)] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + (syntax-case stx (set!) + [(set! id _) (raise-syntax-error + #f + "cannot mutate syntax identifier" + stx + #'id)] + [else (v stx)])] + [else + (raise-syntax-error + #f + "bad syntax" + stx + #f)]))))) + + (define (syntax-parameter-value id) + (let ([v (syntax-local-value id (lambda () #f))]) + (unless (syntax-parameter? v) + (raise-type-error 'syntax-parameter-value "syntax parameter" v)) + (let ([target (syntax-parameter-target v)]) + (syntax-local-value (syntax-local-get-shadower target) + (lambda () + #f + (syntax-local-value + target + (lambda () #f))))))))