Implement ENVIRONMENT?

* fth/misc2.fth (ENVIRONMENT?): New.
(env=, 2env=, max-u, max-n): New helpers.

* fth/t_corex.fth: Add basic tests for ENVIRONMENT?.

diff --git a/fth/misc2.fth b/fth/misc2.fth
index cf20173..53c9197 100644 (file)
--- a/fth/misc2.fth
+++ b/fth/misc2.fth
@@ -233,3 +233,35 @@ VARIABLE SPAN
     addr3 cnt3 flag
 ;
 
     addr3 cnt3 flag
 ;
 

+private{
+
+: env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
+    { x } 2over compare 0= if 2drop x true true else false then
+;
+
+: 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
+    { x y } 2over compare 0= if 2drop x y true true else false then
+;
+
+0 invert constant max-u
+0 invert 1 rshift constant max-n
+
+}private
+
+: ENVIRONMENT? ( c-addr u -- false | i*x true )
+    s" /COUNTED-STRING"      255 env= if exit then
+    s" /HOLD"                128 env= if exit then \ same as PAD
+    s" /PAD"                 128 env= if exit then
+    s" ADDRESS-UNITS-BITS"     8 env= if exit then
+    s" FLOORED"            false env= if exit then
+    s" MAX-CHAR"             255 env= if exit then
+    s" MAX-D"       max-n max-u 2env= if exit then
+    s" MAX-N"              max-n env= if exit then
+    s" MAX-U"              max-u env= if exit then
+    s" MAX-UD"      max-u max-u 2env= if exit then
+    s" RETURN-STACK-CELLS"   512 env= if exit then \ DEFAULT_RETURN_DEPTH
+    s" STACK-CELLS"          512 env= if exit then \ DEFAULT_USER_DEPTH
+    2drop false
+;
+
+privatize

diff --git a/fth/t_corex.fth b/fth/t_corex.fth
index 405b5c1..3784cee 100644 (file)
--- a/fth/t_corex.fth
+++ b/fth/t_corex.fth
@@ -315,5 +315,11 @@ DECIMAL
 \ Check number prefixes in compile mode
 T{ : nmp  #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T
 
 \ Check number prefixes in compile mode
 T{ : nmp  #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T
 

+\  ----------------------------------------------------- ENVIRONMENT?
+
+T{ s" unknown-query-string" ENVIRONMENT? }T{ FALSE }T
+T{ s" MAX-CHAR" ENVIRONMENT? }T{ 255 TRUE }T
+T{ s" ADDRESS-UNITS-BITS" ENVIRONMENT? }T{ 8 TRUE }T
+

 }TEST
 
 }TEST