1afc2ba1dSToomas Soome\ ** ficl/softwords/softcore.fr
2afc2ba1dSToomas Soome\ ** FICL soft extensions
3afc2ba1dSToomas Soome\ ** John Sadler (john_sadler@alum.mit.edu)
4afc2ba1dSToomas Soome\ ** September, 1998
5afc2ba1dSToomas Soome
6afc2ba1dSToomas SoomeS" FICL_WANT_USER" ENVIRONMENT? drop [if]
7afc2ba1dSToomas Soome\ ** Ficl USER variables
8afc2ba1dSToomas Soome\ ** See words.c for primitive def'n of USER
9afc2ba1dSToomas Soomevariable nUser  0 nUser !
10afc2ba1dSToomas Soome: user   \ name ( -- )
11afc2ba1dSToomas Soome    nUser dup @ user 1 swap +! ;
12afc2ba1dSToomas Soome
13afc2ba1dSToomas Soome[endif]
14afc2ba1dSToomas Soome
15afc2ba1dSToomas Soome
16afc2ba1dSToomas Soome
17afc2ba1dSToomas SoomeS" FICL_WANT_LOCALS" ENVIRONMENT? drop [if]
18afc2ba1dSToomas Soome
19afc2ba1dSToomas Soome\ ** LOCAL EXT word set
20afc2ba1dSToomas Soome
21afc2ba1dSToomas Soome: locals|  ( name...name | -- )
22afc2ba1dSToomas Soome    begin
23afc2ba1dSToomas Soome        bl word   count
24afc2ba1dSToomas Soome        dup 0= abort" where's the delimiter??"
25afc2ba1dSToomas Soome        over c@
26afc2ba1dSToomas Soome        [char] | - over 1- or
27afc2ba1dSToomas Soome    while
28afc2ba1dSToomas Soome        (local)
29afc2ba1dSToomas Soome    repeat 2drop   0 0 (local)
30afc2ba1dSToomas Soome; immediate
31afc2ba1dSToomas Soome
32afc2ba1dSToomas Soome: local  ( name -- )  bl word count (local) ;  immediate
33afc2ba1dSToomas Soome
34afc2ba1dSToomas Soome: 2local  ( name -- ) bl word count (2local) ; immediate
35afc2ba1dSToomas Soome
36afc2ba1dSToomas Soome: end-locals  ( -- )  0 0 (local) ;  immediate
37afc2ba1dSToomas Soome
38afc2ba1dSToomas Soome
39afc2ba1dSToomas Soome\ Submitted by lch.
40afc2ba1dSToomas Soome: strdup ( c-addr length -- c-addr2 length2 ior )
41afc2ba1dSToomas Soome	0 locals| addr2 length c-addr | end-locals
42afc2ba1dSToomas Soome	length 1 + allocate
43afc2ba1dSToomas Soome	0= if
44afc2ba1dSToomas Soome		to addr2
45afc2ba1dSToomas Soome		c-addr addr2 length move
46afc2ba1dSToomas Soome		addr2 length 0
47afc2ba1dSToomas Soome	else
48afc2ba1dSToomas Soome		0  -1
49afc2ba1dSToomas Soome	endif
50afc2ba1dSToomas Soome	;
51afc2ba1dSToomas Soome
52afc2ba1dSToomas Soome: strcat ( 2:a 2:b -- 2:new-a )
53afc2ba1dSToomas Soome	0 locals|  b-length b-u b-addr a-u a-addr | end-locals
54afc2ba1dSToomas Soome	b-u  to b-length
55afc2ba1dSToomas Soome	b-addr a-addr a-u + b-length  move
56afc2ba1dSToomas Soome	a-addr a-u b-length +
57afc2ba1dSToomas Soome	;
58afc2ba1dSToomas Soome
59afc2ba1dSToomas Soome: strcpy ( 2:a 2:b -- 2:new-a )
60afc2ba1dSToomas Soome	locals| b-u b-addr a-u a-addr | end-locals
61afc2ba1dSToomas Soome	a-addr 0  b-addr b-u  strcat
62afc2ba1dSToomas Soome	;
63afc2ba1dSToomas Soome
64afc2ba1dSToomas Soome[endif]
65afc2ba1dSToomas Soome
66*152e3753SToomas Soome: xemit ( xchar -- )
67*152e3753SToomas Soome	dup $80 u< if emit exit then \ special case ASCII
68*152e3753SToomas Soome	0 swap $3F
69*152e3753SToomas Soome	begin 2dup u> while
70*152e3753SToomas Soome		2/ >r dup $3F and $80 or swap 6 rshift r>
71*152e3753SToomas Soome	repeat $7F xor 2* or
72*152e3753SToomas Soome	begin dup $80 u< 0= while emit repeat drop
73*152e3753SToomas Soome;
74afc2ba1dSToomas Soome\ end-of-file