home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / INHERIT.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  4.2 KB  |  127 lines
  1. ;* INHERIT.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Scoops: handle inheritance            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastava        Date: 1986        *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;
  23.  
  24. (define %inherit-method-vars
  25.   (lambda (class)
  26.     (or (%sc-class-inherited class)
  27.         (%inherit-from-mixins
  28.          (%sc-allcvs class)
  29.          (%sc-allivs class)
  30.          (%sc-method-structure class)
  31.          (%sc-mixins class)
  32.          class
  33.          (lambda (class cvs ivs methods)
  34.            (%sc-set-allcvs class cvs)
  35.            (%sc-set-allivs class ivs)
  36.            (%sc-set-method-structure class methods)
  37.            (%sc-set-class-inherited class #T)
  38.            (%sign-on (%sc-name class) class)
  39.            class)))))
  40.  
  41. ;
  42.  
  43. (define %sign-on
  44.   (lambda (name class)
  45.     (mapcar
  46.       (lambda (mixin)
  47.         (let* ((mixin-class (%sc-name->class mixin))
  48.                (subc (%sc-subclasses mixin-class)))
  49.           (if (not (%sc-class-inherited mixin-class))
  50.               (%inherit-method-vars mixin-class))
  51.           (or (memq name subc)
  52.               (%sc-set-subclasses mixin-class (cons name subc)))))
  53.       (%sc-mixins class))))
  54.  
  55.  
  56.  
  57. ;
  58.  
  59. (define %inherit-from-mixins
  60.   (letrec
  61.     ((insert-entry
  62.       (lambda (entry class1 method-entry name2 previous current)
  63.         (cond ((null? current)
  64.                (set-cdr! previous
  65.                          (cons (cons (caadr method-entry) name2) '())))
  66.               ((%before name2 (cdar current) (%sc-name class1))
  67.                (set-cdr! previous
  68.                          (cons (cons (caadr method-entry) name2) current)))
  69.               (else '()))))
  70.  
  71.     (insert
  72.       (lambda (struct1 entry class1 struct2 name2)
  73.         ((rec loop-insert
  74.            (lambda (struct1 entry class1 struct2 name2 previous current)
  75.              (if (insert-entry entry class1 struct2 name2 previous current)
  76.                  struct1
  77.                  (loop-insert struct1 entry class1 struct2 name2
  78.                               current (cdr current)))))
  79.          struct1 entry class1 struct2 name2 entry (cdr entry))))
  80.  
  81.     (add-entry
  82.       (lambda (struct1 class1 method-entry name2)
  83.         (cons (list (car method-entry) (cons (caadr method-entry) name2))
  84.               struct1)))
  85.  
  86.     (combine-methods
  87.       (lambda (struct1 class1 struct2 name2)
  88.         (if struct2
  89.             (combine-methods
  90.              (let ((entry (assq (caar struct2) struct1)))
  91.                (if entry
  92.                    (insert struct1 entry class1 (car struct2) name2)
  93.                    (add-entry struct1 class1 (car struct2) name2)))
  94.              class1
  95.              (cdr struct2)
  96.              name2)
  97.             struct1)))
  98.  
  99.      (combine-vars
  100.        (lambda (list1 list2)
  101.          (if list2
  102.              (combine-vars
  103.               (if (assq (caar list2) list1)
  104.                   list1
  105.                   (cons (car list2) list1))
  106.               (cdr list2))
  107.              list1)))
  108.      )
  109.  
  110.   (lambda (cvs ivs methods mixins class receiver)
  111.     ((rec loop-mixins
  112.        (lambda (cvs ivs methods mixins class receiver)
  113.          (if mixins
  114.              (let ((mixin-class (%sc-name->class (car mixins))))
  115.                (%inherit-method-vars mixin-class)
  116.                (loop-mixins
  117.                  (combine-vars cvs (%sc-allcvs mixin-class))
  118.                  (combine-vars ivs (%sc-allivs mixin-class))
  119.                  (combine-methods methods class
  120.                           (%sc-method-structure mixin-class) (car mixins))
  121.                  (cdr mixins)
  122.                  class
  123.                  receiver))
  124.              (receiver class cvs ivs methods ))))
  125.      cvs ivs methods mixins class receiver))))
  126.  
  127.