source: project/release/5/simple-cells/trunk/simple-cells.scm @ 36312

Last change on this file since 36312 was 36312, checked in by juergen, 11 months ago

port of simple-cells to chicken-5

File size: 4.5 KB
Line 
1; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
2;
3; Copyright (c) 2017-2018, Juergen Lorenz
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions are
8; met:
9;
10; Redistributions of source code must retain the above copyright
11; notice, this list of conditions and the following dispasser.
12;
13; Redistributions in binary form must reproduce the above copyright
14; notice, this list of conditions and the following dispasser in the
15; documentation and/or other materials provided with the distribution.
16;
17; Neither the name of the author nor the names of its contributors may be
18; used to endorse or promote products derived from this software without
19; specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
24; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
34#|[
35In their paper "The First Report on Scheme Revisited", the authors
36Sussman and Steele remarked
37
38"We also now believe that Carl Hewitt was right: we would have been
39better off to have introduced cells as a separate, primitive kind of
40object, rather than allowing assignment to any and every lambda-bound
41variable."
42
43This module implements a cell datatype. Using it instead of set!
44set-car! and set-cdr! you have what Hewitt proposed ...
45]|#
46
47;(require-library simple-exceptions)
48
49(module simple-cells (simple-cells cell cell? cell-of?)
50  (import scheme
51          (only simple-exceptions <<<)
52          (only (chicken condition) condition-case)
53          (only (chicken base)
54                define-values gensym case-lambda error print))
55
56;;; (cell var . tests)
57;;; (cell? xpr)
58;;; ------------------
59;;; cell constructor and type predicate
60(define-values (cell cell?)
61  (let ((type (gensym 'cell)))
62    (values
63      (lambda (var . tests)
64        (let ((checks #f) (state #f))
65          (set! checks tests)
66          (set! state (apply (<<< 'cell) var 'state checks))
67          (case-lambda
68            (() state);(values state checks))
69            ((arg)
70             (let ((old state))
71               (set! state
72                     (if (and (symbol? arg) (eq? arg type))
73                       arg
74                       (apply (<<< 'cell) arg 'arg checks)))
75               old)))))
76      (lambda (xpr)
77        (and (procedure? xpr)
78             (let ((old (xpr)) ; save state
79                   (result? (condition-case
80                              (eq? type
81                                   (and (xpr type) (xpr)))
82                              ((exn) #f))))
83               (xpr old) ; restore state
84               result?))))))
85
86;;; ((cell-of? ok?) xpr)
87;;; --------------------
88;;; evaluates xpr to a cell passing the ok? check?
89(define ((cell-of? ok?) xpr)
90  (and (cell? xpr)
91       (ok? (xpr))))
92
93;;; (simple-cells sym ..)
94;;; ---------------------
95;;; documentation procedure
96(define simple-cells
97  (let ((als '(
98    (simple-cells
99      procedure:
100      (simple-cells sym ..)
101      "documentation procedure")
102    (cell
103      procedure:
104      (cell var . tests)
105      "creates a cell, initialising its contents to var"
106      "provided all test predicates succed."
107      "A cell is a procedure of zero or one argument."
108      "Without argument, it returns two values,"
109      "its content and the list of test predicates."
110      "With an argument the content is changed to that argument"
111      "provided all test predicates succeed.")
112    (cell?
113      procedure:
114      (cell? xpr)
115      "type predicate.")
116    (cell-of?
117      procedure:
118      (cell-of? ok?)
119      "returns a predicate, which checks, if its argument"
120      "is passed by the ok? check")
121    )))
122    (case-lambda
123      (()
124       (map car als))
125      ((sym)
126       (let ((pair (assq sym als)))
127         (if pair
128           (for-each print (cdr pair))
129           (error "Not in list"
130                  sym
131                  (map car als))))))))
132
133) ; module simple-cells
134
Note: See TracBrowser for help on using the repository browser.