diff --git a/collects/eopl/datatype.ss b/collects/eopl/datatype.ss index 85212c248e..97c19d6f20 100644 --- a/collects/eopl/datatype.ss +++ b/collects/eopl/datatype.ss @@ -1,344 +1,343 @@ - ;; NOTE: datatypes are currently transparent, for the sake of EoPL's ;; use of `equal?' -(module datatype mzscheme +#lang mzscheme - (require mzlib/pconvert-prop) - (require-for-syntax "private/utils.ss") +(require mzlib/pconvert-prop) +(require-for-syntax "private/utils.ss") - (define-syntax define-datatype - (lambda (stx) - (syntax-case stx () - [(_ name pred-name - (variant-name (field-name field-pred) ...) - ...) - (let ([variant-names (syntax->list (syntax (variant-name ...)))]) - ;; More syntax checks... - (unless (identifier? (syntax name)) - (raise-syntax-error #f - "expected an identifier for the datatype name" - stx (syntax name))) - (unless (identifier? (syntax pred-name)) - (raise-syntax-error #f - "expected an identifier for the predicate name" - stx (syntax pred-name))) - (for-each (lambda (vt fields) - (unless (identifier? vt) - (raise-syntax-error - 'cases - "expected an identifier for the variant name" - stx vt)) - (for-each (lambda (field) - (unless (identifier? field) - (raise-syntax-error - 'cases - "expected an identifier for the field name" - stx field))) - (syntax->list fields))) - variant-names - (syntax->list (syntax ((field-name ...) ...)))) - ;; Count the fields for each variant: - (with-syntax ([(variant-field-count ...) - (map (lambda (n) - (datum->syntax-object (quote-syntax here) n #f)) - (map length - (map - syntax->list - (syntax->list - (syntax ((field-name ...) ...))))))] - [(variant? ...) - (map (lambda (vn) - (datum->syntax-object - vn - (string->uninterned-symbol - (format "~a?" (syntax-e vn))))) - variant-names)] - [(variant-accessor ...) - (map (lambda (vn) - (datum->syntax-object - vn - (string->uninterned-symbol - (format "~a-accessor" (syntax-e vn))))) - variant-names)] - [(variant-mutator ...) - (generate-temporaries variant-names)] - [(make-variant ...) - (generate-temporaries variant-names)] - [(struct:variant ...) - (generate-temporaries variant-names)] - [(make-variant-name ...) - (map (lambda (vn) - (datum->syntax-object - vn - (string->symbol - (format "make-~a" (syntax-e vn))))) - variant-names)]) - (syntax - (begin - (define-syntax name - ;; Note: we're back to the transformer environment, here. - ;; Also, this isn't a transformer function, so any direct - ;; use of the name will trigger a syntax error. The name - ;; can be found by `syntax-local-value', though. - (let ([cert (syntax-local-certifier #t)]) - (make-dt (cert (syntax pred-name)) - (list - (make-vt (cert (syntax variant-name)) - (cert (syntax variant?)) - (cert (syntax variant-accessor)) - variant-field-count) - ...)))) - ;; Bind the predicate and selector functions: - (define-values (pred-name - variant-name ... - variant? ... - variant-accessor ...) - ;; Create a new structure for the datatype (using the - ;; datatype name in `struct', so it prints nicely). - (let-values ([(struct:x make-x x? acc mut) - (make-struct-type 'name #f 0 0 #f null (make-inspector))]) - (let-values ([(struct:variant make-variant variant? - variant-accessor variant-mutator) - (make-struct-type 'variant-name struct:x variant-field-count 0 - #f - `((,prop:print-convert-constructor-name . variant-name)) - (make-inspector))] - ...) - ;; User-available functions: - (values - x? ;; The datatype predicate - ;; Create the constructor functions: - (let ([vname (quote variant-name)]) - (let ([variant-name - (lambda (field-name ...) - (unless (field-pred field-name) - (error vname - "bad value for ~a field: ~e" - (quote field-name) - field-name)) - ... - (make-variant field-name ...))]) - variant-name)) - ... - variant? ... - variant-accessor ...)))) - ;; Compatibility bindings - (define-values (make-variant-name ...) (values variant-name ...))))))] - [(_ name pred-name variant ...) - ;; Must be a bad variant... - (for-each (lambda (variant) - (syntax-case variant () - [(variant-name field ...) - (let ([name (syntax variant-name)]) - (unless (identifier? name) - (raise-syntax-error - #f - "expected an identifier for the variant name" - stx - name)) - ;; Must be a bad field: - (for-each (lambda (field) - (syntax-case field () - [(field-name field-pred) - (let ([name (syntax field-name)]) - (unless (identifier? name) - (raise-syntax-error - #f - "expected an identifier for the field name" - stx - name)))] - [_else +(define-syntax define-datatype + (lambda (stx) + (syntax-case stx () + [(_ name pred-name + (variant-name (field-name field-pred) ...) + ...) + (let ([variant-names (syntax->list (syntax (variant-name ...)))]) + ;; More syntax checks... + (unless (identifier? (syntax name)) + (raise-syntax-error #f + "expected an identifier for the datatype name" + stx (syntax name))) + (unless (identifier? (syntax pred-name)) + (raise-syntax-error #f + "expected an identifier for the predicate name" + stx (syntax pred-name))) + (for-each (lambda (vt fields) + (unless (identifier? vt) + (raise-syntax-error + 'cases + "expected an identifier for the variant name" + stx vt)) + (for-each (lambda (field) + (unless (identifier? field) + (raise-syntax-error + 'cases + "expected an identifier for the field name" + stx field))) + (syntax->list fields))) + variant-names + (syntax->list (syntax ((field-name ...) ...)))) + ;; Count the fields for each variant: + (with-syntax ([(variant-field-count ...) + (map (lambda (n) + (datum->syntax-object (quote-syntax here) n #f)) + (map length + (map + syntax->list + (syntax->list + (syntax ((field-name ...) ...))))))] + [(variant? ...) + (map (lambda (vn) + (datum->syntax-object + vn + (string->uninterned-symbol + (format "~a?" (syntax-e vn))))) + variant-names)] + [(variant-accessor ...) + (map (lambda (vn) + (datum->syntax-object + vn + (string->uninterned-symbol + (format "~a-accessor" (syntax-e vn))))) + variant-names)] + [(variant-mutator ...) + (generate-temporaries variant-names)] + [(make-variant ...) + (generate-temporaries variant-names)] + [(struct:variant ...) + (generate-temporaries variant-names)] + [(make-variant-name ...) + (map (lambda (vn) + (datum->syntax-object + vn + (string->symbol + (format "make-~a" (syntax-e vn))))) + variant-names)]) + (syntax + (begin + (define-syntax name + ;; Note: we're back to the transformer environment, here. + ;; Also, this isn't a transformer function, so any direct + ;; use of the name will trigger a syntax error. The name + ;; can be found by `syntax-local-value', though. + (let ([cert (syntax-local-certifier #t)]) + (make-dt (cert (syntax pred-name)) + (list + (make-vt (cert (syntax variant-name)) + (cert (syntax variant?)) + (cert (syntax variant-accessor)) + variant-field-count) + ...)))) + ;; Bind the predicate and selector functions: + (define-values (pred-name + variant-name ... + variant? ... + variant-accessor ...) + ;; Create a new structure for the datatype (using the + ;; datatype name in `struct', so it prints nicely). + (let-values ([(struct:x make-x x? acc mut) + (make-struct-type 'name #f 0 0 #f null (make-inspector))]) + (let-values ([(struct:variant make-variant variant? + variant-accessor variant-mutator) + (make-struct-type 'variant-name struct:x variant-field-count 0 + #f + `((,prop:print-convert-constructor-name . variant-name)) + (make-inspector))] + ...) + ;; User-available functions: + (values + x? ;; The datatype predicate + ;; Create the constructor functions: + (let ([vname (quote variant-name)]) + (let ([variant-name + (lambda (field-name ...) + (unless (field-pred field-name) + (error vname + "bad value for ~a field: ~e" + (quote field-name) + field-name)) + ... + (make-variant field-name ...))]) + variant-name)) + ... + variant? ... + variant-accessor ...)))) + ;; Compatibility bindings + (define-values (make-variant-name ...) (values variant-name ...))))))] + [(_ name pred-name variant ...) + ;; Must be a bad variant... + (for-each (lambda (variant) + (syntax-case variant () + [(variant-name field ...) + (let ([name (syntax variant-name)]) + (unless (identifier? name) + (raise-syntax-error + #f + "expected an identifier for the variant name" + stx + name)) + ;; Must be a bad field: + (for-each (lambda (field) + (syntax-case field () + [(field-name field-pred) + (let ([name (syntax field-name)]) + (unless (identifier? name) + (raise-syntax-error + #f + "expected an identifier for the field name" + stx + name)))] + [_else + (raise-syntax-error + #f + "expected a field name followed by a predicate expression, all in parentheses" + stx + field)])) + (syntax->list (syntax (field ...)))))] + [_else + (raise-syntax-error + #f + "expected a variant name followed by a sequence of field declarations, all in parentheses" + stx + variant)])) + (syntax->list (syntax (variant ...))))] + [(_ name) + (raise-syntax-error + #f + "missing predicate name and variant clauses" + stx)]))) + +(define-syntax cases + (lambda (stx) + (syntax-case stx () + [(_ datatype expr + clause + ...) + ;; Get datatype information: + (let ([dt (and (identifier? (syntax datatype)) + (syntax-local-value (syntax datatype) (lambda () #f)))]) + (unless (dt? dt) + (raise-syntax-error + 'cases + "not a datatype name" + stx + (syntax datatype))) + + ;; Parse clauses: + (let-values ([(vts field-idss bodys else-body) + (let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null]) + (cond + [(null? clauses) + (values null null null #f)] + [else + (let ([clause (car clauses)]) + (syntax-case* clause (else) + (lambda (a b) + (and (eq? (syntax-e b) 'else) + (not (identifier-binding b)))) + [(variant (field-id ...) body0 body1 ...) + (let* ([variant (syntax variant)] + [vt + (ormap (lambda (dtv) + (let ([vt-name (vt-name-stx dtv)]) + (and (module-identifier=? variant vt-name) + dtv))) + (dt-variants dt))] + [orig-variant (and vt (vt-name-stx vt))]) + (unless orig-variant + (raise-syntax-error + #f + (format "not a variant of `~a'" + (syntax-object->datum (syntax datatype))) + stx + variant)) + + (let ([field-ids (syntax->list (syntax (field-id ...)))]) + (for-each (lambda (fid) + (unless (identifier? fid) + (raise-syntax-error + #f + "expected an identifier for a field" + stx + fid))) + field-ids) + (let ([dtv (variant-assq variant (dt-variants dt))]) + (unless (= (length field-ids) + (vt-field-count dtv)) (raise-syntax-error #f - "expected a field name followed by a predicate expression, all in parentheses" + (format + "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)" + (syntax-object->datum variant) + (syntax-object->datum (syntax datatype)) + (vt-field-count dtv) + (length field-ids)) stx - field)])) - (syntax->list (syntax (field ...)))))] - [_else - (raise-syntax-error - #f - "expected a variant name followed by a sequence of field declarations, all in parentheses" - stx - variant)])) - (syntax->list (syntax (variant ...))))] - [(_ name) - (raise-syntax-error - #f - "missing predicate name and variant clauses" - stx)]))) - - (define-syntax cases - (lambda (stx) - (syntax-case stx () - [(_ datatype expr - clause - ...) - ;; Get datatype information: - (let ([dt (and (identifier? (syntax datatype)) - (syntax-local-value (syntax datatype) (lambda () #f)))]) - (unless (dt? dt) - (raise-syntax-error - 'cases - "not a datatype name" - stx - (syntax datatype))) - - ;; Parse clauses: - (let-values ([(vts field-idss bodys else-body) - (let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null]) - (cond - [(null? clauses) - (values null null null #f)] - [else - (let ([clause (car clauses)]) - (syntax-case* clause (else) (lambda (a b) - (and (eq? (syntax-e b) 'else) - (not (identifier-binding b)))) - [(variant (field-id ...) body0 body1 ...) - (let* ([variant (syntax variant)] - [vt - (ormap (lambda (dtv) - (let ([vt-name (vt-name-stx dtv)]) - (and (module-identifier=? variant vt-name) - dtv))) - (dt-variants dt))] - [orig-variant (and vt (vt-name-stx vt))]) - (unless orig-variant - (raise-syntax-error - #f - (format "not a variant of `~a'" - (syntax-object->datum (syntax datatype))) - stx - variant)) + clause))) - (let ([field-ids (syntax->list (syntax (field-id ...)))]) - (for-each (lambda (fid) - (unless (identifier? fid) - (raise-syntax-error - #f - "expected an identifier for a field" - stx - fid))) - field-ids) - (let ([dtv (variant-assq variant (dt-variants dt))]) - (unless (= (length field-ids) - (vt-field-count dtv)) - (raise-syntax-error - #f - (format - "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)" - (syntax-object->datum variant) - (syntax-object->datum (syntax datatype)) - (vt-field-count dtv) - (length field-ids)) - stx - clause))) + ;; Check for duplicate local field ids: + (let ([dup (check-duplicate-identifier field-ids)]) + (when dup + (raise-syntax-error + #f + "duplicate field identifier" + stx + dup))) - ;; Check for duplicate local field ids: - (let ([dup (check-duplicate-identifier field-ids)]) - (when dup - (raise-syntax-error - #f - "duplicate field identifier" - stx - dup))) + ;; Check for redundant case: + (when (memq orig-variant saw-cases) + (raise-syntax-error + #f + "duplicate case" + stx + clause)) - ;; Check for redundant case: - (when (memq orig-variant saw-cases) - (raise-syntax-error - #f - "duplicate case" - stx - clause)) - - ;; This clause is ok: - (let-values ([(vts idss bodys else) - (loop (cdr clauses) (cons orig-variant saw-cases))]) - (values (cons vt vts) - (cons field-ids idss) - (cons (syntax (begin body0 body1 ...)) bodys) - else))))] - [(else body0 body1 ...) - (begin - (unless (null? (cdr clauses)) - (raise-syntax-error - #f - "else clause must be last" - stx - clause)) - (values null null null (syntax (begin body0 body1 ...))))] - [_else (raise-syntax-error - #f - "bad clause" - stx - clause)]))]))]) - - ;; Missing any variants? - (unless (or else-body - (= (length vts) (length (dt-variants dt)))) - (let* ([here (map vt-name-stx vts)] - [missing (let loop ([l (dt-variants dt)]) - (cond - [(null? l) ""] - [(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here) - (loop (cdr l))] - [else - (format " ~a~a" - (syntax-e (vt-name-stx (car l))) - (loop (cdr l)))]))]) - (raise-syntax-error - #f - (format "missing cases for the following variants:~a" missing) - stx))) - - ;; Create the result: - (with-syntax ([pred (dt-pred-stx dt)] - [(variant? ...) (map vt-predicate-stx vts)] - [((field-extraction ...) ...) - (map (lambda (vt) - (with-syntax ([accessor (vt-accessor-stx vt)]) - (let loop ([n 0]) - (if (= n (vt-field-count vt)) - null - (cons (with-syntax ([n n]) - (syntax (accessor v n))) - (loop (add1 n))))))) - vts)] - [((field-id ...) ...) field-idss] - [(body ...) bodys] - [else-body (or else-body - (syntax - (error 'cases "no variant case matched")))]) - (syntax - (let ([v expr]) - (if (not (pred v)) - (error 'cases "not a ~a: ~s" - (quote datatype) v) - (cond - [(variant? v) - (let ([field-id field-extraction] ...) - body)] - ... - [else else-body])))))))]))) - - (define-syntax provide-datatype - (lambda (stx) - (syntax-case stx () - [(_ datatype) - (let ([dt (syntax-local-value (syntax datatype) (lambda () #f))]) - (unless (dt? dt) - (raise-syntax-error - #f - "not a datatype name" - stx - (syntax datatype))) - (with-syntax ([pred (dt-pred-stx dt)] - [(orig-variant ...) - (map vt-name-stx (dt-variants dt))]) - (syntax - (provide datatype - pred - orig-variant ...))))]))) + ;; This clause is ok: + (let-values ([(vts idss bodys else) + (loop (cdr clauses) (cons orig-variant saw-cases))]) + (values (cons vt vts) + (cons field-ids idss) + (cons (syntax (begin body0 body1 ...)) bodys) + else))))] + [(else body0 body1 ...) + (begin + (unless (null? (cdr clauses)) + (raise-syntax-error + #f + "else clause must be last" + stx + clause)) + (values null null null (syntax (begin body0 body1 ...))))] + [_else (raise-syntax-error + #f + "bad clause" + stx + clause)]))]))]) - (provide define-datatype cases provide-datatype)) + ;; Missing any variants? + (unless (or else-body + (= (length vts) (length (dt-variants dt)))) + (let* ([here (map vt-name-stx vts)] + [missing (let loop ([l (dt-variants dt)]) + (cond + [(null? l) ""] + [(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here) + (loop (cdr l))] + [else + (format " ~a~a" + (syntax-e (vt-name-stx (car l))) + (loop (cdr l)))]))]) + (raise-syntax-error + #f + (format "missing cases for the following variants:~a" missing) + stx))) + + ;; Create the result: + (with-syntax ([pred (dt-pred-stx dt)] + [(variant? ...) (map vt-predicate-stx vts)] + [((field-extraction ...) ...) + (map (lambda (vt) + (with-syntax ([accessor (vt-accessor-stx vt)]) + (let loop ([n 0]) + (if (= n (vt-field-count vt)) + null + (cons (with-syntax ([n n]) + (syntax (accessor v n))) + (loop (add1 n))))))) + vts)] + [((field-id ...) ...) field-idss] + [(body ...) bodys] + [else-body (or else-body + (syntax + (error 'cases "no variant case matched")))]) + (syntax + (let ([v expr]) + (if (not (pred v)) + (error 'cases "not a ~a: ~s" (quote datatype) v) + (cond + [(variant? v) + (let ([field-id field-extraction] ...) + body)] + ... + [else else-body])))))))]))) + +(define-syntax provide-datatype + (lambda (stx) + (syntax-case stx () + [(_ datatype) + (let ([dt (syntax-local-value (syntax datatype) (lambda () #f))]) + (unless (dt? dt) + (raise-syntax-error + #f + "not a datatype name" + stx + (syntax datatype))) + (with-syntax ([pred (dt-pred-stx dt)] + [(orig-variant ...) + (map vt-name-stx (dt-variants dt))]) + (syntax + (provide datatype + pred + orig-variant ...))))]))) + +(provide define-datatype cases provide-datatype)