[Win32forth-cvs] win32forth/src/lib/Ext_classes Objlist.f, NONE, 1.1 Sequence.f, NONE, 1.1 ARRAY11.F, 1.1, 1.2 ORDERED-COL.F, 1.1, 1.2

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

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

Modified Files:
	ARRAY11.F ORDERED-COL.F 
Added Files:
	Objlist.f Sequence.f 
Log Message:
gah: Updated Array11.f and ordered-col.f to match Doug Hoffmans latest versions. Added Sequence.f and Objlist.f

--- NEW FILE: Objlist.f ---
\ $Id: Objlist.f,v 1.1 2007/02/21 09:57:32 georgeahubert Exp $

\ a dynamically expandable list of objects
:class objList <super sequence
 ptr list
 var current

\ :m ListSize: ( -- n )
\    size: list ;m

:m valid?: ( idx0 -- t/f )
 nil?: list IF false exitm THEN
 size: list cell /  \ idx0 idxmax+1
 < ;m

:m ^elem: ( idx -- addr )
 cell * get: list + ;m

:m at: ( idx -- ^obj )
 ^elem: self @ ;m

:m add: ( ^class -- ^obj )
 >body DUP ?isClass 0= ABORT" Not a class" (heapobj) dup
 nil?: list
 IF cell new: list get: list !  \ ^obj
 ELSE
  size: list dup cell + resize: list  \ ^obj ^obj size
  get: list + !
 THEN ;m

 :m first?: ( -- ^obj t | f )
  nil?: list IF false exitm THEN
  clear: current
  0 at: self true ;m

 :m next?:  ( -- ^obj t | f )
  1 +: current get: current dup valid?: self
  IF at: self true
  ELSE drop false
  THEN ;m

 :m release:
  BEGIN
    each: self
  WHILE
    <release
  REPEAT
  clear: list clear: current clear: each_started?
   ;m

 :m print:
   BEGIN
     each: self
   WHILE
     cr print: **
   REPEAT ;m

  :m size: ( -- n ) \ number of objects in list
    size: list cell / ;m


;class


Index: ORDERED-COL.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/Ext_classes/ORDERED-COL.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ORDERED-COL.F	16 Sep 2006 10:52:04 -0000	1.1
--- ORDERED-COL.F	21 Feb 2007 09:57:32 -0000	1.2
***************
*** 9,14 ****
  anew -ordered-col.f
  
! needs var11.f
! needs array11.f
  
   \ 06/19/05 dbh  code lifted from Mops
--- 9,13 ----
  anew -ordered-col.f
  
! needs ext_classes\array11.f
  
   \ 06/19/05 dbh  code lifted from Mops
***************
*** 55,61 ****
   LOOP  ;m
  
  
! :m PRINT:
!  get: size  0  ?do  i  at: self  cr .  loop  ;m
  
  ;class
--- 54,67 ----
   LOOP  ;m
  
+ :m first?: ( -- elem t | f )
+   size: self 1 < IF false exitm THEN
+   clear: current
+   0 at: self true ;m
  
! :m next?:  ( -- ^obj t | f )
!   1 +: current get: current dup size: self <
!   IF at: self true
!   ELSE drop false
!   THEN ;m
  
  ;class

Index: ARRAY11.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/Ext_classes/ARRAY11.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ARRAY11.F	16 Sep 2006 10:52:04 -0000	1.1
--- ARRAY11.F	21 Feb 2007 09:57:32 -0000	1.2
***************
*** 2,74 ****
  
  \ Classes for indexed objects
! \ Version 1.0, 4 Feb 1997
  \ Andrew McKewan
  \ mc...@au...
  \ Win32Forth version, 3 July 2006 G.Hubert (Requires V6.11.10 or later)
  
  anew -array11.f
  
! \ ==================================================================
! \ This is the base class for all indexed objects. It provides the
! \ primitives that are common to all indexed objects.
  
! :Class IndexedObj  <Super Object  CELL <Indexed
  
