[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 ----------------------------------------------
- Follow-Ups:
- Cscheme posting
- From: Ross Judson <jarvis.csri.toronto.edu!utgpu!utzoo!dciem!nrcaer!sce!cognos!rossj@rutgers.edu>