source: project/lexmod/lexmod.scm @ 5139

Last change on this file since 5139 was 5139, checked in by Kon Lovett, 13 years ago

Added structures like functionality.

File size: 10.8 KB
Line 
1;;; (C) 2003 Taylor Campbell.
2;;; All rights reserved.
3;;;
4;;; For details, see the LICENCE file, which should have come in the
5;;; lexmod distribution.
6
7#;
8(define-syntax lexmod
9  (syntax-rules (export)
10    ((_ ?name (export ?exported ...) ?defn ...)
11     (let ()
12       (define *defined* (make-hash-table eq?))
13       ?defn ...
14       (lexmod:expand-exports *defined* ?exported ...)
15       (lambda (x)
16         (cond ((symbol? x)
17                (hash-table-ref *defined* x
18                  (lambda () (error "Unknown name in module"
19                                    '?name x))))
20               ((eq? x lexmod:get-defined-tag) *defined*)
21               ((eq? x lexmod:get-modname-tag) '?name)
22               (else (error "lexmod: Bad argument"
23                            '?name
24                            x))))))))
25
26(define-syntax lexmod
27  (syntax-rules (export)
28    ((_ ?name (export ?exported ...) ?defn ...)
29     (let ((*defined* (make-hash-table eq?)))
30       ?defn ...
31       (lexmod:expand-exports *defined* ?exported ...)
32       (lambda (x)
33         (cond ((symbol? x)
34                (hash-table-ref *defined* x
35                  (lambda () (error '?name "unknown name in lexmod" x))))
36               ((eq? x lexmod:get-defined-tag) *defined*)
37               ((eq? x lexmod:get-modname-tag) '?name)
38               (else (error '?name "invalid lexmod argument" x))))))))
39
40;;; Commented out is the hack to surround each subform in a LET.
41;(define-syntax lexmod
42;  (syntax-rules (export)
43;    ((_ ?name (export ?exported ...) ?defn ...)
44;     (let ((*defined* (make-symbol-table)))
45;       (lexmod:expand-defns ?name *defined* (?exported ...)
46;                            ?defn ...)))))
47
48;(define-syntax lexmod:expand-defns
49;  (syntax-rules ()
50;    ((_ ?name ?*defined* (?exported ...))
51;     (begin
52;       (lexmod:expand-exports ?*defined* ?exported ...)
53;       (lambda (x)
54;         (cond ((symbol? x)
55;                (symbol-table-get *defined* x
56;                  (lambda () (error "Unknown name in module"
57;                                    '?name
58;                                    x))))
59;               ((eq? x lexmod:get-defined-tag) ?*defined*)
60;               ((eq? x lexmod:get-modname-tag) '?name)
61;               (else (error "lexmod: Bad argument"
62;                            '?name
63;                            x))))))
64;    ((_ ?name ?*defined* ?exports ?defn1 ?defn2 ...)
65;     (let ()
66;       ?defn1
67;       (lexmod:expand-defns ?name ?*defined* ?exports ?defn2 ...)))))
68
69(define-syntax lexmod:expand-exports
70  (syntax-rules (as)
71    ((_ ?*defined*) #t)
72    ((_ ?*defined* (as ?exported-name ?internal-name) . ?more)
73     (begin
74       (hash-table-set! ?*defined* '?exported-name ?internal-name)
75       (lexmod:expand-exports ?*defined* . ?more)))
76    ((_ ?*defined* ?name . ?more)
77     (begin
78       (hash-table-set! ?*defined* '?name ?name)
79       (lexmod:expand-exports ?*defined* . ?more)))))
80
81(define-syntax define-lexmod
82  (syntax-rules ()
83    ((_ ?name ?exports ?defn1 ?defn2 ...)
84     (define ?name
85       (lexmod ?name ?exports
86         ?defn1 ?defn2 ...)))))
87
88(define-syntax let-imports
89  (syntax-rules ()
90    ((_ ((?module ?import-clause ...) ...) ?body1 ?body2 ...)
91     (let-syntax
92         ((k (syntax-rules ()
93               ((_ ?body  ?clauses)
94                (let ?clauses . ?body)))))
95       (lexmod:genclauses-multiply (k (?body1 ?body2 ...))
96                                   ((?module ?import-clause ...)
97                                    ...))))))
98
99(define-syntax define-imports
100  (syntax-rules ()
101    ((_ (?module ?import-clause ...) ...)
102     (lexmod:genclauses-multiply (lexmod:define-imports-k)
103                                 ((?module ?import-clause ...)
104                                  ...)))))
105
106;;; Unfortunately, this and FUNCTOR-K below must be defined separately
107;;; because of ellipsis problems, and with DEFINE-IMPORTS, the fact
108;;; that we can't use LET-SYNTAX, because that would create DEFINEs in
109;;; expression contexts.
110(define-syntax lexmod:define-imports-k
111  (syntax-rules ()
112    ((_ ((?var ?val) ...))
113     (begin (define ?var ?val)
114            ...))))
115
116(define-syntax lexmod:syntax-apply
117  (syntax-rules ()
118    ((_ (?k ?env ...) . ?args)
119     (?k ?env ... . ?args))))
120
121(define-syntax lexmod:syntax-list-append
122  (syntax-rules ()
123    ((_ ?k () ?l)
124     (lexmod:syntax-apply ?k ?l))
125    ((_ ?k ?l ())
126     (lexmod:syntax-apply ?k ?l))
127    ((_ ?k (?x . ?more) ?l)
128     (lexmod:syntax-list-append (lexmod:syntax-list-append-k ?k ?x)
129                                ?more ?l))))
130
131(define-syntax lexmod:syntax-list-append-k
132  (syntax-rules ()
133    ((_ ?k ?x  ?tail)
134     (lexmod:syntax-apply ?k (?x . ?tail)))))
135
136(define-syntax lexmod:genclauses-multiply
137  (syntax-rules ()
138    ((_ ?k ())
139     (lexmod:syntax-apply ?k ()))
140    ((_ ?k ((?module) ?more ...))
141     (lexmod:genclauses-multiply ?k (?more ...)))
142    ((_ ?k ((?module ?import-clause ...) ?more ...))
143     (lexmod:genclauses-singly (lexmod:genclauses-multiply-k1
144                                ?k
145                                (?more ...))
146                               ?module (?import-clause ...)))))
147
148(define-syntax lexmod:genclauses-multiply-k1
149  (syntax-rules ()
150    ((_ ?k ?clauses  ?new-clauses)
151     (lexmod:genclauses-multiply (lexmod:genclauses-multiply-k2
152                                  ?k ?new-clauses)
153                                 ?clauses))))
154(define-syntax lexmod:genclauses-multiply-k2
155  (syntax-rules ()
156    ((_ ?k ?new-clauses  ?new-clauses*)
157     (lexmod:syntax-list-append ?k ?new-clauses ?new-clauses*))))
158
159(define-syntax lexmod:genclauses-singly
160  (syntax-rules ()
161    ((_ ?k ?module ())
162     (lexmod:syntax-apply ?k ()))
163    ((_ ?k ?module (?clause ?more ...))
164     (lexmod:genclauses-singly (lexmod:genclauses-singly-k ?k ?module
165                                                           ?clause)
166                               ?module
167                               (?more ...)))))
168(define-syntax lexmod:genclauses-singly-k
169  (syntax-rules (as)
170    ((_ ?k ?module (as ?imported ?exported)  ?new-clauses)
171     (lexmod:syntax-apply ?k ((?imported (?module '?exported))
172                              . ?new-clauses)))
173    ((_ ?k ?module ?id  ?new-clauses)
174     (lexmod:genclauses-singly-k ?k ?module (as ?id ?id)
175                                 ?new-clauses))))
176
177(define-syntax let*-imports
178  (syntax-rules ()
179    ((_ () ?e1 ?e2 ...)
180     (let () ?e1 ?e2 ...))
181    ((_ ((?module ?import-clause ...) ?more ...) ?e1 ?e2 ...)
182     (let-imports ((?module ?import-clause ...))
183       (let*-imports (?more ...) ?e1 ?e2 ...)))))
184
185(define-syntax import-in
186  (syntax-rules ()
187    ((_ ?module (?clause ...) ?e1 ?e2 ...)
188     (begin
189       (display
190        "Warning: IMPORT-IN is deprecated; use LET-IMPORTS instead")
191       (newline)
192       (lexmod:import-aux ?module (?clause ...) () ?e1 ?e2 ...)))))
193
194(define-syntax lexmod:import-aux
195  (syntax-rules ()
196    ((_ ?module () ?let-clauses ?e1 ?e2 ...)
197     (let ?let-clauses ?e1 ?e2 ...))
198    ((_ ?module ((?imported-id ?exported-id) ?more ...) ?let-clauses
199        ?e1 ?e2 ...)
200     (lexmod:import-aux ?module (?more ...)
201                        ((?imported-id (?module '?exported-id))
202                         . ?let-clauses)
203                        ?e1 ?e2 ...))
204    ((_ ?module (?id ?more ...) ?let-clauses ?e1 ?e2 ...)
205     (lexmod:import-aux ?module (?more ...)
206                        ((?id (?module '?id)) . ?let-clauses)
207                        ?e1 ?e2 ...))))
208
209(define-syntax interface
210  (syntax-rules ()
211    ((interface ?symbol ...)
212     (let ((new (make-hash-table eq?)))
213       (hash-table-set! new '?symbol #t)
214       ...
215       new))))
216
217(define-syntax define-interface
218  (syntax-rules ()
219    ((_ ?name ?symbol ...)
220     (define ?name (interface ?symbol ...)))))
221
222(define-syntax lexmod:syntax-gentemps
223  (syntax-rules ()
224    ((syntax-gentemps ?k ())
225     (lexmod:syntax-apply ?k ()))
226    ((syntax-gentemps ?k (?var ?more ...))
227     (let-syntax
228         ((k (syntax-rules ()
229               ((k ?k*  ?tail)
230                (lexmod:syntax-apply ?k* (new-temporary . ?tail))))))
231       (lexmod:syntax-gentemps (k ?k) (?more ...))))))
232
233(define-syntax functor
234  (syntax-rules ()
235    ((functor ((?lexmod ?interface) ...) ?export
236              ?defn0 ?defn1 ...)
237     (functor _anonymous_ ((?lexmod ?interface) ...) ?export
238       ?defn0 ?defn1 ...))
239    ((functor ?name ((?lexmod ?interface) ...) ?export
240       ?defn0 ?defn1 ...)
241     (lexmod:syntax-gentemps
242      (lexmod:functor-k ?name ((?lexmod ?interface) ...) ?export
243                        (?defn0 ?defn1 ...))
244      (?interface ...)))))
245
246(define-syntax lexmod:functor-k
247  (syntax-rules ()
248    ((functor-k ?name ((?lexmod ?interface) ...) ?export-list
249        (?defn0 ?defn1 ...)
250
251        (?interface-var ...))
252     (let ((?interface-var ?interface) ...)
253       (lambda (?lexmod ...)
254         (lexmod:assert-satisfies ?lexmod ?interface-var)
255         ...
256         (lexmod ?name ?export-list ?defn0 ?defn1 ...))))))
257
258;;; Useful macros for doing something like:
259;;; (define-lexmod @foo (export ...)
260;;;   (include "foo.scm"))
261;;; to keep module information and source code separate.
262
263;(define-syntax include
264;  (transformer ; Explicit renaming: get rid of the TRANSFORMER
265;   (lambda (form rename compare) ; wrapper for Scheme48, and change
266;     (if (and (proper-list? form) ; it to ER-MACRO-TRANSFORMER for
267;              (every string? (cdr form))) ; MIT Scheme.
268;         (cond ((null? (cdr form)) (list (rename 'if) #f #f)) ; Does
269;               ((null? (cddr form)) ; anyone actually use the
270;                (call-with-input-file (cadr form) ; TRANSFORMER form
271;                  (lambda (in) ; as specified in the paper?
272;                    (cons (rename 'begin) ; (Yes: Larceny)
273;                          (let recur ()
274;                            (let ((expr (read in)))
275;                              (if (eof-object? expr)
276;                                  '()
277;                                  (cons expr (recur)))))))))
278;               (else
279;                (cons (rename 'begin)
280;                      (map (lambda (file)
281;                             `(,(rename 'include) ,file))
282;                           (cdr form)))))
283;         ;;; Return a valid, error-indicating expression, for lack of
284;         ;;; a better way to report syntax errors.
285;         ''syntax-error))))
286
287;(define-syntax include
288;  (lambda (stx)
289;    (syntax-case stx ()
290;      ((_ ?filename)
291;       (string? (syntax-object->datum (syntax ?filename)))
292;       (with-syntax
293;           (((?expr ...)
294;             (datum->syntax-object
295;              stx
296;              (call-with-input-file (syntax-object->datum
297;                                     (syntax ?filename))
298;                (lambda (in)
299;                  (let recur ()
300;                    (let ((expr (read in)))
301;                      (if (eof-object? expr)
302;                          '()
303;                          (cons expr (recur))))))))))
304;         (syntax (begin ?expr ...))))
305;      ((_ ?filename ...)
306;       (begin (include ?filename) ...)))))
Note: See TracBrowser for help on using the repository browser.