Changeset 35239 in project


Ignore:
Timestamp:
03/04/18 21:29:34 (9 months ago)
Author:
kon
Message:

re-flow, add make-box-variable-closure & make-box-location-closure, mv types to define

Location:
release/4/box/trunk
Files:
1 added
4 edited

Legend:

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

    r27985 r35239  
    1111  (check-errors "1.9.0"))
    1212 (test-depends test)
    13  (files "box.meta" "box.setup" "chicken-primitive-object-inlines.scm" "box.scm" "tests/run.scm"))
     13 (files
     14  "box.meta" "box.setup"
     15  "chicken-primitive-object-inlines.scm" "box.scm"
     16  "tests/run.scm" "tests/box-test.scm"))
  • release/4/box/trunk/box.scm

    r34402 r35239  
    1313(;export
    1414  ;;
    15   make-box (make-box-variable $finvar) (make-box-location $finloc)
     15  make-box
     16  make-box-variable
     17  make-box-location
    1618  box? box-variable? box-location?
    1719  box-mutable? box-immutable?
     
    1921  box-swap!
    2022  box-location
     23  make-box-variable-closure
     24  make-box-location-closure
    2125  ;;
    2226  box set-box! unbox
     
    2529  *box-procedure? *box-procedure-ref *box-procedure-set!)
    2630
    27 (import scheme)
    28 
    29 (import chicken foreign)
    30 
    31 (import
     31(import scheme chicken foreign)
     32(use
    3233  (only ports
    3334    with-output-to-port
     
    3536  (only lolevel
    3637    extend-procedure procedure-data
    37     make-weak-locative make-locative))
    38 (require-library ports lolevel)
    39 
    40 (import (only type-errors define-error-type) )
    41 (require-library type-errors)
     38    make-weak-locative make-locative)
     39  (only type-errors define-error-type) )
    4240
    4341(declare
    4442  (bound-to-procedure
    45     ##sys#signal-hook
    4643    ##sys#procedure->string ) )
    4744
     
    5451(: ##sys#procedure->string (* -> string))
    5552
    56 (: $finloc (symbol (-> *) (* -> undefined) (-> locative) -> box-closure))
    57 (: $finvar (symbol (-> *) (* -> undefined) -> box-closure))
    58 
    59 (: make-box (#!optional * boolean -> box-struct))
    60 
    61 (: box? (* -> boolean : box))
    62 (: box-variable? (* -> boolean : box-closure))
    63 (: box-location? (* -> boolean : box-closure))
    64 (: box-immutable? (* -> boolean : box))
    65 (: box-mutable? (* -> boolean : box))
    66 
    67 (: box-set! (box * -> undefined))
    68 (: box-ref (box -> *))
    69 (: box-swap! (box (* #!rest * -> *) #!rest * -> *))
    70 
    71 (: box-location (box #!optional boolean -> locative))
    72 
    73 (: *box-ref (box -> *))
    74 
    75 (: *box-structure? (* -> boolean : box-struct))
    76 (: *box-structure-ref (box-struct -> *))
    77 (: *box-structure-set! (box-struct * -> undefined))
    78 
    79 (: *box-procedure? (* -> boolean : box-closure))
    80 (: box-procedure-ref (box-closure -> *))
    81 (: *box-procedure-set! (box-closure * -> undefined))
    82 
    8353;;; Prelude
    8454
     
    9767
    9868(define-inline (%box-structure? obj)
    99   (and (or (%box-structure-mutable? obj) (%box-structure-immutable? obj))
    100        (%fx= 2 (%structure-length obj)) ) )
     69  (and
     70    (or
     71      (%box-structure-mutable? obj)
     72      (%box-structure-immutable? obj))
     73    (%fx= 2 (%structure-length obj)) ) )
    10174
    10275(define-inline (%box-structure-tag obj)
    103   (and (%box-structure? obj) (%structure-tag obj)) )
     76  (and
     77    (%box-structure? obj)
     78    (%structure-tag obj)) )
    10479
    10580(define-inline (%box-structure-ref box)
     
    12095
    12196(define-inline (%box-variable-tag? obj)
    122   (or (%box-variable-mutable-tag? obj) (%box-variable-immutable-tag? obj) ) )
     97  (or
     98    (%box-variable-mutable-tag? obj)
     99    (%box-variable-immutable-tag? obj) ) )
    123100
    124101(define-inline (%box-variable? obj)
    125   (and-let* ((dat (procedure-data obj)))
     102  (and-let* (
     103    (dat (procedure-data obj)) )
    126104    (%box-variable-tag? dat) ) )
    127105
     
    135113
    136114(define-inline (%box-location-tag? obj)
    137   (or (%box-location-mutable-tag? obj) (%box-location-immutable-tag? obj) ) )
     115  (or
     116    (%box-location-mutable-tag? obj)
     117    (%box-location-immutable-tag? obj) ) )
    138118
    139119(define-inline (%box-location? obj)
    140   (and-let* ((dat (procedure-data obj)))
     120  (and-let* (
     121    (dat (procedure-data obj)) )
    141122    (%box-location-tag? dat) ) )
    142123
     
    147128
    148129(define-inline (%box-closure-tag obj)
    149   (and-let* ((dat (procedure-data obj))
    150              ((%box-closure-tag? dat)))
     130  (and-let* (
     131    (dat (procedure-data obj))
     132    ((%box-closure-tag? dat)) )
    151133    dat ) )
    152134
     
    155137
    156138(define-inline (%box-closure-immutable? obj)
    157   (and-let* ((dat (procedure-data obj)))
    158     (or (%box-variable-immutable-tag? dat) (%box-location-immutable-tag? dat) ) ) )
     139  (and-let* (
     140    (dat (procedure-data obj)) )
     141    (or
     142      (%box-variable-immutable-tag? dat)
     143      (%box-location-immutable-tag? dat) ) ) )
    159144
    160145(define-inline (%box-closure-mutable? obj)
    161   (and-let* ((dat (procedure-data obj)))
    162     (or (%box-variable-mutable-tag? dat) (%box-location-mutable-tag? dat) ) ) )
     146  (and-let* (
     147    (dat (procedure-data obj)) )
     148    (or
     149      (%box-variable-mutable-tag? dat)
     150      (%box-location-mutable-tag? dat) ) ) )
    163151
    164152;; Box Procedure Operations
     
    176164
    177165(define-inline (%box? obj)
    178   (or (%box-structure? obj) (%box-closure? obj)) )
     166  (or
     167    (%box-structure? obj)
     168    (%box-closure? obj)) )
    179169
    180170;; Errors
     
    183173(define-error-type box)
    184174
    185 ;; Print
    186 
    187 (define-inline (%box-print box)
    188   (let ((val
    189           (cond
    190             ((%box-structure? box)
    191               (%box-structure-ref box))
    192             ((%box-closure? box)
    193               (%box-closure-ref box))
    194             (else
    195               (error-box 'box-print box)))))
    196           (display "#&") (write val) ) )
    197 
    198175;; Finishers
    199176
    200 (define ($finvar tag ref set)
    201   (extend-procedure
    202     (lambda (proc)
    203       (proc ref set (lambda () (location (ref)))) )
    204     tag) )
    205 
    206 (define ($finloc tag ref set loc)
    207   (extend-procedure
    208     (lambda (proc) (proc ref set loc) )
    209     tag) )
     177(: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
     178;
     179(define (make-box-variable-closure immutable? ref set)
     180  (let (
     181    (tag (if immutable? 'boxvar 'boxvar!)) )
     182    (extend-procedure
     183      (lambda (proc)
     184        (proc ref set (lambda () (location (ref)))) )
     185      tag) ) )
     186
     187(: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> box-closure))
     188;
     189(define (make-box-location-closure immutable? ref set refloc)
     190  (let (
     191    (tag (if immutable? 'boxloc 'boxloc!)) )
     192    (extend-procedure
     193      (lambda (proc) (proc ref set refloc) )
     194      tag) ) )
    210195
    211196;;; Box
     
    214199;; For use by high-performance routines (such as core routine replacements)
    215200
     201(: *box-structure? (* -> boolean : box-struct))
     202;
    216203(define (*box-structure? obj)
    217204  (%box-structure? obj) )
    218205
     206(: *box-structure-ref (box-struct -> *))
     207;
    219208(define (*box-structure-ref box)
    220209  (%box-structure-ref box) )
    221210
     211(: *box-structure-set! (box-struct * -> void))
     212;
    222213(define (*box-structure-set! box val)
    223214  (%box-structure-set! box val) )
    224215
     216(: *box-procedure? (* -> boolean : box-closure))
     217;
    225218(define (*box-procedure? obj)
    226219  (%box-closure? obj) )
    227220
     221(: box-procedure-ref (box-closure -> *))
     222;
    228223(define (*box-procedure-ref box)
    229224  (%box-closure-ref box) )
    230225
     226(: *box-procedure-set! (box-closure * -> void))
     227;
    231228(define (*box-procedure-set! box val)
    232229  (%box-closure-set! box val) )
    233230
     231(: *box-ref (box -> *))
     232;
    234233(define (*box-ref box)
    235234  (cond
     
    245244(define-syntax make-box-variable
    246245  (syntax-rules ()
     246    ;
    247247    ((_ ?var)
    248248      (make-box-variable ?var #f) )
     249    ;
    249250    ((_ ?var ?immutable?)
    250251     #;(identifier? ?var)
    251      ($finvar
    252         (if ?immutable? 'boxvar 'boxvar!)
     252     (make-box-variable-closure
     253        ?immutable?
    253254        (lambda () ?var)
    254255        (if ?immutable? void (lambda (val) (set! ?var val)))) ) ) )
     
    256257(define-syntax make-box-location
    257258  (syntax-rules ()
     259    ;
    258260    ((_ ?typ ?val)
    259261      (make-box-location ?typ ?val #f) )
     262    ;
    260263    ((_ ?typ ?val ?immutable?)
    261264     #;(identifier? ?typ)
    262265     (let-location ((var ?typ ?val))
    263        ($finloc
    264           (if ?immutable? 'boxloc 'boxloc!)
     266       (make-box-location-closure
     267          ?immutable?
    265268          (lambda () var)
    266269          (if ?immutable? void (lambda (val) (set! var val)))
    267270          (lambda () (location var))) ) ) ) )
    268271
     272(: make-box (#!optional * boolean -> box-struct))
     273;
    269274(define (make-box #!optional init immutable?)
    270275  (%make-box (if immutable? 'box 'box!) init) )
     
    272277;; Predicates
    273278
     279(: box? (* -> boolean : box))
     280;
    274281(define (box? obj)
    275282  (%box? obj) )
    276283
     284(: box-variable? (* -> boolean : box-closure))
     285;
    277286(define (box-variable? obj)
    278287  (%box-variable? obj) )
    279288
     289(: box-location? (* -> boolean : box-closure))
     290;
    280291(define (box-location? obj)
    281292  (%box-location? obj) )
    282293
     294(: box-immutable? (* -> boolean : box))
     295;
    283296(define (box-immutable? obj)
    284297  (or (%box-structure-immutable? obj) (%box-closure-immutable? obj)) )
    285298
     299(: box-mutable? (* -> boolean : box))
     300;
    286301(define (box-mutable? obj)
    287302  (or (%box-structure-mutable? obj) (%box-closure-mutable? obj)) )
     
    289304;; Mutators
    290305
     306
     307(: box-set! (box * -> void))
     308;
    291309(define (box-set! box val)
    292310  (case (%box-structure-tag box)
     
    304322          (error-box 'box-set! box) ) ) ) ) )
    305323
    306 #; ;Inline version below
     324#; ;inlined version below
    307325(define (box-swap! box func . args)
    308   (let* ((oval (*box-ref box) )
    309          (nval (apply func oval args) ) )
     326  (let* (
     327    (oval (*box-ref box))
     328    (nval (apply func oval args)) )
    310329    (box-set! box nval)
    311330    nval ) )
    312331
     332(: box-swap! (box (* #!rest * -> *) #!rest * -> *))
     333;
    313334(define (box-swap! box func . args)
    314335  (let* (
    315       (btag
    316         (%box-structure-tag box))
    317       (oval
    318         (case btag
    319           ((box!)
    320             (%box-structure-ref box) )
    321           ((box)
    322             (error-box-mutable 'box-swap! box) )
    323           (else
    324             (case (%box-closure-tag box)
    325               ((boxvar! boxloc!)
    326                 (%box-closure-ref box) )
    327               ((boxvar boxloc)
    328                 (error-box-mutable 'box-swap! box) )
    329               (else
    330                 (error-box 'box-swap! box) ) ) ) ) )
    331       (nval
    332         (apply func oval args)) )
     336    (btag
     337      (%box-structure-tag box))
     338    (oval
     339      (case btag
     340        ((box!)
     341          (%box-structure-ref box) )
     342        ((box)
     343          (error-box-mutable 'box-swap! box) )
     344        (else
     345          (case (%box-closure-tag box)
     346            ((boxvar! boxloc!)
     347              (%box-closure-ref box) )
     348            ((boxvar boxloc)
     349              (error-box-mutable 'box-swap! box) )
     350            (else
     351              (error-box 'box-swap! box) ) ) ) ) )
     352    (nval
     353      (apply func oval args)) )
    333354    (case btag
    334355      ((box!)
     
    340361;; Assessors
    341362
    342 (define box-ref (getter-with-setter *box-ref box-set!))
    343 
     363(: box-ref (box -> *))
     364;
     365(define box-ref
     366  (getter-with-setter *box-ref box-set!))
     367
     368(: box-location (box #!optional boolean -> locative))
     369;
    344370(define (box-location box #!optional (weak? #f))
    345371  (cond
     
    390416        (##sys#procedure->string x)))))
    391417
     418;; Print
     419
     420(define (%box-print box)
     421  (let (
     422    (val
     423      (cond
     424        ((%box-structure? box)
     425          (%box-structure-ref box))
     426        ((%box-closure? box)
     427          (%box-closure-ref box))
     428        (else
     429          (error-box 'box-print box)))))
     430          (display "#&") (write val) ) )
     431
    392432) ;module box
  • release/4/box/trunk/box.setup

    r34406 r35239  
    55(verify-extension-name 'box)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.3.4")
     7(setup-shared-extension-module (extension-name) (extension-version "2.4.0")
    88  #:types? #t
    99  #:inline? #t
  • release/4/box/trunk/tests/run.scm

    r34151 r35239  
    1 (require-extension test)
    21
    3 (require-extension box)
     2(define EGG-NAME "box")
    43
    5 (test-group "Box Mutable"
    6         (let ((tbox #f))
    7     (test-assert (make-box (void)))
    8     (set! tbox (make-box (void)))
    9     (test-assert (box? tbox))
    10     (box-set! tbox #t)
    11     (test-assert (box-ref tbox))
    12     (test-assert (not (box? 3))) )
    13 )
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    145
    15 (test-group "Box Immutable"
    16         (let ((tbox #f))
    17     (test-assert (make-box #f #t))
    18     (set! tbox (make-box #f #t))
    19     (test-assert (box? tbox))
    20     (test-assert (not (box-ref tbox)))
    21     (test-error (box-set! tbox #t)) )
    22 )
     6(use files)
    237
    24 (test-group "Box References"
    25         (let ((var (void))
    26         (tbox #f))
    27     (test-assert (make-box-variable var))
    28     (set! tbox (make-box-variable var))
    29     (test-assert (box? tbox))
    30     (test-assert (box-variable? tbox))
    31     (test-assert (not (box-location? tbox)))
    32     (test "Unbound Box" (void) (box-ref tbox))
    33     (set! (box-ref tbox) #t)
    34     (test-assert "Bound Box" (box-ref tbox))
    35     (test-assert "Bound Var" var)
    36     (test-assert (not (box? 3))) )
    37 )
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    3810
    39 (test-group "Box Swap"
    40         (let ((tbox #f))
    41     (test-assert (make-box (void)))
    42     (set! tbox (make-box 0))
    43     (test-assert (box? tbox))
    44     (test 1 (box-swap! tbox + 1))
    45     (test 1 (box-ref tbox))
    46     (test 2 (box-swap! tbox add1))
    47     (test 2 (box-ref tbox)) )
    48 )
     11(define *args* (argv))
    4912
    50 (test-exit)
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
     15
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
     24
     25;;;
     26
     27(set! EGG-NAME (egg-name))
     28
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     37
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.