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 / class.scm < prev    next >
Text File  |  1999-01-02  |  13KB  |  390 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: class.scm,v 1.9 1999/01/02 06:19:10 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995-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. ;;;; Classes
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define-structure (class (conc-name class/)
  26.              (constructor %make-class
  27.                       (name direct-superclasses direct-slots))
  28.              (print-procedure
  29.               (standard-unparser-method 'CLASS
  30.                 (lambda (class port)
  31.                   (let ((name (class-name class)))
  32.                 (if name
  33.                     (begin
  34.                       (write-char #\space port)
  35.                       (write name port))))))))
  36.   (name #f read-only #t)
  37.   (direct-superclasses #f read-only #t)
  38.   (direct-slots #f read-only #t)
  39.   precedence-list
  40.   slots
  41.   dispatch-tag)
  42.  
  43. (define (make-class name direct-superclasses direct-slots)
  44.   (if (not (and (list? direct-superclasses)
  45.         (for-all? direct-superclasses class?)))
  46.       (error:wrong-type-argument direct-superclasses
  47.                  "list of classes"
  48.                  'MAKE-CLASS))
  49.   (if (not (list? direct-slots))
  50.       (error:wrong-type-argument direct-slots "list" 'MAKE-CLASS))
  51.   (let ((class
  52.      (%make-class name
  53.               (if (null? direct-superclasses)
  54.               (list <instance>)
  55.               direct-superclasses)
  56.               (map (lambda (slot)
  57.                  (canonicalize-slot-argument slot 'MAKE-CLASS))
  58.                direct-slots))))
  59.     (set-class/precedence-list! class (compute-precedence-list class))
  60.     (set-class/slots! class (compute-slots class))
  61.     (set-class/dispatch-tag! class (make-dispatch-tag class))
  62.     (install-slot-accessor-methods class)
  63.     class))
  64.  
  65. (define (make-trivial-subclass superclass . superclasses)
  66.   (make-class (class-name superclass) (cons superclass superclasses) '()))
  67.  
  68. (define <object>
  69.   (let ((class (%make-class '<OBJECT> '() '())))
  70.     (set-class/precedence-list! class (list class))
  71.     (set-class/slots! class '())
  72.     (set-class/dispatch-tag! class (make-dispatch-tag class))
  73.     class))
  74.  
  75. (define (class-name class)
  76.   (class/name (guarantee-class class 'CLASS-NAME)))
  77.  
  78. (define (class-direct-superclasses class)
  79.   (class/direct-superclasses
  80.    (guarantee-class class 'CLASS-DIRECT-SUPERCLASSES)))
  81.  
  82. (define (class-direct-slot-names class)
  83.   (map car (class/direct-slots (guarantee-class class 'CLASS-DIRECT-SLOTS))))
  84.  
  85. (define (class-precedence-list class)
  86.   (class/precedence-list (guarantee-class class 'CLASS-PRECEDENCE-LIST)))
  87.  
  88. (define (class-slots class)
  89.   (class/slots (guarantee-class class 'CLASS-SLOTS)))
  90.  
  91. (define (class-slot class name error?)
  92.   (or (list-search-positive (class/slots (guarantee-class class 'CLASS-SLOT))
  93.     (lambda (slot)
  94.       (eq? name (slot-name slot))))
  95.       (and error?
  96.        (class-slot class (error:no-such-slot class name) error?))))
  97.  
  98. (define (class->dispatch-tag class)
  99.   (class/dispatch-tag (guarantee-class class 'CLASS->DISPATCH-TAG)))
  100.  
  101. (define (subclass? c s)
  102.   (let ((pl (class-precedence-list c)))
  103.     (and (there-exists? (specializer-classes s)
  104.        (lambda (s)
  105.          (memq s pl)))
  106.      #t)))
  107.  
  108. (define (guarantee-class class name)
  109.   (cond ((class? class) class)
  110.     ((record-type? class) (record-type-class class))
  111.     (else (error:wrong-type-argument class "class" name))))
  112.  
  113. (define (compute-precedence-list class)
  114.   (let ((elements (build-transitive-closure class/direct-superclasses class)))
  115.     (topological-sort
  116.      elements
  117.      (build-constraints class/direct-superclasses elements)
  118.      (lambda (partial-cpl elements)
  119.        (let loop ((partial-cpl (reverse partial-cpl)))
  120.      (if (null? partial-cpl)
  121.          (error:bad-range-argument class 'COMPUTE-PRECEDENCE-LIST))
  122.      (let ((ds-of-ce
  123.         (class/direct-superclasses (car partial-cpl))))
  124.        (let find-common ((elements elements))
  125.          (cond ((null? elements) (loop (cdr partial-cpl)))
  126.            ((memq (car elements) ds-of-ce) (car elements))
  127.            (else (find-common (cdr elements)))))))))))
  128.  
  129. (define (compute-slots class)
  130.   (let loop
  131.       ((slots (append-map class/direct-slots (class/precedence-list class)))
  132.        (index 1)
  133.        (descriptors '()))
  134.     (if (null? slots)
  135.     (reverse! descriptors)
  136.     (let ((slot (car slots)))
  137.       (let ((name (car slot)))
  138.         (let inner ((slots (cdr slots)) (same '()) (diff '()))
  139.           (cond ((null? slots)
  140.              (loop (reverse! diff)
  141.                (+ index 1)
  142.                (cons (compute-slot-descriptor
  143.                   class
  144.                   (cons slot (reverse! same))
  145.                   index)
  146.                  descriptors)))
  147.             ((eq? name (caar slots))
  148.              (inner (cdr slots)
  149.                 (cons (car slots) same)
  150.                 diff))
  151.             (else
  152.              (inner (cdr slots)
  153.                 same
  154.                 (cons (car slots) diff))))))))))
  155.  
  156. ;;;; Topological Sort
  157.  
  158. ;;; Topologically sort a list of ELEMENTS.  CONSTRAINTS is the partial
  159. ;;; order, expressed as a list of pairs (X . Y) where X precedes Y.
  160. ;;; TIE-BREAKER is a procedure that is called when it is necessary to
  161. ;;; choose from multiple minimal elements; it is called with the
  162. ;;; partial result and the set of minimal elements as its arguments.
  163.  
  164. (define (topological-sort elements original-constraints tie-breaker)
  165.   (let ((result (cons '() '())))
  166.     (let ((add-to-result
  167.        (lambda (element)
  168.          (let ((tail (list element)))
  169.            (if (null? (car result))
  170.            (set-car! result tail)
  171.            (set-cdr! (cdr result) tail))
  172.            (set-cdr! result tail)))))
  173.       (let loop
  174.       ((elements (list-copy elements))
  175.        (constraints (list-copy original-constraints)))
  176.     (if (null? elements)
  177.         (car result)
  178.         (let ((minimal
  179.            (remove-if (lambda (element)
  180.                 (let loop ((constraints constraints))
  181.                   (and (not (null? constraints))
  182.                        (or (eq? (cdar constraints) element)
  183.                        (loop (cdr constraints))))))
  184.                   elements)))
  185.           (if (null? minimal)
  186.           (error:bad-range-argument original-constraints
  187.                         'TOPOLOGICAL-SORT))
  188.           (let ((elements
  189.              (remove-if! (lambda (element)
  190.                    (memq element minimal))
  191.                  elements))
  192.             (constraints
  193.              (remove-if! (lambda (constraint)
  194.                    (or (memq (car constraint) minimal)
  195.                        (memq (cdr constraint) minimal)))
  196.                  constraints)))
  197.         (let break-ties ((minimal minimal))
  198.           (if (null? (cdr minimal))
  199.               (let ((choice (car minimal)))
  200.             (add-to-result choice)
  201.             (loop elements constraints))
  202.               (let ((choice (tie-breaker (car result) minimal)))
  203.             (add-to-result choice)
  204.             (break-ties (remove-item! choice minimal))))))))))))
  205.  
  206. (define (build-transitive-closure get-follow-ons element)
  207.   (let loop ((result '()) (pending (list element)))
  208.     (cond ((null? pending)
  209.        result)
  210.       ((memq (car pending) result)
  211.        (loop result (cdr pending)))
  212.       (else
  213.        (loop (cons (car pending) result)
  214.          (append (get-follow-ons (car pending)) (cdr pending)))))))
  215.  
  216. (define (build-constraints get-follow-ons elements)
  217.   (let loop ((elements elements) (result '()))
  218.     (if (null? elements)
  219.     result
  220.     (loop (cdr elements)
  221.           (let loop
  222.           ((element (car elements))
  223.            (follow-ons (get-follow-ons (car elements))))
  224.         (if (null? follow-ons)
  225.             result
  226.             (cons (cons element (car follow-ons))
  227.               (loop (car follow-ons) (cdr follow-ons)))))))))
  228.  
  229. (define (remove-if predicate items)
  230.   (let loop ((items items))
  231.     (if (pair? items)
  232.     (if (predicate (car items))
  233.         (loop (cdr items))
  234.         (cons (car items) (loop (cdr items))))
  235.     '())))
  236.  
  237. (define (remove-if! predicate items)
  238.   (letrec ((trim-initial-segment
  239.         (lambda (items)
  240.           (if (pair? items)
  241.           (if (predicate (car items))
  242.               (trim-initial-segment (cdr items))
  243.               (begin
  244.             (locate-initial-segment items (cdr items))
  245.             items))
  246.           items)))
  247.        (locate-initial-segment
  248.         (lambda (last this)
  249.           (if (pair? this)
  250.           (if (predicate (car this))
  251.               (set-cdr! last (trim-initial-segment (cdr this)))
  252.               (locate-initial-segment this (cdr this)))
  253.           this))))
  254.     (trim-initial-segment items)))
  255.  
  256. (define (remove-item! item items)
  257.   (cond ((null? items)
  258.      items)
  259.     ((eq? item (car items))
  260.      (cdr items))
  261.     (else
  262.      (let loop ((last items) (this (cdr items)))
  263.        (if (not (null? this))
  264.            (if (eq? item (car this))
  265.            (set-cdr! last (cdr this))
  266.            (loop this (cdr this)))))
  267.      items)))
  268.  
  269. ;;;; Built-in Classes
  270.  
  271. (define <instance> (make-class '<INSTANCE> (list <object>) '()))
  272.  
  273. (let-syntax
  274.     ((define-primitive-class
  275.        (macro (name . superclasses)
  276.      `(DEFINE ,name (MAKE-CLASS ',name (LIST ,@superclasses) '())))))
  277.  
  278. (define-primitive-class <boolean> <object>)
  279. (define-primitive-class <char> <object>)
  280. (define-primitive-class <pair> <object>)
  281. (define-primitive-class <%record> <object>)
  282. (define-primitive-class <record> <%record>)
  283. (define-primitive-class <dispatch-tag> <%record>)
  284. (define-primitive-class <string> <object>)
  285. (define-primitive-class <symbol> <object>)
  286. (define-primitive-class <vector> <object>)
  287.  
  288. (define-primitive-class <number>)
  289. (define-primitive-class <complex> <number>)
  290. (define-primitive-class <real> <complex>)
  291. (define-primitive-class <rational> <real>)
  292. (define-primitive-class <integer> <rational>)
  293.  
  294. (define-primitive-class <exact> <number>)
  295. (define-primitive-class <exact-complex> <complex> <exact>)
  296. (define-primitive-class <exact-real> <real> <exact-complex>)
  297. (define-primitive-class <exact-rational> <rational> <exact-real>)
  298. (define-primitive-class <exact-integer> <integer> <exact-rational>)
  299.  
  300. (define-primitive-class <inexact> <number>)
  301. (define-primitive-class <inexact-complex> <complex> <inexact>)
  302. (define-primitive-class <inexact-real> <real> <inexact-complex>)
  303. (define-primitive-class <inexact-rational> <rational> <inexact-real>)
  304. (define-primitive-class <inexact-integer> <integer> <inexact-rational>)
  305.  
  306. (define-primitive-class <fixnum> <exact-integer>)
  307. (define-primitive-class <bignum> <exact-integer>)
  308. (define-primitive-class <ratnum> <exact-rational>)
  309. (define-primitive-class <flonum> <inexact-rational>)
  310. (define-primitive-class <flonum-vector> <flonum>)
  311. (define-primitive-class <recnum> <complex>)
  312.  
  313. (define-primitive-class <procedure> <object>)
  314. (define-primitive-class <generic-procedure> <procedure>)
  315. (define-primitive-class <entity> <procedure>)
  316.  
  317. )
  318.  
  319. (define (object-class object)
  320.   (dispatch-tag->class (dispatch-tag object)))
  321.  
  322. (define (record-type-class type)
  323.   (dispatch-tag->class (record-type-dispatch-tag type)))
  324.  
  325. (define (record-class record)
  326.   (record-type-class (record-type-descriptor record)))
  327.  
  328. (define (dispatch-tag->class tag)
  329.   (let ((contents (dispatch-tag-contents tag)))
  330.     (cond ((class? contents) contents)
  331.       ((hash-table/get built-in-class-table tag #f))
  332.       ((record-type? contents)
  333.        (let ((class (make-record-type-class contents)))
  334.          (hash-table/put! built-in-class-table tag class)
  335.          class))
  336.       (else <object>))))
  337.  
  338. (define (make-record-type-class type)
  339.   (let ((class
  340.      (make-class (string->symbol
  341.               (string-append "<" (record-type-name type) ">"))
  342.              (list <record>)
  343.              (record-type-field-names type))))
  344.     (set-class/dispatch-tag! class (record-type-dispatch-tag type))
  345.     class))
  346.  
  347. (define built-in-class-table
  348.   (make-eq-hash-table))
  349.  
  350. (let ((assign-type
  351.        (lambda (name class)
  352.      (hash-table/put! built-in-class-table
  353.               (or (built-in-dispatch-tag name)
  354.                   (built-in-dispatch-tag
  355.                    (microcode-type/code->name
  356.                 (microcode-type/name->code name)))
  357.                   (error "Unknown type name:" name))
  358.               class))))
  359.   (assign-type 'BOOLEAN <boolean>)
  360.   (assign-type 'CHARACTER <char>)
  361.   (assign-type 'PAIR <pair>)
  362.   (assign-type 'RECORD <%record>)
  363.   (assign-type 'DISPATCH-TAG <dispatch-tag>)
  364.   (assign-type 'STRING <string>)
  365.   (assign-type 'INTERNED-SYMBOL <symbol>)
  366.   (assign-type 'UNINTERNED-SYMBOL <symbol>)
  367.   (assign-type 'VECTOR <vector>)
  368.  
  369.   (assign-type 'COMPILED-PROCEDURE <procedure>)
  370.   (assign-type 'EXTENDED-PROCEDURE <procedure>)
  371.   (assign-type 'PRIMITIVE <procedure>)
  372.   (assign-type 'PROCEDURE <procedure>)
  373.   (assign-type 'ENTITY <entity>)
  374.  
  375.   (if (> microcode-id/version 11)
  376.       (begin
  377.     (assign-type 'POSITIVE-FIXNUM <fixnum>)
  378.     (assign-type 'NEGATIVE-FIXNUM <fixnum>))
  379.       (assign-type 'FIXNUM <fixnum>))
  380.   (assign-type 'BIGNUM <bignum>)
  381.   (assign-type 'RATNUM <ratnum>)
  382.   (assign-type 'FLONUM <flonum>)
  383.   (assign-type 'FLONUM-VECTOR <flonum-vector>)
  384.   (assign-type 'RECNUM <recnum>))
  385.  
  386. (hash-table/put! built-in-class-table
  387.          standard-generic-procedure-tag
  388.          <generic-procedure>)
  389.  
  390. (define <class> (object-class <object>))