make.rkt (1633B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 racket/struct-info)) 4 (provide make) 5 6 ;; get-struct-info : identifier stx -> struct-info-list 7 (define-for-syntax (get-struct-info id ctx) 8 (define (bad-struct-name x) 9 (raise-syntax-error #f "expected struct name" ctx x)) 10 (unless (identifier? id) 11 (bad-struct-name id)) 12 (let ([value (syntax-local-value id (lambda () #f))]) 13 (unless (struct-info? value) 14 (bad-struct-name id)) 15 (extract-struct-info value))) 16 17 ;; (make struct-name field-expr ...) 18 ;; Checks that correct number of fields given. 19 (define-syntax (make stx) 20 (syntax-case stx () 21 [(make S expr ...) 22 (let () 23 (define info (get-struct-info #'S stx)) 24 (define constructor (list-ref info 1)) 25 (define accessors (list-ref info 3)) 26 (unless (identifier? #'constructor) 27 (raise-syntax-error #f "constructor not available for struct" stx #'S)) 28 (unless (andmap identifier? accessors) 29 (raise-syntax-error #f "incomplete info for struct type" stx #'S)) 30 (let ([num-slots (length accessors)] 31 [num-provided (length (syntax->list #'(expr ...)))]) 32 (unless (= num-provided num-slots) 33 (raise-syntax-error 34 #f 35 (format "wrong number of arguments for struct ~s (expected ~s, got ~s)" 36 (syntax-e #'S) 37 num-slots 38 num-provided) 39 stx))) 40 (with-syntax ([constructor constructor]) 41 (syntax-property #'(constructor expr ...) 42 'disappeared-use 43 #'S)))]))