;; -----------------------------------------------------------------
;; define-object defines a SICP object closure
;; defclass, defaspect macro experiment (ripped from aspect.jl)
;; TODO see ocl.jl for invariant, pre-condition, post-condition syntax

;; (define-macro (first xs)
;;   `(car ,xs))
;; (define-macro (second xs)
;;   `(cadr ,xs))
;; (define-macro (third xs)
;;   `(caddr ,xs))
;; (define-macro (fourth xs)
;;   `(cadddr ,xs))
;; (define-macro (rest xs)
;;   `(cdr ,xs))
;;
;; (define-macro (push value lst)
;;   `(set! ,lst (cons ,value ,lst)))
;; (define-macro (pop lst)
;;   `(let ((head (car ,lst)))
;;      (set! ,lst (cdr ,lst))
;;      head))

(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define rest cdr)

(define-syntax push
  (syntax-rules ()
    ((_ value stack)
     (set! stack (cons value stack)))))

(define-syntax pop
  (syntax-rules ()
    ((_ stack)
     (let ((head (car stack)))
       (set! stack (cdr stack))
       head))))

(define-macro (define-object . args)
  (let ((class-name (first args))
        (forms (rest args))
        (attribs ())
        (methods ()))
    (define (method-body name)
      (rest (assoc name (map cdr forms))))
    (define (attribute-initialiser name)
      (rest (assoc name (map cdr forms))))
    ;; collect def{attrib,method} names
    (dolist (form forms)
      (case (car form)
        ((defattrib)
         (push (second form) attribs))
        ((defmethod)
         (push (second form) methods))
        (else (print "unknown item"))))
    ;; generate form
    `(define (,class-name)              ; XXX make- ,class-name ?
       ;; attribute closure
       (let (,@(map (lambda (a)
                      (list a (first (attribute-initialiser a))))
                    attribs))
         ;; method definitions
         ,@(map (lambda (m)
                  `(define (,@m) ,@(method-body m)))
                methods)
         ;; dispatcher
         (lambda args
           (apply
            (case (car args)
              ,@(map (lambda (m) `((,(car m)) ,(car m))) methods)
              ,@(map (lambda (a) `((,a) (lambda () ,a))) attribs)
              ((type) (lambda () ',class-name))
              ((interface) (lambda () (list ',attribs ',methods)))
              (else (error "%s: unknown method `%s'"
                           ',class-name (car args))))
            (cdr args)))))))

;; e.g.
(define-object counter
  ;; (defattrib name #!optional init mode), mode: 'read 'write 'r/w 'none
  (defattrib count 0)

  ;; (defmethod name #!rest body)
  (defmethod (increment)
    (set! count (+ count 1)))

  (defmethod (decrement)
    (set! count (- count 1))))

(define c (counter))
(print (c 'count))
(c 'increment)
(c 'increment)
(c 'decrement)
(print (c 'count))

;; methods with parameters
(define-object stack
  (defattrib the-stack ())
  (defmethod (push item)
    (set! the-stack (cons item the-stack)))
  (defmethod (pop)
    (let ((head (first the-stack)))
      (set! the-stack (rest the-stack))
      head))
  (defmethod (to-list)
    the-stack))

(let ((s (stack)))
  (print (s 'type))
  (print (s 'interface))
  (s 'push 'aap)
  (s 'push 'noot)
  (print (s 'to-list))
  (print (s 'pop))
  (print (s 'pop)))