;;;; box.scm  -*- Scheme -*-
;;;; 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-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 set-box! unbox
  ;;
  *box-structure? *box-structure-ref *box-structure-set!
  *box-procedure? *box-procedure-ref *box-procedure-set!)

(import scheme
  (chicken base)
  (chicken type)
  (chicken foreign)
  (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!)
  (only (chicken port) with-output-to-port with-output-to-string)
  (only (chicken memory representation) extend-procedure procedure-data)
  (only (chicken locative) make-weak-locative make-locative)
  (only type-errors define-error-type))

(declare
  (bound-to-procedure
    ##sys#procedure->string ) )

;;;

(define-type box-struct (or (struct box) (struct box!)))
(define-type box-closure ((* * * -> *) -> *))
(define-type box (or box-struct box-closure))

(: ##sys#procedure->string (* -> string))

;;; Prelude

(include "chicken-primitive-object-inlines")

;;; Box Structure Support

(define-inline (%make-box tag init)
  (%make-structure tag init) )

(define-inline (%box-structure-mutable? obj)
  (%structure-instance? obj 'box!) )

(define-inline (%box-structure-immutable? obj)
  (%structure-instance? obj 'box) )

(define-inline (%box-structure? obj)
  (and
    (or
      (%box-structure-mutable? obj)
      (%box-structure-immutable? obj))
    (%fx= 2 (%structure-length obj)) ) )

(define-inline (%box-structure-tag obj)
  (and
    (%box-structure? obj)
    (%structure-tag obj)) )

(define-inline (%box-structure-ref box)
  (%structure-ref box 1) )

(define-inline (%box-structure-set! box obj)
  (%structure-set! box 1 obj) )

;;; 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 ()
    ;
    ((_ ?var)
      (make-box-variable ?var #f) )
    ;
    ((_ ?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 ()
    ;
    ((_ ?typ ?val)
      (make-box-location ?typ ?val #f) )
    ;
    ((_ ?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?)
  (%make-box (if immutable? 'box 'box!) init) )

;; Predicates

(: box? (* -> boolean : box))
;
(define (box? obj)
  (%box? obj) )

(: box-variable? (* -> boolean : box-closure))
;
(define (box-variable? obj)
  (%box-variable? obj) )

(: box-location? (* -> boolean : box-closure))
;
(define (box-location? obj)
  (%box-location? obj) )

(: box-immutable? (* -> boolean : box))
;
(define (box-immutable? obj)
  (or (%box-structure-immutable? obj) (%box-closure-immutable? obj)) )

(: box-mutable? (* -> boolean : box))
;
(define (box-mutable? obj)
  (or (%box-structure-mutable? obj) (%box-closure-mutable? obj)) )

;; Mutators


(: box-set! (box * -> void))
;
(define (box-set! box val)
  (case (%box-structure-tag box)
    ((box!)
      (%box-structure-set! box val) )
    ((box)
      (error-box-mutable 'box-set! box) )
    (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* (
    (btag
      (%box-structure-tag box))
    (oval
      (case btag
        ((box!)
          (%box-structure-ref box) )
        ((box)
          (error-box-mutable 'box-swap! 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)) )
    (case btag
      ((box!)
        (%box-structure-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))))

;;; MZ Scheme Style

(define-syntax box
  (syntax-rules ()
    ((_ ?arg0 ...)
      (make-box ?arg0 ...))))

(define-syntax unbox
  (syntax-rules ()
    ((_ ?box)
      (box-ref ?box))))

(define-syntax set-box!
  (syntax-rules ()
    ((_ ?box ?val)
      (box-set! ?box ?val))))


;;; Read/Print Syntax

(set-sharp-read-syntax! #\&
  (lambda (p)
    (make-box (read p))))

(define-reader-ctor 'box make-box)

(define (*box-print box port)
  (with-output-to-port port (lambda () (%box-print box))) )

(define-record-printer (box x p) (*box-print x p))
(define-record-printer (box! x p) (*box-print x p))

(set! ##sys#procedure->string
  (let ((##sys#procedure->string ##sys#procedure->string))
    (lambda (x)
			(if (%box? x)
			  (with-output-to-string (lambda () (%box-print x)))
        (##sys#procedure->string x)))))

;; Print

(define (%box-print box)
  (let (
    (val
      (cond
        ((%box-structure? box)
          (%box-structure-ref box))
        ((%box-closure? box)
          (%box-closure-ref box))
        (else
          (error-box 'box-print box)))))
	  (display "#&") (write val) ) )

) ;module box