source: project/release/3/crunch/trunk/crunch-syntax.scm @ 9918

Last change on this file since 9918 was 9918, checked in by Kon Lovett, 12 years ago

Using canonical directory structure.

File size: 3.9 KB
Line 
1;;; crunch-syntax.scm - extended macro definitions
2;
3; Copyright (c) 2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36;; Taken from Olegs prelude, IIRC:
37
38(define-syntax crunch:cond-expand-feature
39  (syntax-rules ()
40    ((_ x kt kf) kf)))
41
42(define-syntax cond-expand
43  (letrec-syntax ((cond-expand-2
44                   (syntax-rules (crunch srfi-0 highlevel-macros syntax-rules)
45                     ((_ crunch kt kf) kt)
46                     ((_ srfi-0 kt kf) kt)
47                     ((_ highlevel-macros kt kf) kt)
48                     ((_ syntax-rules kt kf) kt)
49                     ((_ x kt kf) (crunch:cond-expand-feature x kt kf)))) )
50    (syntax-rules (else and or not)
51      ((cond-expand)
52       (let ()))
53      ((cond-expand (else . cmd-or-defs*))
54       (begin . cmd-or-defs*))
55      ((cond-expand "satisfies?" (and) kt kf) kt)
56      ((cond-expand "satisfies?" (and clause) kt kf)
57       (cond-expand "satisfies?" clause kt kf))
58      ((cond-expand "satisfies?" (and clause . rest) kt kf)
59       (cond-expand "satisfies?" clause
60                    (cond-expand "satisfies?" (and . rest) kt kf) kf))
61      ((cond-expand "satisfies?" (or) kt kf) kf)
62      ((cond-expand "satisfies?" (or clause) kt kf)
63       (cond-expand "satisfies?" clause kt kf))
64      ((cond-expand "satisfies?" (or clause . rest) kt kf)
65       (cond-expand "satisfies?" clause kt
66                    (cond-expand "satisfies?" (or . rest) kt kf)))
67      ((cond-expand "satisfies?" (not clause) kt kf)
68       (cond-expand "satisfies?" clause kf kt))
69      ((cond-expand "satisfies?" x kt kf)
70       (cond-expand-2 x kt kf))
71      ((cond-expand (feature-req . cmd-or-defs*) . rest-clauses)
72       (cond-expand "satisfies?" feature-req
73                    (begin . cmd-or-defs*)
74                    (cond-expand . rest-clauses))))))
75
76(define-syntax when
77  (syntax-rules ()
78    [(_ x y z ...) (if x (begin y z ...))] ) )
79
80(define-syntax unless
81  (syntax-rules ()
82    [(_ x y z ...) (if x (##core#undefined) (begin y z ...))] ) )
83
84(define-syntax switch
85  (syntax-rules (else)
86    ((_ v (else e1 e2 ...))
87     (begin e1 e2 ...))
88    ((_ v (k e1 e2 ...))
89     (let ((x v))
90       (if (eqv? x k) (begin e1 e2 ...)) ) )
91    ((_ v (k e1 e2 ...) c1 c2 ...)
92     (let ((x v))
93       (if (eqv? x k)
94           (begin e1 e2 ...)
95           (switch x c1 c2 ...))))))
96
97(define-syntax rec
98  (syntax-rules ()
99    ((rec (NAME . VARIABLES) . BODY)
100     (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME))
101    ((rec NAME EXPRESSION)
102     (letrec ( (NAME EXPRESSION) ) NAME))))
Note: See TracBrowser for help on using the repository browser.