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