[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

method combination -- mayday PCL



Has anyone encountered (and perhaps fixed) a problem with
MAYDAY pcl involving the use of the :ARGUMENTS option to
DEFINE-METHOD-COMBINATION?

My source code:

(define-method-combination help-string-merge ()
   ((primary () :required t))
  (:arguments  form)

  `(block :done
     ,@(mapcar #'(lambda (method)
		   `(when
		      (multiple-value-call #'merge-into-help-strings
					   (call-method ,method ()))
		      (return-from :done nil)))
	        primary)
     (structure-inherit-help-string ,form)))

Which macroexpands into:
(PROGN
  '(DEFINE-METHOD-COMBINATION HELP-STRING-MERGE)
  (EVAL-WHEN (LOAD EVAL)
     (PCL::LOAD-LONG-DEFCOMBIN 'HELP-STRING-MERGE (QUOTE NIL)
       #'(LAMBDA (PCL::.GENERIC-FUNCTION.
		       PCL::.METHOD-COMBINATION.
		       PCL::.APPLICABLE-METHODS.)
		 (PROGN
		  PCL::.GENERIC-FUNCTION.
		  PCL::.METHOD-COMBINATION.
		  PCL::.APPLICABLE-METHODS.)
		 (BLOCK PCL::.LONG-METHOD-COMBINATION-FUNCTION.
			(LET ((PCL::INNER-RESULT.
			       (LET ((FORM '#:G74750)
				     PRIMARY
				     #:G74749)
				    (DOLIST (PCL::.METHOD.
						  PCL::.APPLICABLE-METHODS.)
					    (LET ((PCL::.QUALIFIERS.
							(METHOD-QUALIFIERS
							 PCL::.METHOD.))
						  (PCL::.SPECIALIZERS.
							(PCL::METHOD-SPECIALIZERS
							 PCL::.METHOD.)))
						 (PROGN
						  PCL::.QUALIFIERS.
						  PCL::.SPECIALIZERS.)
						 (COND ((OR
							 (NULL
							  PCL::.QUALIFIERS.))
							(IF
							 (EQUAL
							  #:G74749
							  PCL::.SPECIALIZERS.)
							 (RETURN-FROM PCL::.LONG-METHOD-COMBINATION-FUNCTION.
								      '(ERROR
									"More than one method of type ~S ~
                                      with the same specializers."
									'PRIMARY))
							 (SETQ
							  #:G74749
							  PCL::.SPECIALIZERS.))
							(PUSH
							 PCL::.METHOD.
							 PRIMARY)))))
				    (WHEN (NULL PRIMARY)
					  (RETURN-FROM PCL::.LONG-METHOD-COMBINATION-FUNCTION.
						       '(ERROR
							 "No ~S methods."
							 'PRIMARY)))
				    (SETQ PRIMARY
					  (NREVERSE PRIMARY))
				    (LIST* 'BLOCK ':DONE
					   (APPEND
					    (MAPCAR
					     #'(LAMBDA (METHOD)
						       (LIST* 'WHEN
							      (LIST
							       'MULTIPLE-VALUE-CALL
							       '#'MERGE-INTO-HELP-STRINGS
							       (LIST*
								'CALL-METHOD
								METHOD
								'(NIL)))
							      '((RETURN-FROM :DONE
									     NIL))))
					     PRIMARY)
					    (LIST
					     (LIST
					      'STRUCTURE-INHERIT-HELP-STRING
					      FORM)))))))
			     (LIST* 'APPLY
				    (LIST 'FUNCTION
					  (LIST 'LAMBDA
						'(#:G74750
						  &REST
						  PCL::.IGNORE.)
						'(DECLARE
						  (IGNORE
						   PCL::.IGNORE.))
						PCL::INNER-RESULT.))
				    '(PCL::.COMBINED-METHOD-ARGS.))))))))

when compiling
   Warning: Symbol PCL::.COMBINED-METHOD-ARGS. declared special

and, not surprisingly, when run, 
error Unbound Symbol PCL::.COMBINED-METHOD-ARGS.

The source of the reference to this symbol is the PCL function
DEAL-WITH-ARGUMENTS-OPTION, which appears to be written expecting
a variable by this name to be (lexically perhaps) bound around
the code it produces.  I can find no other references to the symbol
    PCL::.COMBINED-METHOD-ARGS. 
in the PCL sources I have.

(defun deal-with-arguments-option (wrapped-body arguments-option)
  (let* ((intercept-lambda-list
	  (gathering1 (collecting)
		      (dolist (arg arguments-option)
			      (if (memq arg lambda-list-keywords)
				  (gather1 arg)
				(gather1 (gensym))))))
	 (intercept-rebindings
	  (gathering1 (collecting)
		      (iterate ((arg (list-elements arguments-option))
				(int (list-elements intercept-lambda-list)))
			       (unless (memq arg lambda-list-keywords)
				       (gather1 `(,arg ',int)))))))
    ;;
    ;;
    (setf (cadr wrapped-body)
	  (append intercept-rebindings (cadr wrapped-body)))
    ;;
    ;; Be sure to fill out the intercept lambda list so that it can
    ;; be too short if it wants to.
    ;; 
    (cond ((memq '&rest intercept-lambda-list))
	  ((memq '&allow-other-keys intercept-lambda-list))
	  ((memq '&key intercept-lambda-list)
	   (setq intercept-lambda-list
		 (append intercept-lambda-list '(&allow-other-keys))))
	  (t
	   (setq intercept-lambda-list
		 (append intercept-lambda-list '(&rest .ignore.)))))

    `(let ((inner-result. ,wrapped-body))
       `(apply #'(lambda ,',intercept-lambda-list
		   ,,(when (memq '.ignore. intercept-lambda-list)
			   ''(declare (ignore .ignore.)))
		   ,inner-result.)
	       .combined-method-args.))))