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