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 / runtime / gdatab.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  79 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gdatab.scm,v 14.6 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 1990, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. 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.  
  22. ;;;; Global Databases
  23. ;;; package: (runtime global-database)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! event:after-restore (make-event-distributor))
  29.   (set! event:after-restart (make-event-distributor))
  30.   (set! event:before-exit (make-event-distributor))
  31.   (set! tagged-pair-methods (make-1d-table))
  32.   (set! tagged-vector-methods (make-1d-table))
  33.   (set! named-structure-descriptions (make-1d-table)))
  34.  
  35. (define event:after-restore)
  36. (define event:after-restart)
  37. (define event:before-exit)
  38. (define tagged-pair-methods)
  39. (define tagged-vector-methods)
  40. (define named-structure-descriptions)
  41.  
  42. (define (unparser/tagged-pair-method tag)
  43.   (and (not (future? tag))
  44.        (1d-table/get tagged-pair-methods tag false)))
  45.  
  46. (define (unparser/set-tagged-pair-method! tag method)
  47.   (1d-table/put! tagged-pair-methods tag method))
  48.  
  49. (define (unparser/tagged-vector-method tag)
  50.   (and (not (future? tag))
  51.        (1d-table/get tagged-vector-methods tag false)))
  52.  
  53. (define (unparser/set-tagged-vector-method! tag method)
  54.   (1d-table/put! tagged-vector-methods tag method))
  55.  
  56. (define (named-structure/get-tag-description tag)
  57.   (1d-table/get named-structure-descriptions tag false))
  58.  
  59. (define (named-structure/set-tag-description! tag description)
  60.   (1d-table/put! named-structure-descriptions tag description))
  61.  
  62. ;;; Support for old-style methods
  63.  
  64. (define (add-unparser-special-pair! tag method)
  65.   (unparser/set-tagged-pair-method! tag (convert-old-method method)))
  66.  
  67. (define (add-unparser-special-object! tag method)
  68.   (unparser/set-tagged-vector-method! tag (convert-old-method method)))
  69.  
  70. (define (unparse-with-brackets thunk)
  71.   (write-string "#[")
  72.   (thunk)
  73.   (write-char #\]))
  74.  
  75. (define (convert-old-method method)
  76.   (lambda (state object)
  77.     (with-output-to-port (unparser-state/port state)
  78.       (lambda ()
  79.     (method object)))))