Changeset 13616 in project


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

Added primitive inlines.

Location:
release/4/box
Files:
2 added
3 edited

Legend:

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

    r13555 r13616  
    99 (needs setup-helper)
    1010 (files
     11  "chicken-primitive-object-inlines.scm"
    1112  "tests"
    1213        "box.scm"
  • release/4/box/trunk/box.meta

    r13555 r13616  
    99 (needs setup-helper)
    1010 (files
     11  "chicken-primitive-object-inlines.scm"
    1112  "tests"
    1213        "box.scm"
  • release/4/box/trunk/box.scm

    r13528 r13616  
    1919  (bound-to-procedure
    2020    ##sys#signal-hook
    21     ##sys#procedure->string) )
     21    ##sys#procedure->string))
    2222
    2323;;; Prelude
     
    2727(require-library ports lolevel)
    2828
     29;;
     30
     31(define-inline (%->boolean obj) (and obj #t))
     32
    2933
    3034;;; Box Structure Support
    3135
    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) )
     36(define-inline (%make-box tag init) (%make-structure tag init))
     37
     38(define-inline (%box-structure-mutable? obj) (%structure-instance? obj 'box!))
     39
     40(define-inline (%box-structure-immutable? obj) (%structure-instance? obj 'box))
     41
     42(define-inline (%box-structure? obj
     43  (or (%box-structure-mutable? obj) (%box-structure-immutable? obj)))
     44
     45(define-inline (%box-structure-tag obj) (and (%box-structure? obj) (%structure-tag obj)))
     46
     47(define-inline (%box-structure-ref box) (%structure-ref box 1))
     48
     49(define-inline (%box-structure-set! box obj) (%structure-set!/maybe-immediate box 1 obj))
    5450
    5551
     
    5854;; Box Variable
    5955
    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) )
     56(define-inline (%box-variable-immutable-tag? obj) (%eq? 'boxvar obj))
     57
     58(define-inline (%box-variable-mutable-tag? obj) (%eq? 'boxvar! obj))
    6559
    6660(define-inline (%box-variable-tag? obj)
    67   (or (%box-variable-mutable-tag? obj)
    68       (%box-variable-immutable-tag? obj) ) )
     61  (or (%box-variable-mutable-tag? obj) (%box-variable-immutable-tag? obj)))
    6962
    7063(define-inline (%box-variable? obj)
    71   (and-let* ([dat (procedure-data obj)])
    72     (%box-variable-tag? dat) ) )
     64  (and-let* ((dat (procedure-data obj)))
     65    (%box-variable-tag? dat)))
    7366
    7467;; Box Location
    7568
    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) )
     69(define-inline (%box-location-immutable-tag? obj) (%eq? 'boxloc obj))
     70
     71(define-inline (%box-location-mutable-tag? obj) (%eq? 'boxloc! obj))
    8172
    8273(define-inline (%box-location-tag? obj)
    83   (or (%box-location-mutable-tag? obj)
    84       (%box-location-immutable-tag? obj) ) )
     74  (or (%box-location-mutable-tag? obj) (%box-location-immutable-tag? obj)))
    8575
    8676(define-inline (%box-location? obj)
    87   (and-let* ([dat (procedure-data obj)])
    88     (%box-location-tag? dat) ) )
     77  (and-let* ((dat (procedure-data obj)))
     78    (%box-location-tag? dat)))
    8979
    9080;; Box Procedure
    9181
    92 (define-inline (%box-procedure-tag? obj)
    93   (or (%box-variable-tag? obj)
    94       (%box-location-tag? obj) ) )
     82(define-inline (%box-procedure-tag? obj) (or (%box-variable-tag? obj) (%box-location-tag? obj)))
    9583
    9684(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 ) )
     85  (and-let* ((dat (procedure-data obj))
     86             ((%box-procedure-tag? dat)))
     87    dat))
     88
     89(define-inline (%box-procedure? obj) (%->boolean (%box-procedure-tag obj)))
    10490
    10591(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) ) ) )
     92  (and-let* ((dat (procedure-data obj)))
     93    (or (%box-variable-immutable-tag? dat) (%box-location-immutable-tag? dat))))
    10994
    11095(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) ) ) )
     96  (and-let* ((dat (procedure-data obj)))
     97    (or (%box-variable-mutable-tag? dat) (%box-location-mutable-tag? dat))))
    11498
    11599;; Box Procedure Operations
    116100
    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)) )
     101(define-inline (%box-procedure-ref box) (box (lambda (ref set loc) (ref))))
     102
     103(define-inline (%box-procedure-set! box obj) (box (lambda (ref set loc) (set obj))))
     104
     105(define-inline (%box-procedure-location box) (box (lambda (ref set loc) (loc))))
     106
     107;;
     108
     109(define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj)))
    131110
    132111
     
    134113
    135114(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) )
     115  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
    137116
    138117(define-inline (%box-type-error loc obj . args)
    139   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
     118  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
    140119
    141120
     
    143122
    144123(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) ) )
     124  (let ((val (cond ((%box-structure? box)  (%box-structure-ref box))
     125                   ((%box-procedure? box)  (%box-procedure-ref box)))))
     126          (display "#&") (write val)))
    148127
    149128
     
    164143    optional                ;due to #!optional implementation
    165144    let-optionals           ;due to #!optional implementation
     145    define-reader-ctor
    166146    define-record-printer
    167147    let-location
     
    177157  (only lolevel
    178158    extend-procedure procedure-data
    179     make-weak-locative make-locative) )
     159    make-weak-locative make-locative))
    180160
    181161
     
    185165
    186166(define (finvar tag ref set)
    187   (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag) )
     167  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag))
    188168
    189169(define (finloc tag ref set loc)
    190   (extend-procedure (lambda (proc) (proc ref set loc)) tag) )
     170  (extend-procedure (lambda (proc) (proc ref set loc)) tag))
    191171
    192172
     
    197177(define-syntax make-box-variable
    198178  (syntax-rules ()
    199     [(_ ?var)
    200      (make-box-variable ?var #f) ]
    201     [(_ ?var ?immutable?)
     179    ((_ ?var)
     180     (make-box-variable ?var #f))
     181    ((_ ?var ?immutable?)
    202182     #;(identifier? ?var)
    203183     (finvar
    204184      (if ?immutable? 'boxvar 'boxvar!)
    205185      (lambda () ?var)
    206       (if ?immutable? (void) (lambda (val) (set! ?var val)))) ] ) )
     186      (if ?immutable? (void) (lambda (val) (set! ?var val)))))))
    207187
    208188(define-syntax make-box-location
    209189  (syntax-rules ()
    210     [(_ ?typ ?val)
    211      (make-box-location ?typ ?val #f) ]
    212     [(_ ?typ ?val ?immutable?)
     190    ((_ ?typ ?val)
     191     (make-box-location ?typ ?val #f))
     192    ((_ ?typ ?val ?immutable?)
    213193     #;(identifier? ?typ)
    214      (let-location ([var ?typ ?val])
     194     (let-location ((var ?typ ?val))
    215195       (finloc
    216196        (if ?immutable? 'boxloc 'boxloc!)
    217197        (lambda () var)
    218198        (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) )
     199        (lambda () (location var)))))))
     200
     201(define (make-box #!optional init immutable?) (%make-box (if immutable? 'box 'box!) init))
    223202
    224203;; Predicates
    225204
    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) ) )
     205(define (box? obj) (%box? obj))
     206
     207(define (box-variable? obj) (%box-variable? obj))
     208
     209(define (box-location? obj) (%box-location? obj))
     210
     211(define (box-immutable? obj) (or (%box-structure-immutable? obj) (%box-procedure-immutable? obj)))
     212
     213(define (box-mutable? obj) (or (%box-structure-mutable? obj) (%box-procedure-mutable? obj)))
    242214
    243215;; Mutators
    244216
    245217(define (box-set! box val)
    246   (cond [(%box-structure-tag box) =>
     218  (cond ((%box-structure-tag box) =>
    247219         (lambda (tag)
    248220           (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) =>
     221             ((box!) (%box-structure-set! box val))
     222             ((box)  (%box-immutable-error 'box-set! box val)))))
     223        ((%box-procedure-tag box) =>
    254224         (lambda (tag)
    255225           (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) ] ) )
     226             ((boxvar! boxloc!) (%box-procedure-set! box val))
     227             ((boxvar boxloc)   (%box-immutable-error 'box-set! box val)))))
     228        (else
     229         (%box-type-error 'box-set! box val))))
    262230
    263231;; Assessors
     
    266234  (getter-with-setter
    267235    (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! ) )
     236      (cond ((%box-structure? box)  (%box-structure-ref box))
     237            ((%box-procedure? box)  (%box-procedure-ref box))
     238            (else                   (%box-type-error 'box-ref box))))
     239    box-set!))
    273240
    274241(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) ] ) )
     242  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
     243        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
     244        (else                    (%box-type-error 'box-location box))))
    279245
    280246
     
    283249(define-syntax box
    284250  (syntax-rules ()
    285     [(_ ?arg0 ...)
    286      (make-box ?arg0 ...) ] ) )
     251    ((_ ?arg0 ...) (make-box ?arg0 ...))))
    287252
    288253(define-syntax unbox
    289254  (syntax-rules ()
    290     [(_ ?box)
    291      (box-ref ?box) ] ) )
     255    ((_ ?box) (box-ref ?box))))
    292256
    293257(define-syntax set-box!
    294258  (syntax-rules ()
    295     [(_ ?box ?val)
    296      (box-set! ?box ?val) ] ) )
     259    ((_ ?box ?val) (box-set! ?box ?val))))
    297260
    298261
    299262;;; Read/Print Syntax
    300263
    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))) )
     264(set-sharp-read-syntax! #\& (lambda (p) (make-box (read p))))
     265
     266(define-reader-ctor 'box make-box)
     267
     268(define-record-printer (box x p) (with-output-to-port p (lambda () (%box-print x))))
     269
     270(define-record-printer (box-immutable x p) (with-output-to-port p (lambda () (%box-print x))))
    310271
    311272(set! ##sys#procedure->string
    312   (let ([##sys#procedure->string ##sys#procedure->string])
     273  (let ((##sys#procedure->string ##sys#procedure->string))
    313274    (lambda (x)
    314                         (if (%box? x)
    315                                         (with-output-to-string (lambda () (%box-print x)))
    316                                         (##sys#procedure->string x) ) ) ) )
     275                        (if (%box? x) (with-output-to-string (lambda () (%box-print x)))
     276                                        (##sys#procedure->string x)))))
    317277
    318278) ;module box
Note: See TracChangeset for help on using the changeset viewer.