version 1.1, 1994/02/11 16:30:46
|
version 1.3, 1994/11/17 15:53:11
|
Line 1
|
Line 1
|
\ ENVIRON.FS Answer environmental queries 20may93jaw |
\ environmental queries |
|
|
\ May be cross-compiled |
\ wordlist constant environment-wordlist |
|
|
decimal |
Create environment-wordlist wordlist drop |
|
|
AVARIABLE EnvLink 0 EnvLink ! |
: environment? ( c-addr u -- false / ... true ) |
|
environment-wordlist search-wordlist if |
|
execute true |
|
else |
|
false |
|
endif ; |
|
|
: (env) |
environment-wordlist set-current |
EnvLink linked |
get-order environment-wordlist swap 1+ set-order |
dup c, here over chars allot swap move align |
|
, ; |
\ assumes that chars, cells and doubles use an integral number of aus |
|
|
: (2env) |
\ this should be computed in C as CHAR_BITS/sizeof(char), |
EnvLink linked |
\ but I don't know any machine with gcc where an au does not have 8 bits. |
dup $80 or |
8 constant ADDRESS-UNIT-BITS |
c, here over chars allot swap move align |
1 ADDRESS-UNIT-BITS chars lshift 1- constant MAX-CHAR |
, , ; |
MAX-CHAR constant /COUNTED-STRING |
|
ADDRESS-UNIT-BITS cells 2* 2 + constant /HOLD |
: env" ( n -- ) |
&84 constant /PAD |
State @ |
true constant CORE |
IF postpone S" postpone (env) |
\ CORE-EXT? |
ELSE [char] " parse (env) THEN ; immediate |
1 -3 mod 0< constant FLOORED |
|
|
: 2env" ( d -- ) |
1 ADDRESS-UNIT-BITS cells 1- lshift 1- constant MAX-N |
State @ |
-1 constant MAX-U |
IF postpone S" postpone (2env) |
|
ELSE [char] " parse (2env) THEN ; immediate |
-1 MAX-N 2constant MAX-D |
|
-1. 2constant MAX-UD |
|
|
: environment? EnvLink |
0 0 2constant gforth \ minor mayor version |
BEGIN @ dup |
|
WHILE dup cell+ count $1f and |
\ !! RETURN-STACK-CELLS |
4 pick 4 pick compare 0= |
\ !! STACK-CELLS |
IF nip nip cell+ count dup -rot |
|
$1f and + aligned |
forth definitions |
swap $80 and IF 2@ ELSE @ THEN |
previous |
EXIT |
|
THEN |
|
REPEAT |
|
drop 2drop false ; |
|
|
|