Changeset 13655 in project


Ignore:
Timestamp:
03/10/09 10:03:58 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

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

    r13528 r13655  
    1515  (local)
    1616  (no-procedure-checks)
    17   (no-bound-checks)
    1817  (disable-warning redef) ;##sys#procedure->string is redefined!
    1918  (bound-to-procedure
    2019    ##sys#signal-hook
    21     ##sys#procedure->string) )
     20    ##sys#procedure->string))
    2221
    2322;;; Prelude
     
    2726(require-library ports lolevel)
    2827
     28;;
     29
     30(define-inline (%->boolean obj) (and obj #t))
     31
    2932
    3033;;; Box Structure Support
    3134
    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) )
     35(define-inline (%make-box tag init) (%make-structure tag init))
     36
     37(define-inline (%box-structure-mutable? obj) (%structure-instance? obj 'box!))
     38
     39(define-inline (%box-structure-immutable? obj) (%structure-instance? obj 'box))
     40
     41(define-inline (%box-structure? obj
     42  (or (%box-structure-mutable? obj) (%box-structure-immutable? obj)))
     43
     44(define-inline (%box-structure-tag obj) (and (%box-structure? obj) (%structure-tag obj)))
     45
     46(define-inline (%box-structure-ref box) (%structure-ref box 1))
     47
     48(define-inline (%box-structure-set! box obj) (%structure-set!/maybe-immediate box 1 obj))
    5449
    5550
     
    5853;; Box Variable
    5954
    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) )
     55(define-inline (%box-variable-immutable-tag? obj) (%eq? 'boxvar obj))
     56
     57(define-inline (%box-variable-mutable-tag? obj) (%eq? 'boxvar! obj))
    6558
    6659(define-inline (%box-variable-tag? obj)
    67   (or (%box-variable-mutable-tag? obj)
    68       (%box-variable-immutable-tag? obj) ) )
     60  (or (%box-variable-mutable-tag? obj) (%box-variable-immutable-tag? obj)))
    6961
    7062(define-inline (%box-variable? obj)
    71   (and-let* ([dat (procedure-data obj)])
    72     (%box-variable-tag? dat) ) )
     63  (and-let* ((dat (procedure-data obj)))
     64    (%box-variable-tag? dat)))
    7365
    7466;; Box Location
    7567
    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) )
     68(define-inline (%box-location-immutable-tag? obj) (%eq? 'boxloc obj))
     69
     70(define-inline (%box-location-mutable-tag? obj) (%eq? 'boxloc! obj))
    8171
    8272(define-inline (%box-location-tag? obj)
    83   (or (%box-location-mutable-tag? obj)
    84       (%box-location-immutable-tag? obj) ) )
     73  (or (%box-location-mutable-tag? obj) (%box-location-immutable-tag? obj)))
    8574
    8675(define-inline (%box-location? obj)
    87   (and-let* ([dat (procedure-data obj)])
    88     (%box-location-tag? dat) ) )
     76  (and-let* ((dat (procedure-data obj)))
     77    (%box-location-tag? dat)))
    8978
    9079;; Box Procedure
    9180
    92 (define-inline (%box-procedure-tag? obj)
    93   (or (%box-variable-tag? obj)
    94       (%box-location-tag? obj) ) )
     81(define-inline (%box-procedure-tag? obj) (or (%box-variable-tag? obj) (%box-location-tag? obj)))
    9582
    9683(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 ) )
     84  (and-let* ((dat (procedure-data obj))
     85             ((%box-procedure-tag? dat)))
     86    dat))
     87
     88(define-inline (%box-procedure? obj) (%->boolean (%box-procedure-tag obj)))
    10489
    10590(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) ) ) )
     91  (and-let* ((dat (procedure-data obj)))
     92    (or (%box-variable-immutable-tag? dat) (%box-location-immutable-tag? dat))))
    10993
    11094(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) ) ) )
     95  (and-let* ((dat (procedure-data obj)))
     96    (or (%box-variable-mutable-tag? dat) (%box-location-mutable-tag? dat))))
    11497
    11598;; Box Procedure Operations
    11699
    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)) )
     100(define-inline (%box-procedure-ref box) (box (lambda (ref set loc) (ref))))
     101
     102(define-inline (%box-procedure-set! box obj) (box (lambda (ref set loc) (set obj))))
     103
     104(define-inline (%box-procedure-location box) (box (lambda (ref set loc) (loc))))
     105
     106;;
     107
     108(define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj)))
    131109
    132110
     
    134112
    135113(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) )
     114  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
    137115
    138116(define-inline (%box-type-error loc obj . args)
    139   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
     117  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
    140118
    141119
     
    143121
    144122(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) ) )
     123  (let ((val (cond ((%box-structure? box)  (%box-structure-ref box))
     124                   ((%box-procedure? box)  (%box-procedure-ref box)))))
     125          (display "#&") (write val)))
    148126
    149127
     
    164142    optional                ;due to #!optional implementation
    165143    let-optionals           ;due to #!optional implementation
     144    define-reader-ctor
    166145    define-record-printer
    167146    let-location
     
    177156  (only lolevel
    178157    extend-procedure procedure-data
    179     make-weak-locative make-locative) )
     158    make-weak-locative make-locative))
    180159
    181160
     
    185164
    186165(define (finvar tag ref set)
    187   (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag) )
     166  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag))
    188167
    189168(define (finloc tag ref set loc)
    190   (extend-procedure (lambda (proc) (proc ref set loc)) tag) )
     169  (extend-procedure (lambda (proc) (proc ref set loc)) tag))
    191170
    192171
     
    197176(define-syntax make-box-variable
    198177  (syntax-rules ()
    199     [(_ ?var)
    200      (make-box-variable ?var #f) ]
    201     [(_ ?var ?immutable?)
     178    ((_ ?var)
     179     (make-box-variable ?var #f))
     180    ((_ ?var ?immutable?)
    202181     #;(identifier? ?var)
    203182     (finvar
    204183      (if ?immutable? 'boxvar 'boxvar!)
    205184      (lambda () ?var)
    206       (if ?immutable? (void) (lambda (val) (set! ?var val)))) ] ) )
     185      (if ?immutable? (void) (lambda (val) (set! ?var val)))))))
    207186
    208187(define-syntax make-box-location
    209188  (syntax-rules ()
    210     [(_ ?typ ?val)
    211      (make-box-location ?typ ?val #f) ]
    212     [(_ ?typ ?val ?immutable?)
     189    ((_ ?typ ?val)
     190     (make-box-location ?typ ?val #f))
     191    ((_ ?typ ?val ?immutable?)
    213192     #;(identifier? ?typ)
    214      (let-location ([var ?typ ?val])
     193     (let-location ((var ?typ ?val))
    215194       (finloc
    216195        (if ?immutable? 'boxloc 'boxloc!)
    217196        (lambda () var)
    218197        (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) )
     198        (lambda () (location var)))))))
     199
     200(define (make-box #!optional init immutable?) (%make-box (if immutable? 'box 'box!) init))
    223201
    224202;; Predicates
    225203
    226 (define (box? obj)
    227   (%box? obj) )
    228 
    229 (define (box-variable? obj)
    230   (%box-variable? obj) )
    231 
    232 (define (box-location? obj)
    233   (%box-location? obj) )
    234 
    235 (define (box-immutable? obj)
    236   (or (%box-structure-immutable? obj)
    237       (%box-procedure-immutable? obj) ) )
    238 
    239 (define (box-mutable? obj)
    240   (or (%box-structure-mutable? obj)
    241       (%box-procedure-mutable? obj) ) )
     204(define (box? obj) (%box? obj))
     205
     206(define (box-variable? obj) (%box-variable? obj))
     207
     208(define (box-location? obj) (%box-location? obj))
     209
     210(define (box-immutable? obj) (or (%box-structure-immutable? obj) (%box-procedure-immutable? obj)))
     211
     212(define (box-mutable? obj) (or (%box-structure-mutable? obj) (%box-procedure-mutable? obj)))
    242213
    243214;; Mutators
    244215
    245216(define (box-set! box val)
    246   (cond [(%box-structure-tag box) =>
     217  (cond ((%box-structure-tag box) =>
    247218         (lambda (tag)
    248219           (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) =>
     220             ((box!) (%box-structure-set! box val))
     221             ((box)  (%box-immutable-error 'box-set! box val)))))
     222        ((%box-procedure-tag box) =>
    254223         (lambda (tag)
    255224           (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) ] ) )
     225             ((boxvar! boxloc!) (%box-procedure-set! box val))
     226             ((boxvar boxloc)   (%box-immutable-error 'box-set! box val)))))
     227        (else
     228         (%box-type-error 'box-set! box val))))
    262229
    263230;; Assessors
     
    266233  (getter-with-setter
    267234    (lambda (box)
    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! ) )
     235      (cond ((%box-structure? box)  (%box-structure-ref box))
     236            ((%box-procedure? box)  (%box-procedure-ref box))
     237            (else                   (%box-type-error 'box-ref box))))
     238    box-set!))
    273239
    274240(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))) ]
    277         [else
    278          (%box-type-error 'box-location box) ] ) )
     241  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
     242        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
     243        (else                    (%box-type-error 'box-location box))))
    279244
    280245
     
    283248(define-syntax box
    284249  (syntax-rules ()
    285     [(_ ?arg0 ...)
    286      (make-box ?arg0 ...) ] ) )
     250    ((_ ?arg0 ...) (make-box ?arg0 ...))))
    287251
    288252(define-syntax unbox
    289253  (syntax-rules ()
    290     [(_ ?box)
    291      (box-ref ?box) ] ) )
     254    ((_ ?box) (box-ref ?box))))
    292255
    293256(define-syntax set-box!
    294257  (syntax-rules ()
    295     [(_ ?box ?val)
    296      (box-set! ?box ?val) ] ) )
     258    ((_ ?box ?val) (box-set! ?box ?val))))
    297259
    298260
    299261;;; Read/Print Syntax
    300262
    301 (set-sharp-read-syntax! #\&
    302   (lambda (port)
    303     (make-box (read port))))
    304 
    305 (define-record-printer (box x out)
    306   (with-output-to-port out (lambda () (%box-print x))) )
    307 
    308 (define-record-printer (box-immutable x out)
    309   (with-output-to-port out (lambda () (%box-print x))) )
     263(set-sharp-read-syntax! #\& (lambda (p) (make-box (read p))))
     264
     265(define-reader-ctor 'box make-box)
     266
     267(define-record-printer (box x p) (with-output-to-port p (lambda () (%box-print x))))
     268
     269(define-record-printer (box-immutable x p) (with-output-to-port p (lambda () (%box-print x))))
    310270
    311271(set! ##sys#procedure->string
    312   (let ([##sys#procedure->string ##sys#procedure->string])
     272  (let ((##sys#procedure->string ##sys#procedure->string))
    313273    (lambda (x)
    314                         (if (%box? x)
    315                                         (with-output-to-string (lambda () (%box-print x)))
    316                                         (##sys#procedure->string x) ) ) ) )
     274                        (if (%box? x) (with-output-to-string (lambda () (%box-print x)))
     275                                        (##sys#procedure->string x)))))
    317276
    318277) ;module box
Note: See TracChangeset for help on using the changeset viewer.