diff --git a/collects/mzlib/compat.ss b/collects/mzlib/compat.ss index d630336..cee217e 100644 --- a/collects/mzlib/compat.ss +++ b/collects/mzlib/compat.ss @@ -11,7 +11,8 @@ gentemp atom? putprop getprop - new-cafe) + new-cafe + define-structure) (define 1+ add1) (define 1- sub1) @@ -78,4 +79,42 @@ (lambda () (current-eval orig-eval) (exit-handler orig-exit)))))])]) - nc))) + nc)) + + (define-syntax define-structure + (lambda (stx) + (syntax-case stx () + [(_ (sname field ...)) + (syntax (define-structure (sname field ...) ()))] + [(_ (sname field ...) ([init-field init] ...)) + (andmap identifier? (syntax->list + (syntax (sname field ... init-field ...)))) + (let ([name (symbol->string (syntax-e (syntax sname)))] + [fields (map symbol->string + (map syntax-e + (syntax->list (syntax (field ...)))))] + [init-fields (map symbol->string + (map syntax-e + (syntax->list (syntax (init-field ...)))))] + [+ (lambda args + (datum->syntax (string->symbol (apply string-append args)) + (syntax sname) (syntax sname)))]) + (with-syntax ([struct: (+ "struct:" name)] + [make- (+ "make-" name)] + [? (+ name "?")] + [(gs ...) + (apply + append + (map (lambda (f) (list (+ name "-" f) + (+ "set-" name "-" f "!"))) + (append fields init-fields)))]) + (syntax + (define-values (struct: make- ? gs ...) + (let-values ([(struct: make- ? gs ...) + (struct sname (field ... init-field ...))]) + (values struct: + (let ([make- (lambda (field ...) + (make- field ... + init ...))]) + make-) + ? gs ...))))))])))) diff --git a/collects/mzlib/shared.ss b/collects/mzlib/shared.ss index aaad1da..04a4c7e 100644 --- a/collects/mzlib/shared.ss +++ b/collects/mzlib/shared.ss @@ -1,14 +1,100 @@ -(begin-elaboration-time - (require-library "functios.ss")) +(module shared mzscheme -(begin-elaboration-time - (require-library "invoke.ss")) - -(begin-elaboration-time - (define-values/invoke-unit (shared) - (require-library "sharedr.ss"))) - -(define-macro shared shared) + (export shared) + (define undefined (letrec ([x x]) x)) + (export-indirect undefined) + + (define-syntax shared + (lambda (stx) + (syntax-case stx () + [(_ ([name expr] ...) body1 body ...) + (let ([names (syntax->list (syntax (name ...)))] + [exprs (syntax->list (syntax (expr ...)))]) + (for-each (lambda (name) + (unless (identifier? name) + (raise-syntax-error + 'shared + "not an identifier" + stx + name))) + names) + (let ([dup (check-duplicate-identifier names)]) + (when dup + (raise-syntax-error + 'shared + "duplicate identifier" + stx + dup))) + (with-syntax ([(init-expr ...) + (map (lambda (expr) + (define (bad n) + (raise-syntax-error + 'shared + (format "illegal use of ~a" n) + stx + expr)) + (syntax-case expr (cons list box vector) + [(cons a d) + (syntax (cons undefined undefined))] + [(cons . _) + (bad "list")] + [(list e ...) + (with-syntax ([(e ...) + (map (lambda (x) (syntax undefined)) + (syntax->list (syntax (e ...))))]) + (syntax (list e ...)))] + [(list . _) + (bad "list")] + [(box v) + (syntax (box undefined))] + [(box . _) + (bad "box")] + [(vector e ...) + (with-syntax ([(e ...) + (map (lambda (x) (syntax undefined)) + (syntax->list (syntax (e ...))))]) + (syntax (vector e ...)))] + [(vector . _) + (bad "vector")] + [_else expr])) + exprs)] + [(finish-expr ...) + (let ([gen-n (lambda (l) + (let loop ([l l][n 0]) + (if (null? l) + null + (cons (datum->syntax n #f (quote-syntax here)) + (loop (cdr l) (add1 n))))))]) + (map (lambda (name expr) + (with-syntax ([name name]) + (syntax-case expr (cons list box vector) + [(cons a d) + (syntax (begin + (set-car! name a) + (set-cdr! name d)))] + [(list e ...) + (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))]) + (syntax (let ([lst name]) + (set-car! (list-tail lst n) e) + ...)))] + [(box v) + (syntax (set-box! name v))] + [(vector e ...) + (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))]) + (syntax (let ([vec name]) + (vector-set! vec n e) + ...)))] + [_else (syntax (void))]))) + names exprs))]) + (syntax + (letrec ([name init-expr] ...) + finish-expr + ... + body1 + body + ...))))])))) + + \ No newline at end of file