From 78e075a1c1eda2703bef123d3f48f840d8ef4694 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 10 Jan 1993 10:43:16 +0000 Subject: [PATCH] Class and object data structures are now tagged as if by DEFINE-STRUCTURE. --- v7/src/edwin/class.scm | 24 ++++++---------- v7/src/edwin/clscon.scm | 62 +++++++++++++++++++---------------------- v7/src/edwin/debuge.scm | 28 +++++++------------ 3 files changed, 47 insertions(+), 67 deletions(-) diff --git a/v7/src/edwin/class.scm b/v7/src/edwin/class.scm index 398794bcc..4581a2dd9 100644 --- a/v7/src/edwin/class.scm +++ b/v7/src/edwin/class.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/class.scm,v 1.70 1989/05/01 21:10:16 cph Rel $ +;;; $Id: class.scm,v 1.71 1993/01/10 10:42:57 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -52,20 +52,19 @@ ;;; likely will not ever, be supported as a part of the Scheme system. ;;; ****************************************************************** -(define-structure (class (type vector) - (constructor false) - (initial-offset 1)) +(define-structure (class (constructor %make-class)) (name false read-only true) (superclass false read-only true) - (object-size false read-only true) - (instance-transforms false read-only true) + object-size + instance-transforms (methods false read-only true)) (define (class-method class name) (class-methods/ref (class-methods class) name)) (define (class-methods/ref methods name) - (or (method-lookup methods name) (error "unknown method" name))) + (or (method-lookup methods name) + (error "Unknown method:" name))) (define (method-lookup methods name) (let loop ((methods methods)) @@ -92,10 +91,10 @@ (and class (or (eq? class class*) (loop (class-superclass class))))))) - + (define (make-object class) (if (not (class? class)) - (error "not a class" class)) + (error:wrong-type-argument class "class" 'MAKE-OBJECT)) (let ((object (make-vector (class-object-size class) false))) (vector-set! object 0 class) object)) @@ -119,11 +118,6 @@ (define-integrable (object-method object name) (class-method (object-class object) name)) -(define (object-description object) - (map (lambda (transform) - (list (car transform) (vector-ref object (cdr transform)))) - (class-instance-transforms (object-class object)))) - (define (send object operation . args) (apply (object-method object operation) object args)) diff --git a/v7/src/edwin/clscon.scm b/v7/src/edwin/clscon.scm index 49dcebb1b..22aace09d 100644 --- a/v7/src/edwin/clscon.scm +++ b/v7/src/edwin/clscon.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/clscon.scm,v 1.5 1991/11/21 10:02:56 cph Exp $ +;;; $Id: clscon.scm,v 1.6 1993/01/10 10:43:05 cph Exp $ ;;; -;;; Copyright (c) 1986-91 Massachusetts Institute of Technology +;;; Copyright (c) 1986-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -54,25 +54,27 @@ (define (make-class name superclass variables) (let ((entry (assq name class-descriptors)) - (object-size (if superclass - (+ (length variables) (class-object-size superclass)) - (1+ (length variables)))) + (object-size + (+ (length variables) + (if superclass (class-object-size superclass) 1))) (transforms (make-instance-transforms superclass variables))) (let ((make-class (lambda () (let ((class - (vector class-tag - name - superclass - object-size - transforms - (cons '() - (and superclass - (class-methods superclass)))))) - (unparser/set-tagged-vector-method! + (%make-class name + superclass + object-size + transforms + (cons '() + (and superclass + (class-methods superclass)))))) + (named-structure/set-tag-description! class - (unparser/standard-method name)) - (named-structure/set-tag-description! class object-description) + (make-define-structure-type 'VECTOR + name + (map car transforms) + (map cdr transforms) + (unparser/standard-method name))) class)))) (if (not entry) (let ((class (make-class))) @@ -83,26 +85,15 @@ (let ((class (make-class))) (set-cdr! entry class) class)) - ((or (not (= object-size (vector-ref class 3))) - (not (equal? transforms (vector-ref class 4)))) - (warn "Redefining class" name) - (vector-set! class 3 object-size) - (vector-set! class 4 transforms) + ((and (= object-size (class-object-size class)) + (equal? transforms (class-instance-transforms class))) class) (else + (warn "Redefining class:" name) + (set-class-object-size! class object-size) + (set-class-instance-transforms! class transforms) class))))))) -(define (class? x) - (and (vector? x) - (not (zero? (vector-length x))) - (eq? class-tag (vector-ref x 0)))) - -(define (name->class name) - (cdr (or (assq name class-descriptors) - (error "unknown class name" name)))) - -(define class-tag "Class") - (define (make-instance-transforms superclass variables) (define (generate variables n tail) (if (null? variables) @@ -115,8 +106,11 @@ (class-instance-transforms superclass)) (generate variables 1 '()))) -(unparser/set-tagged-vector-method! class-tag - (unparser/standard-method 'CLASS)) +(define (name->class name) + (let ((entry (assq name class-descriptors))) + (if (not entry) + (error "Unknown class name:" name)) + (cdr entry))) (define class-descriptors '()) \ No newline at end of file diff --git a/v7/src/edwin/debuge.scm b/v7/src/edwin/debuge.scm index 0c81c34a5..1b41ff43c 100644 --- a/v7/src/edwin/debuge.scm +++ b/v7/src/edwin/debuge.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debuge.scm,v 1.49 1992/11/12 18:00:17 cph Exp $ +;;; $Id: debuge.scm,v 1.50 1993/01/10 10:43:16 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -153,25 +153,17 @@ ;;;; Object System Debugging -(define (po object) - (for-each (lambda (entry) - (newline) - (write (car entry)) - (write-string ": ") - (write (vector-ref object (cdr entry)))) - (class-instance-transforms (object-class object)))) - (define (instance-ref object name) (let ((entry (assq name (class-instance-transforms (object-class object))))) - (if entry - (vector-ref object (cdr entry)) - (error "Not a valid instance-variable name" name)))) + (if (not entry) + (error "Not a valid instance-variable name:" name)) + (vector-ref object (cdr entry)))) (define (instance-set! object name value) (let ((entry (assq name (class-instance-transforms (object-class object))))) - (if entry - (vector-set! object (cdr entry) value) - (error "Not a valid instance-variable name" name)))) + (if (not entry) + (error "Not a valid instance-variable name:" name)) + (vector-set! object (cdr entry) value))) ;;;; Screen Trace @@ -186,7 +178,7 @@ (if (default-object? screen) (begin (if (not edwin-editor) - (error "no screen to trace")) + (error "No screen to trace.")) (editor-selected-screen edwin-editor)) screen))) (set! trace-output '()) @@ -200,7 +192,7 @@ (if (default-object? screen) (begin (if (not edwin-editor) - (error "no screen to trace")) + (error "No screen to trace.")) (editor-selected-screen edwin-editor)) screen))) (for-each (lambda (window) -- 2.25.1