New Micros, Inc

RMDumse

08-09-04, 05:31 AM

While this is only commented and not fully tested, maybe this listing will help understanding.

( String words. Parallel those available in Basic.
( Taken from Forth Dimensions example. Comments added.
( Transcription error in S+ corrected
( Should work on HC11 type arch, but not yet suitable for
( Harvard type arch. of 'Pod's yet

( IMPORTANT NOTE!
( The words with < and > in them had to be separated with spaces
( because this media took them as formating commands
( The spaces must be removed to make the code downloadable

( SRCH a word for counting a string to the null char
( Use: A$ DROP SRCH
: SRCH ( straddr --- strlength
DUP ( Begining address dup
BEGIN
DUP C@ ( Get char at index address
SWAP 1+ SWAP ( Swap up index, add 1, swap back
0= ( See if fetched character is null char
END ( Until
SWAP ( Swap for correct order of subtraction
- 1- ( Take different of beginning and ending
; ( and then 1 less because over indexed

( STRING a defining word to create a new string variable
( Use defining: STRING A$ ( defining string
( Use runtime : A$ ( string leaves straddr strlength
: STRING ( <name> ---
< BUILDS ( Compile time action
ABS ( Work with only positive lengths
255 MIN ( Lengths less than 256 total
1 MAX ( Lengths greater than 0, at least 1
DUP C, ( First location is length
0 ( For the length count, 0-length
DO
32 C, ( Fill with spaces
LOOP
0 C, ( And end with a null char
DOES > ( Run time action
1+ ( At address of count, 1+
DUP SRCH ( Dup and search
( leaves --- straddr strlength
;

( IB a temprary internal buffer
( Use: IB A$ CMOVE
VARIABLE IB
254 ALLOT ( 254+1 long

( (") A primitive operator for the " function
( Use: ( not used, primitive
: (") ( --- straddr strcount ; branch past string
R@ ( Get address of calling word
COUNT ( Dup the address and move one forward, fetch count
DUP 1+ ( Copy count, add one more
R > ( Move the instruction pointer ahead
+ ( by getting from return stack and adding count+1
> R ( and putting back on the return stack
;

( " Word to compile an inline constant string
( Use: : <NAME> ( ... ) " This is a constant string" A$ CMOVE ( ... ) ;
: "
34 ( Put ascii for " on stack
STATE @ ( See if compiling or interpreting
IF ( If compiling
COMPILE (") ( compile the primative (")
WORD ( Parse out the string until " is found
HERE C@ 1+ ( Use the count left by word and add 1 for null
ALLOT ( and allot room
ELSE ( If interpreting
WORD ( Parse out the string until " is found
HERE COUNT ( Use the count left by word
IB ( Internal Buffer
SWAP ( Here Count IB --- Here IB Count
ROT ( Here IB Count --- IB Count Here
OVER ( IB Count Here --- IB Count Here Count
IB ( IB Count Here Count IB
SWAP 1+ ( IB Count Here IB Count+1
CMOVE ( Move string from Here to IB for Count+1
2DUP ( IB Count IB Count
+ ( IB Count IB+Count
0 ( IB Count IB+Count 0
SWAP ( IB Count 0 IB+Count
C! ( Store null at end of string, leave IB COUNT
THEN
; IMMEDIATE

( VAL Word to convert a str to a number
( Use: A$ VAL
: VAL ( straddr strlength --- n
OVER ( straddr strlength straddr
+ ( straddr strlength+straddr, or ending addr
BL SWAP C! ( put a blank at the end of the string
1- NUMBER ( move back one address for number, and convert
;

( STR$ Word makes a string out of a number
( Use: D1 2@ STR$ A$ CMOVE
: STR$ ( d --- ; where d is n1 n2
SWAP ( n1 n2 --- n2 n1
OVER ( n2 n1 --- n2 n1 n2
DABS ( prep double number with sign word for format
< # #S SIGN # > ( format in current base to just prior PAD
;

( MLEN A word to measure a length
( Use: A$ MLEN
: MLEN ( straddr strlength1 --- strlength2
DROP 1- C@ ( Drop this length, move back, take old counted length
;

( S! A word to store a string at an address
( Use: " TEST" A$ S!
: S! ( straddr1 strlength1 straddr2 strlength2 ---
DROP ( straddr1 strlength1 straddr2
DUP 1- C@ ( straddr1 strlength1 straddr2 strcount2
ROT ( straddr1 straddr2 strcount2 strlength1
MIN 1 MAX ( straddr1 straddr2 strlength2
2DUP + ( straddr1 straddr2 strlength2 straddr2end
0 SWAP C! ( Make sure null terminated
CMOVE ( Source straddr1 Dest straddr2 Count strcount2
;

( LEN A word that gives the length of a string
( Use: A$ LEN 5 < IF ...
: LEN ( straddr strlength --- strlength
SWAP DROP ( Swap up address and drop leaving only length
;

( MID$ A word that
( Use: 8 6 A$ MID$ B$ S!
: MID$ ( n1 n2 straddr1 strlength1 ---
SWAP > R ( n1 n2 strlength1 R: straddr1
ROT ( n2 strlength1 n1 R: straddr1
MIN 1 MAX ( n2 n1mm R: straddr1
SWAP OVER ( n1mm n2 n1mm R: straddr1
MAX ( n1mm n2m R: straddr1
OVER - ( n1mm n3 R: straddr1
1+ ( n1mm n3+1 R: straddr1
SWAP ( n3+1 n1mm R: straddr1
R > ( n3+1 n1mm straddr1
+ 1- ( n3+1 newaddr
SWAP OVER ( newaddr n3+1 newaddr
SRCH MIN ( newaddr newlength
;

( LEFT$ A word that
( Use: 7 A$ LEFT$
: LEFT$ ( n1 straddr1 strlength1 ---
> R > R ( n1 R: strlength1 straddr1
1 SWAP ( 1 n1 R: strlength1 straddr1
R > R > ( 1 n1 straddr1 strlength1
MID$ ( Extract the string from 1 upto n1
;

( RIGHT$
A word that
( Use: 8 A$ RIGHT$
: RIGHT$ ( n1 straddr1 strlength1 ---
> R > R ( n1 R: strlength1 straddr1
256 ( n1 256 R: strlength1 straddr1
R > R > ( n1 256 straddr1 strlength1
MID$ ( Extract the string from n1 upto 256
;

( S+ A word that concatenates one string to another
( Use: A$ B$ S+ C$ S!
: S+ ( straddr1 strlength1 straddr2 strlength2 ---
ROT > R ( straddr1 straddr2 strlength2 R: strlength1
( ROT > R
SWAP OVER ( straddr1 strlength2 straddr2 strlength2 R: strlength1
IB SWAP ( straddr1 strlength2 straddr2 IB strlength2 R: strlength1
CMOVE ( straddr1 strlength2 R: strlength1
R > ( straddr1 strlength2 strlength1
SWAP OVER ( straddr1 strlength1 strlength2 strlength1
+ ( straddr1 strlength1 strlength3
255 MIN ( straddr1 strlength1 strlength3
DUP ( straddr1 strlength1 strlength3 strlength3
> R ( straddr1 strlength1 strlength3 R: strlength3
OVER - SWAP ( straddr1 strlength4 strlength1 R: strlength3
IB + ( straddr1 strlength4 strlength1+IB R: strlength3
SWAP ( straddr1 strlength1+IB strlength4 R: strlength3
CMOVE
R > ( strlength3
0 OVER IB ( strlength3 0 strlength3 IB
+ C! ( strlength3
IB SWAP ( IB strlength3
;

( SUB A word that substitutes one string from another
( Use: A$ B$ SUB ( Puts A$ into B$ variable
: SUB ( straddr1 strlength1 straddr2 strlength2 ---
ROT ( straddr1 straddr2 strlength2
strlength1

MIN 1 MAX ( straddr1 straddr2 strlength
CMOVE ( Source: straddr1 Dest: straddr2 Count: strlength
;

( S= A word that compares one string to another
( Use: A$ B$ S= IF ...
: S= ( straddr1 strlength1 straddr2 strlength2 ---
ROT OVER = ( straddr1 straddr2 strlength2 b1
IF
1 SWAP 0 ( straddr1 straddr2 b1 strlength2 0
DO ( straddr1 straddr2 b1
DROP ( straddr1 straddr2
OVER C@ ( straddr1 straddr2 char1
OVER C@ ( straddr1 straddr2 char1 char2
= ( straddr1 straddr2 b2
IF
1+ SWAP ( Inc addr2
1+ SWAP ( Inc addr1
1 ( straddr1++ straddr2++ b1
ELSE
0 ( straddr1++ straddr2++ b0
LEAVE ( Terminate loop
THEN
LOOP
ELSE
DROP 0 ( straddr1 straddr2 b0
THEN
SWAP DROP ( straddr1 b0/1
SWAP DROP ( b0/1
;