;;; -*- Mode: LISP;Syntax: Zetalisp;Package: cl-user; Base: 10;Patch-File: T -*-

;;; There is a bug in the 6.1 beta version of si:xr-cl-#s-macro.  Of course
;;; since Bolics has chosen not to ship sources for this function its harder
;;; to fix than it should be.  This is a rewrite of that function, based on
;;; reading Steele and the disassembled code.
si:
(defun xr-cl-#s-macro (list-so-far stream)
  list-so-far
  (let ((list (read-recursive stream))
	constructor)
    (and (atom list)
	 (read-error stream "#S was followed by ~S, which is not a list" list))
    (cond ((setq constructor (get-defstruct-constructor-macro-name (car list)))
	   (loop for x on (cdr list) by 'cddr
		  do (rplaca x (intern (string (car x)) 'keyword)))
	   (apply constructor (cdr list)))
	  (t
	   (ferror "~S is either not the name of a structure or doesn't have a~%~
                    standard constructor macro.")))))


(fmakunbound 'lt::expand-subst-definition-internal)	;LT seems to have this bug.

zl:compiler:
(defun commutative-constant-folder-recurse (function args do-not-reorder)
  (let ((variables nil)
	(constants nil)
	(float-passed nil))
    (loop for arg in args
	  if (and (constant-form-p arg)
		  (not (and (listp arg)
			    (eq (car arg) 'quote)
			    (listp (cdr arg))
			    (listp (cadr arg))
			    (eq (caadr arg) eval-at-load-time-marker))))
	  do (if (floatp arg) (setq float-passed t))	;probably have to punt...
	     (push arg constants)
	  else if (and (not do-not-reorder)
		       (listp arg)
		       (eq (car arg) function)) do
	  (multiple-value-bind (variable constant punt)
	      (commutative-constant-folder-recurse function (cdr arg) do-not-reorder)
	    (if punt
		(push arg variables)
		(progn
		  (dolist (v variable) (push v variables))
		  (push constant constants))))
	  else do (push arg variables)
	  finally
	  (if (and float-passed variables)
	      (return nil nil t)		   
	      (return (nreverse variables)
		      (let ((identity (get function 'arithmetic-identity-element)))
			(if constants
			    (condition-case (error-object)
				(apply function (setq constants (nreverse constants)))
			      (error
				(phase-1-warning "Could not apply ~S to ~S:~%~A~@
						      ~S was substituted instead."
						 function constants error-object identity)
				identity))
			    identity)))))))

;;; hacks needed to make this win in 6.1

(defmacro si:define-function-spec-handler (type args &body body)
    `(setf (get ',type 'sys::function-spec-handler) #'(lambda ,args . ,body)))


;;; Lexical closure utilities

(defsubst si:lexical-closure-p (thing)
  (= (sys:%data-type thing) sys:dtp-lexical-closure))

(defsubst si:lexical-closure-environment (cl)
  (si:%p-contents-offset cl 0))

(defsubst si:lexical-closure-function (cl)
  (si:%p-contents-offset cl 1))


(defun get-setf-method-multiple-value (reference &optional for-effect
						 &aux method)
  (si:LOOP si:WITH ORIGINAL-REFERENCE = REFERENCE si:DO	;Loop expanding macros
     (cond ((and (symbolp reference)
		 (lt::propertyp reference
				'zetalisp-system::symbol-macro))
	    (setq reference (macroexpand-1 reference)))
	   ((and (symbolp reference)
		 (lt::propertyp reference
				'lt::atomic-macro))
	    (setq reference (macroexpand-1 reference)))
	   ((lt::variablep reference)
	    (RETURN
	      (LET ((STORE (GENSYM)))
		(VALUES () () (LIST STORE) `(SETQ ,REFERENCE ,STORE) REFERENCE))))
	   ((OR (ATOM REFERENCE) (NOT (SYMBOLP (CAR REFERENCE))))
	    (COMPILER:WARN '(:FATAL T)
			   "~S is not valid as a generalized variable reference~
				~:[ (macroexpanded from ~S)~]"
			   REFERENCE (EQ REFERENCE ORIGINAL-REFERENCE) ORIGINAL-REFERENCE))
	   ((setq method (get (car reference) 'lt::trivial-setf-method))
	    (return
	      (LET ((STORE (LIST (GENSYM)))
		    (TEMPS (MAPCAR #'(LAMBDA (IGNORE) (GENSYM))
				   (CDR REFERENCE))))
		(VALUES TEMPS (CDR REFERENCE) STORE
			(IF (SYMBOLP METHOD)
			    `(,METHOD ,@TEMPS ,@STORE)
			    `(FUNCALL #',METHOD ,@TEMPS ,@STORE))
			`(,(FIRST REFERENCE) ,@TEMPS)))))
	   ((setq method (get (car reference) 'lt::setf-equivalence))
	    (SETQ REFERENCE
		  (LIST (FIRST METHOD) (CONS (SECOND METHOD) (CDR REFERENCE)))))
	   ((SETQ METHOD (get (CAR REFERENCE) 'lt::SETF-METHOD))
	    (RETURN
	      (IF FOR-EFFECT
		  ;; Optimize if store-form known to be used for effect only
		  (MULTIPLE-VALUE-BIND (VARS VALS STORE-VARS STORE-FORM ACCESS-FORM)
		      (FUNCALL METHOD REFERENCE)
		    (WHEN (AND (LISTP STORE-FORM)
			       (EQ (FIRST STORE-FORM) 'lt::LET-VALUE))
		      (SETQ STORE-FORM (lt::SUBST (THIRD STORE-FORM)
						  (SECOND STORE-FORM)
						  (FOURTH STORE-FORM))))
		    (VALUES VARS VALS STORE-VARS STORE-FORM ACCESS-FORM))
		  (FUNCALL METHOD REFERENCE))))

	   
	   ((AND (SETQ METHOD (GET (CAR REFERENCE) 'SI:DEFSTRUCT-SLOT))
		 (SI:DEFSTRUCT-SLOT-READ-ONLY-P (CAR METHOD) (CDR METHOD)))
	    (COMPILER:WARN '(:FATAL T)
	      "~S cannot be SETF'ed because it is a read-only structure slot~
	       ~:[ (macroexpanded from ~S)~]"
	      (CAR REFERENCE)
	      (EQ REFERENCE ORIGINAL-REFERENCE)
	      ORIGINAL-REFERENCE))
	   
	   ((NEQ REFERENCE (SETQ REFERENCE (MACROEXPAND-1 REFERENCE))))
	   ;;This is a kludge until such time as we have a type system that
	   ;; cares about THE
	   ((EQ (CAR REFERENCE) 'THE)
	    (SETQ REFERENCE (THIRD REFERENCE)))
	   (T (COMPILER:WARN '(:FATAL T)
		"No SETF method known for ~S forms~:[ (macroexpanded from ~S)~]"
		(CAR REFERENCE) (EQ REFERENCE ORIGINAL-REFERENCE)
		ORIGINAL-REFERENCE))
	   
	   )))