source: project/release/4/anaphora/trunk/anaphora.scm @ 29985

Last change on this file since 29985 was 29985, checked in by juergen, 8 years ago

version 0.4 with define-anaphor define-properties tree-recurser atree-recurser list-recurser alist-recurser

File size: 14.9 KB
Line 
1; Author: Juergen Lorenz
2; ju (at) jugilo (dot) de
3;
4; Last update: Sep 08, 2011
5;
6; Copyright (c) 2011, Juergen Lorenz
7; All rights reserved.
8;
9; Redistribution and use in source and binary forms, with or without
10; modification, are permitted provided that the following conditions are
11; met:
12;
13; Redistributions of source code must retain the above copyright
14; notice, this list of conditions and the following disclaimer.
15;
16; Redistributions in binary form must reproduce the above copyright
17; notice, this list of conditions and the following disclaimer in the
18; documentation and/or other materials provided with the distribution.
19;
20; Neither the name of the author nor the names of its contributors may be
21; used to endorse or promote products derived from this software without
22; specific prior written permission.
23;
24; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
25; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
26; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
27; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
28; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
29; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
30; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
31; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
32; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35;
36
37
38;Inspired by Paul Graham's classic "On Lisp" this module introduces
39;anaphoric macros, which are unhygienic by design. Hence they can not be
40;implemented with syntax-rules! In fact, they introduce new identifiers
41;behind the scene, mostly named it, which can be referenced in the body
42;without being declared. Please note, that this identifier is not
43;renamed!
44
45(module anaphora
46
47(export anaphora aif awhen acond awhile aand alambda define-anaphor
48        define-properties alist-recurser atree-recurser
49        tree-recurser list-recurser)
50(import scheme (only chicken case-lambda gensym print)) ;;print
51
52;;; (aif test consequent [alternative])
53;;; ------------------------------------
54;;; anaphoric if, where consequent and alternative can refer to result
55;;; of test named it
56(define-syntax aif
57  (ir-macro-transformer
58    (lambda (form inject compare?)
59      (let ((it (inject 'it)))
60        (let (
61          (test (cadr form))
62          (consequent (caddr form))
63          (alternative (cdddr form))
64          )
65          (if (null? alternative)
66            `(let ((,it ,test))
67               (if ,it ,consequent))
68            `(let ((,it ,test))
69               (if ,it ,consequent ,(car alternative)))))))))
70
71;;; (awhen test xpr . xprs)
72;;; ------------------------
73;;; anaphoric when, where xpr ... can refer to result of test
74;;; named it
75(define-syntax awhen
76  (ir-macro-transformer
77    (lambda (form inject compare?)
78      (let ((it (inject 'it)))
79        (let (
80          (test (cadr form))
81          (xpr (caddr form))
82          (xprs (cdddr form))
83          )
84          `(let ((,it ,test))
85             (if ,it (begin ,xpr ,@xprs))))))))
86
87;;; (acond . clauses)
88;;; -----------------
89;;; anaphoric cond, where each clause is a list (test xpr ...) in which
90;;; each xpr can refer to result of test named it.
91;;; The last clause can start with else which evaluates to #t.
92(define-syntax acond
93  (ir-macro-transformer
94    (lambda (form inject compare?)
95      (let ((it (inject 'it)))
96        (let ((clauses (cdr form)))
97          (let loop ((clauses clauses))
98            (if (null? clauses)
99              #f
100              (let* (
101                (clause (car clauses))
102                (cnd (car clause))
103                )
104                `(let ((sym ,(if (compare? cnd 'else) #t cnd)))
105                   (if sym
106                     (let ((,it sym))
107                       ,@(cdr clause))
108                     ,(loop (cdr clauses))))))))))))
109
110;;; (awhile test xpr . xprs)
111;;; -------------------------
112;;; anaphoric while, where each xpr ... can refer to the result of
113;;; the successive test, named it
114(define-syntax awhile
115  (ir-macro-transformer
116    (lambda (form inject compare?)
117      (let ((it (inject 'it)))
118        (let (
119          (test (cadr form))
120          (xpr (caddr form))
121          (xprs (cdddr form))
122          )
123          `(let loop ((,it ,test))
124             (when ,it
125               ,xpr ,@xprs
126               (loop ,test))))))))
127
128;;; (aand . args)
129;;; -------------
130;;; anaphoric and, where each successive argument can refer to the
131;;; result of the previous argument, named it.
132(define-syntax aand
133  (ir-macro-transformer
134    (lambda (form inject compare?)
135      (let ((it (inject 'it)))
136        (let ((args (cdr form)))
137          (let loop ((args args))
138            (cond
139              ((null? args) #t)
140              ((null? (cdr args)) (car args))
141              (else
142                `(let ((,it ,(car args)))
143                   (if ,it
144                     ,(loop (cdr args))))))))))))
145
146;;; (alambda args xpr . xprs)
147;;; -------------------------
148;;; anaphoric lambda, where the body xpr ... can refer to self, so that
149;;; recursion is possible
150(define-syntax alambda
151  (ir-macro-transformer
152    (lambda (form inject compare?)
153      (let ((self (inject 'self)))
154        (let ((args (cadr form)) (body (cddr form)))
155          `(letrec ((,self (lambda ,args ,@body)))
156             ,self))))))
157
158#|[
159Most of  the anaphoric macros above could be generated automatically by
160means of the following macro, define-anaphor, which generates another
161macro defining it. It accepts three arguments, the name of the new
162macro to be defined, the name of the procedure or macro on which the
163anaphoric macro is patterned and a rule transforming the latter into the
164former, presently one of the procedures cascade-it and first-it.
165cascade-it produces a cascade of variables named it, storing the
166values of the previous arguments as in aand above, where first-it stores
167only the first argument as variable it to be used in any of the
168following arguments as in awhen above.  So we could have defined them as
169
170  (define-anaphor aand and cascade-it)
171  (define-anaphor awhen when first-it)
172
173and used as follows
174
175  (aand '(1 2 3) (cdr it) (cdr it)) ; -> '(3)
176  (awhen (! 5) it (* 2 it)) ; -> 240
177
178where ! is the factorial.
179But note, that define-anaphor could be used for any function as well,
180for example
181
182  (define-anaphor a* * cascade-it)
183  (a* 10 (* 2 it) (+ 5 it)) ; -> 35
184]|#
185
186;;; (define-anaphor name from rule)
187;;; -------------------------------
188;;; defines an anaphoric macro, name, patterned after the fuction or
189;;; macro from and transformed according to rule, one of the symbols
190;;; cascade or first.
191;;; Note, that this macro is hygienic, but it creates an anaphoric one.
192(define-syntax define-anaphor
193  (syntax-rules ()
194    ((_ name from rule)
195     (define-syntax name
196       (er-macro-transformer
197         (lambda (form rename compare?)
198           (let ((%let (rename 'let)) (%let* (rename 'let*)))
199             (letrec (
200               (cascade-it
201                 (lambda (op args)
202                   (let loop ((args args) (xpr `(,op)))
203                     (if (null? args)
204                       xpr
205                       (let ((sym (gensym)))
206                         `(,%let* ((,sym ,(car args)) (it ,sym))
207                                  ,(loop (cdr args)
208                                         (append xpr (list sym)))))))))
209               (first-it
210                 (lambda (op args)
211                   `(,%let ((it ,(car args)))
212                           (,op it ,@(cdr args)))))
213               )
214               (case rule
215                 ((#:cascade)
216                  (cascade-it 'from (cdr form)))
217                 ((#:first)
218                  (first-it 'from (cdr form)))
219                 (else
220                   (error 'define-anaphor
221                       "rule must be one of #:cascade or #:first")))))))))))
222;(define-syntax define-anaphor
223;  (syntax-rules ()
224;    ((_ name from rule)
225;     (define-syntax name
226;       (er-macro-transformer
227;         (lambda (form rename compare?)
228;           (rule 'from (cdr form) rename)))))))
229;
230;(define (first-it op args rename)
231;  (let ((%let (rename 'let)))
232;    `(,%let ((it ,(car args)))
233;            (,op it ,@(cdr args)))))
234;
235;(define (cascade-it op args  rename)
236;  (let ((%let* (rename 'let*)))
237;    (let loop ((args args) (xpr `(,op)))
238;      (if (null? args)
239;        xpr
240;        (let ((sym (gensym)))
241;          `(,%let* ((,sym ,(car args)) (it ,sym))
242;                   ,(loop (cdr args) (append xpr (list sym)))))))))
243
244#|[
245The following macro defines new macros masking property-accessors and
246-mutators get and put!  For each supplied identifier, prop, another
247identifier, prop!, is constructed behind the scene. The former will be
248the accessor, the latter the mutator. So
249  (prop sym)
250is expands into
251  (get sym 'prop)
252and
253  (prop! sym val)
254into
255  (put! sym 'prop val)
256Note how the new names with the ! suffix are generated at compile time,
257i.e. within an unquote. Note also the use of the injection argument, i, for
258the property-name, prop, and the suffixed name, prop!, within that unquote.
259]|#
260
261;;; (define-properties . names)
262;;; ---------------------------
263;;; defines, for each name, property-accessors and -mutators
264;;; name and name!
265(define-syntax define-properties
266  (ir-macro-transformer
267    (lambda (f i c?)
268      `(begin
269         ,@(map (lambda (prop)
270                  `(begin
271                     (define-syntax ,prop
272                       (ir-macro-transformer
273                         (lambda (form inject compare?)
274                           `(get ,(cadr form) ',',prop))))
275                     (define-syntax ,(i (string->symbol
276                                          (string-append
277                                            (symbol->string (i prop))
278                                            "!")))
279                       (ir-macro-transformer
280                         (lambda (form inject compare?)
281                           `(put! ,(cadr form)
282                                  ',',prop
283                                  ,(caddr form)))))))
284                (cdr f))))))
285
286#|[
287The following two macros and two procedures represent recursion an lists
288and trees respectively. They are, again, inspired by Graham. The
289procedures are defined with alambda, the anaphoric version of lambda
290with injected symbol self.  These procedures, list-recurser and
291tree-recurser,  accept a recurser and a base as arguments, the recurser
292being itself procedures accepting the actual list or tree as argument,
293as well as one or two thunks representing recursion along the cdr or the
294car and the cdr respectively.
295The macros, alist-recurser and atree-recurser, are anaphoric versions of
296the procedures list-recurser and tree-recurser. They both inject the
297symbol it behind the scene, representing the actual list or tree
298respectively, as well as symbols go-on or go-left and go-right
299respectively representing the recurser arguments of the functions.
300
301The relations between the procedures and the anaphoric macros are shown
302in the following exaples:
303  (define lcopy
304    (list-recurser (lambda (lst th) (cons (car lst) (th))) '()))
305  (define alcopy
306    (alist-recurser (cons (car it) (go-on)) '()))
307  (define tcopy
308    (tree-recurser (lambda (tree left right)
309                     (cons (left) (or (right) '())))
310                   identity))
311  (define atcopy
312    (atree-recurser (cons (go-left) (or (go-right) '())) it))
313]|#
314
315;;; (alist-recurser recurser base)
316;;; ------------------------------
317;;; wrapping list-recurser into an anaphoric macro with injected symbols it and go-on
318;;; where it is the list itself and go-on the recurser-thunk
319(define-syntax alist-recurser
320  (ir-macro-transformer
321    (lambda (form inject compare?)
322      (let ((it (inject 'it))
323            (go-on (inject 'go-on)))
324        `(list-recurser (lambda (,it thunk)
325                          (letrec ((,go-on thunk))
326                            ,(cadr form)))
327                        ,@(cddr form))))))
328
329;;; (atree-recurser recurser base)
330;;; ------------------------------
331;;; wrapping tree-recurser into an anaphoric macro with injected symbols
332;;; it, go-left and go-right representing the actual tree and recursers
333;;; along the car and the cdr respectively.
334(define-syntax atree-recurser
335  (ir-macro-transformer
336    (lambda (form inject compare?)
337      (let ((recurser (cadr form))
338            (base (caddr form))
339            (it (inject 'it))
340            (go-left (inject 'go-left))
341            (go-right (inject 'go-right)))
342        `(tree-recurser
343           (lambda (,it left right)
344             (letrec ((,go-left left)
345                      (,go-right right))
346               ,recurser))
347           (lambda (,it) ,base))))))
348
349;;; (list-recurser recurser base)
350;;; -----------------------------
351;;; recurser is a procedure of a list and a thunk processing the cdr
352(define (list-recurser recurser base)
353  (alambda (lst)
354    (if (null? lst)
355      (if (procedure? base)
356        (base)
357        base)
358      (recurser lst
359                (lambda ()
360                  (self (cdr lst)))))))
361
362;;; (tree-recurser recurser base)
363;;; -----------------------------
364;;; recurser is a procedure of a tree and two thunks processing the car
365;;; and the cdr
366(define (tree-recurser recurser base)
367  (alambda (tree)
368    (cond
369      ((pair? tree)
370       (recurser tree
371                 (lambda ()
372                   (self (car tree)))
373                 (lambda ()
374                   (if (null? (cdr tree))
375                     #f
376                     (self (cdr tree))))))
377      (else ; atom
378        (if (procedure? base)
379          (base tree)
380          base)))))
381
382;;; documentation dispatcher
383
384(define anaphora
385  (let (
386    (alist '(
387      (aif
388        (macro it ()
389          (aif consequent)
390          (aif consequent alternative)))
391      (awhen
392        (macro it ()
393          (awhen xpr . xprs)))
394      (acond
395        (macro it ()
396          (acond clauses)))
397      (awhile
398        (macro it ()
399          (awhile xpr . xprs)))
400      (aand
401        (macro it ()
402          (aand args)))
403      (alambda
404        (macro self ()
405          (alambda . body)))
406      (define-anaphor
407        (macro ()
408          (define-anaphor name from rule)))
409      (define-properties
410        (macro name! ... ()
411          (define-properties name ...)))
412      (list-recurser
413        (procedure
414          (list-recurser (lambda (lst thunk) ...)  base)))
415      (alist-recurser
416        (macro it go-on ()
417          (alist-recurser recurser-xpr base-xpr)))
418      (tree-recurser
419        (procedure
420          (tree-recurser (lambda (tree thunk0 thunk1) ...)  base)))
421      (atree-recurser
422        (macro it go-left go-right ()
423          (atree-recurser recurser-xpr base-xpr)))))
424    )
425    (case-lambda
426      (() (map car alist))
427      ((sym)
428       (let ((pair (assq sym alist)))
429         (if pair
430           (cadr pair)
431           (begin
432             (display "Choose one of ")
433             (display (map car alist)))))))))
434
435) ; module anaphora
436
Note: See TracBrowser for help on using the repository browser.