!  \ ( -- addr )  Leave addr of 0th indexed element
!  :M  IxAddr:   idxBase   ;M
  
!  \ ( -- limit ) Leave max #elements for array
!  :M  Limit:  limit   ;M
  
!  \ ( -- len )  leave width of indexed elements
!  :M  Width:  #width  ;M
  
!  \ ( index -- addr )  return then address of an indexed element
!  :M  ^Elem:  ?idx  ^elem    ;M
  
!  \ ( -- )  Indexed Clear: erases indexed area
!  :M  Clear:  idxBase  #width limit * ERASE  ;M
  
  ;Class
  
  
! \ ==================================================================
! \ Basic cell array
  
! :Class Array  <Super IndexedObj \  CELL <Indexed
  
!  :M  At:    ?idx  At4  ;M   ( index -- val )
!  :M  To:    ?idx  To4  ;M   ( val Index -- )
!  :M  +To:   ?idx  ++4  ;M   ( incVal index -- )
  
!  \ Fill the array with a value
!  :M Fill: ( val -- )  limit 0 DO  DUP I To4  LOOP DROP  ;M
  
! ;Class
  
! \ ==================================================================
! \ X-Array can execute its elements.
  
! :Class X-Array  <Super Array \ cell <indexed
  
!  \ ( ind -- )  execute the cfa at Ind
!  :M  Exec:  ?idx  At4  DUP 0= ABORT" Null xt"  EXECUTE  ;M
  
