source: project/release/5/box/trunk/box-core.scm @ 39165

;;;; box-core.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-core

(;export
  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!
  make-box-variable-closure make-box-location-closure
  ;
  *box-structure? *box-structure-ref *box-structure-set!
  *box-procedure? *box-procedure-ref *box-procedure-set!)

(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))

;;;

;;

(include "box.types")

;;; 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))
(: 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)))))
      tag) ) )

(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))
(: *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
    ((%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))
(: make-box-immutable (#!optional * -> box-struct))
(: make-box-mutable (#!optional * -> box-struct))

(define (make-box #!optional init immutable?)
  (if immutable?
    (make-box-structure-immutable 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))
(: 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
    ((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) ) ) ) ) )

(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)
  #; ;inlined version below
  (let ((nval (apply func (*box-ref box) args)))
    (box-set! box nval)
    nval )
  (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 ) )

;; Read/Print Syntax

(: box-print (* output-port -> void))

(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))

) ;module box-core