[Win32forth-cvs] win32forth/src Class.f,1.19,1.20

[George H. <geo...@us...>]

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

Modified Files:
	Class.f 
Log Message:
gah:Added code for dealing with indexed IVARS.

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** Class.f	29 Jun 2006 10:27:42 -0000	1.19
--- Class.f	17 Jul 2006 12:07:39 -0000	1.20
***************
*** 449,457 ****
  \ Build a class header with its superclass pointer
  : inherit       ( pfa -- )
!                 dup here class-size move        \ copy class data
!                 here body> vcfa>voc voc>vlink
                  voc-link @ over !
                  voc-link !
-                 class-size allot                \ reserve rest of class data
  
                  dup ^Class SFA !                \ store pointer to superclass
--- 449,456 ----
  \ Build a class header with its superclass pointer
  : inherit       ( pfa -- )
!                 here 2dup class-size dup allot move  \ copy class data
!                 body> vcfa>voc voc>vlink
                  voc-link @ over !
                  voc-link !
  
                  dup ^Class SFA !                \ store pointer to superclass
***************
*** 459,463 ****
                  ^Class ^Self iclass !           \ store my class in SELF
                                                  \ add to search order
!                 ^Class XFA OFF
                  also ^class body> vcfa>voc context ! definitions
                  obj-class 0= if reveal then ;
--- 458,462 ----
                  ^Class ^Self iclass !           \ store my class in SELF
                                                  \ add to search order
!                 ^Class XFA dup @ 0max swap !    \ inherit indexing
                  also ^class body> vcfa>voc context ! definitions
                  obj-class 0= if reveal then ;
***************
*** 505,509 ****
  
  : <Super        ( -- )        \ W32F     Class
! \ *G allow inheriting from a class or an object
  \ *E Specify the superclass of the class or object being created. Used as follows;
  \ **       :Class  <newclassname> <Super <superclassname>
--- 504,508 ----
  
  : <Super        ( -- )        \ W32F     Class
! \ *G Allow inheriting from a class or an object
  \ *E Specify the superclass of the class or object being created. Used as follows;
  \ **       :Class  <newclassname> <Super <superclassname>
***************
*** 521,525 ****
--- 520,526 ----
  
  synonym <Object <Super
+ \ *G See <Super
  synonym <Class  <Super
+ \ *G See <Super.
  
  \ Create an identical copy (clone) of an existing object
***************
*** 788,793 ****
                    1 ( object ) of  Obj.Var,                     endof
                    2 ( class  ) of  >Class (findm) ,             endof
!                   3 ( vector ) of  ,  POSTPONE (defer) ,        endof
!                   4 ( parm   ) of  ,  POSTPONE (defer) ,        endof
                    5 ( paren  ) of  drop LateBound               endof
                  Endcase ;
--- 789,794 ----
                    1 ( object ) of  Obj.Var,                     endof
                    2 ( class  ) of  >Class (findm) ,             endof
!                   3 ( vector ) of  compile,  POSTPONE (defer) ,        endof
!                   4 ( parm   ) of  compile,  POSTPONE (defer) ,        endof
                    5 ( paren  ) of  drop LateBound               endof
                  Endcase ;
***************
*** 950,954 ****
  
  : <noClassPointer ( -- )
! \ *G Set a class and its subclasses to suppress the class pointer when used as IVARs.
  \ XFA is -1 when no class pointer is reserved for IVARs.
          -1 ^class XFA ! ;
--- 951,956 ----
  
  : <noClassPointer ( -- )
! \ *G Set a class to suppress the class pointer when used for IVARs.
! \ ** Not inherited by subclasses.
  \ XFA is -1 when no class pointer is reserved for IVARs.
          -1 ^class XFA ! ;
***************
*** 959,964 ****
  
  : Self  ( -- addr )
! \ *G Compile a self reference, but only if the class is guaranteed to
! \ ** have a class pointer.  We can send ourself late-bound messages
  \ ** with the syntax:   Msg: [ self ].
          POSTPONE ^base ; IMMEDIATE
--- 961,966 ----
  
  : Self  ( -- addr )
! \ *G Compile a self reference so we can send ourself late-bound messages, but
! \ ** only if the class is guaranteed to have a class pointer.
  \ ** with the syntax:   Msg: [ self ].
          POSTPONE ^base ; IMMEDIATE
***************
*** 1119,1122 ****
--- 1121,1171 ----
  in-application
  
+ : @width  ( ^class -- elWidth )  \ return the indexed element width for a class
+  XFA @  0 MAX ;
+ 
+ \ =====================================================================
+ \ Indexed primitives. These should be in code for best performance.
+ 
+ : idxBase  ( -- addr )  \ get base of idx data area
+  ^base  DUP obj>class DFA @ +  CELL+ ;
+ 
+ : limit    ( -- n )  \ get idx limit (#elems)
+  ^base  DUP obj>class DFA @ + 2 + w@ ;
+ 
+ : #width    ( -- n )  \ width of an idx element
+  ^base obj>class XFA @ ;
+ 
+ : ^elem   ( index -- addr ) \ get addr of idx element
+  #width *  idxBase + ;
+ 
+ \ Fast access to byte and cell arrays.
+ : At1  ( index -- char )   idxBase + C@ ;
+ : At4  ( index -- cell )   CELLS idxBase + @ ;
+ 
+ : To1  ( char index -- )   idxBase + C! ;
+ : To4  ( cell index -- )   CELLS idxBase + ! ;
+ 
+ : ++1  ( char index -- )   idxBase + C+! ;
+ : ++4  ( cell index -- )   CELLS idxBase + +! ;
+ 
+ \ Compute total length of object.
+ \ The length does not include class pointer.
+ : objlen  ( -- objlen )
+  ^base obj>class DUP DFA @  ( non-indexed data )
+  SWAP @width ?DUP
+  IF  idxBase 2 - w@ ( #elems ) * +  CELL+  THEN ;
+ 
+ \ =====================================================================
+ \ Runtime indexed range checking. Use +range and -range to turn range
+ \ checking on and off.
+ 
+ defer ?idx
+ 
+ internal
+ 
+ : ?range  ( index -- index )  \ range check
+  DUP idxBase CELL - 2 + w@ ( #elems )  U< IF EXIT THEN
+  TRUE ABORT" Index out of range" ;
+ 
  \ : int-array    ( size -<name>- )
  \                header
***************
*** 1129,1133 ****
  module
  
! forth definitions
  
  : Dispose       ( addr -- )
--- 1178,1189 ----
  module
  
! forth definitions also hidden
! 
! : +range  ['] ?range is ?idx ;  +range
! : -range  ['] NOOP   is ?idx ;
! 
! initialization-chain chain-add +range
! 
! previous
  
  : Dispose       ( addr -- )