Changeset 31167 in project for release/4/cells/trunk/cells.scm


Ignore:
Timestamp:
07/30/14 17:12:53 (6 years ago)
Author:
juergen
Message:

cells 1.2 with cell->closure

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/cells/trunk/cells.scm

    r30565 r31167  
    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 ;
     1(module cells (cells cell cell? cell-of? cell-ref cell-set! cell->closure)
     2(import scheme
     3        (only chicken define-record-type define-record-printer
     4              case-lambda getter-with-setter)
     5        (only extras fprintf))
    366
    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))
     7(define-record-type cell
     8  (cell var)
     9  cell?
     10  (var cell-ref cell-set!))
     11
     12(define cell-ref (getter-with-setter cell-ref cell-set!))
     13
     14(define ((cell-of? type?) xpr)
     15  (and (cell? xpr)
     16       (type? (cell-ref xpr))))
     17
     18(define (cell->closure cl)
     19  (case-lambda
     20    (() (cell-ref cl))
     21    ((val) (cell-set! cl val))))
     22
     23(define-record-printer (cell var out)
     24  (fprintf out "!~s!" (cell-ref var)))
    4225
    4326(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)))))))
     27  (let ((signatures '((cell init)
     28                      (cell? xpr)
     29                      (cell-of? ok?)
     30                      (cell-ref cl)
     31                      (cell-set! cl val)
     32                      (cell->closure cl))))
     33    (case-lambda
     34      (() (map car signatures))
     35      ((sym) (assq sym signatures)))))
    5636
    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)))))))
     37) ; cells
    7238
    73 (define (cell-of? ok?)
    74   (lambda (c%)
    75     (and (cell? c%) (ok? (c%)))))
    7639
    77 (define-reader-ctor '% cell)
    7840
    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 TracChangeset for help on using the changeset viewer.