;;; -*- Mode: Scheme -*-

;;;; T Objects & Operations for Scheme48

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

; ,open assembler closures receiving templates signals
; ,for-syntax ,open destructuring

(define (make-object proc dispatcher)
  (cond ((closure? proc)
         (%make-object (closure-template proc)
                       (closure-env      proc)
                       dispatcher
                       object-tag))
        ((not proc)
         (%make-object inapplicable-object-template
                       #f               ; null environment
                       dispatcher
                       object-tag))
        (else
         (error "invalid object procedure"
                proc))))

(define object-tag (list 'object))

;; (define (%make-object template env dispatcher tag)
;;   ;; Think of a CLOSURE procedure like the VECTOR procedure.
;;   (closure template env dispatcher tag))

(define %make-object
  (lap %make-object ()
       (protocol 4)
       (pop)
       (make-stored-object 4 closure)
       (return)))

;; (define (inapplicable-object . args)
;;   (error "inapplicable object" (current-procedure) args))

(define inapplicable-object
  (lap inapplicable-object ()
       (protocol 0 + (push template))
       (push)
       (stack-ref 2)
       (make-stored-object 2 pair)
       (push+stack-indirect 1 4)        ; literal ()
       (make-stored-object 2 pair)
       (push+stack-indirect 1 5)        ; literal "inapplicable object"
       (push+stack-ref 1)
       (make-stored-object 2 pair)
       (push+stack-indirect 2 6)        ; literal ERROR
       (push+stack-ref 1)
       (make-stored-object 2 pair)
       (trap)
       (return)))

(define inapplicable-object-template
  (let* ((old (closure-template inapplicable-object))
         (new (make-template 7 #f))
         (copy (lambda (i)
                 (template-set! new i (template-ref old i)))))
    (copy 0) (copy 1) (copy 2) (copy 3)
    (template-set! new 4 '())
    (template-set! new 5 "inapplicable object")
    (template-set! new 6 'error)
    new))

(define (object-dispatcher obj)
  (%object-dispatcher object-tag obj))

;; (define (%object-dispatcher object-tag obj)
;;   (and (closure? obj)
;;        (= 4 (closure-length obj))
;;        (eq? object-tag (closure-ref obj 3))
;;        (closure-ref obj 2)))

(define %object-dispatcher
  (lap object-dispatcher ()
       (protocol 2)
       (stack-ref 0)
       (stored-object-has-type? closure)
       (jump-if-false return)
       (stack-ref 0)
       (stored-object-length closure)
       (push)
       (literal 4)
       (=)
       (jump-if-false return)
       (stack-indirect 0 3)
       (stack-ref+push 1)
       (eq?)
       (jump-if-false return)
       (stack-indirect 0 2)
return (return)))

;;; Predicate for possible integration of Scheme48's generic dispatch
;;; system:
;;;
;;;   (define-simple-type :bogus-entity (:value) bogus-entity?)
;;;
;;;   (define-method &disclose ((obj :bogus-entity))
;;;     (disclose obj))
;;;
;;;   &c.

(define (bogus-entity? obj)
  (%bogus-entity? object-tag obj))

;; (define (%bogus-entity? object-tag obj)
;;   (and (closure? obj)
;;        (= 4 (closure-length obj))
;;        (eq? object-tag (closure-ref obj 3))))

(define %bogus-entity?
  (lap %bogus-entity? ()
       (protocol 2)
       (stack-ref 0)
       (stored-object-has-type? closure)
       (jump-if-false return)
       (stack-ref 0)
       (stored-object-length closure)
       (push)
       (literal 4)
       (=)
       (jump-if-false return)
       (stack-indirect 0 3)
       (stack-ref+push 1)
       (eq?)
return (return)))

;;;; OBJECT Syntax

(define-syntax object
  (syntax-rules ()
    ((OBJECT proc
       ((op self . args) body0 body1 ...)
       ...)
     (MAKE-OBJECT proc
                  (*DISPATCHER ((op self . args) body0 body1 ...)
                               ...)))))

;;; Rough definition.  The real one doesn't cons a closure for every
;;; dispatch.

; (define-syntax *dispatcher
;   (syntax-rules ()
;     ((*DISPATCHER ((op self . args) body0 body1 ...)
;                   ...)
;      (LAMBDA (OPERATION)
;        (VALUES (COND ((EQ? OPERATION op)
;                       (METHOD-LAMBDA self args body0 body1 ...))
;                      ...
;                      (ELSE #F))
;                NO-MORE-JOIN-LINKS)))))

(define-syntax *dispatcher
  (lambda (form rename compare)
    (let ((method-vars
           (let ((n 0))
             (map (lambda (method)
                    (set! n (+ n 1))
                    (rename (string->symbol
                             (string-append "method"
                                            (number->string n)))))
                  (cdr form))))
          (%let (rename 'LET))
          (%method-lambda (rename 'METHOD-LAMBDA))
          (%lambda (rename 'LAMBDA))
          (%operation (rename 'OPERATION))
          (%values (rename 'VALUES))
          (%cond (rename 'COND))
          (%eq? (rename 'EQ?))
          (%else (rename 'ELSE)))
      `(,%let ,(map (lambda (var method)
                      (destructure (( ((op self . args) . body)
                                      method))
                        `(,var (,%method-lambda ,self ,args ,@body))))
                    method-vars (cdr form))
         (,%lambda (,%operation)
           (,%values (,%cond ,@(map (lambda (var method)
                                      `((,%eq? ,%operation
                                               ,(caar method))
                                        ,var))
                                    method-vars (cdr form))
                             (,%else #F))
                     ,(rename 'NO-MORE-JOIN-LINKS))))))
  (let method-lambda lambda values cond eq? else no-more-join-links))

;;; (METHOD-LAMBDA self args body)
;;; (METHOD-LAMBDA (true-self [self [next [op]]]) args body)

(define-syntax method-lambda
  (syntax-rules ()
    ((METHOD-LAMBDA (true-self) args body0 body1 ...)
     (LAMBDA (true-self SELF NEXT OP . args)
       SELF NEXT OP          ; ignored
       body0 body1 ...))
    ((METHOD-LAMBDA (true-self self) args body0 body1 ...)
     (LAMBDA (true-self self NEXT OP . args)
       NEXT OP               ; ignored
       body0 body1 ...))
    ((METHOD-LAMBDA (true-self self next) args body0 body1 ...)
     (LAMBDA (true-self self next OP . args)
       OP                    ; ignored
       body0 body1 ...))
    ((METHOD-LAMBDA (true-self self next op) args body0 body1 ...)
     (LAMBDA (true-self self next op . args)
       body0 body1 ...))
    ((METHOD-LAMBDA self args body0 body1 ...)
     (LAMBDA (TRUE-SELF self NEXT OP . args)
       TRUE-SELF NEXT OP     ; ignored
       body0 body1 ...))))

;;;; Operations

(define (operate operation obj . args)
  (apply operate-as operation obj obj args))

(define (operate-as operation obj other . args)
  (receive (method next)
           (dispatch obj operation)
    (if method
        (apply method obj other next operation args)
        (apply run-default-method operation other args))))

(define (dispatch obj operation)
  (cond ((object-dispatcher obj)
         => (lambda (dispatcher)
              (dispatcher operation)))
        (else
         (primitive-dispatch obj operation))))

(define (primitive-dispatch obj op)
  (values #f no-more-join-links))

(define-syntax operation
  (syntax-rules ()
    ((OPERATION default method-clause ...)
     (LETREC ((DEFAULT-METHOD default)
              (OP
               (OBJECT (LAMBDA (OBJ . ARGS)
                         (RECEIVE (METHOD NEXT)
                                  (DISPATCH OBJ OP)
                           (COND (METHOD
                                  (APPLY METHOD OBJ OBJ NEXT OP ARGS))
                                 (DEFAULT-METHOD
                                  (APPLY DEFAULT-METHOD OBJ ARGS))
                                 (ELSE
                                  (ERROR "no default method"
                                         OP OBJ ARGS)))))
                 ((RUN-DEFAULT-METHOD SELF OBJ . ARGS)
                  (IF DEFAULT-METHOD
                      (APPLY DEFAULT-METHOD OBJ ARGS)
                      (ERROR "no default method"
                             OP OBJ ARGS)))
                 ((OPERATION? SELF) #T)
                 method-clause ...
                 ((DISCLOSE SELF)
                  `(OPERATION ,@(COND ((IDENTIFICATION OP) => LIST)
                                      (ELSE '())))))))
       OP))))

(define-syntax define-operation
  (syntax-rules ()
    ((DEFINE-OPERATION (name . args))
     (DEFINE name (OPERATION #F ((IDENTIFICATION SELF) 'name))))
    ((DEFINE-OPERATION (name . args) body0 body1 ...)
     (DEFINE name
             (OPERATION (LAMBDA args body0 body1 ...)
               ((IDENTIFICATION SELF) 'name))))))

(define-syntax define-predicate
  (syntax-rules ()
    ((DEFINE-PREDICATE name)
     (DEFINE-OPERATION (name OBJ) #F))))

(define-predicate operation?)
(define-operation (run-default-method op obj . args))
(define-operation (identification obj) #f)
(define-operation (disclose obj) #f)
(define-operation (setter op))

(define-syntax define-settable-operation
  (syntax-rules ()
    ((DEFINE-SETTABLE-OPERATION (name . args) body0 body1 ...)
     (DEFINE name
       (LET ((THE-SETTER (OPERATION #F
                           ((IDENTIFICATION SELF)
                            `(SETTER ,name)))))
         (OPERATION (LAMBDA args body0 body1 ...)
           ((SETTER SELF) THE-SETTER)
           ((IDENTIFICATION SELF) 'name)))))))

;;;; Joined Objects

(define (join obj . objs)
  (if (null? objs)
      obj
      (join2 obj (apply join objs))))

(define (join2 a b)
  (if (joined? a joined-tag)
      (join2 (joined-lhs a)
             (join2 (joined-rhs a) b))
      (make-object (if (eq? (closure-template a)
                            inapplicable-object-template)
                       b
                       a)
                   (make-closure join-dispatcher-template
                                 (vector a b joined-tag)))))

(define join-dispatcher-template
        (closure-template
         (let ((a #f) (b #f))
           (lambda (op)
             ;; A is guaranteed to be a non-joined object, so NEXT is
             ;; guaranteed to be NO-MORE-JOIN-LINKS.
             (receive (method next) (dispatch a op)
               (if method
                   (values method b)
                   (dispatch b op)))))))

(define joined-tag (list 'joined))

;; (define (joined? obj joined-tag)
;;   (and (closure? obj)
;;        (= 3 (closure-length obj))
;;        (= 3 (vector-length
;;              (closure-ref obj 1)))      ;(closure-env obj)
;;        (eq? joined-tag (closure-ref obj 3))))

(define joined?
  (lap joined? ()
       (protocol 2)
       (stack-ref 1)
       (stored-object-has-type? closure)
       (jump-if-false lose)
       (stack-ref 1)
       (stored-object-length closure)
       (push)
       (literal 3)
       (=)
       (jump-if-false lose)
       (stack-indirect+push 1 1)
       (stored-object-length vector)
       (push)
       (literal 3)
       (=)
       (jump-if-false lose)
       (stack-indirect 0 2)
       (stack-ref+push 2)
       (eq?)
lose   (return)))

(define (joined-lhs joined)
  (vector-ref (closure-env joined) 0))

(define (joined-rhs joined)
  (vector-ref (closure-env joined) 1))

(define no-more-join-links
        (make-object #f (lambda (op)
                          (values #f no-more-join-links))))