Errors in the SCOOPS for the Macintosh

[Kai Zimmermann <mcsun!unido!fauern!tumuc!lan!zimmerma@uunet.uu.net>]

Hello everybody,
I have discovered and REMOVED two errors in the implementation 
of TI's SCOOPS package for the Apple Macintosh that comes 
with Lightship's MacScheme.

1. You can't work with the special instance variable SELF
   because it's not bound to the instance itself but to the
   dispatching procedure for that instance.

2. (describe <any instance>) produces an error if you haven't 
   defined any class that uses CLASSVARS yet.
   Thus,
     (load "SCOOPS")
     (define-class foo)
     (define fie (make-instance foo))
     (describe fie)
   results in an error,
   but
     (load "SCOOPS")
     (define-class foo)
     (define-class dummy (CLASSVARS WeNeedJustOne))
     (define fie (make-instance foo))
     (describe fie)
   works.

The following code will remove these errors and documents why they
occured. If anyone has discovered more errors I'd like to hear of them.
Hope I helped someone with this posting,

--Kai

=========================================================================
|    I started lisp programming with the Xerox Interlisp-D environment, |
|   moved down (at that time) to the Symbolics programming environment, |
|   had to work with the Allegro Commonlisp environment?                |
|   and now finally work in MacScheme.                                  |
|    Tomorrow I will work in lisp bytecode directly                     |
|   with nothing but a hardcopy teletype as input device.               |
|    Would be nearly no difference :-(                                  |
|                                                                       |
|   Kai Zimmermann      zimmerma@lan.informatik.tu-muenchen.dbp.de	|
=========================================================================
----------Cut Here-------------

; Just replace the definitions of the procedures
; INSTANCE-DESCRIPTION and
; COMPILE-MAKE-FN
; in the source file that comes with MacScheme
; by the following code.

(define instance-description
  (let ((*key* *key*)
        (inheritance inheritance)
        (writeln (lambda l (for-each display l) (newline))))
    (lambda (inst)
      (letrec ((class (send inst get-class))
               (printvars
                (lambda (f1 f2) ;f1 is a list of instvars and f2 an environment
                  (let ((n 0))
                    (while f1
                           (writeln "   " (car f1) " : " (vector-ref f2 n))
                           (set! n (1+ n))
                           (set! f1 (cdr f1)))))))
        
        (writeln " ")
        (writeln " INSTANCE DESCRIPTION")
        (writeln " ====================")
        (writeln " ")
        (writeln " Instance of Class " (send (class *key*) name))
        (writeln " ")
        (writeln " Class Variables : ")
        (printvars (mapcar car (inheritance class 'get-classvars ))
                   ; Kai Zimmermann, 1989     
                   ; Here was an error due to the fact that in 
                   ; PC-Scheme (car '()) returns () and in
                   ; MacScheme an error is signalled.
                   (let ((possibly-empty-environment
                          (send (class *key*) get-class-environment)))
                     (if (null? possibly-empty-environment)
                         '()
                         (car possibly-empty-environment))))
        (writeln " ")
        (writeln " Instance Variables :")
        (printvars (mapcar car (inheritance class 'get-instvars))
                   (cadr (->pair (car (->pair inst)))))
        (string->symbol "")
        ))))


;-----------


   (define compile-make-fn
     (lambda (x)
       (let* ((params (gensym "init-parms"))
              (instvars (instance-vars x))
              (totalvars (append instvars (class-vars x))))
         `(lambda
           ,params
            (letrec
              ,(append
                (format-vars instvars)
                (list
                 (list 'self 
                       `(lambda
                         msg
                         (case (car msg)
                           ,@(format-case 
                              (append
                               `((get-class (lambda (),x)))
                               (get-methods (inheritance x 'get-gettable)
                                            totalvars)
                               (set-methods (inheritance x 'get-settable)
                                            totalvars)
                               (inheritance x 'get-methods)
                               )))))))        
              ; Kai Zimmermann, 1989     
              ; Here was an error, because self wasn't changed
              ; to the constructed symbol, but left as
              ; the above lambda. This made it impossible to
              ; work with self.
              (set! self
                    (->symbol
                     (list self 
                           ',(cons 'pname 
                                   (string-append "#<INSTANCE "
                                                  (symbol->string 
                                                   (send (x *key*) name))
                                                  ">")))))
              ,(compile-init-code x params)
              self)))))

;------------End----------