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 / compiler / base / object.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  147 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: object.scm,v 4.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 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. ;;;; Support for tagged objects
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-structure (vector-tag
  27.            (constructor %make-vector-tag (parent name index)))
  28.   (parent false read-only true)
  29.   (name false read-only true)
  30.   (index false read-only true)
  31.   (%unparser false)
  32.   (description false)
  33.   (method-alist '()))
  34.  
  35. (define make-vector-tag
  36.   (let ((root-tag (%make-vector-tag false 'OBJECT false)))
  37.     (set-vector-tag-%unparser!
  38.      root-tag
  39.      (lambda (state object)
  40.        ((standard-unparser
  41.      (symbol->string (vector-tag-name (tagged-vector/tag object)))
  42.      false)
  43.     state object)))
  44.     (named-lambda (make-vector-tag parent name enumeration)
  45.       (let ((tag
  46.          (%make-vector-tag (or parent root-tag)
  47.                    name
  48.                    (and enumeration
  49.                     (enumeration/name->index enumeration
  50.                                  name)))))
  51.     (unparser/set-tagged-vector-method! tag tagged-vector/unparse)
  52.     tag))))
  53.  
  54. (define (define-vector-tag-unparser tag unparser)
  55.   (set-vector-tag-%unparser! tag unparser)
  56.   (vector-tag-name tag))
  57.  
  58. (define (vector-tag-unparser tag)
  59.   (or (vector-tag-%unparser tag)
  60.       (let ((parent (vector-tag-parent tag)))
  61.     (if parent
  62.         (vector-tag-unparser parent)
  63.         (error "Missing unparser" tag)))))
  64.  
  65. (define (vector-tag-put! tag key value)
  66.   (let ((entry (assq key (vector-tag-method-alist tag))))
  67.     (if entry
  68.     (set-cdr! entry value)
  69.     (set-vector-tag-method-alist! tag
  70.                       (cons (cons key value)
  71.                         (vector-tag-method-alist tag))))))
  72.  
  73. (define (vector-tag-get tag key)
  74.   (let ((value
  75.      (or (assq key (vector-tag-method-alist tag))
  76.          (let loop ((tag (vector-tag-parent tag)))
  77.            (and tag
  78.             (or (assq key (vector-tag-method-alist tag))
  79.             (loop (vector-tag-parent tag))))))))
  80.     (and value (cdr value))))
  81.  
  82. (define (define-vector-tag-method tag name method)
  83.   (vector-tag-put! tag name method)
  84.   name)
  85.  
  86. (define (vector-tag-method tag name)
  87.   (or (vector-tag-get tag name)
  88.       (error "Unbound method" name tag)))
  89.  
  90. (define-integrable make-tagged-vector
  91.   vector)
  92.  
  93. (define-integrable (tagged-vector/tag vector)
  94.   (vector-ref vector 0))
  95.  
  96. (define-integrable (tagged-vector/index vector)
  97.   (vector-tag-index (tagged-vector/tag vector)))
  98.  
  99. (define-integrable (tagged-vector/unparser vector)
  100.   (vector-tag-unparser (tagged-vector/tag vector)))
  101.  
  102. (define (tagged-vector? object)
  103.   (and (vector? object)
  104.        (not (zero? (vector-length object)))
  105.        (vector-tag? (tagged-vector/tag object))))
  106.  
  107. (define (->tagged-vector object)
  108.   (let ((object
  109.      (if (exact-nonnegative-integer? object)
  110.          (unhash object)
  111.          object)))
  112.     (and (or (tagged-vector? object)
  113.          (named-structure? object))
  114.      object)))
  115.  
  116. (define (tagged-vector/predicate tag)
  117.   (lambda (object)
  118.     (and (vector? object)
  119.      (not (zero? (vector-length object)))
  120.      (eq? tag (tagged-vector/tag object)))))
  121.  
  122. (define (tagged-vector/subclass-predicate tag)
  123.   (lambda (object)
  124.     (and (vector? object)
  125.      (not (zero? (vector-length object)))
  126.      (let loop ((tag* (tagged-vector/tag object)))
  127.        (and (vector-tag? tag*)
  128.         (or (eq? tag tag*)
  129.             (loop (vector-tag-parent tag*))))))))
  130.  
  131. (define (tagged-vector/description object)
  132.   (cond ((named-structure? object)
  133.      named-structure/description)
  134.     ((tagged-vector? object)
  135.      (vector-tag-description (tagged-vector/tag object)))
  136.     (else
  137.      (error "Not a tagged vector" object))))
  138.  
  139. (define (standard-unparser name unparser)
  140.   (let ((name (string-append (symbol->string 'LIAR) ":" name)))
  141.     (if unparser
  142.     (unparser/standard-method name unparser)
  143.     (unparser/standard-method name))))
  144.  
  145. (define (tagged-vector/unparse state vector)
  146.   (fluid-let ((*unparser-radix* 16))
  147.     ((tagged-vector/unparser vector) state vector)))