Changeset 38548 in project


Ignore:
Timestamp:
04/04/20 22:13:44 (11 months ago)
Author:
Kon Lovett
Message:

module box must export srfi-111 bindings, use secondary module (box-core) to hide `box' symbol (record tag nonsense)

Location:
release/5/box/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/box/trunk/box.egg

    r38539 r38548  
    33
    44((synopsis "Boxing")
    5  (version "3.2.0")
     5 (version "3.2.1")
    66 (category data)
    77 (license "BSD")
     
    1010 (test-dependencies test)
    1111(components
    12   (extension box
     12  (extension box-core
    1313    (types-file)
    1414    ;no -strict-types"; has generic returns; ex: make-box
    1515    (csc-options
    1616      "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     17  (extension box
     18    (types-file)
     19    (component-dependencies box-core srfi-111)
     20    (csc-options
     21      "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    1722  (extension srfi-111
    1823    (types-file)
    19     (component-dependencies box)
     24    (component-dependencies box-core)
    2025    (csc-options
    21       "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
     26      "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
  • release/5/box/trunk/box.scm

    r38539 r38548  
    11;;;; box.scm  -*- Scheme -*-
    22;;;; Kon Lovett, Apr '20
    3 ;;;; Kon Lovett, Jul '18
    4 ;;;; Kon Lovett, May '17
    5 ;;;; Kon Lovett, Oct '08
    63
    7 ;; Issues
    8 ;;
    9 ;; - All operations inlined & primitive due to high-performance nature.
    10 ;;
    11 ;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
    12 
    13 (declare
    14   (disable-interrupts))
    15 
    16 (module box
    17 
    18 (;export
    19   make-box
    20   make-box-mutable
    21   make-box-immutable
    22   make-box-variable
    23   make-box-location
    24   box?
    25   box-variable?
    26   box-location?
    27   box-mutable?
    28   box-immutable?
    29   box-set!
    30   box-ref
    31   box-swap!
    32   box-location
    33   make-box-variable-closure
    34   make-box-location-closure
    35   ;
    36   *box-structure?
    37   *box-structure-ref
    38   *box-structure-set!
    39   *box-procedure?
    40   *box-procedure-ref
    41   *box-procedure-set!)
     4(module box ()
    425
    436(import scheme)
    44 (import (chicken base))
    45 (import (chicken syntax))
    46 (import (chicken type))
    47 (import (chicken foreign))
    48 (import (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!))
    49 (import (only (chicken port) with-output-to-port with-output-to-string))
    50 (import (only (chicken memory representation) extend-procedure procedure-data))
    51 (import (only (chicken locative) make-weak-locative make-locative))
    52 (import (only type-errors define-error-type))
     7(import (chicken module))
    538
    54 ;;;
    55 
    56 ;;
    57 
    58 (define-type box-struct (or (struct box) (struct box!)))
    59 (define-type box-closure ((* * * -> *) -> *))
    60 (define-type box (or box-struct box-closure))
    61 
    62 ;;; Prelude
    63 
    64 (define-inline (->boolean x) (and x #t))
    65 
    66 ;;; Box Structure Support
    67 
    68 (define-record box structure-immutable-value)
    69 (define-record-type box
    70   (make-box-structure-immutable value)
    71   box-structure-immutable?
    72   (value box-structure-immutable-value box-structure-immutable-value-set!))
    73 
    74 (define-record box! structure-mutable-value)
    75 (define-record-type box!
    76   (make-box-structure-mutable value)
    77   box-structure-mutable?
    78   (value box-structure-mutable-value box-structure-mutable-value-set!))
    79 
    80 (define-inline (%box-structure? obj)
    81   (or
    82     (box-structure-mutable? obj)
    83     (box-structure-immutable? obj)) )
    84 
    85 (define-inline (%box-structure-ref box)
    86   (cond
    87     ((box-structure-mutable? box) (box-structure-mutable-value box))
    88     ((box-structure-immutable? box) (box-structure-immutable-value box)) ) )
    89 
    90 (define-inline (%box-structure-set! box val)
    91   (cond
    92     ((box-structure-mutable? box) (box-structure-mutable-value-set! box val))
    93     ((box-structure-immutable? box) (box-structure-immutable-value-set! box val)) ) )
    94 
    95 ;;; Box Procedure Support
    96 
    97 ;; Box Variable
    98 
    99 (define-inline (%box-variable-immutable-tag? obj)
    100   (eq? 'boxvar obj) )
    101 
    102 (define-inline (%box-variable-mutable-tag? obj)
    103   (eq? 'boxvar! obj) )
    104 
    105 (define-inline (%box-variable-tag? obj)
    106   (or
    107     (%box-variable-mutable-tag? obj)
    108     (%box-variable-immutable-tag? obj) ) )
    109 
    110 (define-inline (%box-variable? obj)
    111   (and-let* (
    112     (dat (procedure-data obj)) )
    113     (%box-variable-tag? dat) ) )
    114 
    115 ;; Box Location
    116 
    117 (define-inline (%box-location-immutable-tag? obj)
    118   (eq? 'boxloc obj) )
    119 
    120 (define-inline (%box-location-mutable-tag? obj)
    121   (eq? 'boxloc! obj) )
    122 
    123 (define-inline (%box-location-tag? obj)
    124   (or
    125     (%box-location-mutable-tag? obj)
    126     (%box-location-immutable-tag? obj) ) )
    127 
    128 (define-inline (%box-location? obj)
    129   (and-let* (
    130     (dat (procedure-data obj)) )
    131     (%box-location-tag? dat) ) )
    132 
    133 ;; Box Procedure
    134 
    135 (define-inline (%box-closure-tag? obj)
    136   (or (%box-variable-tag? obj) (%box-location-tag? obj)) )
    137 
    138 (define-inline (%box-closure-tag obj)
    139   (and-let* (
    140     (dat (procedure-data obj))
    141     ((%box-closure-tag? dat)) )
    142     dat ) )
    143 
    144 (define-inline (%box-closure? obj)
    145   (->boolean (%box-closure-tag obj)) )
    146 
    147 (define-inline (%box-closure-immutable? obj)
    148   (and-let* (
    149     (dat (procedure-data obj)) )
    150     (or
    151       (%box-variable-immutable-tag? dat)
    152       (%box-location-immutable-tag? dat) ) ) )
    153 
    154 (define-inline (%box-closure-mutable? obj)
    155   (and-let* (
    156     (dat (procedure-data obj)) )
    157     (or
    158       (%box-variable-mutable-tag? dat)
    159       (%box-location-mutable-tag? dat) ) ) )
    160 
    161 ;; Box Procedure Operations
    162 
    163 (define-inline (%box-closure-ref box)
    164   (box (lambda (ref set loc) (ref))) )
    165 
    166 (define-inline (%box-closure-set! box obj)
    167   (box (lambda (ref set loc) (set obj))) )
    168 
    169 (define-inline (%box-closure-location box)
    170   (box (lambda (ref set loc) (loc))) )
    171 
    172 ;;
    173 
    174 (define-inline (%box? obj)
    175   (or
    176     (%box-structure? obj)
    177     (%box-closure? obj)) )
    178 
    179 ;; Errors
    180 
    181 (define-error-type box-mutable)
    182 (define-error-type box)
    183 
    184 ;; Finishers
    185 
    186 (: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
    187 ;
    188 (define (make-box-variable-closure immutable? ref set)
    189   (let (
    190     (tag (if immutable? 'boxvar 'boxvar!)) )
    191     (extend-procedure
    192       (lambda (proc)
    193         (proc ref set (lambda () (location (ref)))) )
    194       tag) ) )
    195 
    196 (: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> box-closure))
    197 ;
    198 (define (make-box-location-closure immutable? ref set refloc)
    199   (let (
    200     (tag (if immutable? 'boxloc 'boxloc!)) )
    201     (extend-procedure
    202       (lambda (proc) (proc ref set refloc) )
    203       tag) ) )
    204 
    205 ;;; Box
    206 
    207 ;; Direct calls
    208 ;; For use by high-performance routines (such as core routine replacements)
    209 
    210 (: *box-structure? (* -> boolean : box-struct))
    211 ;
    212 (define (*box-structure? obj)
    213   (%box-structure? obj) )
    214 
    215 (: *box-structure-ref (box-struct -> *))
    216 ;
    217 (define (*box-structure-ref box)
    218   (%box-structure-ref box) )
    219 
    220 (: *box-structure-set! (box-struct * -> void))
    221 ;
    222 (define (*box-structure-set! box val)
    223   (%box-structure-set! box val) )
    224 
    225 (: *box-procedure? (* -> boolean : box-closure))
    226 ;
    227 (define (*box-procedure? obj)
    228   (%box-closure? obj) )
    229 
    230 (: box-procedure-ref (box-closure -> *))
    231 ;
    232 (define (*box-procedure-ref box)
    233   (%box-closure-ref box) )
    234 
    235 (: *box-procedure-set! (box-closure * -> void))
    236 ;
    237 (define (*box-procedure-set! box val)
    238   (%box-closure-set! box val) )
    239 
    240 (: *box-ref (box -> *))
    241 ;
    242 (define (*box-ref box)
    243   (cond
    244     ((%box-structure? box)  (%box-structure-ref box))
    245     ((%box-closure? box)    (%box-closure-ref box))
    246     (else
    247       (error-box 'box-ref box 'box)) ) )
    248 
    249 ;; Constructers
    250 
    251 (define-syntax make-box-variable
    252   (syntax-rules ()
    253     ;
    254     ((make-box-variable ?var)
    255       (make-box-variable ?var #f) )
    256     ;
    257     ((make-box-variable ?var ?immutable?)
    258       #;(identifier? ?var)
    259       (make-box-variable-closure
    260         ?immutable?
    261         (lambda () ?var)
    262         (if ?immutable? void (lambda (val) (set! ?var val)))) ) ) )
    263 
    264 (define-syntax make-box-location
    265   (syntax-rules ()
    266     ;
    267     ((make-box-location ?typ ?val)
    268       (make-box-location ?typ ?val #f) )
    269     ;
    270     ((make-box-location ?typ ?val ?immutable?)
    271       #;(identifier? ?typ)
    272       (let-location ((var ?typ ?val))
    273         (make-box-location-closure
    274           ?immutable?
    275           (lambda () var)
    276           (if ?immutable? void (lambda (val) (set! var val)))
    277           (lambda () (location var))) ) ) ) )
    278 
    279 (: make-box (#!optional * boolean -> box-struct))
    280 ;
    281 (define (make-box #!optional init immutable?)
    282   (if immutable?
    283     (make-box-structure-immutable init)
    284     (make-box-structure-mutable init) ) )
    285 
    286 (: make-box-immutable (#!optional * -> box-struct))
    287 ;
    288 (define (make-box-immutable #!optional init)
    289   (make-box-structure-immutable init) )
    290 
    291 (: make-box-mutable (#!optional * -> box-struct))
    292 ;
    293 (define (make-box-mutable #!optional init)
    294   (make-box-structure-mutable init) )
    295 
    296 ;; Predicates
    297 
    298 (: box? (* -> boolean : box))
    299 ;
    300 (define (box? obj)
    301   (%box? obj) )
    302 
    303 ;NOTE these are trait predicates, not type predicates, so not a (DOM -> RNG : TYPE)!
    304 
    305 (: box-variable? (* -> boolean))
    306 ;
    307 (define (box-variable? obj)
    308   (%box-variable? obj) )
    309 
    310 (: box-location? (* -> boolean))
    311 ;
    312 (define (box-location? obj)
    313   (%box-location? obj) )
    314 
    315 (: box-immutable? (* -> boolean))
    316 ;
    317 (define (box-immutable? obj)
    318   (or (box-structure-immutable? obj) (%box-closure-immutable? obj)) )
    319 
    320 (: box-mutable? (* -> boolean))
    321 ;
    322 (define (box-mutable? obj)
    323   (or (box-structure-mutable? obj) (%box-closure-mutable? obj)) )
    324 
    325 ;; Mutators
    326 
    327 
    328 (: box-set! (box * -> void))
    329 ;
    330 (define (box-set! box val)
    331   (cond
    332     ((box-structure-immutable? box)
    333       (error-box-mutable 'box-set! box) )
    334     ((box-structure-mutable? box) (box-structure-mutable-value-set! box val) )
    335     (else
    336       (case (%box-closure-tag box)
    337         ((boxvar! boxloc!) (%box-closure-set! box val) )
    338         ((boxvar boxloc)
    339           (error-box-mutable 'box-set! box) )
    340         (else
    341           (error-box 'box-set! box) ) ) ) ) )
    342 
    343 #; ;inlined version below
    344 (define (box-swap! box func . args)
    345   (let* (
    346     (oval (*box-ref box))
    347     (nval (apply func oval args)) )
    348     (box-set! box nval)
    349     nval ) )
    350 
    351 (: box-swap! (box (* #!rest * -> *) #!rest * -> *))
    352 ;
    353 (define (box-swap! box func . args)
    354   (let* (
    355     (oval
    356       (cond
    357         ((box-structure-immutable? box)
    358           (error-box-mutable 'box-swap! box))
    359         ((box-structure-mutable? box) (box-structure-mutable-value box))
    360         (else
    361           (case (%box-closure-tag box)
    362             ((boxvar! boxloc!) (%box-closure-ref box) )
    363             ((boxvar boxloc)
    364               (error-box-mutable 'box-swap! box) )
    365             (else
    366               (error-box 'box-swap! box) ) ) ) ) )
    367     (nval
    368       (apply func oval args)) )
    369     (cond
    370       ((box-structure-mutable? box) (box-structure-mutable-value-set! box nval))
    371       (else                         (%box-closure-set! box nval)) )
    372     nval ) )
    373 
    374 ;; Assessors
    375 
    376 (: box-ref (box -> *))
    377 ;
    378 (define box-ref
    379   (getter-with-setter *box-ref box-set!))
    380 
    381 (: box-location (box #!optional boolean -> locative))
    382 ;
    383 (define (box-location box #!optional (weak? #f))
    384   (cond
    385     ((%box-structure? box)
    386       ((if weak? make-weak-locative make-locative) box 1))
    387     ((%box-closure? box)
    388       (box (lambda (ref set loc) (loc))))
    389     (else
    390       (error-box 'box-location box)) ) )
    391 
    392 ;;; Read/Print Syntax
    393 
    394 (define (box-print box port)
    395   (let (
    396     (val
    397       (cond
    398         ((%box-structure? box)  (%box-structure-ref box))
    399         ((%box-closure? box)    (%box-closure-ref box))
    400         (else
    401           (error-box 'box-print box)) ) ) )
    402           (display "#&" port) (write val port) ) )
    403 
    404 (set-sharp-read-syntax! #\&
    405   (lambda (p)
    406     (make-box-mutable (read p))))
    407 
    408 (define-reader-ctor 'box make-box)
    409 
    410 (define-record-printer (box box port) (box-print box port))
    411 (define-record-printer (box! box port) (box-print box port))
     9(import box-core)
     10(reexport box-core)
     11(import srfi-111)
     12(reexport srfi-111)
    41213
    41314) ;module box
  • release/5/box/trunk/srfi-111.scm

    r38539 r38548  
    1818(import (chicken type))
    1919(import (only (chicken platform) register-feature!))
    20 (import box)
     20(import box-core)
    2121
    2222;;;
Note: See TracChangeset for help on using the changeset viewer.