[Win32forth-cvs] win32forth/src Class.f,1.10,1.11

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24357/win32forth/src

Modified Files:
	Class.f 
Log Message:
gah: Fixed bugs in methods in class object and some dex commemts (work in progress)

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Class.f	13 Jan 2006 12:05:01 -0000	1.10
--- Class.f	14 Jan 2006 13:00:10 -0000	1.11
***************
*** 395,399 ****
  \ The following definition is executed at compile time so as long as its run-time (heapobj) is
  \ in application space it can go in system space
! : Heap>         ( -- addr )
                  '  dup ?isClass not abort" Use: New> classname "
                  >body
--- 395,402 ----
  \ The following definition is executed at compile time so as long as its run-time (heapobj) is
  \ in application space it can go in system space
! 
! : Heap>         ( -<class>- -- addr )     \ W32F                 Class
! \ *G Allocate memory for an object of -<class>- on the heap, initialise the object
! \ ** and return the object address.
                  '  dup ?isClass not abort" Use: New> classname "
                  >body
***************
*** 404,408 ****
                  THEN    ; IMMEDIATE

! synonym New> Heap>

  \ See " Dispose " later for releasing dynamic objects
--- 407,413 ----
                  THEN    ; IMMEDIATE

! synonym New> Heap> ( -<class>- -- addr )     \ W32F                 Class
! \ *G Allocate memory for an object of -<class>- on the heap, initialise the object
! \ ** and return the object address.

  \ See " Dispose " later for releasing dynamic objects
***************
*** 954,959 ****
  0 value BeginningOfRecordAddress

! : Record:       ( -- )  \ define a word that returns the starting address of
!                         \ a group of data fields that need be contiguous
                  -1 to contiguous-data?
                  header
--- 959,966 ----
  0 value BeginningOfRecordAddress

! : Record:       ( -- )       \ W32F             Class
! \ *G Define a word that returns the starting address of a group of data fields that
! \ ** need to be contiguous. Object IVARS have their class pointer suppressed if used
! \ ** in a Record: so only objects that don't use late binding can be used.
                  -1 to contiguous-data?
                  header
***************
*** 963,970 ****
                  (iv+!) , ;      \ add integer to first cell of array     ??

! : ;Record       ( -- )  \ end a group of data fields that need to contiguous
                  0 to contiguous-data? ;

! : ;RecordSize:  ( -<name>- ) \ create a name with the size of the record
                  0 to contiguous-data?
                  ^Class DFA @ BeginningOfRecordAddress - CONSTANT ;
--- 970,980 ----
                  (iv+!) , ;      \ add integer to first cell of array     ??

! : ;Record       ( -- )        \ W32F             Class
! \ *G End a group of data fields that need to contiguous.
                  0 to contiguous-data? ;

! : ;RecordSize:  ( -<name>- )  \ W32F             Class
! \ *G End a group of data fields that need to contiguous and create a name with the
! \ ** size of the record.
                  0 to contiguous-data?
                  ^Class DFA @ BeginningOfRecordAddress - CONSTANT ;
***************
*** 985,989 ****
  :noname 0 bytes ; is ivar-name

! : byte          ( -<name>- )           \ byte (8bit) instance variable
                  header
                  (ivc@) ,
--- 995,1000 ----
  :noname 0 bytes ; is ivar-name

! : byte          ( -<name>- )           \ W32F          Class
! \ *G Byte (8bit) size instance variable.
                  header
                  (ivc@) ,
***************
*** 1036,1040 ****
                  nbits class-bitallot ;

! : short         ( -<name>- )           \ word integer (16bit) instance variable
                  header
                  (ivw@) ,
--- 1047,1053 ----
                  nbits class-bitallot ;

! : short         ( -<name>- )             \ W32F          Class
! \ *G Word integer (16bit) instance variable. When -<name>- is executed the value of -<name>-
! \ ** is zero-extended before pushing onto the stack.
                  header
                  (ivw@) ,
***************
*** 1045,1049 ****
                  2 class-allot ;

! : int           ( -<name>- )           \ long integer (32bit) instance variable
                  header
                  (iv@) ,
--- 1058,1064 ----
                  2 class-allot ;

! : int           ( -<name>- )              \ W32F          Class
! \ *G Long integer (32bit) instance variable. When used as an object variable has the same
! \ ** behaviour as VALUEs.
                  header
                  (iv@) ,
