Changeset 8616


Ignore:
Timestamp:
02/20/05 18:24:15 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r8610 r8616  
    33 *
    44 * Copyright (C) 2003-2005 Peter Graves
    5  * $Id: StructureObject.java,v 1.45 2005-02-20 14:13:55 piso Exp $
     5 * $Id: StructureObject.java,v 1.46 2005-02-20 18:24:15 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    150150            if (currentLevel >= maxLevel && slots.length > 0)
    151151                return "#";
    152             Symbol STRUCTURE_PRINT_FUNCTION =
    153                 PACKAGE_SYS.intern("STRUCTURE-PRINT-FUNCTION");
    154             LispObject fun = STRUCTURE_PRINT_FUNCTION.getSymbolFunction();
    155             if (fun != null) {
    156                 LispObject printFunction = thread.execute(fun, this);
    157                 if (printFunction != NIL) {
    158                     StringOutputStream stream = new StringOutputStream();
    159                     thread.execute(printFunction, this, stream, currentPrintLevel);
    160                     return stream.getString().getStringValue();
    161                 }
    162             }
    163152            StringBuffer sb = new StringBuffer("#S(");
    164153            sb.append(structureClass.getSymbol().writeToString());
  • trunk/j/src/org/armedbear/lisp/defstruct.lisp

    r8445 r8616  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.60 2005-02-01 15:22:06 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.61 2005-02-20 18:23:08 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2020(in-package "SYSTEM")
    2121
    22 (export 'structure-print-function)
    23 
    2422(require :source-transform)
    2523
    2624;;; DEFSTRUCT-DESCRIPTION
    2725
    28 (defmacro dd-name (x)           `(aref ,x  0))
    29 (defmacro dd-conc-name (x)      `(aref ,x  1))
    30 (defmacro dd-constructors (x)   `(aref ,x  2))
    31 (defmacro dd-copier (x)         `(aref ,x  3))
    32 (defmacro dd-include (x)        `(aref ,x  4))
    33 (defmacro dd-type (x)           `(aref ,x  5))
    34 (defmacro dd-named (x)          `(aref ,x  6))
    35 (defmacro dd-initial-offset (x) `(aref ,x  7))
    36 (defmacro dd-predicate (x)      `(aref ,x  8))
    37 (defmacro dd-print-function (x) `(aref ,x  9))
    38 (defmacro dd-direct-slots (x)   `(aref ,x 10))
    39 (defmacro dd-slots (x)          `(aref ,x 11))
     26(defmacro dd-name (x)                `(aref ,x  0))
     27(defmacro dd-conc-name (x)           `(aref ,x  1))
     28(defmacro dd-default-constructor (x) `(aref ,x  2))
     29(defmacro dd-constructors (x)        `(aref ,x  3))
     30(defmacro dd-copier (x)              `(aref ,x  4))
     31(defmacro dd-include (x)             `(aref ,x  5))
     32(defmacro dd-type (x)                `(aref ,x  6))
     33(defmacro dd-named (x)               `(aref ,x  7))
     34(defmacro dd-initial-offset (x)      `(aref ,x  8))
     35(defmacro dd-predicate (x)           `(aref ,x  9))
     36(defmacro dd-print-function (x)      `(aref ,x 10))
     37(defmacro dd-print-object (x)        `(aref ,x 11))
     38(defmacro dd-direct-slots (x)        `(aref ,x 12))
     39(defmacro dd-slots (x)               `(aref ,x 13))
    4040
    4141(defun make-defstruct-description (&key name
    4242                                        conc-name
     43                                        default-constructor
    4344                                        constructors
    4445                                        copier
     
    4950                                        predicate
    5051                                        print-function
     52                                        print-object
    5153                                        direct-slots
    5254                                        slots)
    53   (let ((dd (make-array 13)))
     55  (let ((dd (make-array 14)))
    5456    (setf (dd-name dd) name
    5557          (dd-conc-name dd) conc-name
     58          (dd-default-constructor dd) default-constructor
    5659          (dd-constructors dd) constructors
    5760          (dd-copier dd) copier
     
    6265          (dd-predicate dd) predicate
    6366          (dd-print-function dd) print-function
     67          (dd-print-object dd) print-object
    6468          (dd-direct-slots dd) direct-slots
    6569          (dd-slots dd) slots)
     
    9397(defvar *dd-name*)
    9498(defvar *dd-conc-name*)
     99(defvar *dd-default-constructor*)
    95100(defvar *dd-constructors*)
    96101(defvar *dd-copier*)
     
    101106(defvar *dd-predicate*)
    102107(defvar *dd-print-function*)
     108(defvar *dd-print-object*)
    103109(defvar *dd-direct-slots*)
    104110(defvar *dd-slots*)
     
    114120      (let ((name (dsd-name slot))
    115121            (initform (dsd-initform slot)))
    116         (if name
    117             (progn
    118               (push (list (list (keywordify name) name) initform) keys)
    119               (push name values))
     122        (if (or name (dsd-reader slot))
     123            (let ((dummy (gensym)))
     124              (push (list (list (keywordify name) dummy) initform) keys)
     125              (push dummy values))
    120126            (push initform values))))
    121127    (setf keys (cons '&key (nreverse keys))
     
    352358           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
    353359
     360(defun define-print-function ()
     361  (cond (*dd-print-function*
     362         (if (cadr *dd-print-function*)
     363             `((defmethod print-object ((instance ,*dd-name*) stream)
     364                 (funcall (function ,(cadr *dd-print-function*))
     365                          instance stream *current-print-level*)))
     366             `((defmethod print-object ((instance ,*dd-name*) stream)
     367                 (write-string (%write-to-string instance) stream)))))
     368        (*dd-print-object*
     369         (if (cadr *dd-print-object*)
     370             `((defmethod print-object ((instance ,*dd-name*) stream)
     371                 (funcall (function ,(cadr *dd-print-object*))
     372                          instance stream)))
     373             `((defmethod print-object ((instance ,*dd-name*) stream)
     374                 (write-string (%write-to-string instance) stream)))))
     375        (t
     376         nil)))
     377
    354378(defun parse-1-option (option)
    355379  (case (car option)
     
    366390          (setf name (default-constructor-name)
    367391                arglist nil)
    368           (push (list name arglist) *dd-constructors*))
     392          (push (list name arglist) *dd-constructors*)
     393          )
    369394         (1
    370395          (if (null (car args))
     
    392417           (setf *dd-predicate* (symbol-name (cadr option))))))
    393418    (:print-function
    394      (when (= (length option) 2)
    395        (setf *dd-print-function* (cadr option))))
     419     (setf *dd-print-function* option))
     420    (:print-object
     421     (setf *dd-print-object* option))
    396422    (:type
    397423     (setf *dd-type* (cadr option)))))
     
    417443  (let ((*dd-name* nil)
    418444        (*dd-conc-name* nil)
     445        (*dd-default-constructor* nil)
    419446        (*dd-constructors* nil)
    420447        (*dd-copier* nil)
     
    425452        (*dd-predicate* nil)
    426453        (*dd-print-function* nil)
     454        (*dd-print-object* nil)
    427455        (*dd-direct-slots* ())
    428456        (*dd-slots* ()))
     
    495523                   (make-defstruct-description :name ',*dd-name*
    496524                                               :conc-name ',*dd-conc-name*
     525                                               :default-constructor ',*dd-default-constructor*
    497526                                               :constructors ',*dd-constructors*
    498527                                               :copier ',*dd-copier*
     
    503532                                               :predicate ,*dd-predicate*
    504533                                               :print-function ',*dd-print-function*
     534                                               :print-object ',*dd-print-object*
    505535                                               :direct-slots ',*dd-direct-slots*
    506536                                               :slots ',*dd-slots*))
     
    511541           ,@(define-access-functions)
    512542           ,@(define-copier)
     543           ,@(define-print-function)
    513544           ',*dd-name*)
    514545        `(progn
     
    517548                   (make-defstruct-description :name ',*dd-name*
    518549                                               :conc-name ',*dd-conc-name*
     550                                               :default-constructor ',*dd-default-constructor*
    519551                                               :constructors ',*dd-constructors*
    520552                                               :copier ',*dd-copier*
     
    525557                                               :predicate ,*dd-predicate*
    526558                                               :print-function ',*dd-print-function*
     559                                               :print-object ',*dd-print-object*
    527560                                               :direct-slots ',*dd-direct-slots*
    528561                                               :slots ',*dd-slots*)))
     
    531564           ,@(define-access-functions)
    532565           ,@(define-copier)
     566           ,@(define-print-function)
    533567           ',*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.