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)))))))))
|
|||
|
|
|
|||
|
|
|