Re: rel-7-2 patches need a patch!

[Gregor.pa@Xerox.COM]

    Date: Thu, 16 Jun 88 10:39:37 EDT
    From: rich%linus@mitre-bedford.ARPA

    We have a system which uses clos and also DEFSTRUCTs.  Seems that
    your patch to COMPILE-FROM-STREAM-1 is missing the clause about
    MULTIPLE-DEFINITIONS, which causes the compilation of DEFSTRUCT
    to get all upset about DEFUNs and EVAL-WHENs not at the top level.

Thanks for this fix.  This was a 7.2 change that I didn't notice.
Everyone who use PCL in 7.2 should make this change to
rel-7-2-patches.lisp.

    The patch should really be as follows.  The added clause has the
    comment "THIS CLAUSE NEEDS TO BE ADDED" before it.

    ;;; -*- Package: COMPILER; Mode: LISP; Syntax: Zetalisp -*-

    (DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
      (CATCH-ERROR-RESTART (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
	(LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
	  (LET ((ERROR-MESSAGE-HOOK
		  #'(LAMBDA ()
		      (DECLARE (SYS:DOWNWARD-FUNCTION))
		      (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
			      DBG:*ERROR-MESSAGE-PRINLEVEL*
			      DBG:*ERROR-MESSAGE-PRINLENGTH*
			      FORM))))
	    (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
	  (WHEN (LISTP FORM)			;Ignore atoms at top-level
	    (LET ((FUNCTION (FIRST FORM)))
	      (SELECTQ FUNCTION
		((QUOTE))				;and quoted constants e.g. 'COMPILE
		((PROGN)
		 (DOLIST (FORM (CDR FORM))
		   (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
		((EVAL-WHEN)
		 (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
		 (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
				      (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
		       (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
		       (FORMS (CDDR FORM)))
		   (COND (LOAD-P
			  (DOLIST (FORM FORMS)
			    (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
			 (COMPILE-P
			  (DOLIST (FORM FORMS)
			    (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
		((DEFUN)
		 (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
		   (IF (EQ (CDR TEM) (CDR FORM))
		       (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
		       (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
		((MACRO)
		 (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
		((DECLARE)
		 (DOLIST (FORM (CDR FORM))
		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
			    ;; (DECLARE (SPECIAL ... has load-time action as well.
			    ;; All other DECLARE's do not.
			    (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
		((COMPILER-LET)
		 (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
					#'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
		((SI:DEFINE-SPECIAL-FORM)
		 (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
    ;;;  **************** THIS CLAUSE NEEDS TO BE ADDED  ************************
		((MULTIPLE-DEFINITION)
		 (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
		   (LET ((NAME-VALID (AND (NOT (NULL NAME))
					  (OR (SYMBOLP NAME)
					      (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
			 (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
		     (UNLESS (AND NAME-VALID TYPE-VALID)
		       (WARN "(~S ~S ~S ...) is invalid because~@
			      ~:[~S is not valid as a definition name~;~*~]~
			      ~:[~&~S is not valid as a definition type~;~*~]"
			     'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
		   (LET* ((COMPILED-BODY NIL)
			  (COMPILE-FUNCTION *COMPILE-FUNCTION*)
			  (*COMPILE-FUNCTION*
			    (LAMBDA (OPERATION &REST ARGS)
			      (DECLARE (SYS:DOWNWARD-FUNCTION))
			      (SELECTQ OPERATION
				(:DUMP-FORM
				 (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
						(FIRST ARGS))
				       COMPILED-BODY))
				(:INSTALL-DEFINITION
				 (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
				       COMPILED-BODY))
				(OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
			  (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
						,@LOCAL-DECLARATIONS)))
		     (DOLIST (FORM BODY)
		       (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
		     (FUNCALL COMPILE-FUNCTION :DUMP-FORM
			      `(LOAD-MULTIPLE-DEFINITION
				 ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
    ;;;; **************** END OF ADDED CLAUSE *************************************
		((pcl::top-level-form)
		 (destructuring-bind (name times . body)
				     (cdr form)
		   (si:check-eval-when-times times)
		   (let ((compile-p (or (memq 'compile times)
					(and compile-time-too (memq 'eval times))))
			 (load-p (or (memq 'load times)
				     (memq 'cl:load times)))
			 (fspec `(pcl::top-level-form ,name)))
		     (cond (load-p
			    (compile-from-stream-1
			      `(progn (defun ,fspec () . ,body)
				      (funcall (function ,fspec)))
			      (and compile-p ':force)))
			   (compile-p
			    (dolist (b body)
			      (funcall *compile-form-function* form ':force nil)))))))
		(OTHERWISE
		 (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
		   (IF TEM
		       (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
		       (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))


-------