source: project/release/4/cells/trunk/cells.scm @ 30565

Last change on this file since 30565 was 30565, checked in by juergen, 6 years ago

cells cell-ref and cell-set! added

File size: 2.9 KB
Line 
1; Author: Juergen Lorenz
2; ju (at) jugilo (dot) de
3;
4; Copyright (c) 2014, Juergen Lorenz
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions are
9; met:
10;
11; Redistributions of source code must retain the above copyright
12; notice, this list of conditions and the following disclaimer.
13;
14; Redistributions in binary form must reproduce the above copyright
15; notice, this list of conditions and the following disclaimer in the
16; documentation and/or other materials provided with the distribution.
17;
18; Neither the name of the author nor the names of its contributors may be
19; used to endorse or promote products derived from this software without
20; specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
23; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
24; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
25; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
28; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33;
34; Last update: Mar 15, 2014
35;
36
37(module cells
38(export cells cell cell? cell-of? cell-ref cell-set!)
39(import scheme
40        (only chicken case-lambda condition-case define-values
41              define-reader-ctor gensym assert print))
42
43(define cells
44  (case-lambda
45    (()
46     '(cell cell? cell-of? cell-ref cell-set!))
47    ((sym)
48     (case sym
49       ((cell) (print "constructor: " '(cell arg)))
50       ((cell?) (print "type predicate: " '(cell? xpr)))
51       ((cell-of?) (print "predicate: " '((cell-of? type?) xpr)))
52       ((cell-ref) (print "accessor: " '(cell-ref cell%)))
53       ((cell-set!) (print "mutator: " '(cell-set! cell% val)))
54       (else
55         (print "choose one of " (cells)))))))
56
57(define-values (cell cell?)
58  (let ((type (gensym 'cell)))
59    (values
60      (lambda (val)
61        (let ((var val))
62          (case-lambda
63            (() var)
64            ((val)
65             (if (and (symbol? val) (eq? val type))
66               type ;can never happen with client input
67               (set! var val))))))
68      (lambda (xpr)
69        (and (procedure? xpr) 
70             (condition-case (eq? (xpr type) type)
71               ((exn) #f)))))))
72
73(define (cell-of? ok?)
74  (lambda (c%)
75    (and (cell? c%) (ok? (c%)))))
76
77(define-reader-ctor '% cell)
78
79(define (cell-ref c%)
80  (assert (cell? c%) "not a cell" c%)
81  (c%))
82
83(define (cell-set! c% val)
84  (assert (cell? c%) "not a cell" c%)
85  (c% val))
86
87) ; module cells
Note: See TracBrowser for help on using the repository browser.