source: project/release/3/srfi-89/srfi-89.scm

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

added srfi-89

File size: 9.0 KB
Line 
1;;;; srfi-89.scm
2
3
4; Macro expander for define*.
5
6(define-macro (define* pattern . body)
7  (if (pair? pattern)
8      `(define* ,(car pattern)
9         (lambda* ,(cdr pattern) ,@body))
10      `(define ,pattern ,@body)))
11
12; Macro expander for lambda*.
13
14(define-macro (lambda* formals . body)
15
16;------------------------------------------------------------------------------
17
18; Procedures needed at expansion time.
19
20(define (parse-formals formals)
21
22  (define (variable? x) (symbol? x))
23
24  (define (required-positional? x)
25    (variable? x))
26
27  (define (optional-positional? x)
28    (and (pair? x)
29         (pair? (cdr x))
30         (null? (cddr x))
31         (variable? (car x))))
32
33  (define (required-named? x)
34    (and (pair? x)
35         (pair? (cdr x))
36         (null? (cddr x))
37         (keyword? (car x))
38         (variable? (cadr x))))
39
40  (define (optional-named? x)
41    (and (pair? x)
42         (pair? (cdr x))
43         (pair? (cddr x))
44         (null? (cdddr x))
45         (keyword? (car x))
46         (variable? (cadr x))))
47
48  (define (named? x)
49    (or (required-named? x)
50        (optional-named? x)))
51
52  (define (duplicates? lst)
53    (cond ((null? lst)
54           #f)
55          ((memq (car lst) (cdr lst))
56           #t)
57          (else
58           (duplicates? (cdr lst)))))
59
60  (define (parse-positional-section lst cont)
61    (let loop1 ((lst lst) (rev-reqs '()))
62      (if (and (pair? lst)
63               (required-positional? (car lst)))
64          (loop1 (cdr lst) (cons (car lst) rev-reqs))
65          (let loop2 ((lst lst) (rev-opts '()))
66            (if (and (pair? lst)
67                     (optional-positional? (car lst)))
68                (loop2 (cdr lst) (cons (car lst) rev-opts))
69                (cont lst (cons (reverse rev-reqs) (reverse rev-opts))))))))
70
71  (define (parse-named-section lst cont)
72    (let loop ((lst lst) (rev-named '()))
73      (if (and (pair? lst)
74               (named? (car lst)))
75          (loop (cdr lst) (cons (car lst) rev-named))
76          (cont lst (reverse rev-named)))))
77
78  (define (parse-rest lst
79                      positional-before-named?
80                      positional-reqs/opts
81                      named)
82    (if (null? lst)
83        (parse-end positional-before-named?
84                   positional-reqs/opts
85                   named
86                   #f)
87        (if (variable? lst)
88            (parse-end positional-before-named?
89                       positional-reqs/opts
90                       named
91                       lst)
92            (error "syntax error in formal parameter list"))))
93
94  (define (parse-end positional-before-named?
95                     positional-reqs/opts
96                     named
97                     rest)
98    (let ((positional-reqs (car positional-reqs/opts))
99          (positional-opts (cdr positional-reqs/opts)))
100      (let ((vars
101             (append positional-reqs
102                     (map car positional-opts)
103                     (map cadr named)
104                     (if rest (list rest) '())))
105            (keys
106             (map car named)))
107        (cond ((duplicates? vars)
108               (error "duplicate variable in formal parameter list"))
109              ((duplicates? keys)
110               (error "duplicate keyword in formal parameter list"))
111              (else
112               (list positional-before-named?
113                     positional-reqs
114                     positional-opts
115                     named
116                     rest))))))
117
118  (define (parse lst)
119    (if (and (pair? lst)
120             (named? (car lst)))
121        (parse-named-section
122         lst
123         (lambda (lst named)
124           (parse-positional-section
125            lst
126            (lambda (lst positional-reqs/opts)
127              (parse-rest lst
128                          #f
129                          positional-reqs/opts
130                          named)))))
131        (parse-positional-section
132         lst
133         (lambda (lst positional-reqs/opts)
134           (parse-named-section
135            lst
136            (lambda (lst named)
137              (parse-rest lst
138                          #t
139                          positional-reqs/opts
140                          named)))))))
141
142  (parse formals))
143
144(define (expand-lambda* formals body)
145
146  (define (range lo hi)
147    (if (< lo hi)
148        (cons lo (range (+ lo 1) hi))
149        '()))
150
151  (define (expand positional-before-named?
152                  positional-reqs
153                  positional-opts
154                  named
155                  rest)
156    (if (and (null? positional-opts) (null? named)) ; direct R5RS equivalent
157
158        `(lambda ,(append positional-reqs (or rest '())) ,@body)
159
160        (let ()
161
162          (define utility-fns
163            `(,@(if (or positional-before-named?
164                        (null? positional-reqs))
165                    `()
166                    `(($req
167                       (lambda ()
168                         (if (pair? $args)
169                             (let ((arg (car $args)))
170                               (set! $args (cdr $args))
171                               arg)
172                             (error "too few actual parameters"))))))
173              ,@(if (null? positional-opts)
174                    `()
175                    `(($opt
176                       (lambda (default)
177                         (if (pair? $args)
178                             (let ((arg (car $args)))
179                               (set! $args (cdr $args))
180                               arg)
181                             (default))))))))
182
183          (define positional-bindings
184            `(,@(if positional-before-named?
185                    `()
186                    (map (lambda (x)
187                           `(,x ($req)))
188                         positional-reqs))
189              ,@(map (lambda (x)
190                       `(,(car x) ($opt (lambda () ,(cadr x)))))
191                     positional-opts)))
192
193          (define named-bindings
194            (if (null? named)
195                `()
196                `(($key-values
197                   (vector ,@(map (lambda (x) `$undefined)
198                                  named)))
199                  ($args
200                   ($process-keys
201                    $args
202                    ',(make-perfect-hash-table
203                       (map (lambda (x i)
204                              (cons (car x) i))
205                            named
206                            (range 0 (length named))))
207                    $key-values))
208                  ,@(map (lambda (x i)
209                           `(,(cadr x)
210                             ,(if (null? (cddr x))
211                                  `($req-key $key-values ,i)
212                                  `($opt-key $key-values ,i (lambda ()
213                                                              ,(caddr x))))))
214                         named
215                         (range 0 (length named))))))
216
217          (define rest-binding
218            (if (not rest)
219                `(($args (or (null? $args)
220                             (error "too many actual parameters"))))
221                `((,rest $args))))
222
223          (let ((bindings
224                 (append (if positional-before-named?
225                             (append utility-fns
226                                     positional-bindings
227                                     named-bindings)
228                             (append named-bindings
229                                     utility-fns
230                                     positional-bindings))
231                         rest-binding)))
232            `(lambda ,(append (if positional-before-named?
233                                  positional-reqs
234                                  '())
235                              '$args)
236               (let* ,bindings
237                 ,@body))))))
238
239  (apply expand (parse-formals formals)))
240
241(define (make-perfect-hash-table alist)
242
243  ; "alist" is a list of pairs of the form "(keyword . value)"
244
245  ; The result is a perfect hash-table represented as a vector of
246  ; length 2*N, where N is the hash modulus.  If the keyword K is in
247  ; the hash-table it is at index
248  ;
249  ;   X = (* 2 ($hash-keyword K N))
250  ;
251  ; and the associated value is at index X+1.
252
253  (let loop1 ((n (length alist)))
254    (let ((v (make-vector (* 2 n) #f)))
255      (let loop2 ((lst alist))
256        (if (pair? lst)
257            (let* ((key-val (car lst))
258                   (key (car key-val)))
259              (let ((x (* 2 ($hash-keyword key n))))
260                (if (vector-ref v x)
261                    (loop1 (+ n 1))
262                    (begin
263                      (vector-set! v x key)
264                      (vector-set! v (+ x 1) (cdr key-val))
265                      (loop2 (cdr lst))))))
266            v)))))
267
268(define ($hash-keyword key n)
269  (let ((str (keyword->string key)))
270    (let loop ((h 0) (i 0))
271      (if (< i (string-length str))
272          (loop (modulo (+ (* h 65536) (char->integer (string-ref str i)))
273                        n)
274                (+ i 1))
275          h))))
276
277(expand-lambda* formals body))
278
279(require 'srfi-89-support)
280
281(define-macro (define-macro* head . body)
282  (if (and (pair? head) (symbol? (car head)))
283      `(define-macro ,(car head)
284         (lambda* ,(cdr head) ,@body))
285      `(define-macro head ,@body)))
Note: See TracBrowser for help on using the repository browser.