home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / sos / printer.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  124 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: printer.scm,v 1.2 1999/01/02 06:19:10 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1996, 1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Printer Support
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define write-instance
  26.   (make-generic-procedure 2 'WRITE-INSTANCE))
  27.  
  28. (add-method write-instance
  29.   (make-method (list <instance>)
  30.     (lambda (instance port)
  31.       (write-instance-helper 'INSTANCE instance port
  32.     (lambda ()
  33.       (let ((name (class-name (instance-class instance))))
  34.         (if name
  35.         (begin
  36.           (write-string " of " port)
  37.           (write name port)))))))))
  38. #|
  39. (add-method write-instance
  40.   (make-method (list <class>)
  41.     (lambda (class port)
  42.       (write-instance-helper 'CLASS class port
  43.     (lambda ()
  44.       (let ((name (class-name class)))
  45.         (if name
  46.         (begin
  47.           (write-char #\space port)
  48.           (write name port)))))))))
  49. |#
  50. (add-method write-instance
  51.   (make-method (list <generic-procedure>)
  52.     (lambda (procedure port)
  53.       (write-instance-helper 'GENERIC-PROCEDURE procedure port
  54.     (lambda ()
  55.       (let ((name (generic-procedure-name procedure)))
  56.         (if name
  57.         (begin
  58.           (write-char #\space port)
  59.           (write name port)))))))))
  60.  
  61. (let ((install
  62.        (lambda (class name)
  63.      (add-method write-instance
  64.        (make-method (list class)
  65.          (lambda (object port)
  66.            (write-instance-helper name object port #f)))))))
  67.   (install <method> 'METHOD)
  68.   (install <chained-method> 'CHAINED-METHOD)
  69.   (install <computed-method> 'COMPUTED-METHOD)
  70.   (install <computed-emp> 'COMPUTED-EMP)
  71.   (install <%record> '%RECORD))
  72.  
  73. (add-method write-instance
  74.   (make-method (list <record>)
  75.     (lambda (record port)
  76.       (write-instance-helper (record-type-name (record-type-descriptor record))
  77.                  record port #f))))
  78.  
  79. (add-method write-instance
  80.   (make-method (list <dispatch-tag>)
  81.     (lambda (tag port)
  82.       (write-instance-helper 'DISPATCH-TAG tag port
  83.     (lambda ()
  84.       (write-char #\space port)
  85.       (write (dispatch-tag-contents tag) port))))))
  86.  
  87. (define (write-instance-helper name object port thunk)
  88.   (write-string "#[" port)
  89.   (display name port)
  90.   (if object
  91.       (begin
  92.     (write-char #\space port)
  93.     (write (hash object) port)))
  94.   (if thunk
  95.       (thunk))
  96.   (write-char #\] port))
  97.  
  98. (add-generic-procedure-generator unparse-record
  99.   (lambda (generic tags)
  100.     generic
  101.     (and (let ((class (dispatch-tag-contents (cadr tags))))
  102.        (and (class? class)
  103.         (subclass? class <instance>)))
  104.      (lambda (state instance)
  105.        (with-current-unparser-state state
  106.          (lambda (port)
  107.            (write-instance instance port)))))))
  108.  
  109. (add-generic-procedure-generator pp-description
  110.   (lambda (generic tags)
  111.     generic
  112.     (and (let ((class (dispatch-tag-contents (car tags))))
  113.        (and (class? class)
  114.         (subclass? class <instance>)))
  115.      instance-description)))
  116.  
  117. (define (instance-description instance)
  118.   (map (lambda (slot)
  119.      (let ((name (slot-name slot)))
  120.        (cons name
  121.          (if (slot-initialized? instance name)
  122.              (list (slot-value instance name))
  123.              '()))))
  124.        (class-slots (instance-class instance))))