xref: /freebsd/stand/ficl/softwords/marker.fr (revision 26a58599a09a6181e0f5abe624021865a0c23186)
1*ca987d46SWarner Losh\ ** ficl/softwords/marker.fr
2*ca987d46SWarner Losh\ ** Ficl implementation of CORE EXT MARKER
3*ca987d46SWarner Losh\ John Sadler, 4 Oct 98
4*ca987d46SWarner Losh\ Requires ficl 2.02 FORGET-WID !!
5*ca987d46SWarner Losh\
6*ca987d46SWarner Losh
7*ca987d46SWarner Losh: marker   ( "name" -- )
8*ca987d46SWarner Losh    create
9*ca987d46SWarner Losh    get-current ,
10*ca987d46SWarner Losh    get-order dup ,
11*ca987d46SWarner Losh    0 ?do , loop
12*ca987d46SWarner Losh  does>
13*ca987d46SWarner Losh    0 set-order                     \ clear search order
14*ca987d46SWarner Losh    dup body> >name drop
15*ca987d46SWarner Losh    here - allot                    \ reset HERE to my xt-addr
16*ca987d46SWarner Losh    dup @                           ( pfa current-wid )
17*ca987d46SWarner Losh    dup set-current forget-wid      ( pfa )
18*ca987d46SWarner Losh    cell+ dup @ swap                ( count count-addr )
19*ca987d46SWarner Losh    over cells + swap               ( last-wid-addr count )
20*ca987d46SWarner Losh    0 ?do
21*ca987d46SWarner Losh        dup @ dup                   ( wid-addr wid wid )
22*ca987d46SWarner Losh        >search forget-wid          ( wid-addr )
23*ca987d46SWarner Losh        cell-
24*ca987d46SWarner Losh    loop
25*ca987d46SWarner Losh    drop
26*ca987d46SWarner Losh;
27