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 / cref / object.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  211 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: object.scm,v 1.10 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Package Model Data Structures
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-structure
  27.     (package-description
  28.      (type vector)
  29.      (named
  30.       (string->symbol "#[(cross-reference)package-description]"))
  31.      (constructor make-package-description (name parent))
  32.      (conc-name package-description/))
  33.   (name #f read-only #t)
  34.   (file-cases '())
  35.   (parent #f read-only #t)
  36.   (initialization #f)
  37.   (exports '())
  38.   (imports '()))
  39.  
  40. (define-structure
  41.     (pmodel
  42.      (type vector)
  43.      (named (string->symbol "#[(cross-reference)pmodel]"))
  44.      (conc-name pmodel/))
  45.   (root-package false read-only true)
  46.   (primitive-package false read-only true)
  47.   (packages false read-only true)
  48.   (extra-packages false read-only true)
  49.   (pathname false read-only true))
  50.  
  51. (define-structure
  52.     (package
  53.      (type vector)
  54.      (named (string->symbol "#[(cross-reference)package]"))
  55.      (constructor make-package (name parent))
  56.      (conc-name package/)
  57.      (print-procedure
  58.       (standard-unparser-method 'PACKAGE
  59.     (lambda (package port)
  60.       (write-char #\space port)
  61.       (write (package/name package) port)))))
  62.  
  63.   (name #f read-only #t)
  64.   (file-cases '())
  65.   (files '())
  66.   (initialization #f)
  67.   parent
  68.   (children '())
  69.   (bindings (make-rb-tree eq? symbol<?) read-only #t)
  70.   (references (make-rb-tree eq? symbol<?) read-only #t))
  71.  
  72. (define-integrable (package/n-files package)
  73.   (length (package/files package)))
  74.  
  75. (define-integrable (package/root? package)
  76.   (null? (package/name package)))
  77.  
  78. (define-integrable (package/find-binding package name)
  79.   (rb-tree/lookup (package/bindings package) name #f))
  80.  
  81. (define-integrable (package/sorted-bindings package)
  82.   (rb-tree/datum-list (package/bindings package)))
  83.  
  84. (define-integrable (package/sorted-references package)
  85.   (rb-tree/datum-list (package/references package)))
  86.  
  87. (define-integrable (file-case/type file-case)
  88.   (car file-case))
  89.  
  90. (define-integrable (file-case/clauses file-case)
  91.   (cdr file-case))
  92.  
  93. (define-integrable (file-case-clause/keys clause)
  94.   (car clause))
  95.  
  96. (define-integrable (file-case-clause/files clause)
  97.   (cdr clause))
  98.  
  99. (define-structure
  100.     (binding
  101.      (type vector)
  102.      (named (string->symbol "#[(cross-reference)binding]"))
  103.      (constructor %make-binding (package name value-cell))
  104.      (conc-name binding/)
  105.      (print-procedure
  106.       (standard-unparser-method 'BINDING
  107.     (lambda (binding port)
  108.       (write-char #\space port)
  109.       (write (binding/name binding) port)
  110.       (write-char #\space port)
  111.       (write (package/name (binding/package binding)) port)))))
  112.   (package false read-only true)
  113.   (name false read-only true)
  114.   (value-cell false read-only true)
  115.   (references '())
  116.   (links '()))
  117.  
  118. (define (make-binding package name value-cell)
  119.   (let ((binding (%make-binding package name value-cell)))
  120.     (set-value-cell/bindings!
  121.      value-cell
  122.      (cons binding (value-cell/bindings value-cell)))
  123.     binding))
  124.  
  125. (define-integrable (binding/expressions binding)
  126.   (value-cell/expressions (binding/value-cell binding)))
  127.  
  128. (define-integrable (binding/source-binding binding)
  129.   (value-cell/source-binding (binding/value-cell binding)))
  130.  
  131. (define (binding/internal? binding)
  132.   (eq? binding (binding/source-binding binding)))
  133.  
  134. (define-structure
  135.     (value-cell
  136.      (type vector)
  137.      (named (string->symbol "#[(cross-reference)value-cell]"))
  138.      (constructor make-value-cell ())
  139.      (conc-name value-cell/))
  140.   (bindings '())
  141.   (expressions '())
  142.   (source-binding false))
  143.  
  144. (define-structure
  145.     (link
  146.      (type vector)
  147.      (named (string->symbol "#[(cross-reference)link]"))
  148.      (constructor %make-link)
  149.      (conc-name link/))
  150.   (source false read-only true)
  151.   (destination false read-only true))
  152.  
  153. (define (make-link source-binding destination-binding)
  154.   (let ((link (%make-link source-binding destination-binding)))
  155.     (set-binding/links! source-binding
  156.             (cons link (binding/links source-binding)))
  157.     link))
  158.  
  159. (define-structure
  160.     (expression
  161.      (type vector)
  162.      (named (string->symbol "#[(cross-reference)expression]"))
  163.      (constructor make-expression (package file type))
  164.      (conc-name expression/))
  165.   (package false read-only true)
  166.   (file false read-only true)
  167.   (type false read-only true)
  168.   (references '())
  169.   (value-cell false))
  170.  
  171. (define-structure
  172.     (reference
  173.      (type vector)
  174.      (named (string->symbol "#[(cross-reference)reference]"))
  175.      (constructor %make-reference (package name))
  176.      (conc-name reference/)
  177.      (print-procedure
  178.       (standard-unparser-method 'REFERENCE
  179.     (lambda (reference port)
  180.       (write-char #\space port)
  181.       (write (reference/name reference) port)
  182.       (write-char #\space port)
  183.       (write (package/name (reference/package reference)) port)))))
  184.   (package false read-only true)
  185.   (name false read-only true)
  186.   (expressions '())
  187.   (binding false))
  188.  
  189. (define (symbol-list=? x y)
  190.   (if (null? x)
  191.       (null? y)
  192.       (and (not (null? y))
  193.        (eq? (car x) (car y))
  194.        (symbol-list=? (cdr x) (cdr y)))))
  195.  
  196. (define (symbol-list<? x y)
  197.   (and (not (null? y))
  198.        (if (or (null? x)
  199.            (symbol<? (car x) (car y)))
  200.        true
  201.        (and (eq? (car x) (car y))
  202.         (symbol-list<? (cdr x) (cdr y))))))
  203.  
  204. (define (package<? x y)
  205.   (symbol-list<? (package/name x) (package/name y)))
  206.  
  207. (define (binding<? x y)
  208.   (symbol<? (binding/name x) (binding/name y)))
  209.  
  210. (define (reference<? x y)
  211.   (symbol<? (reference/name x) (reference/name y)))