Changeset 38539 in project


Ignore:
Timestamp:
04/03/20 22:43:34 (13 months ago)
Author:
Kon Lovett
Message:

*-test runner, style, remove primitive-inlines, separate srfi-111 module, added make-box-mutable & make-box-immutable, no strict-types since has box "generic"

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

Legend:

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

    r38529 r38539  
    33
    44((synopsis "Boxing")
    5  (version "3.1.1")
     5 (version "3.2.0")
    66 (category data)
    77 (license "BSD")
     
    1212  (extension box
    1313    (types-file)
     14    ;no -strict-types"; has generic returns; ex: make-box
    1415    (csc-options
    15       "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") ) ) )
     16      "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     17  (extension srfi-111
     18    (types-file)
     19    (component-dependencies box)
     20    (csc-options
     21      "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
  • release/5/box/trunk/box.scm

    r38529 r38539  
    11;;;; box.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Apr '20
    23;;;; Kon Lovett, Jul '18
    34;;;; Kon Lovett, May '17
     
    1112
    1213(declare
    13   (disable-interrupts)
    14   (bound-to-procedure ##sys#procedure->string))
     14  (disable-interrupts))
    1515
    1616(module box
    1717
    1818(;export
    19   ;
    2019  make-box
     20  make-box-mutable
     21  make-box-immutable
    2122  make-box-variable
    2223  make-box-location
    23   box? box-variable?
     24  box?
     25  box-variable?
    2426  box-location?
    2527  box-mutable?
     
    3133  make-box-variable-closure
    3234  make-box-location-closure
    33   ;SRFI 111
    34   box
    35   immutable-box
    36   set-box!
    37   unbox
    3835  ;
    3936  *box-structure?
     
    4643(import scheme)
    4744(import (chicken base))
     45(import (chicken syntax))
    4846(import (chicken type))
    4947(import (chicken foreign))
    50 (import (only (chicken platform) register-feature!))
    5148(import (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!))
    5249(import (only (chicken port) with-output-to-port with-output-to-string))
     
    6360(define-type box (or box-struct box-closure))
    6461
    65 ;;
    66 
    67 (: ##sys#procedure->string (* -> string))
    68 
    6962;;; Prelude
    7063
    71 (include "chicken-primitive-object-inlines")
     64(define-inline (->boolean x) (and x #t))
    7265
    7366;;; Box Structure Support
    7467
    75 (define-inline (%make-box tag init)
    76   (%make-structure tag init) )
    77 
    78 (define-inline (%box-structure-mutable? obj)
    79   (%structure-instance? obj 'box!) )
    80 
    81 (define-inline (%box-structure-immutable? obj)
    82   (%structure-instance? obj 'box) )
     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!))
    8379
    8480(define-inline (%box-structure? obj)
    85   (and
    86     (or
    87       (%box-structure-mutable? obj)
    88       (%box-structure-immutable? obj))
    89     (%fx= 2 (%structure-length obj)) ) )
    90 
    91 (define-inline (%box-structure-tag obj)
    92   (and
    93     (%box-structure? obj)
    94     (%structure-tag obj)) )
     81  (or
     82    (box-structure-mutable? obj)
     83    (box-structure-immutable? obj)) )
    9584
    9685(define-inline (%box-structure-ref box)
    97   (%structure-ref box 1) )
    98 
    99 (define-inline (%box-structure-set! box obj)
    100   (%structure-set! box 1 obj) )
     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)) ) )
    10194
    10295;;; Box Procedure Support
     
    10598
    10699(define-inline (%box-variable-immutable-tag? obj)
    107   (%eq? 'boxvar obj) )
     100  (eq? 'boxvar obj) )
    108101
    109102(define-inline (%box-variable-mutable-tag? obj)
    110   (%eq? 'boxvar! obj) )
     103  (eq? 'boxvar! obj) )
    111104
    112105(define-inline (%box-variable-tag? obj)
     
    123116
    124117(define-inline (%box-location-immutable-tag? obj)
    125   (%eq? 'boxloc obj) )
     118  (eq? 'boxloc obj) )
    126119
    127120(define-inline (%box-location-mutable-tag? obj)
    128   (%eq? 'boxloc! obj) )
     121  (eq? 'boxloc! obj) )
    129122
    130123(define-inline (%box-location-tag? obj)
     
    150143
    151144(define-inline (%box-closure? obj)
    152   (%->boolean (%box-closure-tag obj)) )
     145  (->boolean (%box-closure-tag obj)) )
    153146
    154147(define-inline (%box-closure-immutable? obj)
     
    249242(define (*box-ref box)
    250243  (cond
    251     ((%box-structure? box)
    252       (%box-structure-ref box) )
    253     ((%box-closure? box)
    254       (%box-closure-ref box) )
     244    ((%box-structure? box)  (%box-structure-ref box))
     245    ((%box-closure? box)    (%box-closure-ref box))
    255246    (else
    256       (error-box 'box-ref box 'box) ) ) )
     247      (error-box 'box-ref box 'box)) ) )
    257248
    258249;; Constructers
     
    261252  (syntax-rules ()
    262253    ;
    263     ((_ ?var)
     254    ((make-box-variable ?var)
    264255      (make-box-variable ?var #f) )
    265256    ;
    266     ((_ ?var ?immutable?)
    267      #;(identifier? ?var)
    268      (make-box-variable-closure
     257    ((make-box-variable ?var ?immutable?)
     258      #;(identifier? ?var)
     259      (make-box-variable-closure
    269260        ?immutable?
    270261        (lambda () ?var)
     
    274265  (syntax-rules ()
    275266    ;
    276     ((_ ?typ ?val)
     267    ((make-box-location ?typ ?val)
    277268      (make-box-location ?typ ?val #f) )
    278269    ;
    279     ((_ ?typ ?val ?immutable?)
    280      #;(identifier? ?typ)
    281      (let-location ((var ?typ ?val))
    282        (make-box-location-closure
     270    ((make-box-location ?typ ?val ?immutable?)
     271      #;(identifier? ?typ)
     272      (let-location ((var ?typ ?val))
     273        (make-box-location-closure
    283274          ?immutable?
    284275          (lambda () var)
     
    289280;
    290281(define (make-box #!optional init immutable?)
    291   (%make-box (if immutable? 'box 'box!) init) )
     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) )
    292295
    293296;; Predicates
     
    313316;
    314317(define (box-immutable? obj)
    315   (or (%box-structure-immutable? obj) (%box-closure-immutable? obj)) )
     318  (or (box-structure-immutable? obj) (%box-closure-immutable? obj)) )
    316319
    317320(: box-mutable? (* -> boolean))
    318321;
    319322(define (box-mutable? obj)
    320   (or (%box-structure-mutable? obj) (%box-closure-mutable? obj)) )
     323  (or (box-structure-mutable? obj) (%box-closure-mutable? obj)) )
    321324
    322325;; Mutators
     
    326329;
    327330(define (box-set! box val)
    328   (case (%box-structure-tag box)
    329     ((box!)
    330       (%box-structure-set! box val) )
    331     ((box)
     331  (cond
     332    ((box-structure-immutable? box)
    332333      (error-box-mutable 'box-set! box) )
     334    ((box-structure-mutable? box) (box-structure-mutable-value-set! box val) )
    333335    (else
    334336      (case (%box-closure-tag box)
    335         ((boxvar! boxloc!)
    336           (%box-closure-set! box val) )
     337        ((boxvar! boxloc!) (%box-closure-set! box val) )
    337338        ((boxvar boxloc)
    338339          (error-box-mutable 'box-set! box) )
     
    352353(define (box-swap! box func . args)
    353354  (let* (
    354     (btag
    355       (%box-structure-tag box))
    356355    (oval
    357       (case btag
    358         ((box!)
    359           (%box-structure-ref box) )
    360         ((box)
    361           (error-box-mutable 'box-swap! box) )
     356      (cond
     357        ((box-structure-immutable? box)
     358          (error-box-mutable 'box-swap! box))
     359        ((box-structure-mutable? box) (box-structure-mutable-value box))
    362360        (else
    363361          (case (%box-closure-tag box)
    364             ((boxvar! boxloc!)
    365               (%box-closure-ref box) )
     362            ((boxvar! boxloc!) (%box-closure-ref box) )
    366363            ((boxvar boxloc)
    367364              (error-box-mutable 'box-swap! box) )
     
    370367    (nval
    371368      (apply func oval args)) )
    372     (case btag
    373       ((box!)
    374         (%box-structure-set! box nval) )
    375       (else
    376         (%box-closure-set! box nval) ) )
     369    (cond
     370      ((box-structure-mutable? box) (box-structure-mutable-value-set! box nval))
     371      (else                         (%box-closure-set! box nval)) )
    377372    nval ) )
    378373
     
    393388      (box (lambda (ref set loc) (loc))))
    394389    (else
    395       (error-box 'box-location box))))
    396 
    397 ;;; SRFI-111 Style
    398 
    399 (define-syntax box
    400   (syntax-rules ()
    401     ((box ?arg0 ...)
    402       (make-box ?arg0 ...))))
    403 
    404 (define-syntax immutable-box
    405   (syntax-rules ()
    406     ((immutable-box ?arg0 ...)
    407       (make-box ?arg0 ... #t))))
    408 
    409 (define-syntax unbox
    410   (syntax-rules ()
    411     ((unbox ?box)
    412       (box-ref ?box))))
    413 
    414 (define-syntax set-box!
    415   (syntax-rules ()
    416     ((set-box! ?box ?val)
    417       (box-set! ?box ?val))))
    418 
     390      (error-box 'box-location box)) ) )
    419391
    420392;;; Read/Print Syntax
    421393
    422 (set-sharp-read-syntax! #\&
    423   (lambda (p)
    424     (make-box (read p))))
    425 
    426 (define-reader-ctor 'box make-box)
    427 
    428 (define (*box-print box port)
    429   (with-output-to-port port (lambda () (%box-print box))) )
    430 
    431 (define-record-printer (box x p) (*box-print x p))
    432 (define-record-printer (box! x p) (*box-print x p))
    433 
    434 (set! ##sys#procedure->string
    435   (let ((##sys#procedure->string ##sys#procedure->string))
    436     (lambda (x)
    437                         (if (%box? x)
    438                           (with-output-to-string (lambda () (%box-print x)))
    439         (##sys#procedure->string x)))))
    440 
    441 ;; Print
    442 
    443 (define (%box-print box)
     394(define (box-print box port)
    444395  (let (
    445396    (val
    446397      (cond
    447         ((%box-structure? box)
    448           (%box-structure-ref box))
    449         ((%box-closure? box)
    450           (%box-closure-ref box))
     398        ((%box-structure? box)  (%box-structure-ref box))
     399        ((%box-closure? box)    (%box-closure-ref box))
    451400        (else
    452           (error-box 'box-print box)))))
    453           (display "#&") (write val) ) )
    454 
    455 ;;;
    456 
    457 (register-feature! 'srfi-111)
     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))
    458412
    459413) ;module box
  • release/5/box/trunk/tests/box-test.scm

    r38529 r38539  
    66(test-begin "Box")
    77
     8;;;
     9
    810(import box)
    9 
    10 ;;;
     11(import (chicken base))
     12(import (only (chicken port) with-output-to-string))
    1113
    1214;;
     
    1517        (let ((tbox (make-box (void))))
    1618    (test-assert (box? tbox))
     19    (test "#&#<unspecified>" (with-output-to-string (cut display tbox)))
    1720    (box-set! tbox #t)
    1821    (test-assert (box-ref tbox))
     
    2326        (let ((tbox (make-box #f #t)))
    2427    (test-assert (box? tbox))
     28    (test "#&#f" (with-output-to-string (cut display tbox)))
    2529    (test-assert (not (box-ref tbox)))
    2630    (test-error (box-set! tbox #t)) )
     
    5660
    5761(import (only (chicken platform) features))
     62(import (srfi 111))
    5863
    5964(test-group "Feature"
     
    7782)
    7883
    79 (test-group "Immutable-Box"
     84(test-group "Immutable Box"
    8085        (let ((tbox (immutable-box #f)))
    8186    (test-assert (box? tbox))
Note: See TracChangeset for help on using the changeset viewer.