[pforth] / fth / t_corex.fth

\ @(#) t_corex.fth 98/03/16 1.2\r
\ Test ANS Forth Core Extensions\r
\\r
\ Copyright 1994 3DO, Phil Burk\r
\r
INCLUDE? }T{  t_tools.fth\r
\r
ANEW TASK-T_COREX.FTH\r
\r
DECIMAL\r
\r
\ STUB because missing definition in pForth - FIXME\r
: SAVE-INPUT ;\r
: RESTORE-INPUT -1 ;\r
\r
TEST{\r
\r
\ ==========================================================\r
T{ 1 2 3 }T{ 1 2 3 }T\r
\r
\  ----------------------------------------------------- .(\r
T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T\r
\r
CR .(     1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR\r
\r
T{ .( )   987   .( TEST NULL STRING IN .( ) CR }T{ 987 }T\r
\r
\  ----------------------------------------------------- 0<>\r
T{ 5 0<> }T{ TRUE }T\r
T{ 0 0<> }T{ 0 }T\r
T{ -1000 0<> }T{ TRUE }T\r
\r
\  ----------------------------------------------------- 2>R 2R> 2R@\r
: T2>R  ( -- .... )\r
	17\r
	20 5 2>R\r
	19\r
	2R@\r
	37\r
	2R>\r
\ 2>R should be the equivalent of SWAP >R >R so this next construct\r
\ should reduce to a SWAP.\r
	88 77 2>R R> R>\r
;\r
T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T\r
\r
\  ----------------------------------------------------- :NONAME\r
T{ :NONAME  100 50 + ; EXECUTE }T{ 150 }T\r
\r
\  ----------------------------------------------------- <>\r
T{ 12345 12305 <> }T{ TRUE }T\r
T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T\r
\r
\  ----------------------------------------------------- ?DO\r
: T?DO  ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;\r
T{ 0 T?DO }T{ 0 }T\r
T{ 4 T?DO }T{ 10 }T\r
\r
\  ----------------------------------------------------- AGAIN\r
: T.AGAIN  ( n --  )\r
	BEGIN\r
		DUP .\r
		DUP 6 < IF EXIT THEN\r
		1-\r
	AGAIN\r
;\r
T{ 10 T.AGAIN CR }T{ 5 }T\r
\r
\  ----------------------------------------------------- C"\r
: T.C"  ( -- $STRING )\r
	C" x5&"\r
;\r
T{ T.C"  C@  }T{ 3 }T\r
T{ T.C"  COUNT DROP C@  }T{ CHAR x }T\r
T{ T.C"  COUNT DROP CHAR+ C@ }T{  CHAR 5 }T\r
T{ T.C"  COUNT DROP 2 CHARS + C@  }T{ CHAR & }T\r
\r
\  ----------------------------------------------------- CASE\r
: T.CASE  ( N -- )\r
	CASE\r
		1 OF 101 ENDOF\r
		27 OF 892 ENDOF\r
		941 SWAP \ default\r
	ENDCASE\r
;\r
T{ 1 T.CASE }T{ 101 }T\r
T{ 27 T.CASE }T{ 892 }T\r
T{ 49 T.CASE }T{ 941 }T\r
\r
\  ----------------------------------------------------- COMPILE,\r
: COMPILE.SWAP    ['] SWAP COMPILE, ; IMMEDIATE\r
: T.COMPILE,\r
	19 20 27 COMPILE.SWAP 39\r
;\r
T{ T.COMPILE, }T{ 19 27 20 39 }T\r
\r
\  ----------------------------------------------------- CONVERT\r
: T.CONVERT\r
	0 S>D  S" 1234xyz" DROP CONVERT\r
	>R\r
	D>S\r
	R> C@\r
;\r
T{ T.CONVERT }T{ 1234 CHAR x }T\r
\r
\  ----------------------------------------------------- ERASE\r
: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )\r
	0 ?DO I C, LOOP\r
;\r
CREATE T-ERASE-DATA   64 T.COMMA.SEQ\r
T{ T-ERASE-DATA 8 + C@ }T{ 8 }T\r
T{ T-ERASE-DATA 7 + 3 ERASE\r
T{ T-ERASE-DATA 6 + C@ }T{ 6 }T\r
T{ T-ERASE-DATA 7 + C@ }T{ 0 }T\r
T{ T-ERASE-DATA 8 + C@ }T{ 0 }T\r
T{ T-ERASE-DATA 9 + C@ }T{ 0 }T\r
T{ T-ERASE-DATA 10 + C@ }T{ 10 }T\r
\r
\  ----------------------------------------------------- FALSE\r
T{ FALSE }T{ 0 }T\r
\r
\  ----------------------------------------------------- HEX\r
T{ HEX 10 DECIMAL }T{ 16 }T\r
\r
\  ----------------------------------------------------- MARKER\r
: INDIC?  ( <name> -- ifInDic , is the following word defined? )\r
	bl word find\r
	swap drop 0= 0=\r
;\r
create FOOBAR\r
MARKER MYMARK  \ create word that forgets itself\r
create GOOFBALL\r
MYMARK\r
T{ indic? foobar  indic? mymark indic? goofball }T{ true false false }T\r
\r
\  ----------------------------------------------------- NIP\r
T{ 33 44 55 NIP  }T{ 33 55 }T\r
\r
\  ----------------------------------------------------- PARSE\r
: T.PARSE  ( char <string>char -- addr num )\r
	PARSE\r
	>R  \ save length\r
	PAD R@ CMOVE  \ move string to pad\r
	PAD R>\r
;\r
T{ CHAR % T.PARSE wxyz% SWAP C@ }T{  4  CHAR w }T\r
\r
\  ----------------------------------------------------- PICK\r
T{ 13 12 11 10 2 PICK  }T{ 13 12 11 10 12 }T\r
\r
\  ----------------------------------------------------- QUERY\r
T{ ' QUERY 0<> }T{ TRUE }T\r
\r
\  ----------------------------------------------------- REFILL\r
T{ ' REFILL 0<> }T{ TRUE }T\r
\r
\  ----------------------------------------------------- RESTORE-INPUT\r
T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T  \ EXPECTED FAILURE\r
\r
\  ----------------------------------------------------- ROLL\r
T{ 15 14 13 12 11 10 0 ROLL  }T{  15 14 13 12 11 10 }T\r
T{ 15 14 13 12 11 10 1 ROLL  }T{  15 14 13 12 10 11 }T\r
T{ 15 14 13 12 11 10 2 ROLL  }T{  15 14 13 11 10 12 }T\r
T{ 15 14 13 12 11 10 3 ROLL  }T{  15 14 12 11 10 13 }T\r
T{ 15 14 13 12 11 10 4 ROLL  }T{  15 13 12 11 10 14 }T\r
\r
\  ----------------------------------------------------- SOURCE-ID\r
T{ SOURCE-ID 0<> }T{ TRUE }T\r
T{ : T.SOURCE-ID  S" SOURCE-ID" EVALUATE  ;   T.SOURCE-ID }T{ -1 }T\r
\r
\  ----------------------------------------------------- SPAN\r
T{ ' SPAN 0<>  }T{ TRUE }T\r
\r
\  ----------------------------------------------------- TO VALUE\r
333 VALUE  MY-VALUE\r
T{ MY-VALUE }T{ 333 }T\r
T{ 1000 TO MY-VALUE   MY-VALUE }T{ 1000 }T\r
: TEST.VALUE  ( -- 19 100 )\r
	100 TO MY-VALUE\r
	19\r
	MY-VALUE\r
;\r
T{ TEST.VALUE }T{ 19 100 }T\r
\r
\  ----------------------------------------------------- TRUE\r
T{ TRUE }T{ 0 0= }T\r
\r
\  ----------------------------------------------------- TUCK\r
T{ 44 55 66 TUCK }T{ 44 66 55 66 }T\r
\r
\  ----------------------------------------------------- U.R\r
HEX CR .(     ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR\r
ABCD4321 C U.R CR DECIMAL\r
\r
\  ----------------------------------------------------- U>\r
T{ -5 3 U> }T{ TRUE }T\r
T{ 10 8 U> }T{ TRUE }T\r
\r
\  ----------------------------------------------------- UNUSED\r
T{ UNUSED 0> }T{ TRUE }T\r
\r
\  ----------------------------------------------------- WITHIN\r
T{  4  5 10 WITHIN }T{ 0 }T\r
T{  5  5 10 WITHIN }T{ TRUE }T\r
T{  9  5 10 WITHIN }T{ TRUE }T\r
T{ 10  5 10 WITHIN }T{ 0 }T\r
\r
T{  4  10 5 WITHIN }T{ TRUE }T\r
T{  5  10 5 WITHIN }T{ 0 }T\r
T{  9  10 5 WITHIN }T{ 0 }T\r
T{ 10  10 5 WITHIN }T{ TRUE }T\r
\r
T{  -6  -5 10 WITHIN }T{ 0 }T\r
T{  -5  -5 10 WITHIN    }T{ TRUE }T\r
T{  9  -5 10 WITHIN    }T{ TRUE }T\r
T{ 10  -5 10 WITHIN }T{ 0 }T\r
\r
\r
\  ----------------------------------------------------- [COMPILE]\r
: T.[COMPILE].IF  [COMPILE] IF ; IMMEDIATE\r
: T.[COMPILE]  40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;\r
T{ T.[COMPILE] }T{ TRUE }T\r
\r
\  ----------------------------------------------------- \\r
}TEST\r
\r
Commit	Line	Data
bb6b2dcd	1	\ @(#) t_corex.fth 98/03/16 1.2\r
	2	\ Test ANS Forth Core Extensions\r
	3	\\r
	4	\ Copyright 1994 3DO, Phil Burk\r
	5	\r
	6	INCLUDE? }T{ t_tools.fth\r
	7	\r
	8	ANEW TASK-T_COREX.FTH\r
	9	\r
	10	DECIMAL\r
	11	\r
	12	\ STUB because missing definition in pForth - FIXME\r
	13	: SAVE-INPUT ;\r
	14	: RESTORE-INPUT -1 ;\r
	15	\r
	16	TEST{\r
	17	\r
	18	\ ==========================================================\r
	19	T{ 1 2 3 }T{ 1 2 3 }T\r
	20	\r
	21	\ ----------------------------------------------------- .(\r
	22	T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T\r
	23	\r
	24	CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR\r
	25	\r
	26	T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T\r
	27	\r
	28	\ ----------------------------------------------------- 0<>\r
	29	T{ 5 0<> }T{ TRUE }T\r
	30	T{ 0 0<> }T{ 0 }T\r
	31	T{ -1000 0<> }T{ TRUE }T\r
	32	\r
	33	\ ----------------------------------------------------- 2>R 2R> 2R@\r
	34	: T2>R ( -- .... )\r
	35	17\r
	36	20 5 2>R\r
	37	19\r
	38	2R@\r
	39	37\r
	40	2R>\r
	41	\ 2>R should be the equivalent of SWAP >R >R so this next construct\r
	42	\ should reduce to a SWAP.\r
	43	88 77 2>R R> R>\r
	44	;\r
	45	T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T\r
	46	\r
	47	\ ----------------------------------------------------- :NONAME\r
	48	T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T\r
	49	\r
	50	\ ----------------------------------------------------- <>\r
	51	T{ 12345 12305 <> }T{ TRUE }T\r
	52	T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T\r
	53	\r
	54	\ ----------------------------------------------------- ?DO\r
	55	: T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;\r
	56	T{ 0 T?DO }T{ 0 }T\r
	57	T{ 4 T?DO }T{ 10 }T\r
	58	\r
	59	\ ----------------------------------------------------- AGAIN\r
	60	: T.AGAIN ( n -- )\r
	61	BEGIN\r
	62	DUP .\r
	63	DUP 6 < IF EXIT THEN\r
	64	1-\r
65	AGAIN\r
66	;\r
67	T{ 10 T.AGAIN CR }T{ 5 }T\r
68	\r
69	\ ----------------------------------------------------- C"\r
70	: T.C" ( -- $STRING )\r
71	C" x5&"\r
72	;\r
73	T{ T.C" C@ }T{ 3 }T\r
74	T{ T.C" COUNT DROP C@ }T{ CHAR x }T\r
75	T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T\r
76	T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T\r
77	\r
78	\ ----------------------------------------------------- CASE\r
79	: T.CASE ( N -- )\r
80	CASE\r
81	1 OF 101 ENDOF\r
82	27 OF 892 ENDOF\r
83	941 SWAP \ default\r
84	ENDCASE\r
85	;\r
86	T{ 1 T.CASE }T{ 101 }T\r
87	T{ 27 T.CASE }T{ 892 }T\r
88	T{ 49 T.CASE }T{ 941 }T\r
89	\r
90	\ ----------------------------------------------------- COMPILE,\r
91	: COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE\r
92	: T.COMPILE,\r
93	19 20 27 COMPILE.SWAP 39\r
94	;\r
95	T{ T.COMPILE, }T{ 19 27 20 39 }T\r
96	\r
97	\ ----------------------------------------------------- CONVERT\r
98	: T.CONVERT\r
99	0 S>D S" 1234xyz" DROP CONVERT\r
100	>R\r
101	D>S\r
102	R> C@\r
103	;\r
104	T{ T.CONVERT }T{ 1234 CHAR x }T\r
105	\r
106	\ ----------------------------------------------------- ERASE\r
107	: T.COMMA.SEQ ( n -- , lay down N sequential bytes )\r
108	0 ?DO I C, LOOP\r
109	;\r
110	CREATE T-ERASE-DATA 64 T.COMMA.SEQ\r
111	T{ T-ERASE-DATA 8 + C@ }T{ 8 }T\r
112	T{ T-ERASE-DATA 7 + 3 ERASE\r
113	T{ T-ERASE-DATA 6 + C@ }T{ 6 }T\r
114	T{ T-ERASE-DATA 7 + C@ }T{ 0 }T\r
115	T{ T-ERASE-DATA 8 + C@ }T{ 0 }T\r
116	T{ T-ERASE-DATA 9 + C@ }T{ 0 }T\r
117	T{ T-ERASE-DATA 10 + C@ }T{ 10 }T\r
118	\r
119	\ ----------------------------------------------------- FALSE\r
120	T{ FALSE }T{ 0 }T\r
121	\r
122	\ ----------------------------------------------------- HEX\r
123	T{ HEX 10 DECIMAL }T{ 16 }T\r
124	\r
125	\ ----------------------------------------------------- MARKER\r
126	: INDIC? ( <name> -- ifInDic , is the following word defined? )\r
127	bl word find\r
128	swap drop 0= 0=\r
129	;\r
130	create FOOBAR\r
131	MARKER MYMARK \ create word that forgets itself\r
132	create GOOFBALL\r
133	MYMARK\r
134	T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T\r
135	\r
136	\ ----------------------------------------------------- NIP\r
137	T{ 33 44 55 NIP }T{ 33 55 }T\r
138	\r
139	\ ----------------------------------------------------- PARSE\r
140	: T.PARSE ( char <string>char -- addr num )\r
141	PARSE\r
142	>R \ save length\r
143	PAD R@ CMOVE \ move string to pad\r
144	PAD R>\r
145	;\r
146	T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T\r
147	\r
148	\ ----------------------------------------------------- PICK\r
149	T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T\r
150	\r
151	\ ----------------------------------------------------- QUERY\r
152	T{ ' QUERY 0<> }T{ TRUE }T\r
153	\r
154	\ ----------------------------------------------------- REFILL\r
155	T{ ' REFILL 0<> }T{ TRUE }T\r
156	\r
157	\ ----------------------------------------------------- RESTORE-INPUT\r
158	T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE\r
159	\r
160	\ ----------------------------------------------------- ROLL\r
161	T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T\r
162	T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T\r
163	T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T\r
164	T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T\r
165	T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T\r
166	\r
167	\ ----------------------------------------------------- SOURCE-ID\r
168	T{ SOURCE-ID 0<> }T{ TRUE }T\r
169	T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T\r
170	\r
171	\ ----------------------------------------------------- SPAN\r
172	T{ ' SPAN 0<> }T{ TRUE }T\r
173	\r
174	\ ----------------------------------------------------- TO VALUE\r
175	333 VALUE MY-VALUE\r
176	T{ MY-VALUE }T{ 333 }T\r
177	T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T\r
178	: TEST.VALUE ( -- 19 100 )\r
179	100 TO MY-VALUE\r
180	19\r
181	MY-VALUE\r
182	;\r
183	T{ TEST.VALUE }T{ 19 100 }T\r
184	\r
185	\ ----------------------------------------------------- TRUE\r
186	T{ TRUE }T{ 0 0= }T\r
187	\r
188	\ ----------------------------------------------------- TUCK\r
189	T{ 44 55 66 TUCK }T{ 44 66 55 66 }T\r
190	\r
191	\ ----------------------------------------------------- U.R\r
192	HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR\r
193	ABCD4321 C U.R CR DECIMAL\r
194	\r
195	\ ----------------------------------------------------- U>\r
196	T{ -5 3 U> }T{ TRUE }T\r
197	T{ 10 8 U> }T{ TRUE }T\r
198	\r
199	\ ----------------------------------------------------- UNUSED\r
200	T{ UNUSED 0> }T{ TRUE }T\r
201	\r
202	\ ----------------------------------------------------- WITHIN\r
203	T{ 4 5 10 WITHIN }T{ 0 }T\r
204	T{ 5 5 10 WITHIN }T{ TRUE }T\r
205	T{ 9 5 10 WITHIN }T{ TRUE }T\r
206	T{ 10 5 10 WITHIN }T{ 0 }T\r
207	\r
208	T{ 4 10 5 WITHIN }T{ TRUE }T\r
209	T{ 5 10 5 WITHIN }T{ 0 }T\r
210	T{ 9 10 5 WITHIN }T{ 0 }T\r
211	T{ 10 10 5 WITHIN }T{ TRUE }T\r
212	\r
213	T{ -6 -5 10 WITHIN }T{ 0 }T\r
214	T{ -5 -5 10 WITHIN }T{ TRUE }T\r
215	T{ 9 -5 10 WITHIN }T{ TRUE }T\r
216	T{ 10 -5 10 WITHIN }T{ 0 }T\r
217	\r
218	\r
219	\ ----------------------------------------------------- [COMPILE]\r
220	: T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE\r
221	: T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;\r
222	T{ T.[COMPILE] }T{ TRUE }T\r
223	\r
224	\ ----------------------------------------------------- \\r
225	}TEST\r
226	\r