***************
*** 1054,1058 ****
                  cell class-allot ;

! : dint          ( -<name>- )           \ double (64bit) instance variable
                  header
                  (ivd@) ,
--- 1069,1074 ----
                  cell class-allot ;

! : dint          ( -<name>- )              \ W32F          Class
! \ *G Double (64bit) instance variable.
                  header
                  (ivd@) ,
***************
*** 1088,1105 ****
  \ Revised by -rbs July 9th, 2002

! \ Since ClassRoot inherits from the pseodo class consisting of the classes
! \ Vocabulary plus the five added vectors MFA IFA DFA XFA and SFA ( see primhash.f
! \ for more details ) DO NOT add any more definitions to CLASSES from here on.
! 

! \ Generic Classes ( those that are created SOLELY for other classes to inherit
! \ from and therefore have no instances ) can have the info compiled by :CLASS
! \ and <SUPER ( or <CLASS <OBJECT or INHERIT ) placed IN-SYSTEM. All Method and
! \ IVARs must be placed IN-APPLICATION. Ordinary definitions can go into either
! \ space according to whether or not they are needed in a TURNKEYed application

  in-system

  :Class ClassRoot   ' classes >Class classes inherit

  in-application
--- 1104,1125 ----
  \ Revised by -rbs July 9th, 2002

! \ *P Since ClassRoot inherits from the pseodo class consisting of the classes
! \ ** Vocabulary plus the five added vectors MFA IFA DFA XFA and SFA ( see primhash.f
! \ ** for more details ) DO NOT add any more definitions to CLASSES from here on.

! \ *P Generic Classes ( those that are created SOLELY for other classes to inherit
! \ ** from and therefore have no instances ) can have the info compiled by :CLASS
! \ ** and <SUPER ( or <CLASS <OBJECT or INHERIT ) placed IN-SYSTEM. All Method and
! \ ** IVARs must be placed IN-APPLICATION. Ordinary definitions can go into either
! \ ** space according to whether or not they are needed in a TURNKEYed application

  in-system

  :Class ClassRoot   ' classes >Class classes inherit
+ \ *G Use this class if you have no ivars in your class.
+ \ ** It will trap undefined methods that might slip through otherwise.
+ \ ** Note: Class String SHOULD use this as its Super.  Not changed
+ \ ** at this time.  There are only (expected default) methods defined
+ \ ** here.

  in-application
***************
*** 1107,1120 ****
  \ -rbs Adding a true Base Class that has no default methods for record types.

!         \ Use this class if you have no ivars in your class.
!         \ It will trap undefined methods that might slip through otherwise.
!         \ Note: Class String SHOULD use this as its Super.  Not changed
!         \ at this time.  There are only (expected default) methods defined
!         \ here.

          :M ClassInit:   ;M
!         :M ~:           ;M              \ the default destructor method
          :M Addr:        ( -- addr )     ^base  ;M
          :M Print:       ( -- )          ." Object@" ^base .  ;M

  ;Class
--- 1127,1147 ----
  \ -rbs Adding a true Base Class that has no default methods for record types.

! 

          :M ClassInit:   ;M
! \ *G Initialise the object. This method is called implicitly when an object is created,
! \ ** either at compile time (for objects in the dictionary) or at run-time (for dynamically
! \ ** created objects). Ivars are initialised when the object containing them is initialised.
! \ ** Default does nothing.
!         :M ~:           ;M
! \ *G De-initialise the object. This method is called implicitly when a dynamic object is
! \ ** disposed of, before the memory is freed. Ivars are not implicitly de-initialised so
! \ ** objects and classes that have ivars that need de-initialising should explicitly send
! \ ** this message to them.
          :M Addr:        ( -- addr )     ^base  ;M
+ \ *G Return the address of the object. Since executing the object returns the address anyway
+ \ ** this method is obsolescent. Versions prior to V6.11 needed to use this for object ivars.
          :M Print:       ( -- )          ." Object@" ^base .  ;M
+ \ *G Print the address of the object. Used for debugging purposes only.

  ;Class
***************
*** 1124,1149 ****
  \ Use "<Super OBJECT" for classes that have ivars
  :Class object   <Super ClassRoot

  in-application

! \ The following methods are for use with the dotted notation which compiles code to place
! \ the CFA of the non-object IVAR on the stack and then the object address

  :M Get:         ( -- n1 )                execute ;M

