[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