Changeset 13528 in project


Ignore:
Timestamp:
03/06/09 06:36:07 (11 years ago)
Author:
Kon Lovett
Message:

Rmvd keyword arg style. Chgd to all tag style for box types.

Location:
release/4/box
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/box/tags/2.0.0/box.scm

    r13501 r13528  
    44;; Issues
    55;;
    6 ;; - Use of "chicken-primitive-object-inlines" '%foo' routines is not meant as an
    7 ;; endorsement.
     6;; - All operations inlined & primitive due to high-performance nature.
     7;;
     8;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
    89
    910(declare
    1011  (usual-integrations)
     12  (disable-interrupts)
    1113  (fixnum)
    1214  (inline)
    1315  (local)
    14   ; ##sys#procedure->string is redefined!
    15   (disable-warning redef)
     16  (no-procedure-checks)
     17  (no-bound-checks)
     18  (disable-warning redef) ;##sys#procedure->string is redefined!
    1619  (bound-to-procedure
    1720    ##sys#signal-hook
    18     ##sys#procedure->string)
    19   (no-procedure-checks)
    20   (no-bound-checks) )
     21    ##sys#procedure->string) )
    2122
    2223;;; Prelude
     
    2627(require-library ports lolevel)
    2728
    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-value? setter) )
    45 
    46 (define-inline (box-print box)
    47         (display "#&") (write (box-ref box)) )
     29
     30;;; Box Structure Support
     31
     32(define-inline (%make-box tag init)
     33  (%make-structure tag init) )
     34
     35(define-inline (%box-structure-mutable? obj)
     36  (%structure-instance? obj 'box!) )
     37
     38(define-inline (%box-structure-immutable? obj)
     39  (%structure-instance? obj 'box) )
     40
     41(define-inline (%box-structure? obj)
     42  (or (%box-structure-mutable? obj)
     43      (%box-structure-immutable? obj)) )
     44
     45(define-inline (%box-structure-tag obj)
     46  (and (%box-structure? obj)
     47       (%structure-tag obj) ) )
     48
     49(define-inline (%box-structure-ref box)
     50  (%structure-ref box 1) )
     51
     52(define-inline (%box-structure-set! box obj)
     53  (%structure-set!/maybe-immediate box 1 obj) )
     54
     55
     56;;; Box Procedure Support
     57
     58;; Box Variable
     59
     60(define-inline (%box-variable-immutable-tag? obj)
     61  (%eq? 'boxvar obj) )
     62
     63(define-inline (%box-variable-mutable-tag? obj)
     64  (%eq? 'boxvar! obj) )
     65
     66(define-inline (%box-variable-tag? obj)
     67  (or (%box-variable-mutable-tag? obj)
     68      (%box-variable-immutable-tag? obj) ) )
     69
     70(define-inline (%box-variable? obj)
     71  (and-let* ([dat (procedure-data obj)])
     72    (%box-variable-tag? dat) ) )
     73
     74;; Box Location
     75
     76(define-inline (%box-location-immutable-tag? obj)
     77  (%eq? 'boxloc obj) )
     78
     79(define-inline (%box-location-mutable-tag? obj)
     80  (%eq? 'boxloc! obj) )
     81
     82(define-inline (%box-location-tag? obj)
     83  (or (%box-location-mutable-tag? obj)
     84      (%box-location-immutable-tag? obj) ) )
     85
     86(define-inline (%box-location? obj)
     87  (and-let* ([dat (procedure-data obj)])
     88    (%box-location-tag? dat) ) )
     89
     90;; Box Procedure
     91
     92(define-inline (%box-procedure-tag? obj)
     93  (or (%box-variable-tag? obj)
     94      (%box-location-tag? obj) ) )
     95
     96(define-inline (%box-procedure-tag obj)
     97  (and-let* ([dat (procedure-data obj)]
     98             [(%box-procedure-tag? dat)])
     99    dat ) )
     100
     101(define-inline (%box-procedure? obj)
     102  (and (%box-procedure-tag obj)
     103       #t ) )
     104
     105(define-inline (%box-procedure-immutable? obj)
     106  (and-let* ([dat (procedure-data obj)])
     107    (or (%box-variable-immutable-tag? dat)
     108        (%box-location-immutable-tag? dat) ) ) )
     109
     110(define-inline (%box-procedure-mutable? obj)
     111  (and-let* ([dat (procedure-data obj)])
     112    (or (%box-variable-mutable-tag? dat)
     113        (%box-location-mutable-tag? dat) ) ) )
     114
     115;; Box Procedure Operations
     116
     117(define-inline (%box-procedure-ref box)
     118  (box (lambda (ref set loc) (ref))) )
     119
     120(define-inline (%box-procedure-set! box obj)
     121  (box (lambda (ref set loc) (set obj))) )
     122
     123(define-inline (%box-procedure-location box)
     124  (box (lambda (ref set loc) (loc))) )
     125
     126;;
     127
     128(define-inline (%box? obj)
     129  (or (%box-structure? obj)
     130      (%box-procedure? obj)) )
     131
     132
     133;;; Errors
     134
     135(define-inline (%box-immutable-error loc box . args)
     136  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
     137
     138(define-inline (%box-type-error loc obj . args)
     139  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
     140
     141
     142;;; Print
     143
     144(define-inline (%box-print box)
     145  (let ([val (cond [(%box-structure? box)  (%box-structure-ref box) ]
     146                   [(%box-procedure? box)  (%box-procedure-ref box) ] ) ] )
     147          (display "#&") (write val) ) )
     148
    48149
    49150;;; Module box
     
    61162  scheme
    62163  (only chicken
     164    optional                ;due to #!optional implementation
     165    let-optionals           ;due to #!optional implementation
    63166    define-record-printer
    64167    let-location
     
    76179    make-weak-locative make-locative) )
    77180
     181
    78182;;; Internals
    79183
    80 ;; Errors
    81 
    82 (define (box-immutable-error loc box . args)
    83   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
    84 
    85 (define (box-type-error loc obj . args)
    86   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
    87 
    88184;; Finishers
    89185
    90 (define (finvar ref set)
    91   (extend-procedure
    92         (lambda (proc)
    93                 (proc ref set (lambda () (location (ref)))))
    94         'box-variable) )
    95 
    96 (define (finloc ref set loc)
    97   (extend-procedure
    98         (lambda (proc)
    99                 (proc ref set loc))
    100         'box-location) )
    101 
    102 ;;; Globals
     186(define (finvar tag ref set)
     187  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag) )
     188
     189(define (finloc tag ref set loc)
     190  (extend-procedure (lambda (proc) (proc ref set loc)) tag) )
     191
     192
     193;;; Box
    103194
    104195;; Constructers
    105196
    106197(define-syntax make-box-variable
    107   (syntax-rules (#:immutable?)
     198  (syntax-rules ()
    108199    [(_ ?var)
    109       (make-box-variable ?var #:immutable? #f) ]
    110     [(_ ?var #:immutable? ?flg)
    111       #;(identifier? ?var)
    112       (finvar
    113         (lambda () ?var)
    114         (if ?flg (void) (lambda (value) (set! ?var value)))) ] ) )
     200     (make-box-variable ?var #f) ]
     201    [(_ ?var ?immutable?)
     202     #;(identifier? ?var)
     203     (finvar
     204      (if ?immutable? 'boxvar 'boxvar!)
     205      (lambda () ?var)
     206      (if ?immutable? (void) (lambda (val) (set! ?var val)))) ] ) )
    115207
    116208(define-syntax make-box-location
    117   (syntax-rules (#:immutable?)
     209  (syntax-rules ()
    118210    [(_ ?typ ?val)
    119       (make-box-location ?typ ?val #:immutable? #f) ]
    120     [(_ ?typ ?val #:immutable? ?flg)
    121       #;(identifier? ?typ)
    122       (let-location ([var ?typ ?val])
    123         (finloc
    124           (lambda () var)
    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) )
     211     (make-box-location ?typ ?val #f) ]
     212    [(_ ?typ ?val ?immutable?)
     213     #;(identifier? ?typ)
     214     (let-location ([var ?typ ?val])
     215       (finloc
     216        (if ?immutable? 'boxloc 'boxloc!)
     217        (lambda () var)
     218        (if ?immutable? (void) (lambda (val) (set! var val)))
     219        (lambda () (location var))) ) ] ) )
     220
     221(define (make-box #!optional init immutable?)
     222  (%make-box (if immutable? 'box 'box!) init) )
    130223
    131224;; Predicates
    132225
    133226(define (box? obj)
    134   (or (box-structure? obj)
    135       (box-procedure? obj)) )
     227  (%box? obj) )
    136228
    137229(define (box-variable? obj)
    138   (and-let* ([tag (procedure-data obj)])
    139                 (%eq? 'box-variable tag) ) )
     230  (%box-variable? obj) )
    140231
    141232(define (box-location? obj)
    142   (and-let* ([tag (procedure-data obj)])
    143                 (%eq? 'box-location tag) ) )
     233  (%box-location? obj) )
    144234
    145235(define (box-immutable? obj)
    146   (or (%structure-instance? obj 'box-immutable)
    147       (and (box-procedure? obj)
    148            (box-immutable-setter? (box-setter obj)) ) ) )
     236  (or (%box-structure-immutable? obj)
     237      (%box-procedure-immutable? obj) ) )
    149238
    150239(define (box-mutable? obj)
    151         (not (box-immutable? obj)) )
     240  (or (%box-structure-mutable? obj)
     241      (%box-procedure-mutable? obj) ) )
     242
     243;; Mutators
     244
     245(define (box-set! box val)
     246  (cond [(%box-structure-tag box) =>
     247         (lambda (tag)
     248           (case tag
     249             [(box!)
     250              (%box-structure-set! box val) ]
     251             [(box)
     252              (%box-immutable-error 'box-set! box val) ] ) ) ]
     253        [(%box-procedure-tag box) =>
     254         (lambda (tag)
     255           (case tag
     256             [(boxvar! boxloc!)
     257              (%box-procedure-set! box val) ]
     258             [(boxvar boxloc)
     259              (%box-immutable-error 'box-set! box val) ] ) ) ]
     260        [else
     261         (%box-type-error 'box-set! box val) ] ) )
    152262
    153263;; Assessors
    154 
    155 (define (box-set! box value)
    156   (cond
    157     [(%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)])
    167         (if (box-immutable-setter? setter)
    168             (box-immutable-error 'box-set! box value)
    169             (setter value) ) ) ]
    170     [else
    171       (box-type-error 'box-set! box value) ] ) )
    172264
    173265(define box-ref
    174266  (getter-with-setter
    175267    (lambda (box)
    176       (cond
    177         [(box-structure? box)
    178           (%structure-ref box 1) ]
    179         [(box-procedure? box)
    180           (box (lambda (ref set loc) (ref))) ]
     268      (cond [(%box-structure? box)  (%box-structure-ref box) ]
     269            [(%box-procedure? box)  (%box-procedure-ref box) ]
     270            [else
     271             (%box-type-error 'box-ref box) ] ) )
     272    box-set! ) )
     273
     274(define (box-location box #!optional (weak? #f))
     275  (cond [(%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1) ]
     276        [(%box-procedure? box)   (box (lambda (ref set loc) (loc))) ]
    181277        [else
    182           (box-type-error 'box-ref box) ] ) )
    183     box-set! ) )
    184 
    185 (define (box-location box #!key (weak? #f))
    186   (cond
    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
     278         (%box-type-error 'box-location box) ] ) )
     279
     280
     281;;; MZ Scheme Style
    195282
    196283(define-syntax box
    197284  (syntax-rules ()
    198     [(_ ?arg0 ...)  (make-box ?arg0 ...) ] ) )
     285    [(_ ?arg0 ...)
     286     (make-box ?arg0 ...) ] ) )
    199287
    200288(define-syntax unbox
    201289  (syntax-rules ()
    202     [(_ ?box) (box-ref ?box) ] ) )
     290    [(_ ?box)
     291     (box-ref ?box) ] ) )
    203292
    204293(define-syntax set-box!
    205294  (syntax-rules ()
    206     [(_ ?box ?value)  (box-set! ?box ?value) ] ) )
     295    [(_ ?box ?val)
     296     (box-set! ?box ?val) ] ) )
     297
    207298
    208299;;; Read/Print Syntax
     
    213304
    214305(define-record-printer (box x out)
    215   (with-output-to-port out (lambda () (box-print x))) )
     306  (with-output-to-port out (lambda () (%box-print x))) )
    216307
    217308(define-record-printer (box-immutable x out)
    218   (with-output-to-port out (lambda () (box-print x))) )
     309  (with-output-to-port out (lambda () (%box-print x))) )
    219310
    220311(set! ##sys#procedure->string
    221312  (let ([##sys#procedure->string ##sys#procedure->string])
    222313    (lambda (x)
    223                         (if (box? x)
    224                                         (with-output-to-string (lambda () (box-print x)))
     314                        (if (%box? x)
     315                                        (with-output-to-string (lambda () (%box-print x)))
    225316                                        (##sys#procedure->string x) ) ) ) )
    226317
  • release/4/box/tags/2.0.0/tests/run.scm

    r13469 r13528  
    1717(test-group "Box Immutable"
    1818        (let ([tbox #f])
    19     (test-assert (make-box #f #:immutable? #t))
    20     (set! tbox (make-box #f #:immutable? #t))
     19    (test-assert (make-box #f #t))
     20    (set! tbox (make-box #f #t))
    2121    (test-assert (not (box-ref tbox)))
    2222    (test-error (box-set! tbox #t)) )
  • release/4/box/trunk/box.scm

    r13501 r13528  
    44;; Issues
    55;;
    6 ;; - Use of "chicken-primitive-object-inlines" '%foo' routines is not meant as an
    7 ;; endorsement.
     6;; - All operations inlined & primitive due to high-performance nature.
     7;;
     8;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
    89
    910(declare
    1011  (usual-integrations)
     12  (disable-interrupts)
    1113  (fixnum)
    1214  (inline)
    1315  (local)
    14   ; ##sys#procedure->string is redefined!
    15   (disable-warning redef)
     16  (no-procedure-checks)
     17  (no-bound-checks)
     18  (disable-warning redef) ;##sys#procedure->string is redefined!
    1619  (bound-to-procedure
    1720    ##sys#signal-hook
    18     ##sys#procedure->string)
    19   (no-procedure-checks)
    20   (no-bound-checks) )
     21    ##sys#procedure->string) )
    2122
    2223;;; Prelude
     
    2627(require-library ports lolevel)
    2728
    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-value? setter) )
    45 
    46 (define-inline (box-print box)
    47         (display "#&") (write (box-ref box)) )
     29
     30;;; Box Structure Support
     31
     32(define-inline (%make-box tag init)
     33  (%make-structure tag init) )
     34
     35(define-inline (%box-structure-mutable? obj)
     36  (%structure-instance? obj 'box!) )
     37
     38(define-inline (%box-structure-immutable? obj)
     39  (%structure-instance? obj 'box) )
     40
     41(define-inline (%box-structure? obj)
     42  (or (%box-structure-mutable? obj)
     43      (%box-structure-immutable? obj)) )
     44
     45(define-inline (%box-structure-tag obj)
     46  (and (%box-structure? obj)
     47       (%structure-tag obj) ) )
     48
     49(define-inline (%box-structure-ref box)
     50  (%structure-ref box 1) )
     51
     52(define-inline (%box-structure-set! box obj)
     53  (%structure-set!/maybe-immediate box 1 obj) )
     54
     55
     56;;; Box Procedure Support
     57
     58;; Box Variable
     59
     60(define-inline (%box-variable-immutable-tag? obj)
     61  (%eq? 'boxvar obj) )
     62
     63(define-inline (%box-variable-mutable-tag? obj)
     64  (%eq? 'boxvar! obj) )
     65
     66(define-inline (%box-variable-tag? obj)
     67  (or (%box-variable-mutable-tag? obj)
     68      (%box-variable-immutable-tag? obj) ) )
     69
     70(define-inline (%box-variable? obj)
     71  (and-let* ([dat (procedure-data obj)])
     72    (%box-variable-tag? dat) ) )
     73
     74;; Box Location
     75
     76(define-inline (%box-location-immutable-tag? obj)
     77  (%eq? 'boxloc obj) )
     78
     79(define-inline (%box-location-mutable-tag? obj)
     80  (%eq? 'boxloc! obj) )
     81
     82(define-inline (%box-location-tag? obj)
     83  (or (%box-location-mutable-tag? obj)
     84      (%box-location-immutable-tag? obj) ) )
     85
     86(define-inline (%box-location? obj)
     87  (and-let* ([dat (procedure-data obj)])
     88    (%box-location-tag? dat) ) )
     89
     90;; Box Procedure
     91
     92(define-inline (%box-procedure-tag? obj)
     93  (or (%box-variable-tag? obj)
     94      (%box-location-tag? obj) ) )
     95
     96(define-inline (%box-procedure-tag obj)
     97  (and-let* ([dat (procedure-data obj)]
     98             [(%box-procedure-tag? dat)])
     99    dat ) )
     100
     101(define-inline (%box-procedure? obj)
     102  (and (%box-procedure-tag obj)
     103       #t ) )
     104
     105(define-inline (%box-procedure-immutable? obj)
     106  (and-let* ([dat (procedure-data obj)])
     107    (or (%box-variable-immutable-tag? dat)
     108        (%box-location-immutable-tag? dat) ) ) )
     109
     110(define-inline (%box-procedure-mutable? obj)
     111  (and-let* ([dat (procedure-data obj)])
     112    (or (%box-variable-mutable-tag? dat)
     113        (%box-location-mutable-tag? dat) ) ) )
     114
     115;; Box Procedure Operations
     116
     117(define-inline (%box-procedure-ref box)
     118  (box (lambda (ref set loc) (ref))) )
     119
     120(define-inline (%box-procedure-set! box obj)
     121  (box (lambda (ref set loc) (set obj))) )
     122
     123(define-inline (%box-procedure-location box)
     124  (box (lambda (ref set loc) (loc))) )
     125
     126;;
     127
     128(define-inline (%box? obj)
     129  (or (%box-structure? obj)
     130      (%box-procedure? obj)) )
     131
     132
     133;;; Errors
     134
     135(define-inline (%box-immutable-error loc box . args)
     136  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
     137
     138(define-inline (%box-type-error loc obj . args)
     139  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
     140
     141
     142;;; Print
     143
     144(define-inline (%box-print box)
     145  (let ([val (cond [(%box-structure? box)  (%box-structure-ref box) ]
     146                   [(%box-procedure? box)  (%box-procedure-ref box) ] ) ] )
     147          (display "#&") (write val) ) )
     148
    48149
    49150;;; Module box
     
    61162  scheme
    62163  (only chicken
     164    optional                ;due to #!optional implementation
     165    let-optionals           ;due to #!optional implementation
    63166    define-record-printer
    64167    let-location
     
    76179    make-weak-locative make-locative) )
    77180
     181
    78182;;; Internals
    79183
    80 ;; Errors
    81 
    82 (define (box-immutable-error loc box . args)
    83   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
    84 
    85 (define (box-type-error loc obj . args)
    86   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
    87 
    88184;; Finishers
    89185
    90 (define (finvar ref set)
    91   (extend-procedure
    92         (lambda (proc)
    93                 (proc ref set (lambda () (location (ref)))))
    94         'box-variable) )
    95 
    96 (define (finloc ref set loc)
    97   (extend-procedure
    98         (lambda (proc)
    99                 (proc ref set loc))
    100         'box-location) )
    101 
    102 ;;; Globals
     186(define (finvar tag ref set)
     187  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag) )
     188
     189(define (finloc tag ref set loc)
     190  (extend-procedure (lambda (proc) (proc ref set loc)) tag) )
     191
     192
     193;;; Box
    103194
    104195;; Constructers
    105196
    106197(define-syntax make-box-variable
    107   (syntax-rules (#:immutable?)
     198  (syntax-rules ()
    108199    [(_ ?var)
    109       (make-box-variable ?var #:immutable? #f) ]
    110     [(_ ?var #:immutable? ?flg)
    111       #;(identifier? ?var)
    112       (finvar
    113         (lambda () ?var)
    114         (if ?flg (void) (lambda (value) (set! ?var value)))) ] ) )
     200     (make-box-variable ?var #f) ]
     201    [(_ ?var ?immutable?)
     202     #;(identifier? ?var)
     203     (finvar
     204      (if ?immutable? 'boxvar 'boxvar!)
     205      (lambda () ?var)
     206      (if ?immutable? (void) (lambda (val) (set! ?var val)))) ] ) )
    115207
    116208(define-syntax make-box-location
    117   (syntax-rules (#:immutable?)
     209  (syntax-rules ()
    118210    [(_ ?typ ?val)
    119       (make-box-location ?typ ?val #:immutable? #f) ]
    120     [(_ ?typ ?val #:immutable? ?flg)
    121       #;(identifier? ?typ)
    122       (let-location ([var ?typ ?val])
    123         (finloc
    124           (lambda () var)
    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) )
     211     (make-box-location ?typ ?val #f) ]
     212    [(_ ?typ ?val ?immutable?)
     213     #;(identifier? ?typ)
     214     (let-location ([var ?typ ?val])
     215       (finloc
     216        (if ?immutable? 'boxloc 'boxloc!)
     217        (lambda () var)
     218        (if ?immutable? (void) (lambda (val) (set! var val)))
     219        (lambda () (location var))) ) ] ) )
     220
     221(define (make-box #!optional init immutable?)
     222  (%make-box (if immutable? 'box 'box!) init) )
    130223
    131224;; Predicates
    132225
    133226(define (box? obj)
    134   (or (box-structure? obj)
    135       (box-procedure? obj)) )
     227  (%box? obj) )
    136228
    137229(define (box-variable? obj)
    138   (and-let* ([tag (procedure-data obj)])
    139                 (%eq? 'box-variable tag) ) )
     230  (%box-variable? obj) )
    140231
    141232(define (box-location? obj)
    142   (and-let* ([tag (procedure-data obj)])
    143                 (%eq? 'box-location tag) ) )
     233  (%box-location? obj) )
    144234
    145235(define (box-immutable? obj)
    146   (or (%structure-instance? obj 'box-immutable)
    147       (and (box-procedure? obj)
    148            (box-immutable-setter? (box-setter obj)) ) ) )
     236  (or (%box-structure-immutable? obj)
     237      (%box-procedure-immutable? obj) ) )
    149238
    150239(define (box-mutable? obj)
    151         (not (box-immutable? obj)) )
     240  (or (%box-structure-mutable? obj)
     241      (%box-procedure-mutable? obj) ) )
     242
     243;; Mutators
     244
     245(define (box-set! box val)
     246  (cond [(%box-structure-tag box) =>
     247         (lambda (tag)
     248           (case tag
     249             [(box!)
     250              (%box-structure-set! box val) ]
     251             [(box)
     252              (%box-immutable-error 'box-set! box val) ] ) ) ]
     253        [(%box-procedure-tag box) =>
     254         (lambda (tag)
     255           (case tag
     256             [(boxvar! boxloc!)
     257              (%box-procedure-set! box val) ]
     258             [(boxvar boxloc)
     259              (%box-immutable-error 'box-set! box val) ] ) ) ]
     260        [else
     261         (%box-type-error 'box-set! box val) ] ) )
    152262
    153263;; Assessors
    154 
    155 (define (box-set! box value)
    156   (cond
    157     [(%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)])
    167         (if (box-immutable-setter? setter)
    168             (box-immutable-error 'box-set! box value)
    169             (setter value) ) ) ]
    170     [else
    171       (box-type-error 'box-set! box value) ] ) )
    172264
    173265(define box-ref
    174266  (getter-with-setter
    175267    (lambda (box)
    176       (cond
    177         [(box-structure? box)
    178           (%structure-ref box 1) ]
    179         [(box-procedure? box)
    180           (box (lambda (ref set loc) (ref))) ]
     268      (cond [(%box-structure? box)  (%box-structure-ref box) ]
     269            [(%box-procedure? box)  (%box-procedure-ref box) ]
     270            [else
     271             (%box-type-error 'box-ref box) ] ) )
     272    box-set! ) )
     273
     274(define (box-location box #!optional (weak? #f))
     275  (cond [(%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1) ]
     276        [(%box-procedure? box)   (box (lambda (ref set loc) (loc))) ]
    181277        [else
    182           (box-type-error 'box-ref box) ] ) )
    183     box-set! ) )
    184 
    185 (define (box-location box #!key (weak? #f))
    186   (cond
    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
     278         (%box-type-error 'box-location box) ] ) )
     279
     280
     281;;; MZ Scheme Style
    195282
    196283(define-syntax box
    197284  (syntax-rules ()
    198     [(_ ?arg0 ...)  (make-box ?arg0 ...) ] ) )
     285    [(_ ?arg0 ...)
     286     (make-box ?arg0 ...) ] ) )
    199287
    200288(define-syntax unbox
    201289  (syntax-rules ()
    202     [(_ ?box) (box-ref ?box) ] ) )
     290    [(_ ?box)
     291     (box-ref ?box) ] ) )
    203292
    204293(define-syntax set-box!
    205294  (syntax-rules ()
    206     [(_ ?box ?value)  (box-set! ?box ?value) ] ) )
     295    [(_ ?box ?val)
     296     (box-set! ?box ?val) ] ) )
     297
    207298
    208299;;; Read/Print Syntax
     
    213304
    214305(define-record-printer (box x out)
    215   (with-output-to-port out (lambda () (box-print x))) )
     306  (with-output-to-port out (lambda () (%box-print x))) )
    216307
    217308(define-record-printer (box-immutable x out)
    218   (with-output-to-port out (lambda () (box-print x))) )
     309  (with-output-to-port out (lambda () (%box-print x))) )
    219310
    220311(set! ##sys#procedure->string
    221312  (let ([##sys#procedure->string ##sys#procedure->string])
    222313    (lambda (x)
    223                         (if (box? x)
    224                                         (with-output-to-string (lambda () (box-print x)))
     314                        (if (%box? x)
     315                                        (with-output-to-string (lambda () (%box-print x)))
    225316                                        (##sys#procedure->string x) ) ) ) )
    226317
  • release/4/box/trunk/tests/run.scm

    r13468 r13528  
    1717(test-group "Box Immutable"
    1818        (let ([tbox #f])
    19     (test-assert (make-box #f #:immutable? #t))
    20     (set! tbox (make-box #f #:immutable? #t))
     19    (test-assert (make-box #f #t))
     20    (set! tbox (make-box #f #t))
    2121    (test-assert (not (box-ref tbox)))
    2222    (test-error (box-set! tbox #t)) )
Note: See TracChangeset for help on using the changeset viewer.