[Win32forth-cvs] win32forth/src/lib/Ext_classes $X.F, NONE, 1.1 2ARRAY.F, NONE, 1.1 2ARRAYGEN.F, NONE, 1.1 ARRAY11.F, NONE, 1.1 ORDERED-COL.F, NONE, 1.1 VAR11.F, NONE, 1.1

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

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

Added Files:
	$X.F 2ARRAY.F 2ARRAYGEN.F ARRAY11.F ORDERED-COL.F VAR11.F 
Log Message:
gah:Added extension classes ported from A McKewen/D Hoffmans ANSI compatible Neon Object system for easier porting of code written using them.

--- NEW FILE: 2ARRAYGEN.F ---
\ $Id: 2ARRAYGEN.F,v 1.1 2006/09/16 10:52:04 georgeahubert Exp $

\ 2ARRAYGEN.F for Win32Forth V6.11.09 or higher
\ G.Hubert Sunday, July 23 2006
\ Based on the ANSI Neon Model Class of Doug Hoffman

\ *P A 2arraygen is a dynamically-allocated 2-dimensional array, intended to be
\ ** used for keeping text strings.  The strings are not objects.  Each string
\ ** has a maximum length that it will accept.

\ *P Note that after instantiation we must first send maxsize new: because memory
\ ** from the heap is allocated.  Maxsize is the maximum number of chars we can
\ ** have in each element.  We specify for each array.  Limited to 255.

anew -2arraygen.f

needs var11

:class 2arrayGen <super object

 var #ofRows
 var #ofCols
 var elemSize
 var stride
 ptr arrayData


:m classinit:
 colDim @ put: #ofCols
 rowDim @ put: #ofRows
;m

:m maxsize:  ( -- n )  \ maximum number of characters for a cell
 get: elemSize 1- ;m

:m init:  ( maxSize -- )
 1+ put: elemSize  \ must allow room for count byte
 ;m


:m release:
 release: arrayData ;m

