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

;;; Module box

(module box

  (;export
    ;;
    make-box (make-box-variable $finvar) (make-box-location $finloc)
    box? box-variable? box-location?
    box-mutable? box-immutable?
    box-set! box-ref
    box-location
    ;;
    box set-box! unbox
    ;;
    *box-structure? *box-structure-ref *box-structure-set!
    *box-procedure? *box-procedure-ref *box-procedure-set!)

  (import
    scheme
    (only chicken
      optional                ;due to #!optional implementation
      let-optionals           ;due to #!optional implementation
      define-reader-ctor
      define-record-printer
      let-location
      and-let*
      getter-with-setter
      void
      set-sharp-read-syntax!
      ##sys#signal-hook
      ##sys#procedure->string
      declare
      define-inline
      define-constant
      include)
    (only ports
      with-output-to-port
      with-output-to-string)
    (only lolevel
      extend-procedure procedure-data
      make-weak-locative make-locative)
    (only type-errors
      define-error-type) )

  (require-library ports lolevel type-errors)

  (declare
    (disable-warning redef) ;##sys#procedure->string is redefined!
    (bound-to-procedure
      ##sys#signal-hook
      ##sys#procedure->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)

;; Print

(define-inline (%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) ) )

;; Finishers

(define ($finvar tag ref set)
  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag))

(define ($finloc tag ref set loc)
  (extend-procedure (lambda (proc) (proc ref set loc)) 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))

;; Constructers

(define-syntax make-box-variable
  (syntax-rules ()
    ((_ ?var) (make-box-variable ?var #f))
    ((_ ?var ?immutable?)
     #;(identifier? ?var)
     ($finvar (if ?immutable? 'boxvar 'boxvar!)
              (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))
       ($finloc (if ?immutable? 'boxloc 'boxloc!)
                (lambda () var)
                (if ?immutable? (void) (lambda (val) (set! var val)))
                (lambda () (location var)))))))

(define (make-box #!optional init immutable?) (%make-box (if immutable? 'box 'box!) init))

;; Predicates

(define (box? obj) (%box? 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)))

;; Mutators

(define (box-set! box val)
  (case (%box-structure-tag box)
    ((box!) (%box-structure-set! box val))
    ((box)  (error-box-mutable 'box-set! box 'box))
    (else
      (case (%box-closure-tag box)
        ((boxvar! boxloc!) (%box-closure-set! box val))
        ((boxvar boxloc)   (error-box-mutable 'box-set! box 'box))
        (else
          (error-box 'box-set! box val) ) ) ) ) )

;; Assessors

(define box-ref
  (getter-with-setter
    (lambda (box)
      (cond ((%box-structure? box)  (%box-structure-ref box))
            ((%box-closure? box)    (%box-closure-ref box))
            (else
              (error-box 'box-ref box 'box))))
    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 '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-record-printer (box x p) (with-output-to-port p (lambda () (%box-print x))))

(define-record-printer (box-immutable x p) (with-output-to-port p (lambda () (%box-print x))))

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

) ;module box