! :M Put:         ( n1 -- )       2 cells+ execute ;M
! 
! :M Add:         ( n1 -- )       3 cells+ execute ;M
! 
! :M And:         ( n1 -- )       Get: self AND put: self ;M

! :M Or:          ( n1 -- )       Get: self OR  put: self ;M

! :M Xor:         ( n1 -- )       Get: self XOR  put: self ;M

! :M &OF:         ( -- addr )     >body @ self + ;M

  ;Class
! 
  unres-methods unres-len erase

--- 1151,1195 ----
  \ Use "<Super OBJECT" for classes that have ivars
  :Class object   <Super ClassRoot
+ \ *G Generic class for objects that contain non-object ivars.

  in-application

! \ *P The following methods are for use with the dotted notation which compiles code to place
! \ ** the CFA of the non-object IVAR on the stack and then the object address

  :M Get:         ( -- n1 )                execute ;M
+ \ *G Get the value of the ivar. This is the default method automatically compiled if at ivar
+ \ ** is referenced with dotted notation without a preceeding method.

! :M Put:         ( n/d -- )       2 cells+ execute ;M
! \ *G Put the value on the stack (dints expect a double number/other ivars expect a single
! \ ** number) into the ivar.

! :M Add:         ( n/d -- )       3 cells+ execute ;M
! \ *G Add the value on the stack (dints expect a double number/other ivars expect a single
! \ ** number) to the ivar.

! :M And:         ( n1 -- )
! \ *G Perform a bitwise AND on the contents of the ivar and n1 storing the result in the
! \ ** ivar. Note dints perform the AND on the 2 cells of the ivar storing the result as the
! \ ** most significant cell, with n1 as the least.
!                 dup>r  Get: self AND r> put: self ;M

! :M Or:          ( n1 -- )
! \ *G Perform a bitwise OR on the contents of the ivar and n1 storing the result in the
! \ ** ivar. Note dints perform the OR on the 2 cells of the ivar storing the result as the
! \ ** most significant cell, with n1 as the least.
!                 dup>r Get: self OR r> put: self ;M
! :M Xor:         ( n1 -- )
! \ *G Perform a bitwise XOR on the contents of the ivar and n1 storing the result in the
! \ ** ivar. Note dints perform the XOR on the 2 cells of the ivar storing the result as the
! \ ** most significant cell, with n1 as the least.
!                 dup>r Get: self XOR r> put: self ;M
! :M &OF:         ( -- addr )
! \ *G Return the address of the ivar.
!                 >body @ self + ;M

  ;Class
! \ *G End of class
  unres-methods unres-len erase

***************
*** 1219,1223 ****
  IN-SYSTEM

! : .CLASSES      ( -- )          \ display all classes in the system
                  cr              \ classes are really vocabularies
                  voc-link @
--- 1265,1270 ----
  IN-SYSTEM

! : .CLASSES      ( -- )          \ W32F        Class
! \ *G Display all classes in the system.
                  cr              \ classes are really vocabularies
                  voc-link @
***************
*** 1241,1245 ****
  classes also hidden also

! : GetMethod     { \ m0cfa -- -<method: object>- m0cfa }  \ return xt of method
                  @word _msgFind 1 <> abort" Undefined Method"
                  TRUE to get-reference?  \ tell do_message to return method
--- 1288,1293 ----
  classes also hidden also

! : GetMethod     { \ m0cfa -- -<method: object>- m0cfa }  \ W32F        Class
! \ *G Return the xt of method. Used in interpretive mode or to create parsing words.
                  @word _msgFind 1 <> abort" Undefined Method"
                  TRUE to get-reference?  \ tell do_message to return method
***************
*** 1250,1255 ****
                  then    to obj-save m0cfa ;

! : [GetMethod]   ( compiling:- -<method: object>- -- )
!                 ( runtime:-  -- m0cfa )
                  state @ >r postpone [
                  GetMethod r> if ] then
--- 1298,1303 ----
                  then    to obj-save m0cfa ;

! : [GetMethod]   ( compiling:- -<method: object>- -- ) ( runtime:-  -- m0cfa ) / W32F Class
! \ *G Compile the xt of the method as a literal into the current definition. Compile only.
                  state @ >r postpone [
                  GetMethod r> if ] then