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

(in-package :cluei)

(defun define-contact-resources (class superclass-names variables resource-list)
  "Construct and validate the resource list for CLASS.  A :slot option is added to
each resource specification containing the resource slot name, if any."
  (do* (name
	(resources resource-list   (cdr resources))
	(resource  (car resources) (car resources))
	
	;; Initialize result with all inherited resources
	(result    (delete-duplicates
		     (mapcan #'(lambda (parent)
				 (mapcar #'copy-list ;;;<------- PATCH
					 (clue-resources parent)))
			   superclass-names)
		     :from-end t
		     :test     #'eq
		     :key      #'first)))
       ((endp resources)
	(reconcile-contact-resource-with-slots variables result))
    
    ;; Make name and class keywords
    (let ((class (getf (cdr resource) :class)))
      (setf name (intern (string (car resource)) 'keyword)
	    (car resource) name)
      (when class
	(setf (getf (cdr resource) :class) (intern (string class) 'keyword))))
    
    ;; Error checking
    (do ((option (cdr resource) (cddr option)))
	((endp option))      
      (let ((key (car option)))
	
	(assert (member key '(:initform :type :class :documentation :slot :remove)) ()
		"~s is an unknown option for resource ~s in ~s." key (car resource) class)
	
	(when (eq key :initform)
	  (assert
	    (let ((slot-initform (getf (cdr (assoc (symbol-name name) variables
						   :key #'symbol-name
						   :test #'equal))
				       :initform)))
	      (or (not slot-initform) (equal slot-initform (second option))))
	    ()
	    "Different slot and resource :initform's specified for resource ~s."
	    (car resource)))))   
    
    ;; Merge resource with parent's resource
    (do* ((inherited-resource (cdr (assoc name result :test #'eq)))
	  (old                inherited-resource   (cddr old)))
	 ((endp old))
      (unless (getf (cdr resource) (car old))
	(setq resource (append resource `(,(car old) ,(cadr old))))))
    
    ;; Add (updated) resource spec to final list (unless the :remove option was given)
    (setq result (delete name result :key #'first :test #'eq :count 1))
    (unless (getf (cdr resource) :remove) (push resource result))))







