source: project/lexmod/lexmod.scm @ 2659

Last change on this file since 2659 was 2659, checked in by felix winkelmann, 13 years ago

added lexmod

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