!  :M  ClassInit:  ['] NOOP Fill: self  ;M
  
  ;Class
  
! \ ==================================================================
! \ Basic byte array.
  
! :Class ByteArray  <Super IndexedObj  1 <Indexed
  
!  :M  At:    ?idx  At1  ;M   ( index -- val )
!  :M  To:    ?idx  To1  ;M   ( val Index -- )
!  :M  +To:   ?idx  ++1  ;M   ( incVal index -- )
  
!  \ Fill the array with a value
!  :M Fill: ( val -- )  idxBase limit ROT FILL  ;M
  
  ;Class
  
--- 2,144 ----
  
  \ Classes for indexed objects
! \ Version 1.2, 4 Feb 1997
  \ Andrew McKewan
  \ mc...@au...
  \ Win32Forth version, 3 July 2006 G.Hubert (Requires V6.11.10 or later)
  
+ \ *P These classes are for one-dimensional arrays. The size of the array is passed to the
+ \ ** array when it is created, either at compile-time or at run-time for arrays created
+ \ ** with NEW>. For IVARS the size is passed when the IVAR is declared.
+ 
  anew -array11.f
  
! needs ext_classes\sequence.f
  
! \ *S Glossary
  
! in-system
  
! :Class IndexedObj  ( #elems -- ) <Super Sequence
! \ *G This is the base class for all indexed objects. It provides the
! \ ** primitives that are common to all indexed objects.
! CELL <Indexed
  
! in-previous
  
! :M IxAddr: ( -- addr )
! \ *G Leave addr of 0th indexed element.
!           idxBase   ;M
  
! :M Limit: ( -- limit )
! \ *G Leave max #elements for array.
!           limit   ;M
! 
! :M Width: ( -- len )
! \ *G Leave width of indexed elements.
!           #width  ;M
! 
! :M ^Elem: ( index -- addr )
! \ *G Return the address of an indexed element.
!           ?idx  ^elem    ;M
! 
! :M Clear: ( -- )
! \ *G Indexed Clear: erases indexed area
!           idxBase  #width limit * ERASE  ;M
  
  ;Class
+ \ *G End of class
  
  
! :Class Array  ( #elems -- ) <Super IndexedObj
! \ *G A standard one-dimensional array of #elems elements. The elements are referenced
! \ ** by a 0 based index.
  
! var current
  
! :M  At:   ( index -- n )
! \ *G Fetch the element at index.
!           ?idx  At4  ;M
  
! :M  To:   ( n Index -- )
! \ *G Put n into the element at index.
!           ?idx  To4  ;M
  
! :M  +To:  ( n index -- )
! \ *G Add n to the element at index.
!           ?idx  ++4  ;M
  
! :M Fill:  ( n -- )
! \ *G Fill all the elements of the array with n.
!           limit 0 DO  DUP I To4  LOOP DROP  ;M
  
! :m first?: ( -- elem t | f )
! \ *G Return first element and true.
!   clear: current
!   0 at: self true ;m
  
! :m next?:  ( -- ^obj t | f )
! \ *G Return next obj and true if there is a next object; false otherwise.
!   1 +: current get: current dup limit <
!   IF at: self true
!   ELSE drop false
!   THEN ;m
  
! :m print:
! \ *G Print all elements.
!    BEGIN
!     each: self
!    WHILE cr .
!    REPEAT ;m
! 
! :m apply: ( xt -- )
! \ *G Apply xt to each element and store the result in the element. xt should have the
! \ ** stack effect ( n1 -- n2 ).
!      >r
!     BEGIN
!       each: self
!     WHILE
!       r@ ( elem xt ) execute
!         get: current to: self
!     REPEAT r> drop ;m
  
  ;Class
+ \ *G End of Class.
  
! :Class X-Array  ( #elems -- ) <Super Array
! \ *G Create an array of execution vectors; i.e. a jump table.
  
! :M Exec:  ( index -- )
! \ *G Execute the cfa at Index.
!           ?idx  At4  DUP 0= ABORT" Null xt"  EXECUTE  ;M
  
! :M ClassInit: ( -- )
! \ *G Initialise the class. The elements are set to perform noop.
!           ['] NOOP Fill: self  ;M
  
! ;Class
! \ *G End of Class.
! 
! :Class ByteArray ( #elems -- )  <Super IndexedObj
! \ *G Array of bytes.
!          1 <Indexed
! 
! :M  At:   ( index -- n )
! \ *G Fetch the element at index.
!           ?idx  At1  ;M
! :M  To:   ( n Index -- )
! \ *G Put n into the element at index.
!           ?idx  To1  ;M
! :M  +To:  ( n index -- )
! \ *G Add n to the element at index.
!           ?idx  ++1  ;M
! 
! :M Fill:  ( n -- )
! \ *G Fill all the elements of the array with n.
!           idxBase limit ROT FILL  ;M
  
  ;Class
+ \ *G End of Class.
+ 
+ \ *Z
+ 
  

--- NEW FILE: Sequence.f ---
\ $Id: Sequence.f,v 1.1 2007/02/21 09:57:32 georgeahubert Exp $

\ Originally written by Doug Hoffman
\ Ported to W32F Monday, February 19 2007 by George Hubert

anew -sequence.f

needs ext_classes\var11.f

in-system

:class SEQUENCE <super object
\ *G SEQUENCE is a generic superclass for classes which have multiple items which
\ ** frequently need to be looked at in sequence.  At present the main function of
\ ** Sequence is to implement the EACH: method, which makes it very simple to
\ ** deal with each element.  The usage is

\ *E  BEGIN  each: <obj>  WHILE  <do something to the element>  REPEAT

\ *P Sequence can be a superclass for any class which implements the
\ ** FIRST?: and NEXT?: methods.  The actual implementation details are quite
\ ** irrelevant, as long as these methods are supported.

in-previous

 bool each_started?

:m first?: false ;m

:m next?: false ;m

:m EACH:  \ ( -- (varies) T  |  -- F )
 get: each_started?
 IF \ Subsequent time in:
  next?: [ self ]
  IF  true  ELSE  clear: each_started?  false  THEN
 ELSE \ First time in:
  first?: [ self ]  0= IF 0 exitm THEN
  set: each_started?
  true  \ Yes, we've got the 1st element
 THEN
;m

:m UNEACH: \ Use to terminate an EACH: loop before the end.
 clear: each_started?
;m

  :m apply: ( xt -- )
     >r
    BEGIN
      each: self
    WHILE
      r@ ( elem xt ) execute
    REPEAT r> drop ;m

;class