Changeset 38548 in project

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:

• box-core.scm (added)
• box.egg (modified) (2 diffs)
• box.scm (modified) (1 diff)
• srfi-111.scm (modified) (1 diff)

release/5/box/trunk/box.egg

@@ -3 +3 @@
 
 ((synopsis "Boxing")
- (version "3.2.0")
+ (version "3.2.1")
  (category data)
  (license "BSD")
@@ -10 +10 @@
  (test-dependencies test)
 (components
-  (extension box
+  (extension box-core
     (types-file)
     ;no -strict-types"; has generic returns; ex: make-box
     (csc-options
       "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
+  (extension box
+    (types-file)
+    (component-dependencies box-core srfi-111)
+    (csc-options
+      "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
   (extension srfi-111
     (types-file)
-    (component-dependencies box)
+    (component-dependencies box-core)
     (csc-options
-      "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
+      "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )

release/5/box/trunk/box.scm

@@ -1 +1 @@
 ;;;; box.scm  -*- Scheme -*-
 ;;;; Kon Lovett, Apr '20
-;;;; Kon Lovett, Jul '18
-;;;; Kon Lovett, May '17
-;;;; Kon Lovett, Oct '08
 
-;; Issues
-;;
-;; - All operations inlined & primitive due to high-performance nature.
-;;
-;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
-
-(declare
-  (disable-interrupts))
-
-(module box
-
-(;export
-  make-box
-  make-box-mutable
-  make-box-immutable
-  make-box-variable
-  make-box-location
-  box?
-  box-variable?
-  box-location?
-  box-mutable?
-  box-immutable?
-  box-set!
-  box-ref
-  box-swap!
-  box-location
-  make-box-variable-closure
-  make-box-location-closure
-  ;
-  *box-structure?
-  *box-structure-ref
-  *box-structure-set!
-  *box-procedure?
-  *box-procedure-ref
-  *box-procedure-set!)
+(module box ()
 
 (import scheme)
-(import (chicken base))
-(import (chicken syntax))
-(import (chicken type))
-(import (chicken foreign))
-(import (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!))
-(import (only (chicken port) with-output-to-port with-output-to-string))
-(import (only (chicken memory representation) extend-procedure procedure-data))
-(import (only (chicken locative) make-weak-locative make-locative))
-(import (only type-errors define-error-type))
+(import (chicken module))
 
-;;;
-
-;;
-
-(define-type box-struct (or (struct box) (struct box!)))
-(define-type box-closure ((* * * -> *) -> *))
-(define-type box (or box-struct box-closure))
-
-;;; Prelude
-
-(define-inline (->boolean x) (and x #t))
-
-;;; Box Structure Support
-
-(define-record box structure-immutable-value)
-(define-record-type box
-  (make-box-structure-immutable value)
-  box-structure-immutable?
-  (value box-structure-immutable-value box-structure-immutable-value-set!))
-
-(define-record box! structure-mutable-value)
-(define-record-type box!
-  (make-box-structure-mutable value)
-  box-structure-mutable?
-  (value box-structure-mutable-value box-structure-mutable-value-set!))
-
-(define-inline (%box-structure? obj)
-  (or
-    (box-structure-mutable? obj)
-    (box-structure-immutable? obj)) )
-
-(define-inline (%box-structure-ref box)
-  (cond
-    ((box-structure-mutable? box) (box-structure-mutable-value box))
-    ((box-structure-immutable? box) (box-structure-immutable-value box)) ) )
-
-(define-inline (%box-structure-set! box val)
-  (cond
-    ((box-structure-mutable? box) (box-structure-mutable-value-set! box val))
-    ((box-structure-immutable? box) (box-structure-immutable-value-set! box val)) ) )
-
-;;; Box Procedure Support
-
-;; Box Variable
-
-(define-inline (%box-variable-immutable-tag? obj)
-  (eq? 'boxvar obj) )
-
-(define-inline (%box-variable-mutable-tag? obj)
-  (eq? 'boxvar! obj) )
-
-(define-inline (%box-variable-tag? obj)
-  (or
-    (%box-variable-mutable-tag? obj)
-    (%box-variable-immutable-tag? obj) ) )
-
-(define-inline (%box-variable? obj)
-  (and-let* (
-    (dat (procedure-data obj)) )
-    (%box-variable-tag? dat) ) )
-
-;; Box Location
-
-(define-inline (%box-location-immutable-tag? obj)
-  (eq? 'boxloc obj) )
-
-(define-inline (%box-location-mutable-tag? obj)
-  (eq? 'boxloc! obj) )
-
-(define-inline (%box-location-tag? obj)
-  (or
-    (%box-location-mutable-tag? obj)
-    (%box-location-immutable-tag? obj) ) )
-
-(define-inline (%box-location? obj)
-  (and-let* (
-    (dat (procedure-data obj)) )
-    (%box-location-tag? dat) ) )
-
-;; Box Procedure
-
-(define-inline (%box-closure-tag? obj)
-  (or (%box-variable-tag? obj) (%box-location-tag? obj)) )
-
-(define-inline (%box-closure-tag obj)
-  (and-let* (
-    (dat (procedure-data obj))
-    ((%box-closure-tag? dat)) )
-    dat ) )
-
-(define-inline (%box-closure? obj)
-  (->boolean (%box-closure-tag obj)) )
-
-(define-inline (%box-closure-immutable? obj)
-  (and-let* (
-    (dat (procedure-data obj)) )
-    (or
-      (%box-variable-immutable-tag? dat)
-      (%box-location-immutable-tag? dat) ) ) )
-
-(define-inline (%box-closure-mutable? obj)
-  (and-let* (
-    (dat (procedure-data obj)) )
-    (or
-      (%box-variable-mutable-tag? dat)
-      (%box-location-mutable-tag? dat) ) ) )
-
-;; Box Procedure Operations
-
-(define-inline (%box-closure-ref box)
-  (box (lambda (ref set loc) (ref))) )
-
-(define-inline (%box-closure-set! box obj)
-  (box (lambda (ref set loc) (set obj))) )
-
-(define-inline (%box-closure-location box)
-  (box (lambda (ref set loc) (loc))) )
-
-;;
-
-(define-inline (%box? obj)
-  (or
-    (%box-structure? obj)
-    (%box-closure? obj)) )
-
-;; Errors
-
-(define-error-type box-mutable)
-(define-error-type box)
-
-;; Finishers
-
-(: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
-;
-(define (make-box-variable-closure immutable? ref set)
-  (let (
-    (tag (if immutable? 'boxvar 'boxvar!)) )
-    (extend-procedure
-      (lambda (proc)
-        (proc ref set (lambda () (location (ref)))) )
-      tag) ) )
-
-(: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> box-closure))
-;
-(define (make-box-location-closure immutable? ref set refloc)
-  (let (
-    (tag (if immutable? 'boxloc 'boxloc!)) )
-    (extend-procedure
-      (lambda (proc) (proc ref set refloc) )
-      tag) ) )
-
-;;; Box
-
-;; Direct calls
-;; For use by high-performance routines (such as core routine replacements)
-
-(: *box-structure? (* -> boolean : box-struct))
-;
-(define (*box-structure? obj)
-  (%box-structure? obj) )
-
-(: *box-structure-ref (box-struct -> *))
-;
-(define (*box-structure-ref box)
-  (%box-structure-ref box) )
-
-(: *box-structure-set! (box-struct * -> void))
-;
-(define (*box-structure-set! box val)
-  (%box-structure-set! box val) )
-
-(: *box-procedure? (* -> boolean : box-closure))
-;
-(define (*box-procedure? obj)
-  (%box-closure? obj) )
-
-(: box-procedure-ref (box-closure -> *))
-;
-(define (*box-procedure-ref box)
-  (%box-closure-ref box) )
-
-(: *box-procedure-set! (box-closure * -> void))
-;
-(define (*box-procedure-set! box val)
-  (%box-closure-set! box val) )
-
-(: *box-ref (box -> *))
-;
-(define (*box-ref box)
-  (cond
-    ((%box-structure? box)  (%box-structure-ref box))
-    ((%box-closure? box)    (%box-closure-ref box))
-    (else
-      (error-box 'box-ref box 'box)) ) )
-
-;; Constructers
-
-(define-syntax make-box-variable
-  (syntax-rules ()
-    ;
-    ((make-box-variable ?var)
-      (make-box-variable ?var #f) )
-    ;
-    ((make-box-variable ?var ?immutable?)
-      #;(identifier? ?var)
-      (make-box-variable-closure
-        ?immutable?
-        (lambda () ?var)
-        (if ?immutable? void (lambda (val) (set! ?var val)))) ) ) )
-
-(define-syntax make-box-location
-  (syntax-rules ()
-    ;
-    ((make-box-location ?typ ?val)
-      (make-box-location ?typ ?val #f) )
-    ;
-    ((make-box-location ?typ ?val ?immutable?)
-      #;(identifier? ?typ)
-      (let-location ((var ?typ ?val))
-        (make-box-location-closure
-          ?immutable?
-          (lambda () var)
-          (if ?immutable? void (lambda (val) (set! var val)))
-          (lambda () (location var))) ) ) ) )
-
-(: make-box (#!optional * boolean -> box-struct))
-;
-(define (make-box #!optional init immutable?)
-  (if immutable?
-    (make-box-structure-immutable init)
-    (make-box-structure-mutable init) ) )
-
-(: make-box-immutable (#!optional * -> box-struct))
-;
-(define (make-box-immutable #!optional init)
-  (make-box-structure-immutable init) )
-
-(: make-box-mutable (#!optional * -> box-struct))
-;
-(define (make-box-mutable #!optional init)
-  (make-box-structure-mutable init) )
-
-;; Predicates
-
-(: box? (* -> boolean : box))
-;
-(define (box? obj)
-  (%box? obj) )
-
-;NOTE these are trait predicates, not type predicates, so not a (DOM -> RNG : TYPE)!
-
-(: box-variable? (* -> boolean))
-;
-(define (box-variable? obj)
-  (%box-variable? obj) )
-
-(: box-location? (* -> boolean))
-;
-(define (box-location? obj)
-  (%box-location? obj) )
-
-(: box-immutable? (* -> boolean))
-;
-(define (box-immutable? obj)
-  (or (box-structure-immutable? obj) (%box-closure-immutable? obj)) )
-
-(: box-mutable? (* -> boolean))
-;
-(define (box-mutable? obj)
-  (or (box-structure-mutable? obj) (%box-closure-mutable? obj)) )
-
-;; Mutators
-
-
-(: box-set! (box * -> void))
-;
-(define (box-set! box val)
-  (cond
-    ((box-structure-immutable? box)
-      (error-box-mutable 'box-set! box) )
-    ((box-structure-mutable? box) (box-structure-mutable-value-set! box val) )
-    (else
-      (case (%box-closure-tag box)
-        ((boxvar! boxloc!) (%box-closure-set! box val) )
-        ((boxvar boxloc)
-          (error-box-mutable 'box-set! box) )
-        (else
-          (error-box 'box-set! box) ) ) ) ) )
-
-#; ;inlined version below
-(define (box-swap! box func . args)
-  (let* (
-    (oval (*box-ref box))
-    (nval (apply func oval args)) )
-    (box-set! box nval)
-    nval ) )
-
-(: box-swap! (box (* #!rest * -> *) #!rest * -> *))
-;
-(define (box-swap! box func . args)
-  (let* (
-    (oval
-      (cond
-        ((box-structure-immutable? box)
-          (error-box-mutable 'box-swap! box))
-        ((box-structure-mutable? box) (box-structure-mutable-value box))
-        (else
-          (case (%box-closure-tag box)
-            ((boxvar! boxloc!) (%box-closure-ref box) )
-            ((boxvar boxloc)
-              (error-box-mutable 'box-swap! box) )
-            (else
-              (error-box 'box-swap! box) ) ) ) ) )
-    (nval
-      (apply func oval args)) )
-    (cond
-      ((box-structure-mutable? box) (box-structure-mutable-value-set! box nval))
-      (else                         (%box-closure-set! box nval)) )
-    nval ) )
-
-;; Assessors
-
-(: box-ref (box -> *))
-;
-(define box-ref
-  (getter-with-setter *box-ref box-set!))
-
-(: box-location (box #!optional boolean -> locative))
-;
-(define (box-location box #!optional (weak? #f))
-  (cond
-    ((%box-structure? box)
-      ((if weak? make-weak-locative make-locative) box 1))
-    ((%box-closure? box)
-      (box (lambda (ref set loc) (loc))))
-    (else
-      (error-box 'box-location box)) ) )
-
-;;; Read/Print Syntax
-
-(define (box-print box port)
-  (let (
-    (val
-      (cond
-        ((%box-structure? box)  (%box-structure-ref box))
-        ((%box-closure? box)    (%box-closure-ref box))
-        (else
-          (error-box 'box-print box)) ) ) )
-          (display "#&" port) (write val port) ) )
-
-(set-sharp-read-syntax! #\&
-  (lambda (p)
-    (make-box-mutable (read p))))
-
-(define-reader-ctor 'box make-box)
-
-(define-record-printer (box box port) (box-print box port))
-(define-record-printer (box! box port) (box-print box port))
+(import box-core)
+(reexport box-core)
+(import srfi-111)
+(reexport srfi-111)
 
 ) ;module box

release/5/box/trunk/srfi-111.scm

@@ -18 +18 @@
 (import (chicken type))
 (import (only (chicken platform) register-feature!))
-(import box)
+(import box-core)
 
 ;;;