1;;----------------------------------------------------------------------
2;; with-syntax, generate-temporaries
3
4(module with-stx '#%kernel
5  (#%require "stx.rkt" "define-et-al.rkt" "qq-and-or.rkt" "cond.rkt" "stxcase.rkt"
6             (for-syntax '#%kernel "stxcase.rkt" "stxloc.rkt"
7                         "gen-temp.rkt" "sc.rkt" "qq-and-or.rkt" "cond.rkt"))
8
9  (-define (with-syntax-fail stx)
10    (raise-syntax-error
11     'with-syntax
12     "binding match failed"
13     stx))
14
15  (-define (with-datum-fail stx)
16    (raise-syntax-error
17     'with-datum
18     "binding match failed"
19     stx))
20
21  ;; Partly from Dybvig
22  (begin-for-syntax
23   (define-values (gen-with-syntax)
24     (let ([here-stx (quote-syntax here)])
25       (lambda (x s-exp?)
26         (syntax-case x ()
27           ((_ () e1 e2 ...)
28            (syntax/loc x (let () e1 e2 ...)))
29           ((_ ((out in) ...) e1 e2 ...)
30            (let ([ins (syntax->list (syntax (in ...)))])
31              ;; Check for duplicates or other syntax errors:
32              (get-match-vars (syntax _) x (syntax (out ...)) null)
33              ;; Generate temps and contexts:
34              (let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)]
35                    [heres (map (lambda (x)
36                                  (datum->syntax
37                                   x
38                                   'here
39                                   x))
40                                ins)]
41                    [outs (syntax->list (syntax (out ...)))])
42                ;; Let-bind RHSs, then build up nested syntax-cases:
43                (datum->syntax
44                 here-stx
45                 `(let ,(map (lambda (tmp here in)
46                               `[,tmp ,(if s-exp?
47                                           in
48                                           `(datum->syntax
49                                             (quote-syntax ,here)
50                                             ,in))])
51                             tmps heres ins)
52                    ,(let loop ([tmps tmps][outs outs])
53                       (cond
54                        [(null? tmps)
55                         (syntax (begin e1 e2 ...))]
56                        [else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp?
57                                              [,(car outs) ,(loop (cdr tmps)
58                                                                  (cdr outs))]
59                                              [_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail)
60                                                  ;; Minimize the syntax structure we keep:
61                                                  (quote-syntax ,(datum->syntax
62                                                                  #f
63                                                                  (syntax->datum (car outs))
64                                                                  (car outs))))])])))
65                 x)))))))))
66
67  (-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f)))
68  (-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t)))
69
70  (-define counter 0)
71  (-define (append-number s)
72    (set! counter (add1 counter))
73    (string->symbol (format "~a~s" s counter)))
74
75  (-define (generate-temporaries sl)
76    (unless (stx-list? sl)
77      (raise-argument-error
78       'generate-temporaries
79       "(or/c list? syntax->list)"
80       sl))
81    (let ([l (stx->list sl)])
82      (map (lambda (x)
83	     ((make-syntax-introducer)
84	      (cond
85	       [(symbol? x)
86		(datum->syntax #f (append-number x))]
87	       [(string? x)
88		(datum->syntax #f (append-number x))]
89	       [(keyword? x)
90		(datum->syntax #f (append-number (keyword->string x)))]
91	       [(identifier? x)
92		(datum->syntax #f (append-number (syntax-e x)))]
93	       [(and (syntax? x) (keyword? (syntax-e x)))
94		(datum->syntax #f (append-number (keyword->string (syntax-e x))))]
95	       [else
96		(datum->syntax #f (append-number 'temp))])))
97	   l)))
98
99  (#%provide with-syntax with-datum generate-temporaries))
100