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

Last change on this file since 25285 was 25285, checked in by juergen, 10 years ago

Copyright notice added

File size: 6.4 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
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;We implement all anaphoric macros with ir-macro-transformer.
46
47(module anaphora *
48
49(import scheme (only chicken case-lambda print))
50
51;;; (aif test? consequent [alternative])
52;;; ------------------------------------
53;;; anaphoric if, where consequent and alternative can refer to result
54;;; of test? named it
55(define-syntax aif
56  (ir-macro-transformer
57    (lambda (form inject compare?)
58      (let ((it (inject 'it)))
59        (let (
60          (test? (cadr form))
61          (consequent (caddr form))
62          (alternative (cdddr form))
63          )
64          (if (null? alternative)
65            `(let ((,it ,test?))
66               (if ,it ,consequent))
67            `(let ((,it ,test?))
68               (if ,it ,consequent ,(car alternative)))))))))
69
70;;; (awhen test? xpr . xprs)
71;;; ------------------------
72;;; anaphoric when, where xpr ... can refer to result of test?
73;;; named it
74(define-syntax awhen
75  (ir-macro-transformer
76    (lambda (form inject compare?)
77      (let ((it (inject 'it)))
78        (let (
79          (test? (cadr form))
80          (xpr (caddr form))
81          (xprs (cdddr form))
82          )
83          `(let ((,it ,test?))
84             (if ,it (begin ,xpr ,@xprs))))))))
85
86;;; (acond . clauses)
87;;; -----------------
88;;; anaphoric cond, where each clause is a list (test? xpr ...) in which
89;;; each xpr can refer to result of test? named it.
90;;; The last clause can start with else which evaluates to #t.
91(define-syntax acond
92  (ir-macro-transformer
93    (lambda (form inject compare?)
94      (let ((it (inject 'it)))
95        (let ((clauses (cdr form)))
96          (let loop ((clauses clauses))
97            (if (null? clauses)
98              #f
99              (let* (
100                (clause (car clauses))
101                (cnd (car clause))
102                )
103                `(let ((sym ,(if (compare? cnd 'else) #t cnd)))
104                   (if sym
105                     (let ((,it sym))
106                       ,@(cdr clause))
107                     ,(loop (cdr clauses))))))))))))
108
109;;; (awhile test? xpr . xprs)
110;;; -------------------------
111;;; anaphoric while, where each xpr ... can refer to the result of
112;;; the successive test?, named it
113(define-syntax awhile
114  (ir-macro-transformer
115    (lambda (form inject compare?)
116      (let ((it (inject 'it)))
117        (let (
118          (test? (cadr form))
119          (xpr (caddr form))
120          (xprs (cdddr form))
121          )
122          `(let loop ((,it ,test?))
123             (when ,it
124               ,xpr ,@xprs
125               (loop ,test?))))))))
126
127;;; (aand . args)
128;;; -------------
129;;; anaphoric and, where each successive argument can refer to the
130;;; result of the previous argument, named it.
131(define-syntax aand
132  (ir-macro-transformer
133    (lambda (form inject compare?)
134      (let ((it (inject 'it)))
135        (let ((args (cdr form)))
136          (let loop ((args args))
137            (cond
138              ((null? args) #t)
139              ((null? (cdr args)) (car args))
140              (else
141                `(let ((,it ,(car args)))
142                   (if ,it
143                     ,(loop (cdr args))))))))))))
144
145;;; (alambda args xpr . xprs)
146;;; -------------------------
147;;; anaphoric lambda, where the body xpr ... can refer to self, so that
148;;; recursion is possible
149(define-syntax alambda
150  (ir-macro-transformer
151    (lambda (form inject compare?)
152      (let ((self (inject 'self)))
153        (let ((args (cadr form)) (body (cddr form)))
154          `(letrec ((,self (lambda ,args ,@body)))
155             ,self))))))
156
157;;; documentation dispatcher
158
159(define anaphora
160  (let (
161    (alist '(
162      (aif
163        (aif test? consequent [alternative])
164        "anaphoric if, consequent and alternative can refer to result it
165of test?")
166      (awhen
167         (awhen test? xpr . xprs)
168         "anaphoric when, where xpr ... can refer to result of test?
169named it")
170      (acond
171        (acond . clauses)
172        "anaphoric cond, where each clause is a list (test? xpr ...) in which
173each xpr can refer to result of test? named it.
174The last clause can start with else which evaluates to #t.")
175      (awhile
176        (awhile test? xpr . xprs)
177        "anaphoric while, where each xpr ... can refer to the result of
178the successive test?, named it")
179      (aand
180        (aand . args)
181        "anaporic and, each arg can refer to the previous arg with it")
182      (alambda
183        (alambda args . body)
184        "anaphoric lambda, where body can refer to self")
185      )))
186    (case-lambda
187      (() (map car alist))
188      ((sym)
189       (let ((pair (assq sym alist)))
190         (if pair
191           (cdr pair)
192           (print "Choose one of " (map car alist))))))))
193
194) ; module anaphora
195
Note: See TracBrowser for help on using the repository browser.