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 75