Changeset 38569 in project

Timestamp:

04/06/20 02:32:23 (11 months ago)

Author:

Kon Lovett

Message:

add types include, fix predicate types, reflow

Location:

release/5/box/trunk

Files:

• box-core.scm (modified) (13 diffs)
• box.egg (modified) (2 diffs)
• box.types.scm (added)
• tests/box-test.scm (modified) (2 diffs)

release/5/box/trunk/box-core.scm

@@ -17 +17 @@
 
 (;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
+  make-box make-box-mutable make-box-immutable make-box-variable make-box-location
+  box? box-structure? box-variable? box-location?
+  box-mutable? box-immutable?
+  box-set! box-ref
+  box-location
   box-swap!
-  box-location
-  make-box-variable-closure
-  make-box-location-closure
+  make-box-variable-closure make-box-location-closure
   ;
-  *box-structure?
-  *box-structure-ref
-  *box-structure-set!
-  *box-procedure?
-  *box-procedure-ref
-  *box-procedure-set!)
+  *box-structure? *box-structure-ref *box-structure-set!
+  *box-procedure? *box-procedure-ref *box-procedure-set!)
 
 (import scheme)
@@ -56 +43 @@
 ;;
 
-(define-type box-struct (or (struct box) (struct box!)))
-(define-type box-closure ((* * * -> *) -> *))
-(define-type box (or box-struct box-closure))
+(include "box.types")
 
 ;;; Prelude
@@ -79 +64 @@
 
 (define-inline (%box-structure? obj)
-  (or
-    (box-structure-mutable? obj)
-    (box-structure-immutable? 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-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-mutable? box)   (box-structure-mutable-value-set! box val))
     ((box-structure-immutable? box) (box-structure-immutable-value-set! box val)) ) )
 
@@ -97 +80 @@
 ;; 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-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) ) )
+  (or (%box-variable-mutable-tag? obj) (%box-variable-immutable-tag? obj)) )
 
 (define-inline (%box-variable? obj)
@@ -115 +93 @@
 ;; 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-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) ) )
+  (or (%box-location-mutable-tag? obj) (%box-location-immutable-tag? obj)) )
 
 (define-inline (%box-location? obj)
@@ -161 +134 @@
 ;; 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-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)) )
+(define-inline (%box? obj) (or (%box-structure? obj) (%box-closure? obj)))
 
 ;; Errors
@@ -185 +150 @@
 
 (: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
-;
+(: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> 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)))) )
+      (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 (
@@ -208 +171 @@
 ;; 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 -> *))
-;
+(: *box-structure?      (* -> boolean : box-struct))
+(: *box-structure-ref   (box-struct -> *))
+(: *box-structure-set!  (box-struct * -> void))
+(: *box-procedure?      (* -> boolean : box-closure))
+(: *box-procedure-ref   (box-closure -> *))
+(: *box-procedure-set!  (box-closure * -> void))
+(: *box-ref             (box -> *))
+
+(define (*box-structure? obj)           (%box-structure? obj))
+(define (*box-structure-ref box)        (%box-structure-ref box))
+(define (*box-structure-set! box val)   (%box-structure-set! box val))
+(define (*box-procedure? obj)           (%box-closure? obj))
+(define (*box-procedure-ref box)        (%box-closure-ref box))
+(define (*box-procedure-set! box val)   (%box-closure-set! box val))
+
 (define (*box-ref box)
   (cond
@@ -278 +224 @@
 
 (: make-box (#!optional * boolean -> box-struct))
-;
+(: make-box-immutable (#!optional * -> box-struct))
+(: make-box-mutable (#!optional * -> box-struct))
+
 (define (make-box #!optional init immutable?)
   (if immutable?
@@ -284 +232 @@
     (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) )
+(define (make-box-immutable #!optional init)  (make-box-structure-immutable init))
+(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))
-;
+(: box?           (* -> boolean : box))
+(: box-structure? (* -> boolean : box-struct))
+(: box-variable?  (* -> boolean : box-closure))
+(: box-location?  (* -> boolean : box-closure))
+(: box-immutable? (* -> boolean : box))
+(: box-mutable?   (* -> boolean : box))
+
+(define (box? obj)            (%box? obj))
+(define (box-structure? obj)  (%box-structure? obj))
+(define (box-variable? obj)   (%box-variable? obj))
+(define (box-location? obj)   (%box-location? obj))
+(define (box-immutable? obj)  (or (box-structure-immutable? obj) (%box-closure-immutable? obj)))
+(define (box-mutable? obj)    (or (box-structure-mutable? obj) (%box-closure-mutable? obj)))
+
+;; Accessors
+
+(: box-set!       (box * -> void))
+(: box-ref        (box -> *))
+(: box-location   (box #!optional boolean -> locative))
+
 (define (box-set! box val)
   (cond
@@ -341 +270 @@
           (error-box 'box-set! box) ) ) ) ) )
 
-#; ;inlined version below
+(define box-ref (getter-with-setter *box-ref box-set!))
+
+(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)) ) )
+
+;; Operations
+
+(: box-swap! (box (* #!rest -> *) #!rest -> *))
+
 (define (box-swap! box func . args)
-  (let* (
-    (oval (*box-ref box))
-    (nval (apply func oval args)) )
+  #; ;inlined version below
+  (let ((nval (apply func (*box-ref box) args)))
     (box-set! box nval)
-    nval ) )
-
-(: box-swap! (box (* #!rest * -> *) #!rest * -> *))
-;
-(define (box-swap! box func . args)
+    nval )
   (let* (
     (oval
@@ -372 +310 @@
     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
+;; Read/Print Syntax
+
+(: box-print (* output-port -> void))
 
 (define (box-print box port)
@@ -402 +324 @@
           (display "#&" port) (write val port) ) )
 
-(set-sharp-read-syntax! #\&
-  (lambda (p)
-    (make-box-mutable (read p))))
+(set-sharp-read-syntax! #\& (lambda (p) (make-box-mutable (read p))))
 
 (define-reader-ctor 'box make-box)

release/5/box/trunk/box.egg

@@ -3 +3 @@
 
 ((synopsis "Boxing")
- (version "3.2.2")
+ (version "3.2.3")
  (category data)
  (license "BSD")
@@ -10 +10 @@
  (test-dependencies test)
 (components
+  (scheme-include types.incl
+   (files "box.types.scm"))
   (extension box-core
     (types-file)
-    ;no -strict-types"; has generic returns; ex: make-box
+    ;no -strict-types ; has generic returns; ex: make-box
     (csc-options
       "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )

release/5/box/trunk/tests/box-test.scm

@@ -1 +1 @@
 ;;;; box-test.scm  -*- Scheme -*-
+;;;; Kon Lovett, Apr '20
 ;;;; Kon Lovett, Jul '18
 
@@ -12 +13 @@
 (import (only (chicken port) with-output-to-string))
 (import (only (chicken memory representation) procedure-data))
+
+;should be there
+(include "box.types")
 
 ;;