/[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.7 by pw, Thu Feb 6 21:24:14 1997 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 456  Line 463 
463    (find-class-predicate-from-cell    (find-class-predicate-from-cell
464     symbol (find-class-cell symbol errorp) errorp))     symbol (find-class-cell symbol errorp) errorp))
465    
466    (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
467    
468    ; Use this definition in any CL implementation supporting
469    ; both define-compiler-macro and load-time-value.
470    #+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class
471    (define-compiler-macro find-class (&whole form
472                                       symbol &optional (errorp t) environment)
473      (declare (ignore environment))
474      (if (and (constantp symbol)
475               (legal-class-name-p (eval symbol))
476               (constantp errorp)
477               (member *boot-state* '(braid complete)))
478          (let ((symbol (eval symbol))
479                (errorp (not (null (eval errorp))))
480                (class-cell (make-symbol "CLASS-CELL")))
481            `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
482               (or (find-class-cell-class ,class-cell)
483                   #-cmu17
484                   (find-class-from-cell ',symbol ,class-cell ,errorp)
485                   #+cmu17
486                   ,(if errorp
487                        `(find-class-from-cell ',symbol ,class-cell t)
488                        `(and (kernel:class-cell-class
489                               ',(kernel:find-class-cell symbol))
490                              (find-class-from-cell ',symbol ,class-cell nil))))))
491          form))
492    
493  #-setf  #-setf
494  (defsetf find-class (symbol &optional (errorp t) environment) (new-value)  (defsetf find-class (symbol &optional (errorp t) environment) (new-value)
495    (declare (ignore errorp environment))    (declare (ignore errorp environment))
496    `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))    `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))
497    
498  (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)  (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
   (declare (special *boot-state*))  
499    (if (legal-class-name-p symbol)    (if (legal-class-name-p symbol)
500        (let ((cell (find-class-cell symbol)))        (let ((cell (find-class-cell symbol)))
501          (setf (find-class-cell-class cell) new-value)          (setf (find-class-cell-class cell) new-value)
502          (when (or (eq *boot-state* 'complete)          (when (or (eq *boot-state* 'complete)
503                    (eq *boot-state* 'braid))                    (eq *boot-state* 'braid))
504              #+cmu17
505              (let ((lclass (kernel:layout-class (class-wrapper new-value))))
506                (setf (lisp:class-name lclass) (class-name new-value))
507                (unless (eq (lisp:find-class symbol nil) lclass)
508                  (setf (lisp:find-class symbol) lclass)))
509    
510            (setf (find-class-cell-predicate cell)            (setf (find-class-cell-predicate cell)
511                  (symbol-function (class-predicate-name new-value)))                  (symbol-function (class-predicate-name new-value)))
512            (when (and new-value (not (forward-referenced-class-p new-value)))            (when (and new-value (not (forward-referenced-class-p new-value)))
513    
514              (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))              (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
515                (update-initialize-info-internal                (update-initialize-info-internal
516                 (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.7

  ViewVC Help
Powered by ViewVC 1.1.5