source: project/release/5/simple-loops/tags/1.0/simple-loops.scm @ 37401

Last change on this file since 37401 was 37401, checked in by juergen, 21 months ago

simple-loops 1.0

File size: 4.3 KB
Line 
1; Author: Juergen Lorenz
2; ju (at) jugilo (dot) de
3;
4; Ported to chicken-5:  Aug 15, 2018
5;
6; Copyright (c) 2018, 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(module simple-loops *
37
38(import scheme (chicken base)) ;(only chicken unless case-lambda print))
39
40(define-syntax do-times
41  (syntax-rules ()
42    ((_ i upto xpr0 xpr1 ...)
43     (let ((n upto))
44         (let loop ((i 0))
45           (unless (>= i n)
46             xpr0 xpr1 ...
47             (loop (+ i 1))))))))
48 
49(define-syntax do-list
50  (syntax-rules ()
51    ((_ i lst xpr xpr1 ...)
52    (let loop ((sublst lst))
53      (if (not (null? sublst))
54        (let ((i (car sublst)))
55          xpr xpr1 ...
56          (loop (cdr sublst))))))))
57
58(define-syntax do-for
59  (syntax-rules ()
60    ((_ var (start stop step) xpr xpr1 ...)
61       (let ((%stop stop))
62         (let loop ((var start))
63           (unless (>= var %stop)
64             xpr xpr1 ...
65             (loop (+ step var))))))
66    ((_ var (start stop) xpr . xprs)
67     (do-for var (start stop 1) xpr . xprs))))
68
69(define-syntax do-while
70  (syntax-rules ()
71    ((_ test? xpr xpr1 ...)
72     (let loop ()
73       (if test?
74         (begin
75           xpr xpr1 ...
76           (loop)))))))
77
78(define-syntax do-until
79  (syntax-rules ()
80    ((_ test? xpr xpr1 ...)
81     (let loop ()
82       (if (not test?)
83         (begin
84           xpr xpr1 ...
85           (loop)))))))
86
87;;; the following macro is unhygienic on purpose,
88;;; it exports the exit symbol behind the scene.
89;;; So it can not be defined with syntax-rules
90(define-syntax do-forever
91  (ir-macro-transformer
92    (lambda (form inject compare?)
93      (let ((xpr (cadr form)) (xprs (cddr form)))
94        `(call-with-current-continuation
95           (lambda (,(inject 'exit))
96             (let loop ()
97               ,xpr
98               ,@xprs
99               (loop))))))))
100
101;;; documentation
102(define simple-loops
103  (let (
104    (alist '(
105      (do-forever
106        "endless loop"
107        (do-forever xpr . xprs)
108        "executes body xpr . xprs until exit is called")
109      (do-times
110        "loops a fixed number of times"
111        (do-times i upto xpr . xprs)
112        "execute xpr . xprs for i in [0 upto[")
113      (do-list
114        "loop along a list"
115        (do-list i lst xpr . xprs)
116        "execute xpr . xprs for i in lst")
117      (do-for
118        "for-loop"
119        (do-for var (start stop step) xpr . xprs)
120        "do xpr . xprs for var in [start stop[ with steps (default 1)")
121      (do-while
122        "while-loop"
123       (do-while test? xpr . xprs)
124        "execute xpr . xprs while test? is true")
125      (do-until
126        "until-loop"
127        (do-until test? xpr . xprs)
128        "execute xpr . xprs while test? is false")
129      ))
130    )
131    (case-lambda
132      (() (map car alist))
133      ((sym)
134       (let ((pair (assq sym alist)))
135         (if pair
136           (cdr pair)
137           (print "Choose one of " (map car alist))))))))
138
139) ; module loops
140
Note: See TracBrowser for help on using the repository browser.