;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH

;;; define-lw-class -- provides a "light-weight" object mechanism while still
;;;                    supporting the same external interface, namely handle
;;;                    the messages 'supported-messages, 'object-class and
;;;                    'object-desc in the standard way. Note that the
;;;                    'dont-care fields in the reply to 'object-desc corre-
;;;                    spond to things not supported here (but in the big OO
;;;                    system.
;;;                    Inheritance is not supported for light-weight objects. 
;;;                    
(eval-when (compile eval load)
  (extend-syntax (define-lw-class locals methods init)
    ((define-lw-class (name . idlist)
       (locals (loc-var loc-val) ...)
       (methods (meth-name meth-val) ...)
       (init init-instr ...) )
     (with ((me-func (gensym)) ; MP - V1.01
	    ((m-name ...)
	     (map (lambda (x) (gensym)) '(meth-name ...) ))
	    ((all-meth-name ...) '(meth-name ... me)))
       (with ((constructor (string->symbol (format "MAKE-~a" 'name)))
	      ((loc-m-name ...) (append '(m-name ...) (list 'me-func))); MP - V1.01
	      ((loc-m-val ...) '(meth-val ... (lambda () me)))
	      (init-proc (gensym)) )
	 (define constructor
	   (lambda idlist
	     (let* ((me #f) (loc-var loc-val) ... (init-proc (lambda ()
							       init-instr ...
							       me)))
	       (letrec ((loc-m-name loc-m-val) ...)	; Bind messages
		 (set! me
		       (lambda (m . args)
			 (cond ((eq? m 'supported-messages)
				(list 'meth-name ...))
			       ((eq? m 'object-class) 'name)
			       ((eq? m 'object-system) 'light-weight)
			       ((eq? m 'object-desc)
				(let ((ml (map cons '(meth-name ...)
					       (list m-name ...))))
				  (list 'name ml 'dont-care
					(append (list (cons 'me
							    me-func))
						ml)
	       				'dont-care)))
			       ((eq? m 'all-meth-name)
				(apply loc-m-name args) )
			       ...
			       (else
				(error 'name "invalid message ~s"
				       (cons m args) )))))
		 (init-proc) )))))))
    
    ;; No locals
    ((define-lw-class (name . idlist)
       (methods (meth-name meth-val) ...)
       (init init-expr ...) )
     (define-lw-class (name . idlist)
       (locals)
       (methods (meth-name meth-val) ...)
       (init init-expr ...) ))
    
    ;; No init
    ((define-lw-class (name . idlist)
       (locals (loc-var loc-val) ...)
       (methods (meth-name meth-val) ...) )
     (define-lw-class (name . idlist)
       (locals (loc-var loc-val) ...)
       (methods (meth-name meth-val) ...)
       (init) ))
    
    ;; No locals, no init
    ((define-lw-class (name . idlist)
       (methods (meth-name meth-val) ...) )
     (define-lw-class (name . idlist)
       (locals)
       (methods (meth-name meth-val) ...)
       (init) ))
    
    )
  
  ) ;; End of eval-when