patch2.text

[Gregor.pa@Xerox.COM]

The following is the contents of /pcl/alpha/patch2.text.

Make these changes to the indicated files.

;----------------
;from defsys.lisp

(defun compile-pcl (&optional m)
  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
	)
    (cond ((null m)        (operate-on-system 'pcl :compile))
	  ((eq m :print)   (operate-on-system 'pcl :compile () t))
	  ((eq m :query)   (operate-on-system 'pcl :query-compile))
	  ((eq m :confirm) (operate-on-system 'pcl :confirm-compile))
	  ((eq m 't)       (operate-on-system 'pcl :recompile))        
	  ((listp m)       (operate-on-system 'pcl :compile-from m))
	  ((symbolp m)     (operate-on-system 'pcl :recompile-some `(,m))))))

(defun load-pcl (&optional m)
  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
	)
    (cond ((null m)      (operate-on-system 'pcl :load))
	  ((eq m :query) (operate-on-system 'pcl :query-load)))
    (pushnew :pcl *features*)
    (pushnew :portable-commonloops *features*)))

;----------------
;from braid.lisp
(defun bootstrap-meta-braid ()
  (let* ((std-class-size (length *std-class-slots*))
         (std-class (%allocate-instance--class std-class-size))
         (std-class-wrapper (make-wrapper std-class))
	 (built-in-class (%allocate-instance--class std-class-size))
	 (built-in-class-wrapper (make-wrapper built-in-class))
	 (direct-slotd    (%allocate-instance--class std-class-size))
	 (effective-slotd (%allocate-instance--class std-class-size))
	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
	 (effective-slotd-wrapper (make-wrapper effective-slotd)))
    ;;
    ;; First, make a class metaobject for each of the early classes.  For
    ;; each metaobject we also set its wrapper.  Except for the class T,
    ;; the wrapper is always that of STANDARD-CLASS.
    ;; 
    (dolist (definition *early-class-definitions*)
      (let* ((name (ecd-class-name definition))
	     (meta (ecd-metaclass definition))
             (class (case name
                      (standard-class                     std-class)
                      (standard-direct-slot-definition    direct-slotd)
		      (standard-effective-slot-definition effective-slotd)
		      (built-in-class                     built-in-class)
                      (otherwise
			(%allocate-instance--class std-class-size)))))
	(unless (eq name t)
	  (inform-type-system-about-class class name))
	(setf (std-instance-wrapper class)
	      (ecase meta
		(standard-class std-class-wrapper)
		(built-in-class built-in-class-wrapper)))
        (setf (find-class name) class)))
    ;;
    ;;
    ;;
    (dolist (definition *early-class-definitions*)
      (let ((name (ecd-class-name definition))
	    (source (ecd-source definition))
	    (direct-supers (ecd-superclass-names definition))
	    (direct-slots  (ecd-canonical-slots definition))
	    (other-initargs (ecd-other-initargs definition)))
	(let ((direct-default-initargs
		(getf other-initargs :default-initargs)))
	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
	      (early-collect-inheritance name)
	    (let* ((class (find-class name))
		   (wrapper
		     (cond
		       ((eq class std-class)       std-class-wrapper)
		       ((eq class direct-slotd)    direct-slotd-wrapper)
		       ((eq class effective-slotd) effective-slotd-wrapper)
		       ((eq class built-in-class)  built-in-class-wrapper)
		       (t (make-wrapper class))))
		   (proto nil))
	      (cond ((eq name 't)
		     (setq *the-wrapper-of-t* wrapper
			   *the-class-t* class))
		    ((memq name '(standard-object standard-class))
		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
				  *the-pcl-package*)
			  class)))
	      (dolist (slot slots)
		(unless (eq (getf slot :allocation :instance) :instance)
		  (error "Slot allocation ~S not supported in bootstrap.")))
	      
	      (setf (wrapper-instance-slots-layout wrapper)
		    (mapcar #'canonical-slot-name slots))
	      (setf (wrapper-class-slots wrapper)
		    ())
	      
	      (setq proto (%allocate-instance--class (length slots)))
	      (setf (std-instance-wrapper proto) wrapper)
	    
	      (setq direct-slots
		    (bootstrap-make-slot-definitions direct-slots
						     direct-slotd-wrapper))
	      (setq slots
		    (bootstrap-make-slot-definitions slots
						     effective-slotd-wrapper))
	      
	      (bootstrap-initialize-std-class
		class name source
		direct-supers direct-subclasses cpl wrapper
		direct-slots slots direct-default-initargs default-initargs
		proto)
	      
	      (dolist (slotd direct-slots)
		(bootstrap-accessor-definitions
		  name
		  (bootstrap-get-slot 'std-slotd slotd 'name)
		  (bootstrap-get-slot 'std-slotd slotd 'readers)
		  (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))

;----------------
;from defclass.lisp
(defun make-top-level-form (name times form)
  (flet ((definition-name ()
	   (if (and (listp name)
		    (memq (car name) '(class method method-combination)))
	       (format nil "~A~{ ~S~}"
		       (capitalize-words (car name) ()) (cdr name))
	       (format nil "~S" name))))
    (definition-name)
    #+Genera
    (let ((thunk-name (gensym "TOP-LEVEL-FORM")))
      `(eval-when ,times
	 (defun ,thunk-name () (declare (sys:function-parent ,@name)) ,form)
	 (,thunk-name)))
    #+Lucid3.0
    `(compiler-let ((system:*compiler-message-string*
		      (or system:*compiler-message-string*
			  ,(definition-name))))
       (eval-when ,times ,form))
        #-(or Genera GCLisp :coral Lucid3.0)
    (make-progn `',name `(eval-when ,times ,form))))

;----------------
;from defs.lisp
(defun setfboundp (symbol)
  #+Genera nil
  #+Lucid  (locally
	     (declare (special lucid::*setf-inverse-table*
			       lucid::*simple-setf-method-table*
			       lucid::*setf-method-expander-table*))
	     (or (gethash symbol lucid::*setf-inverse-table*)
		 (gethash symbol lucid::*simple-setf-method-table*)
		 (gethash symbol lucid::*setf-method-expander-table*)))
  #+kcl    (or (get symbol 'si::setf-method)
	       (get symbol 'si::setf-update-fn)
	       (get symbol 'si::setf-lambda))
  #+Xerox  (or (get symbol :setf-inverse)
	       (get symbol 'il:setf-inverse)
	       (get symbol 'il:setfn)
	       (get symbol :shared-setf-inverse)
	       (get symbol :setf-method-expander)
	       (get symbol 'il:setf-method-expander))

  #+:coral (or (get symbol 'ccl::setf-inverse)
	       (get symbol 'ccl::setf-method-expander))
  
  #-(or Genera Lucid KCL Xerox :coral) nil)


-------