mike@ists.ists.ca (Mike Clarkson) (03/31/89)
#--------------------------------CUT HERE------------------------------------- #! /bin/sh # # This is a shell archive. Save this into a file, edit it # and delete all lines above this comment. Then give this # file to sh by executing the command "sh file". The files # will be extracted into the current directory owned by # you with default permissions. # # The files contained herein are: # # -rw-r----- 1 mike 38772 Mar 30 14:35 scoops.scm # echo 'x - scoops.scm' if test -f scoops.scm; then echo 'shar: not overwriting scoops.scm'; else sed 's/^X//' << '________This_Is_The_END________' > scoops.scm X;;; X;;; Copyright (c) 1986 Texas Instruments Incorporated X;;; X;;; Permission to copy this software, to redistribute it, and X;;; to use it for any purpose is granted, subject to the X;;; following restrictions and understandings. X;;; X;;; 1. Any copy made of this software must include this copyright X;;; notice in full. X;;; X;;; 2. All materials developed as a consequence of the use of X;;; this software shall duly acknowledge such use, in accordance X;;; with the usual standards of acknowledging credit in academic X;;; research. X;;; X;;; 3. TI has made no warranty or representation that the X;;; operation of this software will be error-free, and TI is X;;; under no obligation to provide any services, by way of X;;; maintenance, update, or otherwise. X;;; X;;; 4. In conjunction with products arising from the use X;;; of this material, there shall be no use of the name of X;;; Texas Instruments (except for the above copyright credit) X;;; nor of any adaptation thereof in any advertising, promotional, X;;; or sales literature without prior written consent from TI in X;;; each case. X;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; File updated : 5/23/86 ;;; X;;; ;;; X;;; File : class.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file handles class creation. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(declare (usual-integrations)) X X(define ALL-CLASSVARS) X(define ALL-INSTVARS) X(define ALL-METHODS) X(define CLASS-COMPILED?) X(define CLASSVARS) X(define DESCRIBE) X(define INSTVARS) X(define METHODS) X(define MIXINS) X X;;; X(define scoops-package X (make-environment X X(define %%class-tag (make-interned-symbol "#!CLASS")) X X(set! (access named-objects parser-package) X (cons (cons 'CLASS %%class-tag) (access named-objects parser-package))) X X X((access add-unparser-special-object! unparser-package) %%class-tag X (lambda (class) X ((access unparse-with-brackets unparser-package) X (lambda () X (write-string "SCOOPS Class ") X (write (hash class)))))) X X X(define %sc-make-class X (lambda (name cv allivs mixins method-values) X (let ((method-structure X (mapcar (lambda (a) (list (car a) (cons name name))) X method-values)) X (class (make-vector 15))) X (vector-set! class 0 %%class-tag) X (vector-set! class 1 name) X (vector-set! class 2 cv) X (vector-set! class 3 cv) X (vector-set! class 4 allivs) X (vector-set! class 5 mixins) X (vector-set! class 6 (%uncompiled-make-instance class)) X (vector-set! class 9 method-structure) X (vector-set! class 13 method-values) X (vector-set! class 14 allivs) X (putprop name class '%class) X class))) X X(define %scoops-chk-class X (lambda (class) X (and (not (and (vector? class) X (> (vector-length class) 0) X (equal? %%class-tag (vector-ref class 0)))) X (error-handler class 6 #!TRUE)))) X X X;;; %sc-name X(define-integrable (%sc-name class) X (vector-ref class 1)) X X;;; %sc-cv X(define-integrable (%sc-cv class) X (vector-ref class 2)) X X;;; %sc-allcvs X(define-integrable (%sc-allcvs class) X (vector-ref class 3)) X X;;; %sc-allivs X(define-integrable (%sc-allivs class) X (vector-ref class 4)) X X;;; %sc-mixins X(define-integrable (%sc-mixins class) X (vector-ref class 5)) X X;;; %sc-inst-template X(define-integrable (%sc-inst-template class) X (vector-ref class 6)) X X;;; %sc-method-env X(define-integrable (%sc-method-env class) X (vector-ref class 7)) X X;;; %sc-class-env X(define-integrable (%sc-class-env class) X (vector-ref class 8)) X X X;;; %sc-method-structure X(define-integrable (%sc-method-structure class) X (vector-ref class 9)) X X;;; %sc-subclasses X(define-integrable (%sc-subclasses class) X (vector-ref class 10)) X X;;; %sc-class-compiled X(define-integrable (%sc-class-compiled class) X (vector-ref class 11)) X X;;; %sc-class-inherited X(define-integrable (%sc-class-inherited class) X (vector-ref class 12)) X X;;; %sc-method-values X(define-integrable (%sc-method-values class) X (vector-ref class 13)) X X(define-integrable (%sc-iv class) X (vector-ref class 14)) X X;;; %sc-set-name X(define-integrable (%sc-set-name class val) X (vector-set! class 1 val)) X X;;; %sc-set-cv X(define-integrable (%sc-set-cv class val) X (vector-set! class 2 val)) X X X;;; %sc-set-allcvs X(define-integrable (%sc-set-allcvs class val) X (vector-set! class 3 val)) X X;;; %sc-set-allivs X(define-integrable (%sc-set-allivs class val) X (vector-set! class 4 val)) X X;;; %sc-set-mixins X(define-integrable (%sc-set-mixins class val) X (vector-set! class 5 val)) X X;;; %sc-set-inst-template X(define-integrable (%sc-set-inst-template class val) X (vector-set! class 6 val)) X X;;; %sc-set-method-env X(define-integrable (%sc-set-method-env class val) X (vector-set! class 7 val)) X X;;; %sc-set-class-env X(define-integrable (%sc-set-class-env class val) X (vector-set! class 8 val)) X X;;; %sc-set-method-structure X(define-integrable (%sc-set-method-structure class val) X (vector-set! class 9 val)) X X;;; %sc-set-subclasses X(define-integrable (%sc-set-subclasses class val) X (vector-set! class 10 val)) X X X;;; %sc-set-class-compiled X(define-integrable (%sc-set-class-compiled class val) X (vector-set! class 11 val)) X X;;; %sc-set-class-inherited X(define-integrable (%sc-set-class-inherited class val) X (vector-set! class 12 val)) X X;;; %sc-set-method-values X(define-integrable (%sc-set-method-values class val) X (vector-set! class 13 val)) X X;;; %sc-set-iv X(define-integrable (%sc-set-iv class val) X (vector-set! class 14 val)) X X X;;; X(define %sc-name->class X (lambda (name) X (apply-if (getprop name '%class) X (lambda (a) a) X (error-handler name 2 #!TRUE)))) X X;;; %sc-get-meth-value X(define-integrable (%sc-get-meth-value meth-name class) X (cdr (assq meth-name (%sc-method-values class)))) X X;;; %sc-get-cv-value X(define-integrable (%sc-get-cv-value var class) X (cadr (assq var (%sc-cv class)))) X X;;; %sc-concat X(define-integrable (%sc-concat str sym) X (string->symbol (string-append str (symbol->string sym)))) X X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : methods.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file handles the addition/redefinition of methods. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X X;;; is class1 before class2 in class ? X;;; class1 is not equal to class2 X X(define %before X (lambda (class1 class2 class) X (or (eq? class1 class) X (memq class2 (memq class1 (%sc-mixins (%sc-name->class class))))))) X X;;; DEFINE-METHOD X(syntax-table-define system-global-syntax-table 'DEFINE-METHOD X (macro e X (let ((class-name (caar e)) X (method-name (cadar e)) X (formal-list (cadr e)) X (body (cddr e))) X `(%sc-class-add-method X ',class-name X ',method-name X ',class-name X ',class-name X (append (list 'lambda ',formal-list) ',body) X (lambda (env quoted-val) X (let* ((method-name ',method-name) X (temp `(in-package ,env X (define ,method-name X ,quoted-val)))) X (eval temp (the-environment))) X ))))) X;;; X X(define %sc-class-add-method X (lambda (class-name X method-name X method-class X mixin-class X method X assigner) X (let ((class (%sc-name->class class-name))) X (begin X (let ((temp (assq method-name (%sc-method-values class)))) X (if temp X (set-cdr! temp method) X (%sc-set-method-values X class X (cons (cons method-name method) (%sc-method-values class)))))) X (%compiled-add-method class-name method-name method-class mixin-class X method assigner)))) X;;; X X(define %inform-subclasses X (lambda (class-name method-name method-class mixin-class method assigner) X ((rec loop X (lambda (class-name method-name method-class mixin-class X method assigner subclass) X (if subclass X (begin X (%compiled-add-method X (car subclass) method-name method-class class-name X method assigner) X (loop class-name method-name method-class mixin-class X method assigner X (cdr subclass)))))) X class-name method-name method-class mixin-class method assigner X (%sc-subclasses (%sc-name->class class-name))))) X;;; X X(define %compiled-add-method X (lambda (class-name X method-name X method-class X mixin-class X method X assigner) X (letrec X ((class (%sc-name->class class-name)) X X (insert-entry X (lambda (previous current) X (cond ((null? current) X (set-cdr! previous X (cons (cons method-class mixin-class) '()))) X ((eq? mixin-class (cdar current)) X (set-car! (car current) method-class)) X ((%before mixin-class (cdar current) X class-name) X (set-cdr! previous X (cons (cons method-class mixin-class) current))) X (else '())))) X X X (loop-insert X (lambda (previous current) X (if (not (insert-entry previous current)) X (loop-insert (current) (cdr current))))) X X (insert X (lambda (entry) X (if (insert-entry entry (cdr entry)) ;;; insert at head X (add-to-environment) X (loop-insert (cdr entry) (cddr entry))))) X X (add-to-environment X (lambda () X (begin X (if (%sc-class-compiled class) X (assigner (%sc-method-env class) method)) X (if (%sc-subclasses class) X (%inform-subclasses class-name method-name method-class X mixin-class method assigner))))) X X (add-entry X (lambda () X (begin X (%sc-set-method-structure class X (cons (list method-name (cons method-class mixin-class)) X (%sc-method-structure class))) X (add-to-environment)))) X ) X X (let ((method-entry (assq method-name (%sc-method-structure class)))) X (if method-entry X (insert method-entry) X (add-entry)) X method-name)))) X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : meth2.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file handles the deletion of a method from a class. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; DELETE-METHOD X(syntax-table-define system-global-syntax-table 'DELETE-METHOD X (macro e X (let ((class-name (caar e)) X (method-name (cadar e))) X `(%sc-class-del-method X ',class-name X ',method-name X ',class-name X ',class-name X (LAMBDA (ENV VAL) X (SET! (ACCESS ,method-name ENV) VAL)) X #!false)))) X;;; X X(define %deleted-method X (lambda (name) X (lambda args X (error-handler name 3 #!TRUE)))) X;;; X X(define %sc-class-del-method X (lambda (class-name method-name method-class mixin-class assigner del-value) X (let ((class (%sc-name->class class-name))) X (let ((temp (assq method-name (%sc-method-values class)))) X (if temp X (begin X (%sc-set-method-values class X (delq! temp (%sc-method-values class))) X (%compiled-del-method class-name method-name method-class mixin-class X assigner del-value)) X X (error-handler method-name 4 #!true)))))) X;;; X X(define %inform-del-subclasses X (lambda (class-name method-name method-class mixin-class assigner del-value) X ((rec loop X (lambda (class-name method-name method-class mixin-class assigner X del-value subclass) X (if subclass X (begin X (%compiled-del-method (car subclass) method-name X method-class class-name assigner del-value) X (loop class-name method-name method-class mixin-class assigner X del-value (cdr subclass)))))) X class-name method-name method-class mixin-class assigner del-value X (%sc-subclasses (%sc-name->class class-name))))) X;;; X X(define %compiled-del-method X (lambda (class-name method-name method-class mixin-class assigner del-value) X (let ((class (%sc-name->class class-name))) X (letrec X ((delete-entry X (lambda (previous current) X (cond ((eq? mixin-class (cdar current)) X (set-cdr! previous (cdr current)) #!TRUE) X (else #!FALSE)))) X X (loop-delete X (lambda (previous current) X (cond ((or (null? current) X (%before mixin-class (cdar previous) X class-name)) X (error-handler method-name 4 #!TRUE)) X ((delete-entry previous current) #!TRUE) X (else (loop-delete current (cdr current)))))) X X (delete X (lambda (entry) X (if (delete-entry entry (cdr entry)) ;;; delete at head X (modify-environment entry) X (loop-delete (cdr entry) (cddr entry))))) X X (modify-environment X (lambda (entry) X (cond ((null? (cdr entry)) X (%sc-set-method-structure class X (delq! (assq method-name (%sc-method-structure class)) X (%sc-method-structure class))) X (if (%sc-class-compiled class) X (assigner (%sc-method-env class) X (or del-value X (set! del-value X (%deleted-method method-name))))) X (if (%sc-subclasses class) X (%inform-del-subclasses class-name method-name X method-class mixin-class assigner del-value))) X (else X (let ((meth-value X (%sc-get-meth-value method-name X (%sc-name->class (caadr entry))))) X (if (%sc-class-compiled class) X (assigner (%sc-method-env class) meth-value)) X (if (%sc-subclasses class) X (%inform-subclasses class-name X method-name X method-class X mixin-class X meth-value assigner))))))) X ) X X (let ((method-entry (assq method-name (%sc-method-structure class)))) X (if method-entry X (delete method-entry) X (error-handler method-name 4 #!TRUE)) X method-name))))) X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : instance.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file contains compiling and making of an instance. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; COMPILE-CLASS X(syntax-table-define system-global-syntax-table 'COMPILE-CLASS X (macro e X `(let* ((class ,(car e)) X (name (%sc-name class))) X (if (%sc-class-compiled class) X name X (begin X (%inherit-method-vars class) X (eval (%make-template name class) (the-environment))))))) X;;; X X(define (%sc-compile-class class) X (begin X (%inherit-method-vars class) X (eval (%make-template (%sc-name class) class) X user-initial-environment))) X X;;; MAKE-INSTANCE X(syntax-table-define system-global-syntax-table 'MAKE-INSTANCE X (macro e X (cons (list '%sc-inst-template (car e)) (cdr e)))) X;;; X X(define %uncompiled-make-instance X (lambda (class) X (lambda init-msg X (%sc-compile-class class) X (apply (%sc-inst-template class) init-msg)))) X;;; X X(define %make-template X (lambda (name class) X `(begin X;;; do some work to make compile-file work X (%sc-set-allcvs ,name ',(%sc-allcvs class)) X (%sc-set-allivs ,name ',(%sc-allivs class)) X (%sc-set-method-structure ,name X ',(%sc-method-structure class)) X;;; prepare make-instance template X (%sc-set-inst-template ,name X ,(%make-inst-template (%sc-allcvs class) X (%sc-allivs class) X (%sc-method-structure class) X name class)) X (%sc-method-thrust ,name) X (%sc-set-class-compiled ,name #!TRUE) X (%sc-set-class-inherited ,name #!TRUE) X (%sign-on ',name ,name) X ',name))) X;;; X X(define %make-inst-template X (lambda (cvs ivs method-structure name class) X (let ((methods '((%*methods*% '-))) X (classvar (append cvs '((%*classvars*% '-)))) X (instvar (append ivs '((%*instvars*% '-))))) X;;; dummy variables are added to methods, cvs, and ivs to prevent the X;;; compiler from folding them away. X `(let ,classvar X (%sc-set-class-env ,name (the-environment)) X (let ,methods X (%sc-set-method-env ,name (the-environment)) X (let ((%sc-class ,name)) X (lambda %sc-init-vals X (let ,instvar X (the-environment))))))))) X X X X;;; %sc-method-thrust evaluates each method in the method-environment X;;; for the class, enabling methods to grab free variables from the X;;; class-environment without a special code-replacement call. X X(define (%sc-method-thrust class) X (define (iter binding-pair) X (let* ((method-name (car binding-pair)) X (quoted-val (cdr binding-pair)) X (temp `(in-package (%sc-method-env class) X (define ,method-name ,quoted-val)))) X (eval temp (the-environment)))) X(mapcar iter (%sc-method-values class))) X X X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : inht.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file contains routines to handle inheritance. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; X X(define %inherit-method-vars X (lambda (class) X (or (%sc-class-inherited class) X (%inherit-from-mixins X (%sc-allcvs class) X (%sc-allivs class) X (%sc-method-structure class) X (%sc-mixins class) X class X (lambda (class cvs ivs methods) X (%sc-set-allcvs class cvs) X (%sc-set-allivs class ivs) X (%sc-set-method-structure class methods) X (%sc-set-class-inherited class #!true) X (%sign-on (%sc-name class) class) X class))))) X;;; X X(define %sign-on X (lambda (name class) X (mapcar X (lambda (mixin) X (let* ((mixin-class (%sc-name->class mixin)) X (subc (%sc-subclasses mixin-class))) X (if (not (%sc-class-inherited mixin-class)) X (%inherit-method-vars mixin-class)) X (or (memq name subc) X (%sc-set-subclasses mixin-class (cons name subc))))) X (%sc-mixins class)))) X;;; X X(define %inherit-from-mixins X (letrec X ((insert-entry X (lambda (entry class1 method-entry name2 previous current) X (cond ((null? current) X (set-cdr! previous X (cons (cons (caadr method-entry) name2) '()))) X ((%before name2 (cdar current) (%sc-name class1)) X (set-cdr! previous X (cons (cons (caadr method-entry) name2) current))) X (else '())))) X X (insert X (lambda (struct1 entry class1 struct2 name2) X ((rec loop-insert X (lambda (struct1 entry class1 struct2 name2 previous current) X (if (insert-entry entry class1 struct2 name2 previous current) X struct1 X (loop-insert struct1 entry class1 struct2 name2 X current (cdr current))))) X struct1 entry class1 struct2 name2 entry (cdr entry)))) X X (add-entry X (lambda (struct1 class1 method-entry name2) X (cons (list (car method-entry) (cons (caadr method-entry) name2)) X struct1))) X X (combine-methods X (lambda (struct1 class1 struct2 name2) X (if struct2 X (combine-methods X (let ((entry (assq (caar struct2) struct1))) X (if entry X (insert struct1 entry class1 (car struct2) name2) X (add-entry struct1 class1 (car struct2) name2))) X class1 X (cdr struct2) X name2) X struct1))) X X (combine-vars X (lambda (list1 list2) X (if list2 X (combine-vars X (if (assq (caar list2) list1) X list1 X (cons (car list2) list1)) X (cdr list2)) X list1))) X ) X X (lambda (cvs ivs methods mixins class receiver) X ((rec loop-mixins X (lambda (cvs ivs methods mixins class receiver) X (if mixins X (let ((mixin-class (%sc-name->class (car mixins)))) X (%inherit-method-vars mixin-class) X (loop-mixins X (combine-vars cvs (%sc-allcvs mixin-class)) X (combine-vars ivs (%sc-allivs mixin-class)) X (combine-methods methods class X (%sc-method-structure mixin-class) (car mixins)) X (cdr mixins) X class X receiver)) X (receiver class cvs ivs methods )))) X cvs ivs methods mixins class receiver)))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : interf.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file contains class definition and processing of ;;; X;;; define-class. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; DEFINE-CLASS X(syntax-table-define system-global-syntax-table 'DEFINE-CLASS X (macro e X (let ((name (car e)) X (classvars '()) X (instvars '()) (mixins '()) X (options '()) X (allvars '()) X (method-values '())(inits '())) X (letrec X ((chk-class-def X (lambda (deflist) X (if deflist X (begin X (cond ((eq? (caar deflist) 'classvars) X (set! classvars (cdar deflist))) X ((eq? (caar deflist) 'instvars) X (set! instvars (cdar deflist))) X ((eq? (caar deflist) 'mixins) X (set! mixins (cdar deflist))) X ((eq? (caar deflist) 'options) X (set! options (cdar deflist))) X (else (error-handler (caar deflist) 0 '()))) X (chk-class-def (cdr deflist))) X (update-allvars)))) X X (update-allvars X (lambda () X (set! allvars X (append (mapcar (lambda (a) (if (symbol? a) a (car a))) X classvars) X (mapcar (lambda (a) (if (symbol? a) a (car a))) X instvars))))) X X X (chk-option X (lambda (opt-list) X (let loop ((opl opt-list)(meths '())) X (if opl X (loop X (cdr opl) X (cond ((eq? (caar opl) 'gettable-variables) X (append (generate-get (cdar opl)) meths)) X ((eq? (caar opl) 'settable-variables) X (append (generate-set (cdar opl)) meths)) X ((eq? (caar opl) 'inittable-variables) X (set! inits (cdar opl)) meths) X (else (error-handler (car opl) 1 '())))) X meths)))) X X (chk-cvs X (lambda (list-var) X (mapcar X (lambda (a) X (if (symbol? a) X (list a #!false) X a)) X list-var))) X X (chk-init X (lambda (v-form) X (if (memq (car v-form) inits) X `(,(car v-form) X (let ((temp (memq ',(car v-form) %sc-init-vals))) X ;was '%sc-init-vals X (if temp (cadr temp) X ,(cadr v-form)))) X v-form))) X X (chk-ivs X (lambda (list-var) X (mapcar X (lambda (var) X (chk-init X (cond ((symbol? var) (list var #!false)) X ((not-active? (cadr var)) var) X (else (active-val (car var) (cadr var)))))) X list-var))) X X (not-active? X (lambda (a) X (or (not (pair? a)) X (not (eq? (car a) 'active))))) X X (empty-slot? X (lambda (form) X (cond X ((symbol? form) #f) X ((eq? form #f) #t) X (else #f)))) X X (active-val X (lambda (var active-form) X (let loop ((var var)(active-form active-form) X (getfns '())(setfns '%sc-val)) X (if (not-active? (cadr active-form)) X (create-active X var X (if (empty-slot? (caddr active-form)) X getfns X (cons (caddr active-form) getfns)) X (list 'set! var X (if (empty-slot? (cadddr active-form)) X setfns X (list (cadddr active-form) setfns))) X (cadr active-form)) X (loop X var X (cadr active-form) X (if (empty-slot? (caddr active-form)) X getfns X (cons (caddr active-form) getfns)) X (if (empty-slot? (cadddr active-form)) X setfns X (list (cadddr active-form) setfns))))))) X X (create-active X (lambda (var getfns setfns localstate) X (begin X (set! method-values X (cons `(CONS ',(concat "GET-" var) X (list 'lambda '() ',(expand-getfns var getfns))) X (cons `(CONS ',(concat "SET-" var) X (list 'lambda (list '%sc-val) X ',setfns)) X method-values))) X (list var localstate)))) X X (expand-getfns X (lambda (var getfns) X (let loop ((var var)(gets getfns)(exp-form var)) X (if gets X (loop X var X (cdr gets) X (list (car gets) exp-form)) X exp-form)))) X (concat X (lambda (str sym) X (string->symbol (string-append str (symbol->string sym))))) X X (generate-get X (lambda (getlist) X (mapcar X (lambda (a) X `(CONS ',(concat "GET-" a) X (list 'lambda '() X ',a))) X getlist))) X X (generate-set X (lambda (setlist) X (mapcar X (lambda (a) X `(CONS ',(concat "SET-" a) X (list 'lambda (list '%sc-val) X (list 'set! ',a '%sc-val)))) X setlist))) X X ) X X;; define-class begins here. X X (begin X (chk-class-def (cdr e)) X (set! method-values X (chk-option X (mapcar (lambda (a) (if (symbol? a) (cons a allvars) a)) X options))) X (set! instvars (if instvars (chk-ivs instvars))) X;; Evaluate here so that active-value functions are generated properly. X;; --Steve Sherin X (set! classvars (if classvars (chk-cvs classvars))) X X (eval X `(DEFINE ,name X (%SC-MAKE-CLASS X ',name X ',classvars X ',instvars X ',mixins X ,(if method-values (cons 'list method-values)) X )) X user-initial-environment) X ))))) X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : send.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;;-----------------------------------------------------------------;;; X;;; One does not have to use the SEND form to invoke methods ;;; X;;; in the same class; they can be invoked as Scheme functions. ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; SEND X(syntax-table-define system-global-syntax-table 'SEND X (macro e X X (let ((args (cddr e)) X (msg (cadr e)) X (obj (car e))) X `(let* ((set-parent! (access system-environment-set-parent! X environment-package)) X (ep environment-parent) X (ibot ,obj) X (itop (ep (ep ibot))) X (ipar (ep itop)) X (class (access %sc-class ibot)) X (ctop (%sc-class-env class)) X (cpar (ep ctop)) X (cbot (%sc-method-env class)) X (instance-safe? (eq? ipar cbot))) X X (without-interrupts X (lambda () X (dynamic-wind X (lambda () X (set-parent! ctop ibot) X (if instance-safe? X (set-parent! itop cpar))) X X X (lambda () X (in-package cbot (,msg ,@args))) X X (lambda () X (set-parent! ctop cpar) X (set-parent! itop cbot)) X ))))))) X X X;;; SEND-IF-HANDLES X(syntax-table-define system-global-syntax-table 'SEND-IF-HANDLES X (macro e X (let ((obj (car e)) X (msg (cadr e)) X (args (cddr e))) X `(let X ((self ,obj)) X X (if (assq ',msg (%sc-method-structure (access %sc-class self))) X (send self ,msg ,@args) X #!false))))) X X X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; ;;; X;;; S c o o p s ;;; X;;; ;;; X;;; ;;; X;;; Rewritten 5/20/87 for cscheme ;;; X;;; by Steve Sherin--U of P ;;; X;;; File : utl.scm ;;; X;;; ;;; X;;; Amitabh Srivastava ;;; X;;; ;;; X;;; This file contains misc. routines ;;; X;;; ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X X;;; Error handler. Looks up the error message in the table and X;;; prints it. X X(define error-handler X (let ((error-table X (let ((table (make-vector 8))) X (vector-set! table 0 " Invalid class definition ") X (vector-set! table 1 " Invalid option ") X (vector-set! table 2 " Class not defined ") X (vector-set! table 3 " Method has been deleted ") X (vector-set! table 4 " Method is not present ") X (vector-set! table 5 " Variable is not present") X (vector-set! table 6 " Not a Scoops Class") X (vector-set! table 7 " Class not compiled ") X table))) X (lambda (msg number flag) X (if flag X (error (vector-ref error-table number) msg) X (breakpoint (vector-ref error-table number) msg))))) X X X;;; some functions defined globally which will be moved locally later X X (define %sc-class-description X (lambda (class) X (writeln " ") X (writeln " CLASS DESCRIPTION ") X (writeln " ================== ") X (writeln " ") X (writeln " NAME : " (%sc-name class)) X (writeln " CLASS VARS : " X (mapcar car (%sc-allcvs class))) X (writeln " INSTANCE VARS : " X (mapcar car (%sc-allivs class))) X (writeln " METHODS : " X (mapcar car (%sc-method-structure class))) X (writeln " MIXINS : " (%sc-mixins class)) X (writeln " CLASS COMPILED : " (%sc-class-compiled class)) X (writeln " CLASS INHERITED : " (%sc-class-inherited class)) X )) X;;; X X (define %sc-inst-desc X (lambda (inst) X (letrec ((class (access %sc-class inst)) X (printvars X (lambda (f1 f2) X (if f1 ; another var X (begin X (writeln " " (caar f1) " : " X (cadr (assq (caar f1) f2))) X;; environment bindings in list form vs. pair form. Steve Sherin X (printvars (cdr f1) f2)) X *the-non-printing-object*)))) X (writeln " ") X (writeln " INSTANCE DESCRIPTION ") X (writeln " ==================== ") X (writeln " ") X (writeln " Instance of Class : " (%sc-name class)) X (writeln " ") X (writeln " Class Variables : ") X (printvars (%sc-allcvs class) X (environment-bindings (%sc-class-env class))) X (writeln " ") X (writeln " Instance Variables :") X (printvars (%sc-allivs class) (environment-bindings inst)) X ))) X X;;; X(define %scoops-chk-class-compiled X (lambda (name class) X (or (%sc-class-compiled class) X (error-handler name 7 #!true)))) X X;;; X(define %sc-class-info X (lambda (fn) X (lambda (class) X (%scoops-chk-class class) X (mapcar car (fn class))))) X X;;; ALL-CLASSVARS X(set! all-classvars (%sc-class-info %sc-allcvs)) X X;;; ALL-INSTVARS X(set! all-instvars (%sc-class-info %sc-allivs)) X X;;; ALL-METHODS X(set! all-methods (%sc-class-info %sc-method-structure)) X X;;; (CLASS-COMPILED? CLASS) X(set! class-compiled? X (lambda (class) X (%scoops-chk-class class) X (%sc-class-compiled class))) X X;;; (CLASS-OF-OBJECT OBJECT) X(syntax-table-define system-global-syntax-table 'CLASS-OF-OBJECT X (macro e X `(%sc-name (access %sc-class ,(car e))))) X X;;; CLASSVARS X(set! classvars (%sc-class-info %sc-cv)) X X;;; DESCRIBE X(set! describe X (lambda (class-inst) X (if (vector? class-inst) X (begin X (%scoops-chk-class class-inst) X (%sc-class-description class-inst)) X (%sc-inst-desc class-inst)))) X X;;; (GETCV CLASS VAR) X(syntax-table-define system-global-syntax-table 'GETCV X (macro e X (let ((class (car e)) X (var (cadr e))) X `(begin X (and (%sc-name->class ',class) X (%scoops-chk-class-compiled ',class ,class)) X ((access ,(%sc-concat "GET-" var) (%sc-method-env ,class))))))) X X;;; INSTVARS X(set! instvars (%sc-class-info %sc-iv)) X X;;; METHODS X(set! methods (%sc-class-info %sc-method-values)) X X;;; MIXINS X(set! mixins X (lambda (class) X (%scoops-chk-class class) X (%sc-mixins class))) X X;;; (NAME->CLASS NAME) X(syntax-table-define system-global-syntax-table 'NAME->CLASS X (macro e X `(%sc-name->class ,(car e)))) X X;;; (RENAME-CLASS (CLASS NEW-NAME)) X(syntax-table-define system-global-syntax-table 'RENAME-CLASS X (macro e X (let ((class (caar e)) X (new-name (cadar e))) X `(begin X (%sc-name->class ',class) X (%sc-set-name ,class ',new-name) X (eval (define ,new-name ,class) user-initial-environment) X ',new-name)))) X X;;; (SETCV CLASS VAR VAL) X(syntax-table-define system-global-syntax-table 'SETCV X (macro e X (let ((class (car e)) X (var (cadr e)) X (val (caddr e))) X `(begin X (and (%sc-name->class ',class) X (%scoops-chk-class-compiled ',class ,class)) X ((access ,(%sc-concat "SET-" var) (%sc-method-env ,class)) ,val))))) X X;; end scoops-package environment ________This_Is_The_END________ if test `wc -l < scoops.scm` -ne 1163; then echo 'shar: scoops.scm was damaged during transit (should have been 1163 lines)' fi fi ; : end of overwriting check exit 0 -- Mike Clarkson mike@ists.UUCP Institute for Space and Terrestrial Science mike@ists.ists.ca York University, North York, Ontario, uunet!mnetor!yunexus!ists!mike CANADA M3J 1P3 +1 (416) 736-5611