[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

TI Scheme functions for MIT C-Scheme - 2 of 3



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