source: project/release/3/procedure-surface/trunk/procedure-surface.scm @ 9816

Last change on this file since 9816 was 9816, checked in by Kon Lovett, 12 years ago

Removed syntax-case dependency. Full low-level macro support.

File size: 7.1 KB
Line 
1;;;; procedure-surface.scm
2;;;; Kon Lovett, May '06
3
4;; Issues
5;;
6;; - The NAME of declare-procedure-means should be
7;; generated from the PI name when missing. However, this is difficult.
8;;
9;; - The call & apply forms can use procedure-means-ref since
10;; the procedure is not cached.
11;;
12;; - The let form must get the actual procedure
13;; (which forces an explicit load).
14
15;;;
16
17(define-for-syntax (ps$literal-contract? itm)
18  (or (null? itm)
19      (and (pair? itm)
20           (or (or (eq? '-> (car itm))
21                   (eq? 'procedure (car itm)))
22               (eq? 'or (car itm))
23               (and (pair? (car itm))
24                     (or (eq? '-> (caar itm))
25                         (eq? 'procedure (caar itm))))))) )
26
27(cond-expand
28  [syntax-case
29
30    (define-syntax (define-procedure-surface X)
31      (syntax-case X ()
32        [(K NAME REST ...)
33          (with-syntax (
34              [(ARG ...)
35                (map
36                  (lambda (arg)
37                    (let ([itm (syntax-object->datum arg)])
38                      (cond [(keyword? itm)
39                              arg]
40                            [(symbol? itm)
41                              (datum->syntax-object #'K `',itm)]
42                            [(list? itm)
43                              ; Quote literal contracts
44                              (if (ps$literal-contract? itm)
45                                  (datum->syntax-object #'K `',itm)
46                                  arg)]
47                            [else
48                              arg])))
49                  #'(REST ...))])
50            #'(define NAME (make-procedure-surface ARG ... #:name 'NAME)))]))
51
52    (define-syntax (declare-procedure-means X)
53      (syntax-case X ()
54        [(K NAME PS REST ...)
55          (with-syntax (
56              [(ARG ...)
57                (let ([pass-thru? #f])
58                  (map
59                    (lambda (arg)
60                      (let ([itm (syntax-object->datum arg)])
61                        (cond [pass-thru?
62                                (set! pass-thru? #f)
63                                arg]
64                              [(keyword? itm)
65                                arg]
66                              [(symbol? itm)
67                                (set! pass-thru? #t)
68                                (datum->syntax-object #'K `',itm)]
69                              [else
70                                arg])))
71                    #'(REST ...)))])
72            #'(define NAME (make-procedure-means PS ARG ...)))]))
73
74    (define-syntax call-thru-procedure-means
75      (syntax-rules ()
76
77        [(_ PSM PI)
78          ((procedure-means-ref PSM 'PI))]
79
80        [(_ PSM PI ARG ...)
81          ((procedure-means-ref PSM 'PI) ARG ...)]))
82
83    (define-syntax apply-thru-procedure-means
84      (syntax-rules ()
85        [(_ PSM PI ARG ...)
86          (apply (procedure-means-ref PSM 'PI) ARG ...)]))
87
88    (define-syntax let-procedure-means
89      (syntax-rules ()
90
91        [(_ ([(PI ...) PSM]) BODY ...)
92          (let ([PI (procedure-means-closure PSM 'PI)] ...)
93            BODY ...)]
94
95        [(_ ([(PI ...) PSM] MORE ...) BODY ...)
96          (let ([PI (procedure-means-closure PSM 'PI)] ...)
97            (let-procedure-means (MORE ...)
98              BODY ...))]
99
100        [(_ ([PI PSM]) BODY ...)
101          (let ([PI (procedure-means-closure PSM 'PI)])
102            BODY ...)]
103
104        [(_ ([PI PSM] MORE ...) BODY ...)
105          (let ([PI (procedure-means-closure PSM 'PI)])
106            (let-procedure-means (MORE ...)
107              BODY ...))]))
108
109    ;;;
110
111    (define-syntax call/means
112      (syntax-rules ()
113
114        [(_ PSM PI)
115          (call-thru-procedure-means PSM PI)]
116
117        [(_ PSM PI ARG ...)
118          (call-thru-procedure-means PSM PI ARG ...)]))
119
120    (define-syntax apply/means
121      (syntax-rules ()
122        [(_ PSM PI ARG ...)
123          (apply-thru-procedure-means PSM PI ARG ...)]))
124
125    (define-syntax let/means
126      (syntax-rules ()
127        [(_ MORE ...)
128          (let-procedure-means MORE ...)])) ]
129
130  [else
131
132    (define-macro (define-procedure-surface NAME . REST)
133      (let ([ARGS
134              (map (lambda (arg)
135                     (cond [(keyword? arg)
136                             arg]
137                           [(symbol? arg)
138                             `',arg]
139                           [(list? arg)
140                             ; Quote literal contracts
141                             (if (ps$literal-contract? arg)
142                                 `',arg
143                                 arg)]
144                           [else
145                             arg]))
146                   REST)])
147        `(define ,NAME (make-procedure-surface ,@ARGS #:name ',NAME))))
148
149    (define-macro (declare-procedure-means NAME PS . REST)
150      (let ([ARGS
151              (let ([pass-thru? #f])
152                (map (lambda (arg)
153                       (cond [pass-thru?
154                               (set! pass-thru? #f)
155                               arg]
156                             [(keyword? arg)
157                               arg]
158                             [(symbol? arg)
159                               (set! pass-thru? #t)
160                               `',arg]
161                             [else
162                               arg]))
163                     REST))])
164        `(define ,NAME (make-procedure-means ,PS ,@ARGS)) ) )
165
166    (define-macro (call-thru-procedure-means PSM PI . ARGS)
167      `((procedure-means-ref ,PSM ',PI) ,@ARGS) )
168
169    (define-macro (apply-thru-procedure-means PSM PI . ARGS)
170      `(apply (procedure-means-ref ,PSM ',PI) ,@ARGS) )
171
172    (define-macro (let-procedure-means FORMS . BODY)
173      (cond [(null? FORMS)
174              `(begin ,@BODY)]
175            [(pair? FORMS)
176              (let ([form (car FORMS)]
177                    [REST (cdr FORMS)])
178                (cond [(pair? form)
179                        (let ([VAR (car form)]
180                              [PSM (cadr form)])
181                          (if (pair? VAR)
182                            `(let
183                              ,(let loop ([pis VAR]
184                                          [lst '()])
185                                (if (null? pis)
186                                    lst
187                                    (let ([PI (car pis)])
188                                      (loop (cdr pis)
189                                            (cons `(,PI (procedure-means-closure ,PSM ',PI))
190                                                  lst)))))
191                              ,(macroexpand `(let-procedure-means ,REST ,@BODY)))
192                            `(let ([,VAR (procedure-means-closure ,PSM ',VAR)])
193                              ,(macroexpand `(let-procedure-means ,REST ,@BODY)))))]
194                      [else
195                        (syntax-error 'let-procedure-means "invalid let forms" FORMS)]))]
196            [else
197              (syntax-error 'let-procedure-means "invalid let forms" FORMS)]) )
198
199    ;;;
200
201    (define-macro (call/means PSM PI . ARGS)
202      `(call-thru-procedure-means ,PSM ,PI ,@ARGS) )
203
204    (define-macro (apply/meansPSM PI . ARGS)
205      `(apply-thru-procedure-means ,PSM ,PI ,@ARGS) )
206
207    (define-macro (let/means . MORE)
208      `(let-procedure-means ,@MORE) ) ] )
Note: See TracBrowser for help on using the repository browser.