Changeset 13468 in project


Ignore:
Timestamp:
03/03/09 18:59:42 (11 years ago)
Author:
Kon Lovett
Message:

Pre-release

Location:
release/4/box/trunk
Files:
1 deleted
2 edited

Legend:

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

    r13463 r13468  
    11;;;; box.scm
    22;;;; Kon Lovett, Oct '08
     3
     4;; Issues
     5;;
     6;; - Use of "chicken-primitive-object-inlines" '%foo' routines is not meant as an
     7;; endorsement.
    38
    49(declare
     
    611  (fixnum)
    712  (inline)
     13  (local)
    814  ; ##sys#procedure->string is redefined!
    915  (disable-warning redef)
     
    1420  (no-bound-checks) )
    1521
    16 ;;;
     22;;; Prelude
     23
     24(include "chicken-primitive-object-inlines")
    1725
    1826(require-library ports lolevel)
     27
     28;; Helpers
     29
     30(define-inline (box-structure? obj)
     31  (or (%structure-instance? obj 'box)
     32      (%structure-instance? obj 'box-immutable)) )
     33
     34(define-inline (box-procedure? obj)
     35  ; 'procedure-data' returns #f for anything other than an extended-procedure!
     36  (and-let* ([tag (procedure-data obj)])
     37                (or (%eq? 'box-variable tag)
     38                    (%eq? 'box-location tag)) ) )
     39
     40(define-inline (box-setter box)
     41  (box (lambda (ref set loc) set)) )
     42
     43(define-inline (box-immutable-setter? setter)
     44  (%undefined? setter) )
     45
     46(define-inline (box-print box)
     47        (display "#&") (write (box-ref box)) )
     48
     49;;; Module box
    1950
    2051(module box (
     
    3061  scheme
    3162  (only chicken
     63    define-record-printer
     64    let-location
    3265    and-let*
    3366    getter-with-setter
     
    3770    ##sys#procedure->string)
    3871  (only ports
     72    with-output-to-port
    3973    with-output-to-string)
    4074  (only lolevel
    4175    extend-procedure procedure-data
    42     record-instance? make-record-instance
    43     block-ref
    4476    make-weak-locative make-locative) )
    4577
    46 ;;
     78;;; Internals
     79
     80;; Errors
    4781
    4882(define (box-immutable-error loc box . args)
     
    5286  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
    5387
    54 ;;
     88;; Finishers
    5589
    5690(define (finvar ref set)
     
    66100        'box-location) )
    67101
    68 (define (box-structure? obj)
    69   (or (record-instance? obj 'box)
    70       (record-instance? obj 'box-immutable)) )
    71 
    72 (define (box-procedure? obj)
    73   ; 'procedure-data' returns #f for anything other than an extended-procedure!
    74   (and-let* ( (tag (procedure-data obj)) )
    75                 (or (eq? 'box-variable tag)
    76                     (eq? 'box-location tag)) ) )
    77 
    78 (define (box-setter box)
    79   (box (lambda (ref set loc) set)) )
    80 
    81 (define (box-immutable-setter? setter)
    82   (eq? (void) setter) )
    83 
    84 ;;;
    85 
    86 ;;
     102;;; Globals
     103
     104;; Constructers
    87105
    88106(define-syntax make-box-variable
    89   (syntax-rules (#:immutable)
    90     ( (_ ?var)
    91       (make-box-variable ?var #:immutable #f) )
    92     ( (_ ?var #:immutable #f)
     107  (syntax-rules (#:immutable?)
     108    [(_ ?var)
     109      (make-box-variable ?var #:immutable? #f) ]
     110    [(_ ?var #:immutable? ?flg)
    93111      #;(identifier? ?var)
    94112      (finvar
    95113        (lambda () ?var)
    96         (lambda (value) (set! ?var value))) )
    97     ( (_ ?var #:immutable #t)
    98       #;(identifier? ?var)
    99       (finvar
    100         (lambda () ?var)
    101         (void)) ) ) )
    102 
    103 ;;
     114        (if ?flg (void) (lambda (value) (set! ?var value)))) ] ) )
    104115
    105116(define-syntax make-box-location
    106   (syntax-rules (#:immutable)
    107     ( (_ ?typ ?val)
    108       (make-box-location ?typ ?val #:immutable #f) )
    109     ( (_ ?typ ?val #:immutable #f)
     117  (syntax-rules (#:immutable?)
     118    [(_ ?typ ?val)
     119      (make-box-location ?typ ?val #:immutable? #f) ]
     120    [(_ ?typ ?val #:immutable? ?flg)
    110121      #;(identifier? ?typ)
    111       (let-location ( (var ?typ ?val) )
     122      (let-location ([var ?typ ?val])
    112123        (finloc
    113124          (lambda () var)
    114           (lambda (value) (set! var value))
    115           (lambda () (location var))) ) )
    116     ( (_ ?typ ?val #:immutable #t)
    117       #;(identifier? ?typ)
    118       (let-location ( (var ?typ ?val) )
    119         (finloc
    120           (lambda () var)
    121           (void)
    122           (lambda () (location var))) ) ) ) )
    123 
    124 ;;
    125 
    126 (define-syntax box
    127   (syntax-rules ()
    128     ( (_ ?arg0 ...)
    129       (make-box ?arg0 ...) ) ) )
    130 
    131 (define-syntax unbox
    132   (syntax-rules ()
    133     ( (_ ?box)
    134       (box-ref ?box) ) ) )
    135 
    136 (define-syntax set-box!
    137   (syntax-rules ()
    138     ( (_ ?box ?value)
    139       (box-set! ?box ?value) ) ) )
    140 
    141 ;;
    142 
    143 (define (make-box init #!key (immutable #f))
    144   (make-record-instance (if immutable 'box-immutable 'box) init) )
    145 
    146 ;;
     125          (if ?flg (void) (lambda (value) (set! var value)))
     126          (lambda () (location var))) ) ] ) )
     127
     128(define (make-box init #!key (immutable? #f))
     129  (%make-structure (if immutable? 'box-immutable 'box) init) )
     130
     131;; Predicates
    147132
    148133(define (box? obj)
     
    151136
    152137(define (box-variable? obj)
    153   (and-let* ( (tag (procedure-data obj)) )
    154                 (eq? 'box-variable tag) ) )
     138  (and-let* ([tag (procedure-data obj)])
     139                (%eq? 'box-variable tag) ) )
    155140
    156141(define (box-location? obj)
    157   (and-let* ( (tag (procedure-data obj)) )
    158                 (eq? 'box-location tag) ) )
     142  (and-let* ([tag (procedure-data obj)])
     143                (%eq? 'box-location tag) ) )
    159144
    160145(define (box-immutable? obj)
    161   (or (record-instance? obj 'box-immutable)
     146  (or (%structure-instance? obj 'box-immutable)
    162147      (and (box-procedure? obj)
    163            (obj (lambda (ref set loc) (box-immutable-setter? set))) ) ) )
     148           (box-immutable-setter? (box-setter obj)) ) ) )
    164149
    165150(define (box-mutable? obj)
    166151        (not (box-immutable? obj)) )
    167152
    168 ;;
     153;; Assessors
    169154
    170155(define (box-set! box value)
    171156  (cond
    172     ( (record-instance? box)
    173       (case (block-ref box 0)
    174         ( (box)
    175           (set! (block-ref box 1) value) )
    176         ( (box-immutable)
    177           (box-immutable-error 'box-set! box value) )
    178         ( else
    179           (box-type-error 'box-set! box value) ) ) )
    180     ( (box-procedure? box)
    181       (let ( (setter (box-setter box)) )
     157    [(%generic-structure? box)
     158      (case (%structure-tag box)
     159        [(box)
     160          (%structure-set! box 1 value) ]
     161        [(box-immutable)
     162          (box-immutable-error 'box-set! box value) ]
     163        [else
     164          (box-type-error 'box-set! box value) ] ) ]
     165    [(box-procedure? box)
     166      (let ([setter (box-setter box)])
    182167        (if (box-immutable-setter? setter)
    183168            (box-immutable-error 'box-set! box value)
    184             (setter value) ) ) )
    185     ( else
    186       (box-type-error 'box-set! box value) ) ) )
     169            (setter value) ) ) ]
     170    [else
     171      (box-type-error 'box-set! box value) ] ) )
    187172
    188173(define box-ref
     
    190175    (lambda (box)
    191176      (cond
    192         ( (box-structure? box)
    193           (block-ref box 1) )
    194         ( (box-procedure? box)
    195           (box (lambda (ref set loc) (ref))) )
    196         ( else
    197           (box-type-error 'box-ref box) ) ) )
     177        [(box-structure? box)
     178          (%structure-ref box 1) ]
     179        [(box-procedure? box)
     180          (box (lambda (ref set loc) (ref))) ]
     181        [else
     182          (box-type-error 'box-ref box) ] ) )
    198183    box-set! ) )
    199184
    200 (define (box-location box #!key (weak #f))
     185(define (box-location box #!key (weak? #f))
    201186  (cond
    202     ( (box-structure? box)
    203       ((if weak make-weak-locative make-locative) box 1) )
    204     ( (box-procedure? box)
    205       (box (lambda (ref set loc) (loc))) )
    206     ( else
    207       (box-type-error 'box-location box) ) ) )
    208 
    209 ;;
    210 
    211 (define (box-print box)
    212         (display "#&") (write (box-ref box)) )
    213 
    214 ;;; Initialize
     187    [(box-structure? box)
     188      ((if weak? make-weak-locative make-locative) box 1) ]
     189    [(box-procedure? box)
     190      (box (lambda (ref set loc) (loc))) ]
     191    [else
     192      (box-type-error 'box-location box) ] ) )
     193
     194;; MZ Scheme Style
     195
     196(define-syntax box
     197  (syntax-rules ()
     198    [(_ ?arg0 ...)  (make-box ?arg0 ...) ] ) )
     199
     200(define-syntax unbox
     201  (syntax-rules ()
     202    [(_ ?box) (box-ref ?box) ] ) )
     203
     204(define-syntax set-box!
     205  (syntax-rules ()
     206    [(_ ?box ?value)  (box-set! ?box ?value) ] ) )
     207
     208;;; Read/Print Syntax
    215209
    216210(set-sharp-read-syntax! #\&
     
    218212    (make-box (read port))))
    219213
     214(define-record-printer (box x out)
     215  (with-output-to-port out (lambda () (box-print x))) )
     216
     217(define-record-printer (box-immutable x out)
     218  (with-output-to-port out (lambda () (box-print x))) )
     219
    220220(set! ##sys#procedure->string
    221   (let ( (##sys#procedure->string ##sys#procedure->string) )
     221  (let ([##sys#procedure->string ##sys#procedure->string])
    222222    (lambda (x)
    223223                        (if (box? x)
     
    225225                                        (##sys#procedure->string x) ) ) ) )
    226226
    227 ) ;box
     227) ;module box
  • release/4/box/trunk/tests/run.scm

    r12265 r13468  
    1 ;;;; run-testbase.scm (run.scm)
     1(require-extension test)
     2(import test)
    23
    3 (use utils posix)
     4(require-extension box)
     5(import box)
    46
    5 ;;
     7(test-group "Box Mutable"
     8        (let ([tbox #f])
     9    (test-assert (make-box (void)))
     10    (set! tbox (make-box (void)))
     11    (box-set! tbox #t)
     12    (test-assert (box-ref tbox))
     13    (test-assert (box? tbox))
     14    (test-assert (not (box? 3))) )
     15)
    616
    7 #;(define *egg-name* (car (command-line-arguments)))
     17(test-group "Box Immutable"
     18        (let ([tbox #f])
     19    (test-assert (make-box #f #:immutable? #t))
     20    (set! tbox (make-box #f #:immutable? #t))
     21    (test-assert (not (box-ref tbox)))
     22    (test-error (box-set! tbox #t)) )
     23)
    824
    9 (define *verbose* #t)
    10 
    11 (define-constant TESTBASE-TEST-DRIVER "chicken-testbase-driver")
    12 (define-constant TESTBASE-TEST-DRIVER-OPTIONS "--indent 2")
    13 
    14 (define *test-driver-arguments* (string-append TESTBASE-TEST-DRIVER-OPTIONS (if *verbose* " -v" "")))
    15 
    16 ;;
    17 
    18 (system* "~A ~A ~A" TESTBASE-TEST-DRIVER *test-driver-arguments* "*-test.scm")
     25(test-group "Box References"
     26        (let ([var (void)]
     27        [ref #f])
     28    (test-assert (make-box-variable var))
     29    (set! ref (make-box-variable var))
     30    (test (void) (box-ref ref))
     31    (box-set! ref #t)
     32    (test-assert (box-ref ref))
     33    (test-assert var)
     34    (test-assert (box? ref))
     35    (test-assert (box-variable? ref))
     36    (test-assert (not (box-location? ref)))
     37    (test-assert (not (box? 3))) )
     38)
Note: See TracChangeset for help on using the changeset viewer.