;;;; 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-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!)

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

;;;

;;

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

) ;module box-core