/[cmucl]/src/pcl/macros.lisp
ViewVC logotype

Diff of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by phg, Tue Jan 12 18:25:48 1993 UTC revision 1.6.1.1 by ram, Tue Jul 20 19:09:32 1993 UTC
# Line 333  Line 333 
333  ;;; Similar to printing-random-object in the lisp machine but much simpler  ;;; Similar to printing-random-object in the lisp machine but much simpler
334  ;;; and machine independent.  ;;; and machine independent.
335  (defmacro printing-random-thing ((thing stream) &body body)  (defmacro printing-random-thing ((thing stream) &body body)
336    (once-only (stream)    #+cmu17
337    `(progn (format ,stream "#<")    `(print-unreadable-object (,thing ,stream :identity t) ,@body)
338            ,@body    #-cmu17
339            (format ,stream " ")    (once-only (thing stream)
340            (printing-random-thing-internal ,thing ,stream)      `(progn
341            (format ,stream ">"))))         (when *print-readably*
342             (error "~S cannot be printed readably." thing))
343           (format ,stream "#<")
344           ,@body
345           (format ,stream " ")
346           (printing-random-thing-internal ,thing ,stream)
347           (format ,stream ">"))))
348    
349  (defun printing-random-thing-internal (thing stream)  (defun printing-random-thing-internal (thing stream)
350    (declare (ignore thing stream))    (declare (ignore thing stream))
# Line 373  Line 379 
379  ;(warn "****** Things will go faster if you fix define-compiler-macro")  ;(warn "****** Things will go faster if you fix define-compiler-macro")
380  )  )
381    
382    #-cmu
383  (defmacro define-compiler-macro (name arglist &body body)  (defmacro define-compiler-macro (name arglist &body body)
384    #+(or lucid kcl)    #+(or lucid kcl)
385    `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro    `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
# Line 468  Line 475 
475          (setf (find-class-cell-class cell) new-value)          (setf (find-class-cell-class cell) new-value)
476          (when (or (eq *boot-state* 'complete)          (when (or (eq *boot-state* 'complete)
477                    (eq *boot-state* 'braid))                    (eq *boot-state* 'braid))
478              #+cmu17
479              (let ((lclass (kernel:layout-class (class-wrapper new-value))))
480                (setf (lisp:class-name lclass) (class-name new-value))
481                (unless (eq (lisp:find-class symbol nil) lclass)
482                  (setf (lisp:find-class symbol) lclass)))
483    
484            (setf (find-class-cell-predicate cell)            (setf (find-class-cell-predicate cell)
485                  (symbol-function (class-predicate-name new-value)))                  (symbol-function (class-predicate-name new-value)))
486            (when (and new-value (not (forward-referenced-class-p new-value)))            (when (and new-value (not (forward-referenced-class-p new-value)))
487    
488              (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))              (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
489                (update-initialize-info-internal                (update-initialize-info-internal
490                 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))                 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.6.1.1

  ViewVC Help
Powered by ViewVC 1.1.5