Changeset 12290 in project


Ignore:
Timestamp:
10/29/08 02:50:10 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

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

    r12265 r12290  
    1414
    1515(cond-expand
    16   [paranoia]
    17   [else
     16  ( paranoia )
     17  ( else
    1818    (declare
    1919      (no-procedure-checks)
    20       (no-bound-checks) ) ] )
     20      (no-bound-checks) ) ) )
    2121
    2222;;;
     
    2424(module box
    2525  (make-box make-box-variable make-box-location
    26    box? box-mutable? box-immutable box-variable? box-location?
     26   box? box-variable? box-location?
     27   box-mutable? box-immutable?
    2728   box-set! box-ref
    2829   box-location
     
    3031   set-box! unbox)
    3132
    32 (import scheme chicken)
     33(import scheme)
     34(import (only chicken abort make-property-condition make-composite-condition set-sharp-read-syntax!))
    3335(import (only lolevel extend-procedure procedure-data record-instance? make-record-instance))
    3436
     
    4850(define-syntax make-box-variable
    4951  (syntax-rules (#:immutable)
    50     [(_ ?var)
     52    ( (_ ?var)
    5153      #;(identifier? ?var)
    5254      (box:finvar (lambda () ?var)
    53                   (lambda (value) (set! ?var value))) ]
    54     [(_ ?var #:immutable #f)
     55                  (lambda (value) (set! ?var value))) )
     56    ( (_ ?var #:immutable #f)
    5557      #;(identifier? ?var)
    5658      (box:finvar (lambda () ?var)
    57                   (lambda (value) (set! ?var value))) ]
    58     [(_ ?var #:immutable #t)
     59                  (lambda (value) (set! ?var value))) )
     60    ( (_ ?var #:immutable #t)
    5961      #;(identifier? ?var)
    6062      (box:finvar (lambda () ?var)
    61                   box:immutable-set) ] ) )
     63                  box:immutable-set) ) ) )
    6264
    6365(define-syntax make-box-location
    6466  (syntax-rules (#:immutable)
    65     [(_ ?typ ?val)
     67    ( (_ ?typ ?val)
    6668      #;(identifier? ?typ)
    67       (let-location ([var ?typ ?val])
     69      (let-location ( (var ?typ ?val) )
    6870        (box:finloc (lambda () var)
    6971                    (lambda (value) (set! var value))
    70                     (lambda () (location var))) ) ]
    71     [(_ ?typ ?val #:immutable #f)
     72                    (lambda () (location var))) ) )
     73    ( (_ ?typ ?val #:immutable #f)
    7274      #;(identifier? ?typ)
    73       (let-location ([var ?typ ?val])
     75      (let-location ( (var ?typ ?val) )
    7476        (box:finloc (lambda () var)
    7577                    (lambda (value) (set! var value))
    76                     (lambda () (location var))) ) ]
    77     [(_ ?typ ?val #:immutable #t)
     78                    (lambda () (location var))) ) )
     79    ( (_ ?typ ?val #:immutable #t)
    7880      #;(identifier? ?typ)
    79       (let-location ([var ?typ ?val])
     81      (let-location ( (var ?typ ?val) )
    8082        (box:finloc (lambda () var)
    8183                    box:immutable-set
    82                                                                           (lambda () (location var))) ) ] ) )
     84                                                                          (lambda () (location var))) ) ) ) )
    8385
    8486;;
     
    8688(define-syntax box
    8789  (syntax-rules ()
    88     [(_ ?arg0 ...)
    89       (make-box ?arg0 ...) ] ) )
     90    ( (_ ?arg0 ...)
     91      (make-box ?arg0 ...) ) ) )
    9092
    9193(define-syntax unbox
    9294  (syntax-rules ()
    93     [(_ ?box)
    94       (box-ref ?box) ] ) )
     95    ( (_ ?box)
     96      (box-ref ?box) ) ) )
    9597
    9698(define-syntax set-box!
    9799  (syntax-rules ()
    98     [(_ ?box ?value)
    99       (box-set! ?box ?value) ] ) )
     100    ( (_ ?box ?value)
     101      (box-set! ?box ?value) ) ) )
    100102
    101103;;
     
    107109  (make-property-condition 'box 'box box) )
    108110
    109 (define (make-box-condition loc msg box args)
     111(define (make-exn-box-condition loc msg box args)
    110112  (make-composite-condition
    111113    (make-exn-condition loc msg args)
     
    113115
    114116(define (box-location-error loc box . args)
    115   (abort (make-box-condition loc "cannot take location of box" box args)) )
     117  (abort (make-exn-box-condition loc "cannot take location of box" box args)) )
    116118
    117119(define (box-immutable-error loc box . args)
    118   (abort (make-box-condition loc "cannot set immutable box" box args)) )
     120  (abort (make-exn-box-condition loc "cannot set immutable box" box args)) )
    119121
    120122(define (box-check-error loc box . args)
    121   (abort (make-box-condition loc "not a box" box args)) )
     123  (abort (make-exn-box-condition loc "not a box" box args)) )
    122124
    123125;;
     
    147149  (if location
    148150      (extend-procedure
    149         (let ([boxed init])
     151        (let ( (boxed init) )
    150152          (lambda (proc)
    151153            (proc (lambda () boxed)                         ; ref
     
    163165(define (box-structure? obj)
    164166  (and (record-instance? obj)
    165        (let ([tag (%record-tag obj)])
     167       (let ( (tag (%record-tag obj)) )
    166168         (or (eq? 'box tag) (eq? 'box-immutable tag)) ) ) )
    167169
    168170(define (box-procedure? obj)
    169   (and-let* ([pdat (procedure-data obj)])
    170                 (or (eq? 'box pdat) (eq? 'box-reference pdat) ) ) )
     171  ; 'procedure-data' returns #f for anything other than an extended-procedure!
     172  (and-let* ( (tag (procedure-data obj)) )
     173                (or (eq? 'box tag) (eq? 'box-reference tag) ) ) )
    171174
    172175;;
     
    176179
    177180(define (box-variable? obj)
     181  ; 'procedure-data' returns #f for anything other than an extended-procedure!
    178182  (eq? 'box-reference (procedure-data obj)) )
    179183
    180 (define (box-immutable obj)
     184(define (box-immutable? obj)
    181185  (or (and (box-structure? obj)
    182186                     (eq? 'box-immutable (%record-tag obj)) )
     
    191195(define (box-set! box value)
    192196  (cond
    193     [(box-structure? box)
    194       (if (eq? 'box-immutable (%record-tag box))
    195           (box-immutable-error 'box-set! box value)
    196           (%record-slot-set! box 1 value) ) ]
    197     [(box-procedure? box)
    198       (box (lambda (ref set loc) (set value))) ]
    199     [else
    200       (box-check-error 'box-set! box value) ] ) )
     197    ( (record-instance? box)
     198      (case (%record-tag obj)
     199        ( (box)
     200          (%record-slot-set! box 1 value) )
     201        ( (box-immutable)
     202          (box-immutable-error 'box-set! box value) )
     203        ( else
     204          (box-check-error 'box-set! box value) ) ) )
     205    ( (box-procedure? box)
     206      (box (lambda (ref set loc) (set value))) )
     207    ( else
     208      (box-check-error 'box-set! box value) ) ) )
    201209
    202210(define (box-ref box)
    203211  (cond
    204     [(box-structure? box)
    205       (%record-slot-ref box 1) ]
    206     [(box-procedure? box)
    207       (box (lambda (ref set loc) (ref))) ]
    208     [else
    209       (box-check-error 'box-ref box) ] ) )
    210 
    211 (define (box-location box)
     212    ( (box-structure? box)
     213      (%record-slot-ref box 1) )
     214    ( (box-procedure? box)
     215      (box (lambda (ref set loc) (ref))) )
     216    ( else
     217      (box-check-error 'box-ref box) ) ) )
     218
     219(define (box-location box #!key (weak #f))
    212220  (cond
    213     [(box-structure? box)
    214       (box-location-error 'box-location box) ]
    215     [(box-procedure? box)
    216       (box (lambda (ref set loc) (loc))) ]
    217     [else
    218       (box-check-error 'box-location box) ] ) )
    219 
    220 ;;;
     221    ( (box-structure? box)
     222      ((if weak make-weak-locative make-locative) box 1)
     223    ( (box-procedure? box)
     224      (box (lambda (ref set loc) (loc))) )
     225    ( else
     226      (box-check-error 'box-location box) ) ) )
     227
     228;;
    221229
    222230(define (box-print box)
    223231        (display "#&") (write (box-ref box)) )
     232
     233;;; Initialize
    224234
    225235(set-sharp-read-syntax! #\&
     
    228238
    229239(set! ##sys#procedure->string
    230   (let ([##sys#procedure->string ##sys#procedure->string])
     240  (let ( (##sys#procedure->string ##sys#procedure->string) )
    231241    (lambda (x)
    232242                        (if (box? x)
Note: See TracChangeset for help on using the changeset viewer.