Changeset 31167 in project


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

cells 1.2 with cell->closure

Location:
release/4/cells
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/cells/tags/1.2/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
  • release/4/cells/tags/1.2/cells.setup

    r30568 r31167  
    77 'cells
    88 '("cells.so" "cells.import.so")
    9  '((version "1.1.1")))
     9 '((version "1.2")))
    1010
    1111
  • release/4/cells/tags/1.2/tests/run.scm

    r30568 r31167  
    1212(define-test (CELLS)
    1313  (check
    14     (define cell% (cell 5))
    15     (cell? cell%)
     14    (define cl (cell 5))
     15    (cell? cl)
    1616    (not (cell? 5))
    17     ((cell-of? number?) cell%)
    18     (not ((cell-of? list?) cell%))
    19     (= (cell%) 5)
    20     (= (cell-ref cell%) 5)
    21     (cell% 50)
    22     (= (cell%) 50)
    23     (cell-set! cell% 500)
    24     (= (cell-ref cell%) 500)
    25     (condition-case (cell-ref 500)
    26       ((exn) #t))
     17    ((cell-of? number?) cl)
     18    (not ((cell-of? list?) cl))
     19    (= (cell-ref cl) 5)
     20    (cell-set! cl 50)
     21    (= (cell-ref cl) 50)
     22    (cell-set! cl 500)
     23    (= (cell-ref cl) 500)
     24    (not (condition-case (cell-ref 500)
     25           ((exn) #f)))
     26    (define cl% (cell->closure cl))
     27    (cl%) ; -> 500
     28    (cl% 5)
     29    (cl%) ; -> 500
    2730    ))
    2831
    2932(define-test (STACKS)
    3033  (check
    31     (define stack% (cell '()));'#,(% ()))
    32     (cell? stack%)
    33     ((cell-of? list?) stack%)
    34     (not ((cell-of? number?) stack%))
     34    (define stack (cell '()));'#,(% ()))
     35    (cell? stack)
     36    ((cell-of? list?) stack)
     37    (not ((cell-of? number?) stack))
     38    (define stack% (cell->closure stack))
    3539    (null? (stack%))
    3640    (push stack% 5)
  • 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
  • release/4/cells/trunk/cells.setup

    r30568 r31167  
    77 'cells
    88 '("cells.so" "cells.import.so")
    9  '((version "1.1.1")))
     9 '((version "1.2")))
    1010
    1111
  • release/4/cells/trunk/tests/run.scm

    r30568 r31167  
    1212(define-test (CELLS)
    1313  (check
    14     (define cell% (cell 5))
    15     (cell? cell%)
     14    (define cl (cell 5))
     15    (cell? cl)
    1616    (not (cell? 5))
    17     ((cell-of? number?) cell%)
    18     (not ((cell-of? list?) cell%))
    19     (= (cell%) 5)
    20     (= (cell-ref cell%) 5)
    21     (cell% 50)
    22     (= (cell%) 50)
    23     (cell-set! cell% 500)
    24     (= (cell-ref cell%) 500)
    25     (condition-case (cell-ref 500)
    26       ((exn) #t))
     17    ((cell-of? number?) cl)
     18    (not ((cell-of? list?) cl))
     19    (= (cell-ref cl) 5)
     20    (cell-set! cl 50)
     21    (= (cell-ref cl) 50)
     22    (cell-set! cl 500)
     23    (= (cell-ref cl) 500)
     24    (not (condition-case (cell-ref 500)
     25           ((exn) #f)))
     26    (define cl% (cell->closure cl))
     27    (cl%) ; -> 500
     28    (cl% 5)
     29    (cl%) ; -> 500
    2730    ))
    2831
    2932(define-test (STACKS)
    3033  (check
    31     (define stack% (cell '()));'#,(% ()))
    32     (cell? stack%)
    33     ((cell-of? list?) stack%)
    34     (not ((cell-of? number?) stack%))
     34    (define stack (cell '()));'#,(% ()))
     35    (cell? stack)
     36    ((cell-of? list?) stack)
     37    (not ((cell-of? number?) stack))
     38    (define stack% (cell->closure stack))
    3539    (null? (stack%))
    3640    (push stack% 5)
Note: See TracChangeset for help on using the changeset viewer.