Changeset 8404


Ignore:
Timestamp:
01/27/05 12:42:40 (16 years ago)
Author:
piso
Message:

:PRINT-FUNCTION

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/defstruct.lisp

    r8176 r8404  
    11;;; defstruct.lisp
    22;;;
    3 ;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.58 2004-11-21 05:37:26 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: defstruct.lisp,v 1.59 2005-01-27 12:42:40 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1919
    2020(in-package "SYSTEM")
     21
     22(export 'structure-print-function)
    2123
    2224(require :source-transform)
     
    389391           (setf *dd-predicate* nil)
    390392           (setf *dd-predicate* (symbol-name (cadr option))))))
     393    (:print-function
     394     (when (= (length option) 2)
     395       (setf *dd-print-function* (cadr option))))
    391396    (:type
    392397     (setf *dd-type* (cadr option)))))
     
    497502                                               :initial-offset ,*dd-initial-offset*
    498503                                               :predicate ,*dd-predicate*
    499                                                :print-function ,*dd-print-function*
     504                                               :print-function ',*dd-print-function*
    500505                                               :direct-slots ',*dd-direct-slots*
    501506                                               :slots ',*dd-slots*))
     
    519524                                               :initial-offset ,*dd-initial-offset*
    520525                                               :predicate ,*dd-predicate*
    521                                                :print-function ,*dd-print-function*
     526                                               :print-function ',*dd-print-function*
    522527                                               :direct-slots ',*dd-direct-slots*
    523528                                               :slots ',*dd-slots*)))
     
    527532           ,@(define-copier)
    528533           ',*dd-name*))))
     534
     535(defun structure-print-function (arg)
     536  (let ((type (cond ((symbolp arg)
     537                     arg)
     538                    ((classp arg)
     539                     (class-name arg))
     540                    (t
     541                     (type-of arg)))))
     542    (when type
     543      (let ((dd (get type 'structure-definition)))
     544        (and dd (dd-print-function dd))))))
Note: See TracChangeset for help on using the changeset viewer.