248 lines
5.9 KiB
Scheme
248 lines
5.9 KiB
Scheme
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; ;;;
|
||
;;; S c o o p s ;;;
|
||
;;; ;;;
|
||
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
|
||
;;; All Rights Reserved ;;;
|
||
;;; ;;;
|
||
;;; File updated : 8/29/85 ;;;
|
||
;;; ;;;
|
||
;;; File : class.scm ;;;
|
||
;;; ;;;
|
||
;;; Amitabh Srivastava ;;;
|
||
;;; ;;;
|
||
;;; This file contains class creation and function to access ;;;
|
||
;;; various fields. ;;;
|
||
;;; ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
|
||
|
||
;;;
|
||
(define %%class-tag '#!class)
|
||
|
||
(define %sc-make-class
|
||
(lambda (name cv allivs mixins method-values)
|
||
(let ((method-structure
|
||
(mapcar (lambda (a) (list (car a) (cons name name)))
|
||
method-values))
|
||
(class (make-vector 15)))
|
||
(vector-set! class 0 %%class-tag)
|
||
(vector-set! class 1 name)
|
||
(vector-set! class 2 cv)
|
||
(vector-set! class 3 cv)
|
||
(vector-set! class 4 allivs)
|
||
(vector-set! class 5 mixins)
|
||
(vector-set! class 6 (%uncompiled-make-instance class))
|
||
(vector-set! class 9 method-structure)
|
||
(vector-set! class 13 method-values)
|
||
(vector-set! class 14 allivs)
|
||
(putprop name class '%class)
|
||
class)))
|
||
|
||
(define %scoops-chk-class
|
||
(lambda (class)
|
||
(and (not (and (vector? class)
|
||
(> (vector-length class) 0)
|
||
(equal? %%class-tag (vector-ref class 0))))
|
||
(error-handler class 6 #!TRUE))))
|
||
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-name
|
||
(lambda (class)
|
||
(vector-ref class 1)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-cv
|
||
(lambda (class)
|
||
(vector-ref class 2)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-allcvs
|
||
(lambda (class)
|
||
(vector-ref class 3)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-allivs
|
||
(lambda (class)
|
||
(vector-ref class 4)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-mixins
|
||
(lambda (class)
|
||
(vector-ref class 5)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-inst-template
|
||
(lambda (class)
|
||
(vector-ref class 6)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-method-env
|
||
(lambda (class)
|
||
(vector-ref class 7)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-class-env
|
||
(lambda (class)
|
||
(vector-ref class 8)))
|
||
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-method-structure
|
||
(lambda (class)
|
||
(vector-ref class 9)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-subclasses
|
||
(lambda (class)
|
||
(vector-ref class 10)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-class-compiled
|
||
(lambda (class)
|
||
(vector-ref class 11)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-class-inherited
|
||
(lambda (class)
|
||
(vector-ref class 12)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-method-values
|
||
(lambda (class)
|
||
(vector-ref class 13)))
|
||
|
||
(define-integrable %sc-iv
|
||
(lambda (class)
|
||
(vector-ref class 14)))
|
||
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-name
|
||
(lambda (class val)
|
||
(vector-set! class 1 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-cv
|
||
(lambda (class val)
|
||
(vector-set! class 2 val)))
|
||
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-allcvs
|
||
(lambda (class val)
|
||
(vector-set! class 3 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-allivs
|
||
(lambda (class val)
|
||
(vector-set! class 4 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-mixins
|
||
(lambda (class val)
|
||
(vector-set! class 5 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-inst-template
|
||
(lambda (class val)
|
||
(vector-set! class 6 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-method-env
|
||
(lambda (class val)
|
||
(vector-set! class 7 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-class-env
|
||
(lambda (class val)
|
||
(vector-set! class 8 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-method-structure
|
||
(lambda (class val)
|
||
(vector-set! class 9 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-subclasses
|
||
(lambda (class val)
|
||
(vector-set! class 10 val)))
|
||
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-class-compiled
|
||
(lambda (class val)
|
||
(vector-set! class 11 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-class-inherited
|
||
(lambda (class val)
|
||
(vector-set! class 12 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-method-values
|
||
(lambda (class val)
|
||
(vector-set! class 13 val)))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-set-iv
|
||
(lambda (class val)
|
||
(vector-set! class 14 val)))
|
||
|
||
|
||
;;;
|
||
|
||
(define %sc-name->class
|
||
(lambda (name)
|
||
(apply-if (getprop name '%class)
|
||
(lambda (a) a)
|
||
(error-handler name 2 #!TRUE))))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-get-meth-value
|
||
(lambda (meth-name class)
|
||
(cdr (assq meth-name (%sc-method-values class)))))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-get-cv-value
|
||
(lambda (var class)
|
||
(cadr (assq var (%sc-cv class)))))
|
||
|
||
;;;
|
||
|
||
(define-integrable %sc-concat
|
||
(lambda (str sym)
|
||
(string->symbol (string-append str (symbol->string sym)))))
|
||
|