[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Xscheme object context diffs & sample (425 lines)



Since, as far as I know, no solution to the bad behavior of the objects 
in Xscheme has yet appeared here, I am posting one.

Two files are appended to this posting:
    xschemen.dif
    tryit.xs
The former consists of context diffs for the program PATCH . These must be
compiled in order to make the object/class capability of Xscheme, vers. 0.16,
work in a manner similar to Xlisp (especially the versions of Xlisp prior to 
the introduction of "send").
The second file is for trying out some of those capabilities, and is
designed to illustrate how close the modification comes to implementing
what was presumably the original design idea.

Note that very few lines of code need to be added or modified:

  xscomn.c   1 line added

  xsintn.c   3 lines added    1 line deleted

  xsobjn.c   8 lines added    4 lines deleted     4 lines modified


---------------- xschemen.dif ----------------------------------------

*** xscom.c	Thu Jul 13 14:50:58 1989
--- xscomn.c	Thu Jul 13 15:19:04 1989
***************
*** 1,3
  /* xscom.c - a simple scheme bytecode compiler */
  /*	Copyright (c) 1988, by David Michael Betz
  	All Rights Reserved

--- 1,8 -----
+ /**  modified  xlfunction
+ 	David W. Crabb	(crabb@phoenix.princeton.edu)
+      July,  1989
+ **/
+ 
  /* xscom.c - a simple scheme bytecode compiler */
  /*	Copyright (c) 1988, by David Michael Betz
  	All Rights Reserved
***************
*** 101,107
      return (pop());
  }
  
! /* xlfunction - compile a function */
  LVAL xlfunction(fun,fargs,body,ctenv)
    LVAL fun,fargs,body,ctenv;
  {

--- 106,112 -----
      return (pop());
  }
  
! /* xlfunction - compile a function */  /* used only by clanswer()  **/
  LVAL xlfunction(fun,fargs,body,ctenv)
    LVAL fun,fargs,body,ctenv;
  {
***************
*** 110,115
      rplaca(info,newframe(ctenv,1));
      rplacd(info,cons(NIL,NIL));
  
      /* setup the base of the code for this function */
      cbase = cptr = 0;
  

--- 115,122 -----
      rplaca(info,newframe(ctenv,1));
      rplacd(info,cons(NIL,NIL));
  
+     rplacd (car(info), ctenv);	 /** DWC: 7/5/89 */
+ 
      /* setup the base of the code for this function */
      cbase = cptr = 0;
  
***************
*** 316,322
      /* initialize the argument name list and slot number */
      restarg = last = NIL;
      slotn = 1;
!     
      /* handle each required argument */
      while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
  

--- 323,329 -----
      /* initialize the argument name list and slot number */
      restarg = last = NIL;
      slotn = 1;
! 
      /* handle each required argument */
      while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
  
*** xsint.c	Thu Jul 13 14:50:59 1989
--- xsintn.c	Thu Jul 13 14:50:59 1989
***************
*** 1,3
  /* xsint.c - xscheme bytecode interpreter */
  /*	Copyright (c) 1988, by David Michael Betz
  	All Rights Reserved

--- 1,8 -----
+ /**  modified METHOD case of  xlapply()
+ 	David W. Crabb	(crabb@phoenix.princeton.edu)
+      July, 1989
+ **/
+ 
  /* xsint.c - xscheme bytecode interpreter */
  /*	Copyright (c) 1988, by David Michael Betz
  	All Rights Reserved
***************
*** 6,11
  #include "xscheme.h"
  #include "xsbcode.h"
  
  /* sample rate (instructions per sample) */
  #define SRATE	1000
  

--- 11,19 -----
  #include "xscheme.h"
  #include "xsbcode.h"
  
+ /**  from  xsobj.c :  */
+ #define IVENV 1
+ 
  /* sample rate (instructions per sample) */
  #define SRATE	1000
  
***************
*** 356,362
  	break;
      case METHOD:
  	xlfun = getcode(xlval);
! 	xlenv = cons(top(),getenv(xlval));
  	base = pc = getcodestr(xlfun);
  	break;
      case CONTINUATION:

--- 364,374 -----
  	break;
      case METHOD:
  	xlfun = getcode(xlval);
! 
! 	xlenv = getenv(xlval);	/** DWC  7/5/89 */
! 	tmp = getivar(top(),IVENV);   /**  DWC	7/11  */
! 	rplacd(xlenv, tmp);
! 
  	base = pc = getcodestr(xlfun);
  	break;
      case CONTINUATION:
*** xsobj.c	Thu Jul 13 14:50:59 1989
--- xsobjn.c	Thu Jul 13 15:10:12 1989
***************
*** 1,3
  /* xsobj.c - xscheme object-oriented programming support */
  /*	Copyright (c) 1988, by David Michael Betz
  	All Rights Reserved

--- 1,8 -----
+ /**  Modifications to clanswer(), clisnew(), and clnew() .
+        David W. Crabb	(crabb@phoenix.princeton.edu)
+      July, 1989
+ **/
+ 
  /* xsobj.c - xscheme object-oriented programming support */
  /*	Copyright (c) 1988, by David Michael Betz
  	All Rights Reserved
***************
*** 13,18
  static LVAL s_self,k_isnew;
  static LVAL class,object;
  
  /* instance variable numbers for the class 'Class' */
  #define MESSAGES	1	/* list of messages */
  #define IVARS		2	/* list of instance variable names */

--- 18,28 -----
  static LVAL s_self,k_isnew;
  static LVAL class,object;
  
+ /**  DWC:  instance variable numbers for objects  */
+ #define IVENV 1  /** ivars now passed as an environment  */
+ /**  number of instance variables for objects  */
+ #define IVTOT 2
+ 
  /* instance variable numbers for the class 'Class' */
  #define MESSAGES	1	/* list of messages */
  #define IVARS		2	/* list of instance variable names */
***************
*** 140,146
  /* clnew - create a new object instance */
  clnew()
  {
!     LVAL self;
  
      /* create a new object */
      self = xlgaobject();

--- 150,157 -----
  /* clnew - create a new object instance */
  clnew()
  {
! 	       int i;
!     LVAL self, ivframe,ivars,c ;
  
      /* create a new object */
      self = xlgaobject();
***************
*** 144,150
  
      /* create a new object */
      self = xlgaobject();
!     xlval = newobject(self,getivcnt(self,IVARTOTAL));
  
      /* send the 'isnew' message */
      xlsend(xlval,k_isnew);

--- 155,161 -----
  
      /* create a new object */
      self = xlgaobject();
!     xlval = newobject(self,IVTOT);
  
      ivars = getivar(self,IVARS);
      ivframe = newframe(NIL,listlength(ivars) + 1);
***************
*** 146,151
      self = xlgaobject();
      xlval = newobject(self,getivcnt(self,IVARTOTAL));
  
      /* send the 'isnew' message */
      xlsend(xlval,k_isnew);
  }

--- 157,167 -----
      self = xlgaobject();
      xlval = newobject(self,IVTOT);
  
+     ivars = getivar(self,IVARS);
+     ivframe = newframe(NIL,listlength(ivars) + 1);
+     setelement(car(ivframe),0,ivars);
+     setivar(xlval,IVENV, ivframe);
+ 
      /* send the 'isnew' message */
      xlsend(xlval,k_isnew);
  }
***************
*** 153,159
  /* clisnew - initialize a new class */
  LVAL clisnew()
  {
!     LVAL self,ivars,cvars,super;
      int n;
  
      /* get self, the ivars, cvars and superclass */

--- 169,175 -----
  /* clisnew - initialize a new class */
  LVAL clisnew()
  {
!     LVAL self,ivars,cvars,super, tmp;
      int n;
  
      /* get self, the ivars, cvars and superclass */
***************
*** 163,172
      super = (moreargs() ? xlgaobject() : object);
      xllastarg();
  
-     /* create the class variable compile-time environment */
-     xlval = cons(xlenter("%%CLASS"),copylists(cvars,NIL));
-     cpush(cons(xlval,getivar(super,CVARS)));
-     
      /* create the class variable environment */
      xlval = newvector(listlength(xlval)); setelement(xlval,0,self);
      cpush(cons(xlval,getivar(super,CVALS)));

--- 179,184 -----
      super = (moreargs() ? xlgaobject() : object);
      xllastarg();
  
      /* create the class variable environment */
      xlval = newvector(listlength(xlval)); setelement(xlval,0,self);
      cpush(cons(xlval,getivar(super,CVALS)));
***************
*** 172,178
      cpush(cons(xlval,getivar(super,CVALS)));
  
      /* store the instance and class variable lists and the superclass */
!     setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
      setivar(self,CVALS,pop());
      setivar(self,CVARS,pop());
      setivar(self,SUPERCLASS,super);

--- 184,191 -----
      cpush(cons(xlval,getivar(super,CVALS)));
  
      /* store the instance and class variable lists and the superclass */
!     setivar(self,IVARS,ivars);	/* to be retrieved in  clnew()	**/
! 
      setivar(self,CVALS,pop());
  
      tmp = newframe(NIL,listlength(cvars) + 1);
***************
*** 174,180
      /* store the instance and class variable lists and the superclass */
      setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
      setivar(self,CVALS,pop());
!     setivar(self,CVARS,pop());
      setivar(self,SUPERCLASS,super);
  
      /* compute the instance variable count */

--- 187,197 -----
      setivar(self,IVARS,ivars);	/* to be retrieved in  clnew()	**/
  
      setivar(self,CVALS,pop());
! 
!     tmp = newframe(NIL,listlength(cvars) + 1);
!     setelement(car(tmp),0,cvars);
!     setivar(self,CVARS,tmp);
! 
      setivar(self,SUPERCLASS,super);
  
      /* compute the instance variable count */
***************
*** 191,197
  LVAL clanswer()
  {
      extern LVAL xlfunction();
!     LVAL self,msg,fargs,code,mptr;
  
      /* message symbol, formal argument list and code */
      self = xlgaobject();

--- 208,214 -----
  LVAL clanswer()
  {
      extern LVAL xlfunction();
!     LVAL self,msg,fargs,code,mptr, tmp;
  
      /* message symbol, formal argument list and code */
      self = xlgaobject();
***************
*** 206,214
      /* add 'self' to the argument list */
      cpush(cons(s_self,fargs));
  
!     /* extend the class variable environment with the instance variables */
!     xlval = cons(getivar(self,IVARS),getivar(self,CVARS));
!     
      /* compile and store the method */
      xlval = xlfunction(msg,top(),code,xlval);
      rplacd(mptr,cvmethod(xlval,getivar(self,CVALS)));

--- 223,230 -----
      /* add 'self' to the argument list */
      cpush(cons(s_self,fargs));
  
!     tmp = getivar (self,CVARS) ;   /** now an env from	clisnew()  */
! 
      /* compile and store the method */
      xlval = xlfunction(msg,top(),code,tmp);
      rplacd(mptr,cvmethod(xlval, tmp));
***************
*** 210,217
      xlval = cons(getivar(self,IVARS),getivar(self,CVARS));
      
      /* compile and store the method */
!     xlval = xlfunction(msg,top(),code,xlval);
!     rplacd(mptr,cvmethod(xlval,getivar(self,CVALS)));
      drop(1);
  
      /* return the object */

--- 226,233 -----
      tmp = getivar (self,CVARS) ;   /** now an env from	clisnew()  */
  
      /* compile and store the method */
!     xlval = xlfunction(msg,top(),code,tmp);
!     rplacd(mptr,cvmethod(xlval, tmp));
      drop(1);
  
      /* return the object */


----------------------- tryit.xs  ------------------------------------

;  "tryit.xs"  for loading into xscheme - modified version .
;      David W. Crabb        crabb@phoenix.princeton.edu

(define aClass (Class 'new '(ivar1 ivar2) '(cvar1 cvar2)))
(define anInst (aClass 'new))

(aClass 'answer 'set-cvar1 '(value) '( (set! cvar1 value)))
(aClass 'answer 'cvar1? '() '( (print cvar1)))

(aClass 'show)
(anInst 'set-cvar1 592)
(anInst 'cvar1?)                                                ;  >>  592

(aClass 'answer 'set-ivar1 '() '( (set! ivar1 5505)))
(anInst 'set-ivar1)
(aClass 'answer 'ivar1? '() '( (print ivar1)))
(anInst 'ivar1?)                                                ;  >> 5505

(define subClass (Class 'new '(ivar1 ivar2) '(cvar1 cvar2) aClass ))
(define subInst (subClass 'new))
(subInst 'cvar1?)                                               ;  >>  592
(subInst 'ivar1?)                                               ;  >>  ()

(aClass 'answer 'reset-ivar1 '() '( (set! ivar1 -66)))
(subInst 'reset-ivar1)  (subInst 'ivar1?)			;  >>  -66
(anInst 'ivar1?)                                                ;  >>  5505


;;  -------------------- eof ----------------------------------------------