stxclass: added util modules

svn: r13270

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

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?)])

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)

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"

collects/stxclass/private/util.ss

@@ -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)))
-|#

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
+   ___])
+
+
+}

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"))

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)))

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)]))))

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))

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 ...)))]))