From e8349b409f9cf339bd3c3c7a86e4081c6d1ad12d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 23 Jan 2009 21:14:46 +0000 Subject: [PATCH] stxclass: added util modules svn: r13270 --- collects/stxclass/private/lib.ss | 2 +- collects/stxclass/private/parse.ss | 2 +- collects/stxclass/private/rep.ss | 2 +- collects/stxclass/private/sc.ss | 2 +- collects/stxclass/private/util.ss | 320 ----------------------------- collects/stxclass/stxclass.scrbl | 47 +++++ collects/stxclass/util.ss | 9 + collects/stxclass/util/error.ss | 15 ++ collects/stxclass/util/expand.ss | 88 ++++++++ collects/stxclass/util/misc.ss | 117 +++++++++++ collects/stxclass/util/struct.ss | 39 ++++ 11 files changed, 319 insertions(+), 324 deletions(-) delete mode 100644 collects/stxclass/private/util.ss create mode 100644 collects/stxclass/util.ss create mode 100644 collects/stxclass/util/error.ss create mode 100644 collects/stxclass/util/expand.ss create mode 100644 collects/stxclass/util/misc.ss create mode 100644 collects/stxclass/util/struct.ss diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss index c57591d67b..bdb1bb0475 100644 --- a/collects/stxclass/private/lib.ss +++ b/collects/stxclass/private/lib.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "sc.ss" - "util.ss" + "../util.ss" syntax/stx syntax/kerncase scheme/struct-info diff --git a/collects/stxclass/private/parse.ss b/collects/stxclass/private/parse.ss index 87d5c82278..c88df4c676 100644 --- a/collects/stxclass/private/parse.ss +++ b/collects/stxclass/private/parse.ss @@ -11,7 +11,7 @@ syntax/stx syntax/boundmap "rep.ss" - "util.ss") + "../util.ss") (provide/contract [parse:rhs (rhs? (listof sattr?) (listof identifier?) . -> . syntax?)] [parse:clauses (syntax? identifier? identifier? . -> . syntax?)]) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 5725255845..053b10ab9b 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -5,7 +5,7 @@ scheme/contract syntax/boundmap syntax/stx - "util.ss") + "../util.ss") (provide (struct-out sc) (struct-out attr) (struct-out rhs) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 8c971c55a9..8ee75f5c55 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -5,7 +5,7 @@ scheme/private/sc "rep.ss" "parse.ss" - "util.ss") + "../util.ss") scheme/match syntax/stx "kws.ss" diff --git a/collects/stxclass/private/util.ss b/collects/stxclass/private/util.ss deleted file mode 100644 index 9537a92fae..0000000000 --- a/collects/stxclass/private/util.ss +++ /dev/null @@ -1,320 +0,0 @@ - -#lang scheme/base -(require (for-syntax scheme/base - scheme/struct-info) - syntax/boundmap - syntax/kerncase - syntax/stx) - -(provide make - - wrong-syntax - current-syntax-context - - with-temporaries - generate-temporary - generate-n-temporaries - - chunk-kw-seq/no-dups - chunk-kw-seq - reject-duplicate-chunks - check-id - check-nat/f - check-string - check-idlist - - head-local-expand-and-categorize-syntaxes - categorize-expanded-syntaxes - head-local-expand-syntaxes) - -(define-syntax (make stx) - (define (bad-struct-name x) - (raise-syntax-error #f "expected struct name" stx x)) - (define (get-struct-info id) - (unless (identifier? id) - (bad-struct-name id)) - (let ([value (syntax-local-value id (lambda () #f))]) - (unless (struct-info? value) - (bad-struct-name id)) - (extract-struct-info value))) - (syntax-case stx () - [(make S expr ...) - (let () - (define info (get-struct-info #'S)) - (define constructor (list-ref info 1)) - (define accessors (list-ref info 3)) - (unless (identifier? #'constructor) - (raise-syntax-error #f "constructor not available for struct" stx #'S)) - (unless (andmap identifier? accessors) - (raise-syntax-error #f "incomplete info for struct type" stx #'S)) - (let ([num-slots (length accessors)] - [num-provided (length (syntax->list #'(expr ...)))]) - (unless (= num-provided num-slots) - (raise-syntax-error - #f - (format "wrong number of arguments for struct ~s (expected ~s)" - (syntax-e #'S) - num-slots) - stx))) - (with-syntax ([constructor constructor]) - #'(constructor expr ...)))])) - -(define current-syntax-context (make-parameter #f)) - -(define (wrong-syntax stx format-string . args) - (unless (or (eq? stx #f) (syntax? stx)) - (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) - (let* ([ctx (current-syntax-context)] - [blame (syntax-property ctx 'report-errors-as)]) - (raise-syntax-error (if (symbol? blame) blame #f) - (apply format format-string args) - ctx - stx))) - -(define-syntax-rule (with-temporaries (temp-name ...) . body) - (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) - . body)) - -(define (generate-temporary [stx 'g]) - (car (generate-temporaries (list stx)))) - -(define (generate-n-temporaries n) - (generate-temporaries - (for/list ([i (in-range n)]) - (string->symbol (format "g~sx" i))))) - -(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f]) - (let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)]) - (reject-duplicate-chunks chunks) - (values chunks rest))) - -;; chunk-kw-seq : stx -;; alist[keyword => (listof (stx -> any)) -;; -> (listof (cons kw (cons stx(kw) (listof any)))) stx -(define (chunk-kw-seq stx kws #:context [ctx #f]) - (define (loop stx rchunks) - (syntax-case stx () - [(kw . more) - (and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws)) - (let* ([kw-value (syntax-e #'kw)] - [arity (cdr (assq kw-value kws))] - [args+rest (stx-split #'more arity)]) - (if args+rest - (loop (cdr args+rest) - (cons (list* kw-value #'kw (car args+rest)) rchunks)) - (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))] - [(kw . more) - (keyword? (syntax-e #'kw)) - (raise-syntax-error #f "unexpected keyword" ctx #'kw)] - [_ - (values (reverse rchunks) stx)])) - (loop stx null)) - -(define (reject-duplicate-chunks chunks #:context [ctx #f]) - (define kws (make-hasheq)) - (define (loop chunks) - (when (pair? chunks) - (let ([kw (caar chunks)]) - (when (hash-ref kws kw #f) - (raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx)) - (hash-set! kws kw #t)) - (loop (cdr chunks)))) - (loop chunks)) - -;; stx-split : stx nat -> (cons (listof stx) stx) -(define (stx-split stx procs) - (define (loop stx procs acc) - (cond [(null? procs) - (cons (reverse acc) stx)] - [(stx-pair? stx) - (loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))] - [else #f])) - (loop stx procs null)) - -;; check-id : stx -> identifier -(define (check-id stx) - (unless (identifier? stx) - (raise-syntax-error 'pattern "expected identifier" stx)) - stx) - -(define (check-string stx) - (unless (string? (syntax-e stx)) - (raise-syntax-error #f "expected string" stx)) - stx) - -;; nat/f : any -> boolean -(define (nat/f x) - (or (not x) (exact-nonnegative-integer? x))) - -(define (check-nat/f stx) - (let ([d (syntax-e stx)]) - (unless (nat/f d) - (raise-syntax-error #f "expected exact nonnegative integer or #f" stx)) - stx)) - -(define (check-idlist stx) - (unless (and (stx-list? stx) (andmap identifier? (stx->list stx))) - (raise-syntax-error #f "expected list of identifiers" stx)) - (stx->list stx)) - - -;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6 -;; Setting allow-def-after-expr? allows def/expr interleaving. -(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?) - (define estxs (head-local-expand-syntaxes x allow-def-after-expr?)) - (define-values (defs vdefs sdefs exprs) - (categorize-expanded-syntaxes estxs)) - (values estxs estxs defs vdefs sdefs exprs)) - -(define (categorize-expanded-syntaxes estxs0) - (let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null]) - (cond [(pair? estxs) - (let ([ee (car estxs)]) - (syntax-case ee (begin define-values define-syntaxes) - [(define-values . _) - (loop (cdr estxs) - (cons ee defs) - (cons ee vdefs) - sdefs - exprs)] - [(define-syntaxes (var ...) rhs) - (loop (cdr estxs) - (cons ee defs) - vdefs - (cons ee sdefs) - exprs)] - [_ - (loop (cdr estxs) - defs - vdefs - sdefs - (cons ee exprs))]))] - [(null? estxs) - (values (reverse defs) - (reverse vdefs) - (reverse sdefs) - (reverse exprs))]))) - -;; head-local-expand-syntaxes : syntax boolean -> (listof syntax) -(define (head-local-expand-syntaxes x allow-def-after-expr?) - (let ([intdef (syntax-local-make-definition-context)] - [ctx '(block)]) - (let loop ([x x] [ex null] [expr? #f]) - (cond [(stx-pair? x) - (let ([ee (local-expand (stx-car x) - ctx - (kernel-form-identifier-list) - intdef)]) - (syntax-case ee (begin define-values define-syntaxes) - [(begin e ...) - (loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)] - [(begin . _) - (raise-syntax-error #f "bad begin form" ee)] - [(define-values (var ...) rhs) - (andmap identifier? (syntax->list #'(var ...))) - (begin - (when (and expr? (not allow-def-after-expr?)) - (raise-syntax-error #f "definition after expression" ee)) - (syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef) - (loop (stx-cdr x) (cons ee ex) expr?))] - [(define-values . _) - (raise-syntax-error #f "bad define-values form" ee)] - [(define-syntaxes (var ...) rhs) - (andmap identifier? (syntax->list #'(var ...))) - (begin - (when (and expr? (not allow-def-after-expr?)) - (raise-syntax-error #f "definition after expression" ee)) - (syntax-local-bind-syntaxes (syntax->list #'(var ...)) - #'rhs - intdef) - (loop (stx-cdr x) (cons ee ex) expr?))] - [(define-syntaxes . _) - (raise-syntax-error #f "bad define-syntaxes form" ee)] - [_ - (loop (stx-cdr x) (cons ee ex) #t)]))] - [(stx-null? x) - (internal-definition-context-seal intdef) - (reverse ex)])))) - - -#| -;; Mappings - -(define dummy (box #f)) -(define fdummy (lambda () dummy)) -(define (false/p) #f) - -;; -- - -(define-struct monomap (table getter putter mapper foreacher injfail)) - -(define (monomap-get im key [fail false/p]) - ((monomap-getter im) (monomap-table im) key fail)) - -(define (monomap-put! im key val) - (let ([val ((monomap-getter im) (monomap-table im) key fdummy)]) - (unless (eq? val dummy) - ((monomap-injfail im) key val)) - ((monomap-putter im) (monomap-table im) key val))) - -(define (monomap-map im p) - ((monomap-mapper im) (monomap-table im) p)) - -(define (monomap-for-each im p) - ((monomap-foreacher im) (monomap-table im) p) - (void)) - -(define (monomap-domain im) - (monomap-map (lambda (k v) k))) - -(define (monomap-range im) - (monomap-map (lambda (k v) v))) - -(define (make-bound-id-monomap fail) - (make-monomap (make-bound-identifier-mapping) - bound-identifier-mapping-get - bound-identifier-mapping-put! - bound-identifier-mapping-map - bound-identifier-mapping-for-each - fail)) - -(define (make-free-id-monomap fail) - (make-monomap (make-module-identifier-mapping) - module-identifier-mapping-get - module-identifier-mapping-put! - module-identifier-mapping-map - module-identifier-mapping-for-each - fail)) - -(define (make-hash-monomap fail) - (make-monomap (make-hash-table) - hash-table-get - hash-table-put! - hash-table-map - hash-table-for-each - fail)) - -(define-struct isomap (forward backward)) - -(define (isomap-get im k [fail false/p]) - (monomap-get (isomap-forward im) k fail)) -(define (isomap-put! im k v) - (monomap-put! (isomap-forward im) k v) - (monomap-put! (isomap-backward im) k v)) -(define (isomap-map im p) - (monomap-map (isomap-forward im) p)) -(define (isomap-for-each im p) - (monomap-for-each (isomap-forward im) p)) - -(define (isomap-reverse-get im k [fail false/p]) - (monomap-get (isomap-backward im) k fail)) - -(define (isomap-domain im) - (monomap-domain (isomap-forward im))) -(define (isomap-range im) - (monomap-domain (isomap-backward im))) - -(define (-make-isomap fmake rmake ffail rfail) - (make-isomap (fmake ffail) - (rmake rfail))) -|# diff --git a/collects/stxclass/stxclass.scrbl b/collects/stxclass/stxclass.scrbl index 7a92cd73b1..b9b39ab969 100644 --- a/collects/stxclass/stxclass.scrbl +++ b/collects/stxclass/stxclass.scrbl @@ -525,3 +525,50 @@ Accepts any term and returns as the match that term wrapped in a } } + + +@;{ + + +1 How to abstract over similar patterns: + +(syntax-parse stx #:literals (blah bleh blaz kwA kwX) + [(blah (bleh (kwX y z)) blaz) + ___] + [(blah (bleh (kwA (b c))) blaz) + ___]) + +=> + +(define-syntax-class common + #:attributes (inner) + #:literals (blah bleh blaz) + (pattern (blah (bleh inner) blaz))) +(syntax-parse stx #:literals (kwA kwX) + [c:common + #:with (kwX y z) #'c.inner + ___] + [c:common + #:with (kwA (b c)) #'c.inner + ___]) + + +OR => + +(define-syntax-class (common expected-kw) + #:attributes (inner) + #:literals (blah bleh blaz) + (pattern (blah (bleh (kw . inner)) blaz) + #:when (free-identifier=? #'kw expected-kw))) +(syntax-parse stx + [c + #:declare c (common #'kwX) + #:with (y z) #'c.inner + ___] + [c + #:declare c (common #'kwA) + #:with ((b c)) #'c.inner + ___]) + + +} diff --git a/collects/stxclass/util.ss b/collects/stxclass/util.ss new file mode 100644 index 0000000000..6dd0a3e5ba --- /dev/null +++ b/collects/stxclass/util.ss @@ -0,0 +1,9 @@ +#lang scheme/base +(require "util/error.ss" + "util/expand.ss" + "util/misc.ss" + "util/struct.ss") +(provide (all-from-out "util/error.ss") + (all-from-out "util/expand.ss") + (all-from-out "util/misc.ss") + (all-from-out "util/struct.ss")) diff --git a/collects/stxclass/util/error.ss b/collects/stxclass/util/error.ss new file mode 100644 index 0000000000..803832d861 --- /dev/null +++ b/collects/stxclass/util/error.ss @@ -0,0 +1,15 @@ +#lang scheme/base +(provide wrong-syntax + current-syntax-context) + +(define current-syntax-context (make-parameter #f)) + +(define (wrong-syntax stx format-string . args) + (unless (or (eq? stx #f) (syntax? stx)) + (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) + (let* ([ctx (current-syntax-context)] + [blame (syntax-property ctx 'report-errors-as)]) + (raise-syntax-error (if (symbol? blame) blame #f) + (apply format format-string args) + ctx + stx))) diff --git a/collects/stxclass/util/expand.ss b/collects/stxclass/util/expand.ss new file mode 100644 index 0000000000..5e8a6b99ca --- /dev/null +++ b/collects/stxclass/util/expand.ss @@ -0,0 +1,88 @@ +#lang scheme/base +(require syntax/kerncase + syntax/stx) +(provide head-local-expand-and-categorize-syntaxes + categorize-expanded-syntaxes + head-local-expand-syntaxes) + +;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6 +;; Setting allow-def-after-expr? allows def/expr interleaving. +(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?) + (define estxs (head-local-expand-syntaxes x allow-def-after-expr?)) + (define-values (defs vdefs sdefs exprs) + (categorize-expanded-syntaxes estxs)) + (values estxs estxs defs vdefs sdefs exprs)) + +;; categorize-expanded-syntaxes : (listof stx) -> stxs ^ 4 +;; Split head-expanded stxs into +;; definitions, values-definitions, syntaxes-definitions, exprs +;; (definitions include both values-definitions and syntaxes-definitions.) +(define (categorize-expanded-syntaxes estxs0) + (let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null]) + (cond [(pair? estxs) + (let ([ee (car estxs)]) + (syntax-case ee (begin define-values define-syntaxes) + [(define-values . _) + (loop (cdr estxs) + (cons ee defs) + (cons ee vdefs) + sdefs + exprs)] + [(define-syntaxes (var ...) rhs) + (loop (cdr estxs) + (cons ee defs) + vdefs + (cons ee sdefs) + exprs)] + [_ + (loop (cdr estxs) + defs + vdefs + sdefs + (cons ee exprs))]))] + [(null? estxs) + (values (reverse defs) + (reverse vdefs) + (reverse sdefs) + (reverse exprs))]))) + +;; head-local-expand-syntaxes : syntax boolean -> (listof syntax) +(define (head-local-expand-syntaxes x allow-def-after-expr?) + (let ([intdef (syntax-local-make-definition-context)] + [ctx '(block)]) + (let loop ([x x] [ex null] [expr? #f]) + (cond [(stx-pair? x) + (let ([ee (local-expand (stx-car x) + ctx + (kernel-form-identifier-list) + intdef)]) + (syntax-case ee (begin define-values define-syntaxes) + [(begin e ...) + (loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)] + [(begin . _) + (raise-syntax-error #f "bad begin form" ee)] + [(define-values (var ...) rhs) + (andmap identifier? (syntax->list #'(var ...))) + (begin + (when (and expr? (not allow-def-after-expr?)) + (raise-syntax-error #f "definition after expression" ee)) + (syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef) + (loop (stx-cdr x) (cons ee ex) expr?))] + [(define-values . _) + (raise-syntax-error #f "bad define-values form" ee)] + [(define-syntaxes (var ...) rhs) + (andmap identifier? (syntax->list #'(var ...))) + (begin + (when (and expr? (not allow-def-after-expr?)) + (raise-syntax-error #f "definition after expression" ee)) + (syntax-local-bind-syntaxes (syntax->list #'(var ...)) + #'rhs + intdef) + (loop (stx-cdr x) (cons ee ex) expr?))] + [(define-syntaxes . _) + (raise-syntax-error #f "bad define-syntaxes form" ee)] + [_ + (loop (stx-cdr x) (cons ee ex) #t)]))] + [(stx-null? x) + (internal-definition-context-seal intdef) + (reverse ex)])))) diff --git a/collects/stxclass/util/misc.ss b/collects/stxclass/util/misc.ss new file mode 100644 index 0000000000..2693fd7af3 --- /dev/null +++ b/collects/stxclass/util/misc.ss @@ -0,0 +1,117 @@ +#lang scheme/base +(require syntax/kerncase + syntax/stx) + +(provide with-temporaries + generate-temporary + generate-n-temporaries + + chunk-kw-seq/no-dups + chunk-kw-seq + reject-duplicate-chunks + check-id + check-nat/f + check-string + check-idlist) + + +;; Generating temporaries + +;; with-temporaries +(define-syntax-rule (with-temporaries (temp-name ...) . body) + (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) + . body)) + +;; generate-temporary : any -> identifier +(define (generate-temporary [stx 'g]) + (car (generate-temporaries (list stx)))) + +;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier) +(define (generate-n-temporaries n) + (generate-temporaries + (for/list ([i (in-range n)]) + (string->symbol (format "g~sx" i))))) + + +;; Parsing keyword arguments + +;; chunk-kw-seq/no-dups : syntax +;; alist[keyword => (listof (stx -> any))] +;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) +(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f]) + (let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)]) + (reject-duplicate-chunks chunks) + (values chunks rest))) + +;; chunk-kw-seq : stx +;; alist[keyword => (listof (stx -> any)) +;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) +(define (chunk-kw-seq stx kws #:context [ctx #f]) + (define (loop stx rchunks) + (syntax-case stx () + [(kw . more) + (and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws)) + (let* ([kw-value (syntax-e #'kw)] + [arity (cdr (assq kw-value kws))] + [args+rest (stx-split #'more arity)]) + (if args+rest + (loop (cdr args+rest) + (cons (list* kw-value #'kw (car args+rest)) rchunks)) + (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))] + [(kw . more) + (keyword? (syntax-e #'kw)) + (raise-syntax-error #f "unexpected keyword" ctx #'kw)] + [_ + (values (reverse rchunks) stx)])) + (loop stx null)) + +;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void +(define (reject-duplicate-chunks chunks #:context [ctx #f]) + (define kws (make-hasheq)) + (define (loop chunks) + (when (pair? chunks) + (let ([kw (caar chunks)]) + (when (hash-ref kws kw #f) + (raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx)) + (hash-set! kws kw #t)) + (loop (cdr chunks)))) + (loop chunks)) + +;; stx-split : stx nat -> (cons (listof stx) stx) +(define (stx-split stx procs) + (define (loop stx procs acc) + (cond [(null? procs) + (cons (reverse acc) stx)] + [(stx-pair? stx) + (loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))] + [else #f])) + (loop stx procs null)) + +;; check-id : stx -> identifier +(define (check-id stx) + (unless (identifier? stx) + (raise-syntax-error 'pattern "expected identifier" stx)) + stx) + +;; check-string : stx -> stx +(define (check-string stx) + (unless (string? (syntax-e stx)) + (raise-syntax-error #f "expected string" stx)) + stx) + +;; nat/f : any -> boolean +(define (nat/f x) + (or (not x) (exact-nonnegative-integer? x))) + +;; check-nat/f : stx -> stx +(define (check-nat/f stx) + (let ([d (syntax-e stx)]) + (unless (nat/f d) + (raise-syntax-error #f "expected exact nonnegative integer or #f" stx)) + stx)) + +;; check-idlist : stx -> (listof identifier) +(define (check-idlist stx) + (unless (and (stx-list? stx) (andmap identifier? (stx->list stx))) + (raise-syntax-error #f "expected list of identifiers" stx)) + (stx->list stx)) diff --git a/collects/stxclass/util/struct.ss b/collects/stxclass/util/struct.ss new file mode 100644 index 0000000000..e28d31b7ae --- /dev/null +++ b/collects/stxclass/util/struct.ss @@ -0,0 +1,39 @@ +#lang scheme/base +(require (for-syntax scheme/base + scheme/struct-info)) + +(provide make) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" stx x)) + (define (get-struct-info id) + (unless (identifier? id) + (bad-struct-name id)) + (let ([value (syntax-local-value id (lambda () #f))]) + (unless (struct-info? value) + (bad-struct-name id)) + (extract-struct-info value))) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S)) + (define constructor (list-ref info 1)) + (define accessors (list-ref info 3)) + (unless (identifier? #'constructor) + (raise-syntax-error #f "constructor not available for struct" stx #'S)) + (unless (andmap identifier? accessors) + (raise-syntax-error #f "incomplete info for struct type" stx #'S)) + (let ([num-slots (length accessors)] + [num-provided (length (syntax->list #'(expr ...)))]) + (unless (= num-provided num-slots) + (raise-syntax-error + #f + (format "wrong number of arguments for struct ~s (expected ~s)" + (syntax-e #'S) + num-slots) + stx))) + (with-syntax ([constructor constructor]) + #'(constructor expr ...)))]))