98 lines
3.3 KiB
Scheme
98 lines
3.3 KiB
Scheme
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; ;;;
|
||
;;; S c o o p s ;;;
|
||
;;; ;;;
|
||
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
|
||
;;; All Rights Reserved ;;;
|
||
;;; ;;;
|
||
;;; File updated : 8/28/85 ;;;
|
||
;;; ;;;
|
||
;;; File : instance.scm ;;;
|
||
;;; ;;;
|
||
;;; Amitabh Srivastava ;;;
|
||
;;; ;;;
|
||
;;; This file contains the compiling and making of an instance. ;;;
|
||
;;; ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;;
|
||
|
||
(macro compile-class
|
||
(lambda (e)
|
||
(let ((name (cadr e))
|
||
(class (%sc-name->class (cadr e))))
|
||
(if (%sc-class-compiled class)
|
||
name
|
||
(begin
|
||
(%inherit-method-vars class)
|
||
(%make-template name class))))))
|
||
|
||
;;;
|
||
|
||
(define %sc-compile-class
|
||
(lambda (class)
|
||
(%inherit-method-vars class)
|
||
(eval (%make-template (%sc-name class) class)
|
||
user-initial-environment)))
|
||
|
||
;;;
|
||
|
||
(macro make-instance
|
||
(lambda (e)
|
||
(cons (list '%sc-inst-template (cadr e)) (cddr e))))
|
||
;;;
|
||
|
||
(define %uncompiled-make-instance
|
||
(lambda (class)
|
||
(lambda init-msg
|
||
(%sc-compile-class class)
|
||
(apply (%sc-inst-template class) init-msg))))
|
||
|
||
|
||
|
||
;;;
|
||
|
||
(define %make-template
|
||
(lambda (name class)
|
||
`(begin
|
||
;;; do some work to make compile-file work
|
||
(%sc-set-allcvs ,name ',(%sc-allcvs class))
|
||
(%sc-set-allivs ,name ',(%sc-allivs class))
|
||
(%sc-set-method-structure ,name
|
||
',(%sc-method-structure class))
|
||
;;; prepare make-instance template
|
||
(%sc-set-inst-template ,name
|
||
,(%make-inst-template (%sc-allcvs class)
|
||
(%sc-allivs class)
|
||
(%sc-method-structure class)
|
||
name class))
|
||
(%sc-set-class-compiled ,name #!TRUE)
|
||
(%sc-set-class-inherited ,name #!TRUE)
|
||
(%sign-on ',name ,name)
|
||
;;;
|
||
',name)))
|
||
;;;
|
||
|
||
|
||
(define %make-inst-template
|
||
(lambda (cvs ivs method-structure name class)
|
||
(let ((methods
|
||
(append
|
||
(mapcar
|
||
(lambda (a)
|
||
`(,(car a) (%sc-get-meth-value ',(car a) ,(caadr a))))
|
||
method-structure)
|
||
'((%*methods*% '-))))
|
||
(classvar (append cvs '((%*classvars*% '-))))
|
||
(instvar (append ivs '((%*instvars*% '-)))))
|
||
`(let ((%sc-class ,name))
|
||
(let ,methods
|
||
(%sc-set-method-env ,name (the-environment))
|
||
(let ,classvar
|
||
(%sc-set-class-env ,name (the-environment))
|
||
(lambda %sc-init-vals
|
||
(let ,instvar
|
||
(the-environment)))))))))
|
||
|
||
|