;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T; Patch-File: T;  -*-

(in-package "CLUEI")

#|| 04/05/1991 (Hubertus) 
When initializing resource slots, resource initforms are converted by calling 
the convert method on contact's parent. However the manual states (page 12):
"The new contact's convert method is called to perform all representation type 
conversions for resources...". Unfortunately, calling convert on the new contact
may give problems, e.g. contact-display and contact-depth are not initialized.
So we use contact's convert method for the font resource only (which needs it).
||#

#||
(defun define-initialize-resource-slots (contact-class resources)
  "Define the initialize-resource-slots method for CONTACT-CLASS."
  (let (code slot)
    (when (dolist (resource resources code)
	    (when (setq slot (getf (cdr resource) :slot))
	      (push
	       (set-resource-slot (car resource) resources slot))
		code)))
      
    `(defmethod initialize-resource-slots ((instance ,contact-class) resource-table app-defaults)
       
       ;; Check resource types and fill in defaults.
       ;; Assumes the :initform for all resource slots NIL (the true initform is evaluated here).       
       (let (options ;;(parent instance))
 	 ;; 04/05/1991 (Hubertus) binding parent to instance doesn't work
	 ;; for some resource slots whose convert method requires the contatc's
	 ;; display or depth (not yet initialized!)
	 
	     (slot-value (the ,contact-class instance) 'parent))
	 ;;     NOTE: PARENT is null when contact-class is ROOT.
	 ;;     This may lose for some root resources requiring conversion.
	 ,@code
	 options)))))
||#

(defparameter *convert-to-be-called-on-instance-for-types*
    '(font))    

(defun set-resource-slot (name resources slot)
  "Generate code to find resource value, convert to representation type, and set corresponding slot."  
  (let ((resource (rest (assoc name resources))))    
    (let ((type (getf resource :type)))
      `(let* ((value     (or  (slot-value instance ',slot)
			      (get-search-resource resource-table ,name ,(getf resource :class))
			      (getf app-defaults ,name)
			      ,(getf resource :initform))))
	 (when value	   
	   (setf options
		 (list* ',name
			(setf (slot-value instance ',slot)
			      ,(if type
				   `(do-convert
				     ,(if (or (and (listp type)
						   (intersection
						    (cdr type)
						    *convert-to-be-called-on-instance-for-types*))
					      (member type *convert-to-be-called-on-instance-for-types*))
					  'instance
					'parent)
				     value ',type)
				 'value))
			options)))))))

(defmethod convert (contact value (type (eql 'font)))
  (typecase value
    (stringable
     (ignore-errors (open-font
		     ;; (contact-display contact) sometimes not yet initialized
		     (contact-display (contact-parent contact))
		     value)))
    (font value)
    (otherwise nil)))