diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 7113357..91e5835 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1263,27 +1263,34 @@ ;; object% ;;-------------------------------------------------------------------- - (define object<%> (make-interface 'object% null null #f)) - (define object% (make-class 'object% - 0 (vector #f) - object<%> + (define (make-naming-constructor type name) + (let-values ([(struct: make- ? -accessor -mutator) + (make-struct-type name type 0 0 #f null insp)]) + make-)) + + (define object<%> ((make-naming-constructor struct:interface 'interface:object%) + 'object% null null #f)) + (define object% ((make-naming-constructor struct:class 'class:object%) + 'object% + 0 (vector #f) + object<%> - 0 (make-hash-table) null - (vector) (vector) - - 0 (make-hash-table) null - - 'struct:object object? 'make-object - 'field-ref-not-needed 'field-set!-not-needed + 0 (make-hash-table) null + (vector) (vector) + + 0 (make-hash-table) null + + 'struct:object object? 'make-object + 'field-ref-not-needed 'field-set!-not-needed - null + null - (lambda (this super-init args) - (unless (null? args) - (obj-error "make-object" "unused initialization arguments: ~e" args)) - (void)) + (lambda (this super-init args) + (unless (null? args) + (obj-error "make-object" "unused initialization arguments: ~e" args)) + (void)) - #t)) ; no super-init + #t)) ; no super-init (vector-set! (class-supers object%) 0 object%) (let*-values ([(struct:obj make-obj obj? -get -set!) @@ -1644,11 +1651,6 @@ (define undefined (letrec ([x x]) x)) - (define (make-naming-constructor type name) - (let-values ([(struct: make- ? -accessor -mutator) - (make-struct-type name type 0 0 #f null insp)]) - make-)) - (define-struct (exn:object struct:exn) () insp) (define (obj-error where . msg) diff --git a/collects/mzlib/cmdline.ss b/collects/mzlib/cmdline.ss index 8532075..fcb3fca 100644 --- a/collects/mzlib/cmdline.ss +++ b/collects/mzlib/cmdline.ss @@ -177,7 +177,7 @@ (define print-args (lambda (port l f) - (let loop ([l l][a (letrec ([a (arity f)] + (let loop ([l l][a (letrec ([a (procedure-arity f)] [a-c (lambda (a) (cond [(number? a) (cons (sub1 a) (sub1 a))] @@ -204,7 +204,7 @@ [(number? a) (>= a n)] [(arity-at-least? a) #t] [else (ormap a-c a)]))]) - (a-c (arity p)))) + (a-c (procedure-arity p)))) (define parse-command-line (case-lambda @@ -267,7 +267,7 @@ (or (procedure? (cadr line)) (bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line)))) - (let ([a (arity (cadr line))]) + (let ([a (procedure-arity (cadr line))]) (or (and (number? a) (or (>= a 1) (bad-table (format "flag handler procedure must take at least 1 argument: ~e" @@ -280,7 +280,7 @@ (bad-table (format "spec-line help section must be a list of strings"))) (or (let ([l (length (caddr line))] - [a (arity (cadr line))]) + [a (procedure-arity (cadr line))]) (if (number? a) (= a l) (and (>= l 1) @@ -297,11 +297,11 @@ (unless (and (procedure? help) (procedure-arity-includes? help 1)) (raise-type-error 'parse-command-line "help procedure of arity 1" help)) (unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1) - (let ([a (arity unknown-flag)]) + (let ([a (procedure-arity unknown-flag)]) (or (number? a) (arity-at-least? a)))) (raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag)) - (letrec ([a (arity finish)] + (letrec ([a (procedure-arity finish)] [l (length finish-help)] [a-c (lambda (a) (or (and (number? a) (sub1 a)) @@ -404,7 +404,7 @@ (parameterize ([current-output-port s]) (print-args s finish-help finish)) (let ([s (get-output-string s)]) - (if (equal? 2 (arity finish)) + (if (equal? 2 (procedure-arity finish)) (format " 1~a" s) s)))) c @@ -418,7 +418,7 @@ (string-append (car args) " " (loop (cdr args))))))))))] [call-handler (lambda (handler flag args r-acc k) - (let* ([a (arity handler)] + (let* ([a (procedure-arity handler)] [remaining (length args)] [needed (if (number? a) (sub1 a) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 4d11104..5dcaf65 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -3,8 +3,7 @@ (require "spidey.ss") (require-for-syntax (lib "kerncase.ss" "syntax")) - (provide this-expression-source-directory - true false + (provide true false boolean=? symbol=? identity compose @@ -23,20 +22,10 @@ evcase nor nand - let+) + let+ + + this-expression-source-directory) - (define-syntax (this-expression-source-directory stx) - (syntax-case stx () - [(_) - (let ([source (syntax-source stx)]) - (if (and source - (string? source) - (file-exists? source)) - (let-values ([(base file dir?) (split-path source)]) - (with-syntax ([base base]) - (syntax base))) - (syntax #f)))])) - (define true #t) (define false #f) @@ -49,11 +38,11 @@ [(f g) (let ([f (compose f)] [g (compose g)]) - (if (eqv? 1 (arity f)) ; optimize: don't use call-w-values - (if (eqv? 1 (arity g)) ; optimize: single arity everywhere + (if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values + (if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere (lambda (x) (f (g x))) (lambda args (f (apply g args)))) - (if (eqv? 1 (arity g)) ; optimize: single input + (if (eqv? 1 (procedure-arity g)) ; optimize: single input (lambda (a) (call-with-values (lambda () (g a)) @@ -375,5 +364,17 @@ [(recs (var expr) ...) (syntax (letrec ([var expr] ...) rest))] [(_ expr) - (syntax (begin expr rest))])))))])))) + (syntax (begin expr rest))])))))]))) + (define-syntax (this-expression-source-directory stx) + (syntax-case stx () + [(_) + (let ([source (syntax-source stx)]) + (if (and source + (string? source) + (file-exists? source)) + (let-values ([(base file dir?) (split-path source)]) + (with-syntax ([base base]) + (syntax base))) + (syntax (or (current-load-relative-directory) + (current-directory)))))]))) diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss index 3a0528d..0621f79 100644 --- a/collects/mzlib/thread.ss +++ b/collects/mzlib/thread.ss @@ -58,10 +58,10 @@ (raise (make-exn:application:arity (format ": consumer procedure arity is ~e; provided ~s argument~a" - (arity f) num (if (= 1 num) "" "s")) + (procedure-arity f) num (if (= 1 num) "" "s")) (current-continuation-marks) num - (arity f))))) + (procedure-arity f))))) (semaphore-wait protect) (set! front-state (cons new-state front-state)) (semaphore-post protect) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 42173c5..72a4388 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -8,9 +8,24 @@ (define undefined (letrec ([x x]) x)) + (define insp (current-inspector)) ; for named structures + (define-struct unit (num-imports exports go)) (define-struct (exn:unit struct:exn) ()) + (define (make-naming-constructor type name) + (let-values ([(struct: make- ? -accessor -mutator) + (make-struct-type name type 0 0 #f null insp)]) + make-)) + + (define (make-a-unit name num-imports exports go) + ((if name + (make-naming-constructor + struct:unit + (string->symbol (format "unit:~a" name))) + make-unit) + num-imports exports go)) + (define-syntax unit (lambda (stx) (syntax-case stx (import export) @@ -241,20 +256,21 @@ [num-imports (datum->syntax-object (quote-syntax here) (length (syntax->list (syntax (iloc ...)))) - #f)]) - (syntax/loc - stx - (make-unit - num-imports - (list (quote extname) ...) - (lambda () - (let ([eloc (box undefined)] ...) - (list (vector eloc ...) - (lambda (iloc ...) - (let ([intname undefined] ...) - (letrec-syntax redirections - (void) ; in case the body would be empty - defn&expr ...))))))))))))))))))]))) + #f)] + [name (syntax-local-name)]) + (syntax/loc stx + (make-a-unit + 'name + num-imports + (list (quote extname) ...) + (lambda () + (let ([eloc (box undefined)] ...) + (list (vector eloc ...) + (lambda (iloc ...) + (let ([intname undefined] ...) + (letrec-syntax redirections + (void) ; in case the body would be empty + defn&expr ...))))))))))))))))))]))) (define (check-expected-interface tag unit num-imports exports) (unless (unit? unit) @@ -560,7 +576,8 @@ (length imports) #f)] [export-names export-names] - [export-mapping export-mapping]) + [export-mapping export-mapping] + [name (syntax-local-name)]) (syntax/loc stx (let ([constituent unit-expr] @@ -572,7 +589,8 @@ unit-import-count 'unit-export-list)] ...) - (make-unit + (make-a-unit + 'name num-imports (quote export-names) (lambda ()