/[cmucl]/src/code/defstruct.lisp
ViewVC logotype

Diff of /src/code/defstruct.lisp

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

revision 1.73 by pw, Thu Mar 15 18:01:36 2001 UTC revision 1.74 by pw, Fri Sep 21 12:00:43 2001 UTC
# Line 328  Line 328 
328    (declare (ignore depth))    (declare (ignore depth))
329    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
330    
   
331  (defun dd-maybe-make-print-method (defstruct)  (defun dd-maybe-make-print-method (defstruct)
332    ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.    ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.
333    (let ((print-function-value (dd-print-function defstruct)))    (let ((print-function-value (dd-print-function defstruct)))
# Line 337  Line 336 
336              (function (cdr print-function-value)))              (function (cdr print-function-value)))
337          (unless (eq kind 'lambda)          (unless (eq kind 'lambda)
338            (setf (dd-print-function defstruct) nil)            (setf (dd-print-function defstruct) nil)
339            (let* ((name (dd-name defstruct))            (let* ((class (dd-name defstruct))
340                   (function (if (symbolp function) `',function `#',function))                   (func (if (symbolp function) `',function `#',function)))
                  (mcall `(funcall ,function o s))  
                  (fcall `(funcall ,function o s *current-level*)))  
341              ;; We can only generate this code if CLOS is loaded. Maybe should              ;; We can only generate this code if CLOS is loaded. Maybe should
342              ;; signal an error instead of quietly ignoring the defmethod?              ;; signal an error instead of quietly ignoring the defmethod?
343              `((when (fboundp 'print-object)              `((when (fboundp 'print-object)
344                  (defmethod print-object ((o ,name) s)                  (defmethod print-object ((object ,class) stream)
345                    ,(ecase kind                    (funcall
346                       (:print-object mcall)                     ,func object stream
347                       (:print-function fcall)))))))))))                     ,@(when (or (eq kind :print-function)
348                                   (eq function 'default-structure-print))
349                           '(*current-level*))))))))))))
350    
351    
352  ;;; The legendary macro itself.  ;;; The legendary macro itself.

Legend:
Removed from v.1.73  
changed lines
  Added in v.1.74

  ViewVC Help
Powered by ViewVC 1.1.5