;;;; box-core.scm  -*- Scheme -*-
;;;; Kon Lovett, Oct '24
;;;; 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.
;;
;; - Both `box-variable' & `box-location' MUST be single-valued

(declare
  (disable-interrupts))

(module box-core

(;export
  ;
  box box!
  ;
  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!
  ;export-for-syntax
  make-box-variable-closure make-box-location-closure
  ;used by F-operator
  *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 memory representation) extend-procedure procedure-data))
(import (only (chicken locative) make-weak-locative make-locative))

(include-relative "box.types")

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

(: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
(: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> box-closure))

(: make-box             (#!optional * boolean -> box-struct))
(: make-box-immutable   (#!optional * -> (struct box)))
(: make-box-mutable     (#!optional * -> (struct box!)))

(: box?           (* -> boolean : box))
(: box-structure? (* -> boolean : box-struct))
(: box-immutable? (* -> boolean : (struct box)))
(: box-mutable?   (* -> boolean : (struct box!)))

;not distinguised by type
(: box-variable?  (* --> boolean))  ;box-closure
(: box-location?  (* --> boolean))  ;box-closure

(: box-set!       (box * -> void))
(: box-ref        (box -> *))
(: box-location   (box #!optional boolean -> locative))

(: box-swap! (box (* #!rest -> *) #!rest -> *))

;;; Prelude

(define-inline (->boolean x) (and x #t))

;;; Box Structure Support

(: *box-ref ((or false symbol string) box -> *))

(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-box-mutable loc obj)
  (error loc "bad argument type - not a box-mutable" obj) )

(define (error-box loc obj)
  (error loc "bad argument type - not a box" obj) )

;; Finishers

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

(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 loc box)
  (cond ((%box-structure? box)
          (%box-structure-ref box))
        ((%box-closure? box)
          (%box-closure-ref box))
        (else
          (error-box loc 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))) ) ) ) )

(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

(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

(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 (cut *box-ref '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

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

) ;module box-core