usr/src/common/ficl/softcore/ficl.fr

   1 \ ** ficl/softwords/softcore.fr
   2 \ ** FICL soft extensions
   3 \ ** John Sadler (john_sadler@alum.mit.edu)
   4 \ ** September, 1998
   5
   6 S" FICL_WANT_USER" ENVIRONMENT? drop [if]
   7 \ ** Ficl USER variables
   8 \ ** See words.c for primitive def'n of USER
   9 variable nUser  0 nUser !
  10 : user   \ name ( -- )
  11     nUser dup @ user 1 swap +! ;
  12
  13 [endif]
  14
  15
  16
  17 S" 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