home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / CLASS.S next >
Encoding:
Text File  |  1993-06-15  |  4.9 KB  |  249 lines
  1. ;* CLASS.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: Class Creation                *
  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. (define %%class-tag '#!class)
  24.  
  25. (define %sc-make-class
  26.   (lambda (name cv allivs mixins method-values)
  27.     (let ((method-structure
  28.                   (mapcar (lambda (a) (list (car a) (cons name name)))
  29.                           method-values))
  30.           (class (make-vector 15)))
  31.        (vector-set! class 0 %%class-tag)
  32.        (vector-set! class 1 name)
  33.        (vector-set! class 2 cv)
  34.        (vector-set! class 3 cv)
  35.        (vector-set! class 4 allivs)
  36.        (vector-set! class 5 mixins)
  37.        (vector-set! class 6 (%uncompiled-make-instance class))
  38.        (vector-set! class 9 method-structure)
  39.        (vector-set! class 13 method-values)
  40.        (vector-set! class 14 allivs)
  41.        (putprop name class '%class)
  42.        class)))
  43.  
  44. (define %scoops-chk-class
  45.   (lambda (class)
  46.     (and (not (and (vector? class)
  47.                    (> (vector-length class) 0)
  48.                    (equal? %%class-tag (vector-ref class 0))))
  49.          (error-handler class 6 #T))))
  50.  
  51.  
  52. ;
  53.  
  54. (define-integrable %sc-name
  55.   (lambda (class)
  56.     (vector-ref class 1)))
  57.  
  58. ;
  59.  
  60. (define-integrable %sc-cv
  61.   (lambda (class)
  62.     (vector-ref class 2)))
  63.  
  64. ;
  65.  
  66. (define-integrable %sc-allcvs
  67.   (lambda (class)
  68.     (vector-ref class 3)))
  69.  
  70. ;
  71.  
  72. (define-integrable %sc-allivs
  73.   (lambda (class)
  74.     (vector-ref class 4)))
  75.  
  76. ;
  77.  
  78. (define-integrable %sc-mixins
  79.   (lambda (class)
  80.     (vector-ref class 5)))
  81.  
  82. ;
  83.  
  84. (define-integrable %sc-inst-template
  85.   (lambda (class)
  86.     (vector-ref class 6)))
  87.  
  88. ;
  89.  
  90. (define-integrable %sc-method-env
  91.   (lambda (class)
  92.     (vector-ref class 7)))
  93.  
  94. ;
  95.  
  96. (define-integrable %sc-class-env
  97.   (lambda (class)
  98.     (vector-ref class 8)))
  99.  
  100.  
  101. ;
  102.  
  103. (define-integrable %sc-method-structure
  104.   (lambda (class)
  105.     (vector-ref class 9)))
  106.  
  107. ;
  108.  
  109. (define-integrable %sc-subclasses
  110.   (lambda (class)
  111.     (vector-ref class 10)))
  112.  
  113. ;
  114.  
  115. (define-integrable %sc-class-compiled
  116.   (lambda (class)
  117.     (vector-ref class 11)))
  118.  
  119. ;
  120.  
  121. (define-integrable %sc-class-inherited
  122.   (lambda (class)
  123.     (vector-ref class 12)))
  124.  
  125. ;
  126.  
  127. (define-integrable %sc-method-values
  128.   (lambda (class)
  129.     (vector-ref class 13)))
  130.  
  131. (define-integrable %sc-iv
  132.   (lambda (class)
  133.     (vector-ref class 14)))
  134.  
  135.  
  136. ;
  137.  
  138. (define-integrable %sc-set-name
  139.   (lambda (class val)
  140.     (vector-set! class 1 val)))
  141.  
  142. ;
  143.  
  144. (define-integrable %sc-set-cv
  145.   (lambda (class val)
  146.     (vector-set! class 2 val)))
  147.  
  148.  
  149. ;
  150.  
  151. (define-integrable %sc-set-allcvs
  152.   (lambda (class val)
  153.     (vector-set! class 3 val)))
  154.  
  155. ;
  156.  
  157. (define-integrable %sc-set-allivs
  158.   (lambda (class val)
  159.     (vector-set! class 4 val)))
  160.  
  161. ;
  162.  
  163. (define-integrable %sc-set-mixins
  164.   (lambda (class val)
  165.     (vector-set! class 5 val)))
  166.  
  167. ;
  168.  
  169. (define-integrable %sc-set-inst-template
  170.   (lambda (class val)
  171.     (vector-set! class 6 val)))
  172.  
  173. ;
  174.  
  175. (define-integrable %sc-set-method-env
  176.   (lambda (class val)
  177.     (vector-set! class 7 val)))
  178.  
  179. ;
  180.  
  181. (define-integrable %sc-set-class-env
  182.   (lambda (class val)
  183.     (vector-set! class 8 val)))
  184.  
  185. ;
  186.  
  187. (define-integrable %sc-set-method-structure
  188.   (lambda (class val)
  189.     (vector-set! class 9 val)))
  190.  
  191. ;
  192.  
  193. (define-integrable %sc-set-subclasses
  194.   (lambda (class val)
  195.     (vector-set! class 10 val)))
  196.  
  197.  
  198. ;
  199.  
  200. (define-integrable %sc-set-class-compiled
  201.   (lambda (class val)
  202.     (vector-set! class 11 val)))
  203.  
  204. ;
  205.  
  206. (define-integrable %sc-set-class-inherited
  207.   (lambda (class val)
  208.     (vector-set! class 12 val)))
  209.  
  210. ;
  211.  
  212. (define-integrable %sc-set-method-values
  213.   (lambda (class val)
  214.     (vector-set! class 13 val)))
  215.  
  216. ;
  217.  
  218. (define-integrable %sc-set-iv
  219.   (lambda (class val)
  220.     (vector-set! class 14 val)))
  221.  
  222.  
  223. ;
  224.  
  225. (define %sc-name->class
  226.   (lambda (name)
  227.     (apply-if (getprop name '%class)
  228.               (lambda (a) a)
  229.               (error-handler name 2 #T))))
  230.  
  231. ;
  232.  
  233. (define-integrable %sc-get-meth-value
  234.   (lambda (meth-name class)
  235.     (cdr (assq meth-name (%sc-method-values class)))))
  236.  
  237. ;
  238.  
  239. (define-integrable %sc-get-cv-value
  240.   (lambda (var class)
  241.     (cadr (assq var (%sc-cv class)))))
  242.  
  243. ;
  244.  
  245. (define-integrable %sc-concat
  246.   (lambda (str sym)
  247.     (string->symbol (string-append str (symbol->string sym)))))
  248.  
  249.