:m check:  ( row# col# -- )
 get: #ofCols 1 -  > swap
 get: #ofRows 1 -  > or abort" 2arrayGen indices out of bounds." ;m

:m elemAddr:  { row# col# -- addr }
\ locals| col# row# |
 row# col# check: self
 get: arrayData
 get: stride  row# * +
 get: elemSize col# * +
 ;m

:m to: { addr len row# col# | dest -- }
\ 0 locals| dest col# row# len addr |
 len  maxSize: self  min to len
 row# col# elemAddr: self to dest
 addr ( src) dest 1+ len cmove
 len dest c!
 ;m

:m at: ( row# col# -- addr len )
 elemAddr: self dup 1+ swap c@ ;m

:m clearall:
 get: #ofRows 0 ?DO
  get: #ofCols 0 ?DO
   0 j i elemAddr: self c!
      LOOP
     LOOP ;m

:m new: ( maxSize -- ) \ establish max element size and allot memory
 init: self
 get: #ofCols get: elemSize * put: stride
 get: #ofCols get: #ofRows *
 get: elemSize *
 new: arrayData

 clearall: self ;m

:m print:
 cr
 get: #ofRows 0 ?DO
  get: #ofCols 0 ?DO
    j i at: self type 2 spaces
      LOOP
      cr
     LOOP ;m
;class

0 [if]

*** EXAMPLE USE


2arrayGen gg
6 new: gg

s" teststring" 0 0 to: gg

s" test2" 0 1 to: gg
s" test3" 1 0 to: gg

print: gg

release: gg
[then]


--- NEW FILE: $X.F ---
\ $Id: \044X.F,v 1.1 2006/09/16 10:52:04 georgeahubert Exp $

\ G.Hubert Friday, September 15 2006 for Win32Forth V6.11.11 or above
\ Based on the class by Doug Hoffman

\ *P Class $x is a dictionary-based simple string class whose length may vary,
\ ** up to a maximum of 255, but the maximum length is defined at instantiation.
\ ** We cheat a bit here and the INDEXED class definition abilities and
\ ** indexed ivar data area in a way that was not really intended.

\ *P $x's are nice for use as string ivars, or if you want a persistent string
\ ** object in the dictionary (no handles here so we don't need to do a new:
\ ** and restore the data at each runtime).

anew -$x.f

needs array11

:class $x ( chars -- ) <super IndexedObj  1 <indexed  \ Each character is one byte.
 \ At instantiation we simply declare the maximum number of characters
 \ desired as if for a byte array.

:m limit:  ( -- lim )
 limit 1- ;m

:m get$: \ ( -- c-addr ) \ counted string format
 idxbase ;m

:m size:  \ ( -- len)
 get$: self c@ ;m


:m setsize:  \ ( len --)
 dup  limit: self > abort" No more room in $x."
 get$: self c!
 ;m

:m clear: ( -- )
 0 setsize: self ;m

:m classinit: ( -- )
 clear: self ;m

:m Addr:  ( -- addr)  \ redefine to give us the indexed data area+1
   \ which will be the address of the first character of text
 idxbase 1+ ;m

:m put: { addr len -- }
 len setsize: self
 addr Addr: self len cmove ;m

:m get: ( -- addr len )
 Addr: self  size: self ;m

:m print:
 get: self type ;m

:m put$:  ( c-addr -- )
 count put: self ;m

:m add: { addr len | $len  -- }
 size: self to $len
 len $len + setsize: self
 addr Addr: self $len + len cmove ;m

:m add$: ( c-addr -- )
 count add: self ;m


: makeUpper ( addr len -- )
 over + swap
 ?DO i c@ dup [char] a >=
     swap [char] z <= and
     IF i c@ 32 xor i c! THEN
 LOOP ;

:m uc: \  ( -- )  converts to upper case
 get: self makeUpper ;m

:m +:  ( c -- ) \ appends a char to the end of the string
 pad c! pad 1 add: self ;m

:m clip:  ( n -- )  \ remove n characters from end of string
     \ if n is too large, string is just cleared with no error
 size: self over - 0 max setsize: self ;m

;class


--- NEW FILE: VAR11.F ---
\ $Id: VAR11.F,v 1.1 2006/09/16 10:52:04 georgeahubert Exp $

\ Basic object variables
\ Ported to W32F Wednesday, June 14 2006 George Hubert for V6.11.09 or later
\ Based on Version 1.1, 6 Jan 2006  Doug Hoffman
\ Andrew McKewan
\ mc...@au...


\ ======================================================================
\ Define the basic cell-sized variable class. This is a generic superclass
\ that defines the basic access operators.

anew -var11.f

:Class CellObj  <Super Object <NoClassPointer

 CELL bytes Data

[undefined] M@ [if]

: M@   ( -- n )   Data @ ;
: M!   ( n -- )   Data ! ;

[then]

 :M  Get:   ( -- n )   M@   ;M  \ just for testing
 :M  Put:   ( n -- )   M!   ;M  \ ditto

 :M  Clear:   0 M!  ;M
 :M  Print:   M@ .  ;M

 \ ( ^obj -- )  copies data from another CellObj
 :M ->:   @ M!  ;M

;Class


\ ======================================================================
\ Var is for integer data

:Class Var   <Super CellObj <NoClassPointer

 :M  +:  ( n -- )         ^base +!  ;M
 :M  -: ( n -- )  NEGATE ^base +!  ;M

 :M  *:  ( n -- )  M@  *       M!   ;M
 :M  /:  ( n -- )  M@  SWAP /  M!   ;M
 :M  Negate:   M@  NEGATE  M!   ;M

;Class


\ ======================================================================
\ Bool is for storing booleans. It always returns TRUE or FALSE.

:Class Bool   <Super CellObj <NoClassPointer

 :M Put:  ( f -- )   0= 0= M!  ;M

 :M Get: get: super ;M
 :M Set:      TRUE  M!  ;M
 :M Invert:   M@ 0= M!  ;M

 :M Print:  M@ IF ." true " ELSE ." false " THEN  ;M
;Class


\ ======================================================================
\ ExecVec stores an execution token.

:Class ExecVec   <Super CellObj <NoClassPointer

 \ Execute xt stored in variable
 :M Exec:  ( -- )   M@ EXECUTE  ;M

 \ Initialize to do nothing
 :M Clear:      ['] NOOP M!  ;M
 :M ClassInit:  Clear: self  ;M

;Class

\ ======================================================================
\ Ptr stores a pointer to dynamically-allocated memory. We also keep track
\ of the current size of the memory block.

:Class Ptr   <Super CellObj <NoClassPointer

 Var size \ current size

 : ?MEMERR  ( ior -- )   abort" Memory error !" ;

 :M Size:  ( -- n )  \ get current size
  Get: size  ;M

 :M Release:  ( -- )   \ release current memory
  M@ IF  M@ FREE ?MEMERR  0 M!  THEN   Clear: size  ;M

 :M New:  ( len -- )  \ create a new memory block
  Release: self  DUP ALLOCATE ?MEMERR  M!  Put: size  ;M

 :M Resize:  ( len -- )  \ resize memory block
  M@ OVER RESIZE ?MEMERR  M!  Put: size  ;M

 :M Nil?:  ( -- f )  \ true if no memory has been allocated
  M@ 0=  ;M

;Class

--- NEW FILE: ORDERED-COL.F ---
\ $Id: ORDERED-COL.F,v 1.1 2006/09/16 10:52:04 georgeahubert Exp $

\ Win32Forth version, 3 July 2006 G.Hubert for V6.11.10 or later
\ based on Doug Hoffman's version for the ANSI Neon Model OOF

Forth Definitions
decimal

anew -ordered-col.f

needs var11.f
needs array11.f

 \ 06/19/05 dbh  code lifted from Mops

:class ORDERED-COL  <super array \ cell <indexed
 var SIZE    \ # elements in list

:m SIZE: \ ( -- cursize )  Returns #elements currently in list
  get: size  ;m

:m CLEAR:
 clear: size    ;m

:m ADD:  \ ( val -- )  add value to end of list
 get: size  limit  >=  abort" Ordered-col full"
 get: size  to: [ self ]  1 +: size  ;m

:m LAST:  \ ( -- val )  Returns contents of end of list
 get: size dup 0= abort" Empty ordered-col"
 1-  at: self  ;m


\ Removes the element at index
:m REMOVE:  ( indx  -- ) { | cnt wid addr }
 >r    \ indx to r
 get: size  r@ -  1-  to cnt  dup
     0<  abort" Can't remove: ordered-col"
 width: self to wid
 r>  ^elem: self  to addr
\ locals| addr wid cnt |
 1 -: size
 cnt  0= IF exitm THEN
 addr wid +  addr  cnt wid *  move  ;m

\ Finds a value in a collection.
:m INDEXOF:  { val | wid addr  -- indx T  | -- F }
 width: self  to wid   idxbase to addr
\ locals| addr wid val |
 false  get: size  0
 ?DO
  addr @ \ getelem: super
  val =  IF  drop  i  true  LEAVE  THEN
  wid addr + to addr
 LOOP  ;m


:m PRINT:
 get: size  0  ?do  i  at: self  cr .  loop  ;m

;class



--- NEW FILE: ARRAY11.F ---
\ $Id: ARRAY11.F,v 1.1 2006/09/16 10:52:04 georgeahubert Exp $

\ 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


--- NEW FILE: 2ARRAY.F ---
\ $Id: 2ARRAY.F,v 1.1 2006/09/16 10:52:04 georgeahubert Exp $

\ G.Hubert Friday, September 15 2006
\ Based on the code in Doug Hoffman's Class11

anew -2array.f

needs var11.f

:class 2array ( size -- ) <super object  4 <indexed
 var #ofRows
 var #ofCols
 var elemSize
 var stride

:m classinit:
 4 put: elemSize \ a 32 bit integer
 colDim @ put: #ofCols
 rowDim @ put: #ofRows
 get: #ofCols get: elemSize * put: stride
 ;m

:m check:  ( row# col# -- )
 get: #ofCols 1 -  > swap
 get: #ofRows 1 -  > or abort" 2array indice(s) out of bounds." ;m

:m elemAddr:  { row# col# -- addr }
\ locals| col# row# |
 row# col# check: self
 idxbase
 get: stride  row# * +
 get: elemSize col# * +
 ;m


:m to: ( n row# col# -- )
  elemAddr: self !
 ;m


:m at: ( row# col# -- n )
 elemAddr: self @ ;m

:m clearall: ( -- )
 get: #ofRows 0 ?DO
  get: #ofCols 0 ?DO
   0 j i elemAddr: self !
      LOOP
     LOOP ;m

:m print: ( -- )
 get: #ofRows 0 ?DO
  get: #ofCols 0 ?DO
   cr j . i .
   j i at: self .
      LOOP
     LOOP ;m

;class


0 [if]


*** EXAMPLE USE


5 5 dimension 2array a

33 0 6 to: a  \ should error

12 0 0 to: a

33 0 1 to: a

12345678 1 0 to: a

0 0 at: a .
12

0 1 at: a .
33

1 0 at: a .
12345678
print: a

[then]