1#lang racket/base 2(require racket/match/match-expander 3 (for-syntax racket/base 4 racket/struct-info 5 racket/list 6 "../private/struct-util.rkt")) 7 8(define-for-syntax (extract-field-names orig-stx the-struct-info) 9 (define accessors (list-ref the-struct-info 3)) 10 (define parent (list-ref the-struct-info 5)) 11 (define num-fields (length accessors)) 12 (define num-super-fields 13 (if (identifier? parent) 14 (length (cadddr (id->struct-info parent orig-stx))) 15 0)) 16 (define num-own-fields (- num-fields num-super-fields)) 17 (define own-accessors (take accessors num-own-fields)) 18 (define struct-name (predicate->struct-name 'struct* orig-stx (list-ref the-struct-info 2))) 19 (for/list ([accessor (in-list own-accessors)]) 20 ;; add1 for hyphen 21 (string->symbol (substring (symbol->string (syntax-e accessor)) 22 (add1 (string-length struct-name)))))) 23 24(define-for-syntax (id->struct-info id stx) 25 (define compile-time-info (syntax-local-value id (lambda () #f))) 26 (unless (struct-info? compile-time-info) 27 (raise-syntax-error #f "identifier is not bound to a structure type" stx id)) 28 (extract-struct-info compile-time-info)) 29 30(define-match-expander 31 struct* 32 (lambda (stx) 33 (syntax-case stx () 34 [(_ struct-name (field+pat ...)) 35 (let* ([fail (lambda () 36 (raise-syntax-error 37 'struct* "not a structure definition" 38 stx #'struct-name))] 39 [v (if (identifier? #'struct-name) 40 (syntax-local-value #'struct-name fail) 41 (fail))] 42 [field->pattern (make-hash)]) 43 (unless (struct-info? v) (fail)) 44 (define the-struct-info (extract-struct-info v)) 45 46 ;; own-fields and all-accessors are in the reverse order 47 (define all-accessors (list-ref the-struct-info 3)) 48 (define own-fields 49 (if (struct-field-info? v) 50 (struct-field-info-list v) 51 (extract-field-names stx the-struct-info))) 52 ;; Use hash instead of set so that we don't need to require racket/set 53 (define field-set (for/hash ([field own-fields]) (values field #t))) 54 55 ;; Check that all field names are valid 56 (for ([an (in-list (syntax->list #'(field+pat ...)))]) 57 (syntax-case an () 58 [(field pat) 59 (let ([fail-field (λ (msg) (raise-syntax-error 'struct* msg stx #'field))]) 60 (unless (identifier? #'field) 61 (fail-field "not an identifier for field name")) 62 (define name (syntax-e #'field)) 63 (unless (hash-has-key? field-set name) 64 (fail-field "field name not associated with given structure type")) 65 (when (hash-has-key? field->pattern name) 66 (fail-field "field name appears twice")) 67 (hash-set! field->pattern name #'pat))] 68 [_ (raise-syntax-error 69 'struct* "expected a field pattern of the form (<field-id> <pat>)" 70 stx an)])) 71 72 ;; pats is in the reverse order 73 (define pats 74 (for/list ([field (in-sequences (in-list own-fields) 75 (in-cycle '(#f)))] 76 [accessor (in-list all-accessors)] 77 #:when accessor) 78 (hash-ref field->pattern field (syntax/loc stx _)))) 79 (quasisyntax/loc stx (struct struct-name #,(reverse pats))))]))) 80 81(provide struct* ==) 82 83(define-match-expander 84 == 85 (lambda (stx) 86 (syntax-case stx () 87 [(_ val comp) 88 #'(? (lambda (x) (comp val x)))] 89 [(_ val) #'(? (lambda (x) (equal? val x)))]))) 90