DEFINE-STRUCTURE.
;;; -*-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
;;; likely will not ever, be supported as a part of the Scheme system.
;;; ******************************************************************
\f
-(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))
(and class
(or (eq? class class*)
(loop (class-superclass class)))))))
-\f
+
(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))
(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))
;;; -*-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
\f
(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)))
(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)
(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
;;; -*-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
\f
;;;; 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
(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 '())
(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)
projects / mit-scheme.git / commitdiff