Changeset 13461 in project


Ignore:
Timestamp:
03/03/09 05:03:14 (11 years ago)
Author:
Kon Lovett
Message:

Save

Location:
release/4/box/trunk
Files:
3 edited

Legend:

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

    r12265 r13461  
    1010  "tests"
    1111        "box.scm"
    12         "box.setup"
    13         "box.html"))
     12        "box.setup"))
  • release/4/box/trunk/box.scm

    r12290 r13461  
    99  (disable-warning redef)
    1010  (import
     11    ##sys#signal-hook
    1112    ##sys#procedure->string)
    1213  (bound-to-procedure
     14    ##sys#signal-hook
    1315    ##sys#procedure->string) )
    1416
    1517(cond-expand
    16   ( paranoia )
    17   ( else
     18  (paranoia)
     19  (else
    1820    (declare
    1921      (no-procedure-checks)
     
    2224;;;
    2325
    24 (module box
    25   (make-box make-box-variable make-box-location
    26    box? box-variable? box-location?
    27    box-mutable? box-immutable?
    28    box-set! box-ref
    29    box-location
    30    box
    31    set-box! unbox)
    32 
    33 (import scheme)
    34 (import (only chicken abort make-property-condition make-composite-condition set-sharp-read-syntax!))
    35 (import (only lolevel extend-procedure procedure-data record-instance? make-record-instance))
    36 
    37 ;;
    38 
    39 (define (%record-tag rec)
    40   (##sys#slot rec 0) )
    41 
    42 (define (%record-slot-set! rec idx obj)
    43   (##sys#setslot rec idx obj) )
    44 
    45 (define (%record-slot-ref rec idx)
    46   (##sys#slot rec idx) )
     26(require-library lolevel)
     27
     28(module box ()
     29
     30(export
     31  make-box (make-box-variable ##box#finvar) (make-box-location ##box#finloc)
     32  box? box-variable? box-location?
     33  box-mutable? box-immutable?
     34  box-set! box-ref
     35  box-location
     36  box
     37  set-box! unbox)
     38
     39(import
     40  scheme
     41  (only chicken set-sharp-read-syntax!)
     42  (only lolevel
     43    extend-procedure procedure-data
     44    record-instance? make-record-instance
     45    block-ref
     46    make-weak-locative make-locative) )
     47
     48;;
     49
     50(define (box-immutable-error loc box . args)
     51  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
     52
     53(define (box-type-error loc obj . args)
     54  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
     55
     56;;
     57
     58(define (##box#finvar ref set)
     59  (extend-procedure
     60        (lambda (proc)
     61                (proc ref set (lambda () (location (ref)))))
     62        'box-variable) )
     63
     64(define (##box#finloc ref set loc)
     65  (extend-procedure
     66        (lambda (proc)
     67                (proc ref set loc))
     68        'box-location) )
     69
     70(define (box-structure? obj)
     71  (or (record-instance? obj 'box)
     72      (record-instance? obj 'box-immutable)) )
     73
     74(define (box-procedure? obj)
     75  ; 'procedure-data' returns #f for anything other than an extended-procedure!
     76  (and-let* ( (tag (procedure-data obj)) )
     77                (or (eq? 'box-variable tag)
     78                    (eq? 'box-location tag)) ) )
     79
     80(define (box-setter box)
     81  (obj (lambda (ref set loc) set)) )
     82
     83(define (box-immutable-setter? setter)
     84  (eq? (void) setter) )
     85
     86;;;
    4787
    4888;;
     
    5191  (syntax-rules (#:immutable)
    5292    ( (_ ?var)
    53       #;(identifier? ?var)
    54       (box:finvar (lambda () ?var)
    55                   (lambda (value) (set! ?var value))) )
     93      (make-box-variable ?var #:immutable #f) )
    5694    ( (_ ?var #:immutable #f)
    5795      #;(identifier? ?var)
    58       (box:finvar (lambda () ?var)
    59                   (lambda (value) (set! ?var value))) )
     96      (##box#finvar
     97        (lambda () ?var)
     98        (lambda (value) (set! ?var value))) )
    6099    ( (_ ?var #:immutable #t)
    61100      #;(identifier? ?var)
    62       (box:finvar (lambda () ?var)
    63                   box:immutable-set) ) ) )
     101      (##box#finvar
     102        (lambda () ?var)
     103        (void)) ) ) )
     104
     105;;
    64106
    65107(define-syntax make-box-location
    66108  (syntax-rules (#:immutable)
    67109    ( (_ ?typ ?val)
    68       #;(identifier? ?typ)
    69       (let-location ( (var ?typ ?val) )
    70         (box:finloc (lambda () var)
    71                     (lambda (value) (set! var value))
    72                     (lambda () (location var))) ) )
     110      (make-box-location ?typ ?val #:immutable #f) )
    73111    ( (_ ?typ ?val #:immutable #f)
    74112      #;(identifier? ?typ)
    75113      (let-location ( (var ?typ ?val) )
    76         (box:finloc (lambda () var)
    77                     (lambda (value) (set! var value))
    78                     (lambda () (location var))) ) )
     114        (##box#finloc
     115          (lambda () var)
     116          (lambda (value) (set! var value))
     117          (lambda () (location var))) ) )
    79118    ( (_ ?typ ?val #:immutable #t)
    80119      #;(identifier? ?typ)
    81120      (let-location ( (var ?typ ?val) )
    82         (box:finloc (lambda () var)
    83                     box:immutable-set
    84                                                                           (lambda () (location var))) ) ) ) )
     121        (##box#finloc
     122          (lambda () var)
     123          (void)
     124          (lambda () (location var))) ) ) ) )
    85125
    86126;;
     
    103143;;
    104144
    105 (define (make-exn-condition loc msg args)
    106   (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
    107 
    108 (define (make-box-condition box)
    109   (make-property-condition 'box 'box box) )
    110 
    111 (define (make-exn-box-condition loc msg box args)
    112   (make-composite-condition
    113     (make-exn-condition loc msg args)
    114     (make-box-condition box)) )
    115 
    116 (define (box-location-error loc box . args)
    117   (abort (make-exn-box-condition loc "cannot take location of box" box args)) )
    118 
    119 (define (box-immutable-error loc box . args)
    120   (abort (make-exn-box-condition loc "cannot set immutable box" box args)) )
    121 
    122 (define (box-check-error loc box . args)
    123   (abort (make-exn-box-condition loc "not a box" box args)) )
    124 
    125 ;;
    126 
    127 (define (box:immutable-set value)
    128         (box-immutable-error 'box-set! '#<box> value) )
    129 
    130 (define (box:finvar ref set)
    131   (extend-procedure
    132         (lambda (proc)
    133                 (proc ref set (lambda () (location (ref)))))
    134         'box-reference) )
    135 
    136 (define (box:finloc ref set loc)
    137   (extend-procedure
    138         (lambda (proc)
    139                 (proc ref set loc))
    140         'box-reference) )
    141 
    142 (define (check-box loc obj)
    143   (unless (box? obj)
    144     (box-check-error loc obj) ) )
    145 
    146 ;;
    147 
    148 (define (make-box init #!key (immutable #f) (location #f))
    149   (if location
    150       (extend-procedure
    151         (let ( (boxed init) )
    152           (lambda (proc)
    153             (proc (lambda () boxed)                         ; ref
    154                   (if immutable                             ; set!
    155                       box:immutable-set
    156                       (lambda (value) (set! boxed value)) )
    157                   (lambda () (location boxed))) ) )         ; loc
    158           'box)
    159       (if immutable
    160           (make-record-instance 'box-immutable init)
    161           (make-record-instance 'box init) ) ) )
    162 
    163 ;;
    164 
    165 (define (box-structure? obj)
    166   (and (record-instance? obj)
    167        (let ( (tag (%record-tag obj)) )
    168          (or (eq? 'box tag) (eq? 'box-immutable tag)) ) ) )
    169 
    170 (define (box-procedure? obj)
    171   ; 'procedure-data' returns #f for anything other than an extended-procedure!
     145(define (make-box init #!key (immutable #f))
     146  (make-record-instance (if immutable 'box-immutable 'box) init) )
     147
     148;;
     149
     150(define (box? obj)
     151  (or (box-structure? obj)
     152      (box-procedure? obj)) )
     153
     154(define (box-variable? obj)
    172155  (and-let* ( (tag (procedure-data obj)) )
    173                 (or (eq? 'box tag) (eq? 'box-reference tag) ) ) )
    174 
    175 ;;
    176 
    177 (define (box? obj)
    178   (or (box-structure? obj) (box-procedure? obj) ) )
    179 
    180 (define (box-variable? obj)
    181   ; 'procedure-data' returns #f for anything other than an extended-procedure!
    182   (eq? 'box-reference (procedure-data obj)) )
     156                (eq? 'box-variable tag) ) )
     157
     158(define (box-location? obj)
     159  (and-let* ( (tag (procedure-data obj)) )
     160                (eq? 'box-location tag) ) )
    183161
    184162(define (box-immutable? obj)
    185   (or (and (box-structure? obj)
    186                      (eq? 'box-immutable (%record-tag obj)) )
     163  (or (record-instance? obj 'box-immutable)
    187164      (and (box-procedure? obj)
    188            (obj (lambda (ref set loc) (eq? box:immutable-set set))) ) ) )
     165           (obj (lambda (ref set loc) (box-immutable-setter? set))) ) ) )
    189166
    190167(define (box-mutable? obj)
     
    196173  (cond
    197174    ( (record-instance? box)
    198       (case (%record-tag obj)
     175      (case (block-ref obj 0)
    199176        ( (box)
    200           (%record-slot-set! box 1 value) )
     177          (set! (block-ref box 1) value) )
    201178        ( (box-immutable)
    202179          (box-immutable-error 'box-set! box value) )
    203180        ( else
    204           (box-check-error 'box-set! box value) ) ) )
     181          (box-type-error 'box-set! box value) ) ) )
    205182    ( (box-procedure? box)
    206       (box (lambda (ref set loc) (set value))) )
     183      (let ( (setter (box-setter box)) )
     184        (if (box-immutable-setter? setter)
     185            (box-immutable-error 'box-set! box value)
     186            (setter value) ) ) )
    207187    ( else
    208       (box-check-error 'box-set! box value) ) ) )
    209 
    210 (define (box-ref box)
    211   (cond
    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) ) ) )
     188      (box-type-error 'box-set! box value) ) ) )
     189
     190(define box-ref
     191  (getter-with-setter
     192    (lambda (box)
     193      (cond
     194        ( (box-structure? box)
     195          (block-ref box 1) )
     196        ( (box-procedure? box)
     197          (box (lambda (ref set loc) (ref))) )
     198        ( else
     199          (box-type-error 'box-ref box) ) ) )
     200    box-set! ) )
    218201
    219202(define (box-location box #!key (weak #f))
     
    224207      (box (lambda (ref set loc) (loc))) )
    225208    ( else
    226       (box-check-error 'box-location box) ) ) )
     209      (box-type-error 'box-location box) ) ) )
    227210
    228211;;
  • release/4/box/trunk/box.setup

    r12265 r13461  
    11;;;; box.setup
    22
    3 (compile box.scm -shared -optimize-level 2 -debug-level 2 -emit-import-library box)
    4 (compile box.import.scm -shared -optimize-level 2 -debug-level 0)
     3;;
    54
    6 (install-extension
    7  'box
    8  '("box.so" "box.import.so")
    9  '((version "2.0.0")
    10    (syntax)
    11    (documentation "box.html")))
     5(required-chicken-version 4.0)
     6
     7;;
     8
     9(define *version* (if (file-exists? "version") (string-chomp (read-all "version") "\n") "trunk"))
     10
     11;;
     12
     13(define (make-fn bn . en)
     14  (apply make-pathname #f (->string bn) en) )
     15
     16(define (doc-fn bn)
     17  (make-fn bn "html") )
     18
     19(define (source-fn bn)
     20  (make-fn bn "scm") )
     21
     22(define (shared-fn bn)
     23  (make-fn bn ##sys#load-dynamic-extension) )
     24
     25(define (static-fn bn)
     26  (make-fn bn "o") )
     27
     28(define (import-fn bn)
     29  (make-fn bn "import") )
     30
     31(define (source-import-fn bn)
     32  (source-fn (import-fn bn)) )
     33
     34(define (shared-import-fn bn)
     35  (shared-fn (import-fn bn)) )
     36
     37;;
     38
     39(define (compile-static-extension nam . args)
     40  (compile ,(source-fn nam)
     41    -optimize-level 2 -debug-level 1
     42    -c -unit ,nam -output-file ,(static-fn nam)
     43    ,@args) )
     44
     45(define (compile-shared-extension nam . args)
     46  (compile ,(source-fn nam)
     47    -optimize-level 2 -debug-level 1
     48    -shared -output-file ,(shared-fn nam)
     49    -emit-import-library ,nam
     50    ,@args)
     51  (compile ,(source-import-fn nam)
     52    -optimize-level 2 -debug-level 0
     53    -shared -output-file ,(shared-import-fn nam)) )
     54
     55;;
     56
     57(define (install-shared-extension nam #!key (compile '()) (install '()))
     58  (apply compile-shared-extension nam compile)
     59  (install-extension nam
     60   `(,(shared-fn nam) ,(shared-import-fn nam))
     61   `((version ,*version*)
     62     (documentation ,(doc-fn nam))
     63     ,@install)) )
     64
     65(define (install-shared-static-extension nam  #!key (compile '()) (install '()))
     66  (apply compile-shared-extension nam compile)
     67  (apply compile-static-extension nam compile)
     68  (install-extension nam
     69   `(,(shared-fn nam) ,(static-fn nam) ,(shared-import-fn nam))
     70   `((version ,*version*)
     71     (static ,(static-fn nam))
     72     (documentation ,(doc-fn nam))
     73     ,@install)) )
     74
     75;;;
     76
     77(install-shared-extension 'box)
Note: See TracChangeset for help on using the changeset viewer.