Newsgroups: comp.lang.lisp.x
Path: cantaloupe.srv.cs.cmu.edu!das-news2.harvard.edu!news2.near.net!howland.reston.ans.net!ix.netcom.com!netcom.com!mayer
From: mayer@netcom.com (Niels P. Mayer)
Subject: BUG FIX: XLISP 2.1g core dump via RETURN/RETURN-FROM in method.
Message-ID: <mayerDA7Jy9.6Dp@netcom.com>
Organization: NETCOM On-line Communication Services (408 261-4700 guest)
Date: Thu, 15 Jun 1995 09:34:57 GMT
Lines: 139
Sender: mayer@netcom23.netcom.com

The following code fragment causes XLISP 2.1g to get a segmentation
violation. I'm running XLISP from
ftp://oak.oakland.edu/SimTel/msdos/xlisp/xl21gsrc.zip compiled on SGI Irix
5.3 (-DUNIX).

	;;; BEGIN CODE FRAGMENT
	(setq xxx_class
	  (send Class :new
		'(one two)
		'()
		))
	
	(send xxx_class :answer :ISNEW
	      '(x1 x2)
	      '(
		(setq one x1)
		(setq two x2)
		self
		))
	
	(setq var t)
	
	(send xxx_class :answer :FOOB
	      '()
	      '(
		(if var
		    (progn
		      ;; this works w/ xlisp 2.1g:
		      ;;	(return-from :foob :bar)
		      ;;this breaks:
		      ;;	(return-from nil nil)
		      ;;similarly, this breaks too:
		      ;;	(return t)
		      (return t)
		      )
		  nil
		  )
		))
	
	(setq iii
	      (send xxx_class :new 1 2))
	
	(send iii :foob)
	;;; END CODE FRAGMENT

The last call to method :FOOB (the one with the 'return' gets a
segmentation violation:

| Process 15447 (xlisp) stopped on signal SIGSEGV: Segmentation violation
| [xlreturn:104 +0x18,0x4305dc]
|  104  if (tagentry_p(car(frame)) && tagentry_value(car(frame)) == name) {

I think this is happening because code in xlreturn() (in xljump.c) has
problems with the environment entry set up by evmethod() (in xlobj.c) when
a method is being evaluated. This is what happens (specially) for objects:

|     /* create an 'object' stack entry and a new environment frame */
|     oldenv = xlenv;
|     oldfenv = xlfenv;
|     xlenv = cons(cons(obj,msgcls),getenvi(method));
|     xlenv = xlframe(xlenv);
|     xlfenv = getfenv(method);

And I noted that the problem seems to only take place when you call
'return' or 'return-from' from within a method. All other cases did the
right thing and signalled an error "no target for RETURN - nil".  However,
in a method, such a call&condition would core dump....

I also noted that these symptons may be consistent with the warning in
xlisp.h:

| #ifdef LEXBIND
| /* macros for installing tag bindings in xlenv */
| /* Added feature from Luke Tierney 09/93 */
| /* These are ued to insure that return and go only find lexically visible
|    tags. Currently the binding is formed by putting the context pointer
|    of the block, as a fixnum, into the car of a binding in xlenv. This
|    should work fine as long as nothing tacitly assumes these cars must be
|    symbols. If that is a problem, some special symbol can be uses (a gensym
|    or s_unbound, for example). */
| #define tagentry_p(x) (fixp(car(x)))
| #define tagentry_value(x) (cdr(x))
| #define tagentry_context(x) ((CONTEXT *) getfixnum(car(x)))
| #define xlbindtag(c,t,e) xlpbind(cvfixnum((FIXTYPE) (c)),(t),e);
| #endif

Since I'm using the default compile which defined LEXBIND, it seemed
like these could be the sources for the bug...

Therefore, I fixed xlreturn() (xljump.c) to check for and ignore "object"
stack entries -- see the code within "#ifdef WINTERP". With this patch in
place, the XLISP code fragment above seems to work ok with both 'return'
and 'return-from'.

Please let me know if this is the right approach, or if the fix should have
been made elsewhere. 

| /* xlreturn - return from a block */
| VOID xlreturn(name,val)
|   LVAL name,val;
| {
| #ifdef LEXBIND
|     CONTEXT *cptr, *ctarg;
|     LVAL env, frame;
| 
|     /* find the lexical context */
|     for (ctarg = NULL, env = xlenv; consp(env); env = cdr(env))
|         for (frame = car(env); consp(frame); frame = cdr(frame))
|             if (
| #ifdef WINTERP /* NPM: bug fix for core dump if '(return nil)' called inside a method ?? */
| 		consp(car(frame)) &&
| #endif /* WINTERP */
| 		tagentry_p(car(frame)) && tagentry_value(car(frame)) == name) {
|                 ctarg = tagentry_context(car(frame));
|                 goto find_and_jump;
|             }
| 
|     /* find the context and jump */
| find_and_jump:
|     for (cptr = xlcontext; cptr != NULL; cptr = cptr->c_xlcontext)
|         if (cptr->c_flags & CF_RETURN && cptr->c_expr == name && cptr == ctarg)
|             xljump(cptr,CF_RETURN,val);
|     xlerror("no target for RETURN", name);
| #else
|     CONTEXT *cptr;
| 
|     /* find a block context */
|     for (cptr = xlcontext; cptr != NULL; cptr = cptr->c_xlcontext)
|     if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
|         xljump(cptr,CF_RETURN,val);
|     xlfail("no target for RETURN");
| #endif
| }"

=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
= Niels Mayer ..... mayer@eit.com .... http://www.eit.com/people/mayer.html =
=  Multimedia Engineering Collaboration Environment (MM authoring for WWW)  =
=  Enterprise Integration Technologies, 800 El Camino Real, Menlo Park, CA  =
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
