Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!utgpu!water!watmath!clyde!rutgers!super.upenn.edu!linc.cis.upenn.edu!sherin
From: sherin@linc.cis.upenn.edu.UUCP
Newsgroups: comp.lang.lisp
Subject: SCOOPS:  new version of send.scm
Message-ID: <1342@super.upenn.edu.upenn.edu>
Date: Sun, 14-Jun-87 12:36:16 EDT
Article-I.D.: super.1342
Posted: Sun Jun 14 12:36:16 1987
Date-Received: Sun, 14-Jun-87 21:42:15 EDT
Sender: root@super.upenn.edu.upenn.edu
Reply-To: sherin@linc.cis.upenn.edu.UUCP (Steve Sherin)
Distribution: world
Organization: University of Pennsylvania
Lines: 67

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                 ;;;
;;;                     S c o o p s                                 ;;;
;;;                                                                 ;;;
;;;                                                                 ;;;
;;;		Rewritten 5/20/87 for cscheme			    ;;;
;;;		by Steve Sherin--U of P				    ;;;
;;;                   File : send.scm                               ;;;
;;;                                                                 ;;;
;;;                 Amitabh Srivastava                              ;;;
;;;                                                                 ;;;
;;;-----------------------------------------------------------------;;;
;;;    One does not have to use the SEND form to invoke methods     ;;;
;;;    in the same class; they can be invoked as Scheme functions.  ;;;
;;;                                                                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; send

(syntax-table-define system-global-syntax-table 'send
	(macro e

(let ((args (cddr e))
	(msg (cadr e))
	(obj (car e)))
    `(let* ((set-parent! (access system-environment-set-parent! 
			environment-package))
	(ep environment-parent)
	(ibot ,obj)
	(itop (ep (ep ibot)))
	(ipar (ep itop))
	(class (access %sc-class ibot))
	(ctop (%sc-class-env class))
	(cpar (ep ctop))
	(cbot (%sc-method-env class))
	(instance-safe? (eq? ipar cbot)))

  (without-interrupts
   (lambda ()
    (dynamic-wind
      (lambda ()
        (set-parent! ctop ibot)
	(if instance-safe?
         (set-parent! itop cpar))) 


	(lambda ()
	 (in-package cbot (,msg ,@args)))

      (lambda ()
	  (set-parent! ctop cpar)
	  (set-parent! itop cbot))
	)))))))


;;; send-if-handles

(syntax-table-define system-global-syntax-table 'send-if-handles (macro e
    (let ((obj (car e))
	  (msg (cadr e))
	  (args (cddr e)))
`(let
	((self ,obj))

     	     (if (assq ',msg (%sc-method-structure (access %sc-class self)))
			(send self ,msg ,@args)
			#!false)))))