Artifact 8372abc22b4de4ad56c18e2ab85b44ec3032c5fc:

• File tools.fs — part of check-in [d0bf2a8d6c] at 2019-03-26 21:24:19 on branch trunk — Avatar reload when thumbnails are ditched (user: bernd size: 31330) [more...]

\ net2o tools

\ Copyright (C) 2015   Bernd Paysan

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

require err.fs
require unix/pthread.fs
require unix/mmap.fs
require struct-val.fs
require 64bit.fs
require date.fs
require mini-oof2.fs
require forward.fs
require set-compsem.fs

\ enum

: enum ( n "name" -- n+1 )  dup Constant 1+ ;
: enums ( start n "name1" .. "namen" -- )
    0 ?DO enum LOOP drop ;
: bit ( n "name" -- n*2 )   dup Constant 2* ;
: bits: ( start n "name1" .. "namen" -- )
    0 ?DO bit LOOP drop ;

\ argument handling that works transparent from OS and Forth command line

user-o arg-o

object uclass arg-o
    umethod ?nextarg
    umethod ?@nextarg
    umethod ?peekarg
end-class cmd-args-c

align cmd-args-c , here constant cmd-args^

: cmd-args ( -- )  cmd-args^ arg-o ! ;
cmd-args

:noname ( -- addr u t / f )
    argc @ 1 > IF  next-arg true  ELSE  false  THEN ; to ?nextarg
:noname ( -- addr u t / f )
    argc @ 1 > IF  1 arg true  ELSE  false  THEN ; to ?peekarg
:noname ( -- addr u t / f )
    argc @ 1 > IF
	1 arg drop c@ '@' = IF  next-arg 1 /string true  EXIT  THEN
    THEN  false ; to ?@nextarg

cmd-args-c uclass arg-o
end-class word-args-c

align word-args-c , here constant word-args^

: word-args ( -- )  word-args^ arg-o ! ;

word-args

: parse-name" ( -- addr u )
    >in @ >r parse-name
    over c@ '"' = IF  2drop r@ >in ! '"' parse 2drop \"-parse  THEN  rdrop ;
: ?word-nextarg ( -- addr u t / f )
    parse-name" dup 0= IF  2drop  false  ELSE  true  THEN
; lastxt to ?nextarg
:noname ( -- addr u t / f )  >in @ >r
    parse-name" dup 0= IF  2drop  false  ELSE  true  THEN  r> >in !
; to ?peekarg
:noname ( -- addr u t / f )
    >in @ >r ?word-nextarg 0= IF  rdrop false  EXIT  THEN
    over c@ '@' = IF  rdrop 1 /string true  EXIT  THEN
    r> >in ! 2drop false ; to ?@nextarg

: arg-loop { xt -- }
    begin  ?nextarg  while  xt execute  repeat ;
: arg-loop# ( n xt -- ) { xt -- }
    0 ?DO  ?nextarg 0= ?LEAVE  xt execute  LOOP ;
: @arg-loop { xt -- }
    begin  ?@nextarg  while  xt execute  repeat ;

\ string

: smove ( a-from u-from a-to u-to -- )
    rot 2dup u< IF
	drop move -9 throw
    ELSE
	nip move
    THEN ;

[IFUNDEF] safe/string
: safe/string ( c-addr u n -- c-addr' u' )
\G protect /string against overflows.
    dup negate >r  dup 0> IF
        /string dup r> u>= IF  + 0  THEN
    ELSE
        /string dup r> u< IF  + 1+ -1  THEN
    THEN ;
[THEN]

[IFUNDEF] string-suffix?
    : string-suffix? ( addr1 u1 addr2 u2 -- flag )
	\G return true if addr2 u2 is a suffix of addr1 u1
	tuck 2>r over swap - 0 max /string 2r> str= ;
[THEN]

: -skip ( addr u char -- ) >r
    BEGIN  1- dup  0>= WHILE  2dup + c@ r@ <>  UNTIL  THEN  1+ rdrop ;
[IFUNDEF] -scan
    : -scan ( addr u char -- addr u' ) >r
	BEGIN  dup  WHILE  1- 2dup + c@ r@ =  UNTIL  1+  THEN  rdrop ;
[THEN]

[IFUNDEF] basename
: basename ( addr u -- addr' u' )
    2dup '/' -scan nip /string ;
[THEN]

: str0? ( addr u -- flag )
    \ check if string is all zero
    0 scan nip 0= ;

\ set debugging

debug: dummy(

: +-?( ( addr u -- flag )
    2dup +-? IF [: 1 /string type '(' emit ;] $tmp find-name dup
	IF  >does-code ['] dummy( >does-code =  THEN
    ELSE  2drop false  THEN ;

[IFUNDEF] set-debug
    : set-debug ( addr u -- )
	debug-eval $!
	s" db " debug-eval 1 $ins
	s" (" debug-eval $+!
	debug-eval $@ evaluate ;
[THEN]

: ++debug ( -- )
    BEGIN  ?peekarg  WHILE  +-?(  WHILE  ?nextarg drop set-debug  REPEAT  THEN ;

\ logic memory modifiers

: or!   ( x addr -- )    >r r@ @ or   r> ! ;
: xor!  ( x addr -- )    >r r@ @ xor  r> ! ;
: and!  ( x addr -- )    >r r@ @ and  r> ! ;

: xorc! ( x c-addr -- )  >r r@ c@ xor r> c! ;
: andc! ( x c-addr -- )  >r r@ c@ and r> c! ;
: orc!  ( x c-addr -- )  >r r@ c@ or  r> c! ;

: max!@ ( n addr -- )    >r r@ @ max  r> !@ ;
: umax!@ ( n addr -- )   >r r@ @ umax r> !@ ;

\ user stack, automatic init+dispose

: ustack ( "name" -- )
    \G generate user stack, including initialization and free on thread
    \G start and termination
    User  latestxt >r
    :noname  action-of thread-init compile,
    r@ compile, postpone off postpone ;
    is thread-init
    :noname  r> compile, postpone $off  action-of kill-task  compile,
    postpone ;
    is kill-task ;

[IFUNDEF] NOPE
    : NOPE ( c:sys -- )
	\G removes a control structure sys from the stack
	drop 2drop ; immediate restrict
[THEN]

require bits.fs

\ variable length integers, similar to protobuf, but MSB first

: p@+ ( addr -- u64 addr' )  >r 64#0 r@ 10 bounds
    DO  7 64lshift I c@ $7F and n>64 64or
	I c@ $80 and 0= IF  I 1+ UNLOOP rdrop  EXIT  THEN
    LOOP  r> 10 + ;
[IFDEF] 64bit
    : p-size ( u64 -- n ) \ to speed up: binary tree comparison
	\ flag IF  1  ELSE  2  THEN  equals  flag 2 +
	dup    $FFFFFFFFFFFFFF u<= IF
	    dup       $FFFFFFF u<= IF
		dup      $3FFF u<= IF
		    $00000007F u<= 2 +  EXIT  THEN
		$00000001FFFFF u<= 4 +  EXIT  THEN
	    dup   $3FFFFFFFFFF u<= IF
		$00007FFFFFFFF u<= 6 +  EXIT  THEN
	    $00001FFFFFFFFFFFF u<= 8 +  EXIT  THEN
	$000007FFFFFFFFFFFFFFF u<= 10 + ;
    : p!+ ( u64 addr -- addr' )  over p-size + dup >r >r
	dup $7F and r> 1- dup >r c!  7 rshift
	BEGIN  dup  WHILE  dup $7F and $80 or r> 1- dup >r c! 7 rshift  REPEAT
	drop rdrop r> ;
[ELSE]
    : p-size ( x64 -- n ) \ to speed up: binary tree comparison
	\ flag IF  1  ELSE  2  THEN  equals  flag 2 +
	2dup   $FFFFFFFFFFFFFF. du<= IF
	    2dup      $FFFFFFF. du<= IF
		2dup     $3FFF. du<= IF
		    $00000007F. du<= 2 +  EXIT  THEN
		$00000001FFFFF. du<= 4 +  EXIT  THEN
	    2dup  $3FFFFFFFFFF. du<= IF
		$00007FFFFFFFF. du<= 6 +  EXIT  THEN
	    $00001FFFFFFFFFFFF. du<= 8 +  EXIT  THEN
	$000007FFFFFFFFFFFFFFF. du<= 10 + ;
    : p!+ ( u64 addr -- addr' )  >r 2dup p-size r> + dup >r >r
	over $7F and r> 1- dup >r c!  7 64rshift
	BEGIN  2dup or  WHILE  over $7F and $80 or r> 1- dup >r c! 7 64rshift  REPEAT
	2drop rdrop r> ;
[THEN]

: zz>n ( 64zz -- 64n )
    64dup 1 64rshift 64swap 64>n 1 and negate n>64 64xor ;
: n>zz ( 64n -- 64zz )
    64dup 64-0< n>64 64swap 64-2* 64xor ;

: ps!+ ( 64n addr -- addr' )
    >r n>zz r> p!+ ;
: ps@+ ( addr -- 64n addr' )
    p@+ >r zz>n r> ;

\ bit reversing

: bitreverse8 ( u1 -- u2 )
    0 8 0 DO  2* over 1 and + swap 2/ swap  LOOP  nip ;

Create reverse-table $100 0 [DO] [I] bitreverse8 c, [LOOP]

: reverse8 ( c1 -- c2 ) reverse-table + c@ ;
: reverse ( x1 -- x2 )
    0 cell 0 DO  8 lshift over $FF and reverse8 or
       swap 8 rshift swap  LOOP  nip ;
: reverse$16 ( addrsrc addrdst -- ) { dst } dup >r
    count reverse8 r@ $F + c@ reverse8 dst     c! dst $F + c!
    count reverse8 r@ $E + c@ reverse8 dst 1+  c! dst $E + c!
    count reverse8 r@ $D + c@ reverse8 dst 2 + c! dst $D + c!
    count reverse8 r@ $C + c@ reverse8 dst 3 + c! dst $C + c!
    count reverse8 r@ $B + c@ reverse8 dst 4 + c! dst $B + c!
    count reverse8 r@ $A + c@ reverse8 dst 5 + c! dst $A + c!
    count reverse8 r@ $9 + c@ reverse8 dst 6 + c! dst $9 + c!
    c@    reverse8 r> $8 + c@ reverse8 dst 7 + c! dst $8 + c! ;

\ scoping

Variable scope<>
: scope{ ( "vocabulary" -- scope:addr )
    get-current scope<> >stack also ' execute definitions ;
: }scope ( scope:addr -- )
    previous scope<> stack> set-current ;
: scope: ( "vocabulary" -- scope:addr )
    vocabulary get-current scope<> >stack also lastxt execute definitions ;
: cs-scope: ( "vocabulary" -- scope:addr )
    cs-vocabulary get-current scope<> >stack also lastxt execute definitions ;

: class{ ( parent "scope" -- methods vars )
    class cs-scope: ;
: }class ( methods vars -- )
    context @ }scope
    [: body> name>string type ." -class" ;] $tmp nextname
    end-class ;

: struct{ ( "scope" -- vars )
    >in @ >r
    parse-name [: type ." -struct" ;] $tmp nextname
    begin-structure  r> >in !  cs-scope: ;
: }struct ( vars -- )
    }scope end-structure ;

: with ( "vocabulary" -- )
    also ' execute postpone >o ; immediate restrict
: endwith ( -- )
    postpone o> previous ; immediate restrict

Vocabulary net2o

\ file name sanitizer

: printable? ( addr u -- flag )
    true -rot bounds ?DO  I c@ $80 u>= IF
	    I ['] u8@+ catch IF  drop 0 true
	    ELSE  drop dup I - swap I' u>  THEN
	ELSE  1 I c@ $7F bl within  THEN
	IF  2drop false  LEAVE  THEN  +LOOP ;

: ?sane-file ( addr u -- addr u )
    \G check if file name is sane, and if not, fail
    dup 1- $FFF u>= !!filename!!             \ check nullstring+maxpath
    2dup printable? 0= !!filename!!          \ must be printable
    [IFDEF] cygwin                           \ rules for Windows
	2dup '\' scan nip 0<>   !!filename!! \ no backslash allowed
	2dup ':' scan nip 0<>   !!filename!! \ no colon allowed
    [THEN]
    s" /../"     search         !!filename!! \ no embedded .. allowed
    s" /./"      search         !!filename!! \ no embedded . allowed
    s" //"       search         !!filename!! \ no double slash allowed
    2dup s" ../" string-prefix? !!filename!! \ no parent directory allowed
    2dup s" ./"  string-prefix? !!filename!! \ no same directory allowed
    over c@ '/' =               !!filename!! \ no absolute filename allowed
    2dup '/' scan nip IF
	over c@ '~' =           !!filename!! \ no tilde allowed if it's a path
    THEN ;

$20 buffer: filechars
filechars $20 $FF fill
0 filechars l! \ ctrl chars are all illegal
filechars '/' -bit
filechars #del -bit
: no-fat-chars ( addr u -- ) "\\:?*\q<>|%" ;
no-fat-chars bounds [?DO] filechars [I] c@ -bit [LOOP]

\ '%' is allowed, but we use '%' to replace the others

: .## ( n -- ) s>d <# # # #> type ;
: sane-type ( addr u -- )
    [: bounds ?DO
	  I c@ filechars over bit@
	  IF  emit  ELSE  '%' emit .##  THEN
      LOOP ;] $10 base-execute ;

: fn-sanitize ( addr u -- addr' u' )
    ['] sane-type $tmp ;

false Value chat-sanitize?
false Value hash-sanitize?

: chat-sanitize ( addr u -- addr' u' )
    chat-sanitize? IF  fn-sanitize  THEN ;
: hash-sanitize ( addr u -- addr' u' )
    hash-sanitize? IF  fn-sanitize  THEN ;

\ utf8 sanitizer

: utf8-sanitize ( addr u -- )
    bounds ?DO
	I ['] xc@+ catch IF
	    '�' xemit
	    drop  I I' over -
	    ['] x-size catch IF  2drop  1  THEN
	ELSE  xemit I -  THEN
    +LOOP  nothrow ;

\ config stuff

require config.fs

\ net2o specific configurations

[IFUNDEF] no-file#
    2 Constant ENOENT
    #-512 ENOENT - Constant no-file#
[THEN]
[IFUNDEF] file-exist#
    17 Constant EEXIST
    #-512 EEXIST - Constant file-exist#
[THEN]

: init-dir ( addr u mode -- flag ) >r
    \G create a directory with access mode,
    \G return true if the dictionary is new, false if it already existed
    2dup file-status nip no-file# = IF
	r> mkdir-parents throw  true
    ELSE  2drop rdrop  false  THEN ;

\ dirstack

$10 stack: dirstack

: >dir ( -- )
    s" " $make { w^ dir }
    $4000 dir $!len dir $@ get-dir dir $!len drop
    dir @ dirstack >stack ;
: dir> ( -- )
    dirstack $@len 0= ?EXIT
    dirstack stack> { w^ dir }
    dir $@ set-dir throw  dir $free ;
: dir@ ( -- addr u )
    dirstack $[]# 1- dirstack $[]@ ;

scope{ config

Variable timeouts#
Variable passmode#
Variable logsize#
2Variable savedelta&
2Variable patchlimit&
Variable rootdirs$
Variable prio#
Variable host$		\g set host to this name
Variable port#          \g if not zero, use this port
Variable orighost$	\g if the host is orighost$
Variable date#
$Variable objects$
$Variable chats$
$Variable keys$
$Variable .net2o$
$Variable .net2o-config$
$Variable .net2o-cache$
$Variable invite$

}scope

also config

: .net2o/ ( addr u -- addr' u' ) [: .net2o$ $. '/' emit type ;] $tmp ;
: subdir-config ( -- )
    "keys"    .net2o/ keys$ $!
    "chats"   .net2o/ chats$ $!
    "objects" .net2o/ objects$ $! ;
: $set ( xt addr -- ) dup $free $exec ;
: xdg-config ( env u addr -- ) >r
    getenv 2dup d0= IF  rdrop 2drop  EXIT  THEN
    [: type ." /net2o" ;] r> $set ;
: xdg-dir-config ( -- )
    "XDG_DATA_HOME"   .net2o$        xdg-config
    "XDG_CONFIG_HOME" .net2o-config$ xdg-config
    "XDG_CACHE_HOME"  .net2o-cache$  xdg-config ;
: default-dir-config ( -- )
    "~/.local/share/net2o" .net2o$ $!
    "~/.config/net2o"      .net2o-config$ $!
    "~/.cache/net2o"       .net2o-cache$ $!
    xdg-dir-config
    subdir-config ;
default-dir-config

#2 date# !
#20 logsize# !
pad $400 get-dir rootdirs$ $!
"Hello!" invite$ $!
[defined] android 1 and passmode# ! \ default is all entry is masked out
#14 timeouts# !

$1000.0000. patchlimit& 2! \ 256MB patch limit size
#10.000.000.000. savedelta& 2! \ 10 seconds deltat

: .net2o-config/ ( addr u -- addr' u' ) [: .net2o-config$ $. '/' emit type ;] $tmp ;
: .net2o-cache/ ( addr u -- addr' u' ) [: .net2o-cache$ $. '/' emit type ;] $tmp ;
: ~net2o-cache/ ( addr u -- )
    .net2o-cache/ 2dup $1FF init-dir drop set-dir throw ;
: ~net2o-cache/.. ( addr u -- )
    .net2o-cache/ 2dup $1FF init-dir drop dirname set-dir throw ;
: .keys/  ( addr u -- addr' u' ) [: keys$   $. '/' emit type ;] $tmp ;
: objects/.no-fat-file ( -- addr u )
    [: objects$  $. ." /." no-fat-chars type ;] $tmp ;
: chats/.no-fat-file ( -- addr u )
    [: chats$  $. ." /." no-fat-chars type ;] $tmp ;

: ?.net2o ( -- )
    .net2o$ $@ $1FF init-dir drop
    .net2o-config$ $@ $1FF init-dir drop
    .net2o-cache$ $@ $1FF init-dir drop ;
: ?.net2o/keys ( -- flag ) ?.net2o keys$ $@ $1C0 init-dir ;
: ?.net2o/chats ( -- ) ?.net2o chats$ $@ $1FF init-dir drop ;
: ?.net2o/objects ( -- ) ?.net2o objects$ $@ $1FF init-dir drop ;

: ?create-file ( addr u -- flag )
    2dup file-status IF  drop
	r/w create-file  IF  drop false  ELSE  close-file throw  true  THEN
    ELSE  drop 2drop true  THEN ;

: fsane-init ( -- )
    false to hash-sanitize?  false to chat-sanitize?
    ?.net2o/objects objects/.no-fat-file ?create-file
    0= to hash-sanitize?
    ?.net2o/chats   chats/.no-fat-file   ?create-file
    0= to chat-sanitize? ;

$Variable config-file$  "~/.config/net2o/config" config-file$ $!
Variable configured?

:noname defers 'cold
    configured? off
    pad $400 get-dir rootdirs$ $!
; is 'cold
:noname ( -- )
    config:host$ $off
    config:rootdirs$ $off
    defers 'image ; is 'image

: rootdirs>path ( -- )
    config:rootdirs$ $@ bounds ?DO  I c@ ':' = IF 0 I c! THEN LOOP ;

forward default-host

: ?old-config ( addr u wid -- )
    \G check if we have an old config; then keep it.
    "~/.net2o/config" file-status nip no-file# <> IF
	"~/.net2o" 2dup .net2o$ $! .net2o-config$ $!
	subdir-config
	nip nip "~/.net2o/config" rot
	read-config default-host
    ELSE
	?.net2o default-host write-config
    THEN ;

: ?.net2o-config ( -- )  true configured? !@ ?EXIT
    "NET2O_CONF"  getenv ?dup-IF  config-file$ $!  ELSE  drop  THEN
    config-file$ $@ 2dup file-status nip ['] config >body swap
    no-file# = IF  ?old-config  ELSE  read-config default-host  THEN
    rootdirs>path ;

: init-dirs ( -- ) ?.net2o-config fsane-init ;

previous

\ print time

64Variable tick-adjust
: ticks ( -- u64 )  ntime d>64 tick-adjust 64@ 64+ ;

: ticks-u ( -- u )  ticks 64>n ;

1970 1 1 ymd2day Constant unix-day0

: fsplit ( r -- r n )  fdup floor fdup f>s f- ;

: date? ( -- n )  config:date# @ ;
: datehms? ( -- n )  config:date# @ 7 and ;
$8 Constant #today
$10 Constant #splitdate
$20 Constant #splithour
$40 Constant #splitminute
-1 Value last-day
-1 Value last-hour
-1 Value last-minute

: reset-time ( -- )
    -1 to last-day  -1 to last-hour  -1 to last-minute ;
: today? ( day -- flag )
    ticks 64>f 1e-9 f* 86400 fm/ floor f>s = ;

: .ns ( r -- )  1e-9 f*
    fdup 1e-6 f< IF  1e9 f* 10 0 0 f.rdp ." ns"  EXIT  THEN
    fdup 1e-3 f< IF  1e6 f* 10 3 0 f.rdp ." µs"  EXIT  THEN
    fdup 1e   f< IF  1e3 f* 10 6 0 f.rdp ." ms"  EXIT  THEN
    10 6 0 f.rdp 's' emit ;

: >day ( seconds -- fraction day )
    86400 fm/ fsplit ;
: .day ( day -- )
    unix-day0 + day2ymd
    rot 0 .r '-' emit swap .## '-' emit .## 'T' emit ;
: .timeofday ( fraction/day -- )
    24 fm* fsplit
    date? #splithour and IF
	dup last-hour <> IF  ." ==== " dup .## ." Z ====" cr  THEN  to last-hour
    ELSE  .##  THEN
    datehms? 2 < IF  fdrop  ELSE  60 fm* fsplit
    date? #splitminute and IF
	dup last-minute <> IF  ." === :" dup .## ." m ===" cr  THEN  to last-minute
	ELSE  ':' emit .##  THEN
	datehms? 3 < IF  fdrop  ELSE  ':' emit
	    60 fm* datehms? 4 < IF  f>s .##
	    ELSE  fdup 10e f< IF '0' emit 2  ELSE  3  THEN
		datehms? 1+ 7 min 3 and 3 * dup >r + r@ r> f.rdp  THEN
	THEN  THEN  date? #splithour and 0= IF  'Z' emit  THEN ;
: .deg ( degree -- )
    fdup f0< IF ." -" fnegate THEN
    fsplit 0 .r  $B0 ( '°' ) xemit  60 fm*
    fsplit .##   ''' xemit  60 fm*
    fsplit .##   '.' xemit 100 fm*
    f>s .##      '"' xemit ;
: .never ( -- )
    datehms? 1 > IF ." never" ELSE 'n' emit THEN ;
: .forever ( -- )
    datehms? 1 > IF ." forever" ELSE 'f' emit THEN ;

: f.ticks ( rticks -- )
    1e-9 f* >day
    dup today? date? #today and 0= and
    IF
	drop .timeofday
    ELSE
	date? #splitdate and IF
	    dup last-day <> IF
		." ===== " dup .day ."  =====" cr
	    THEN  to last-day
	ELSE  .day  THEN
	datehms? IF .timeofday ELSE fdrop THEN
    THEN ;

: .ticks ( ticks -- )  date? 0= IF  64drop  EXIT  THEN
    64dup 64-0= IF  .never 64drop EXIT  THEN
    64dup -1 n>64 64= IF  .forever 64drop EXIT  THEN
    64>f f.ticks ;

\ insert into sorted string array, discarding n bytes at the end

: $ins[]# ( addr u $array[] rest -- pos )
    \G insert O(log(n)) into pre-sorted array
    \G @var{pos} is the insertion offset or -1 if not inserted
    \G @var{rest} is the rest of the array chopped off for comparison
    { a[] rest } 0 a[] $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup rest - $# a[] $[]@ rest - compare dup 0= IF
		drop $# a[] $[]@ smove \ overwrite in place
		$# EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    { | w^ ins$0 } ins$0 cell a[] r@ cells $ins r@ a[] $[]! r> ;
: $del[]# ( addr u $array[] rest -- )
    \G delete O(log(n)) from pre-sorted array
    { a[] rest } 0 a[] $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup rest - $# a[] $[]@ rest - compare dup 0= IF
		drop $# a[] $[] $off
		a[] $# cells cell $del
		2drop EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT 2drop 2drop ; \ not found

\ insert into sorted string array, discarding n bytes at the start

: $ins[]/ ( addr u $array n -- pos )
    \G insert O(log(n)) into pre-sorted array
    \G @var{pos} is the insertion offset or -1 if not inserted
    { a[] rest } 0 a[] $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup rest safe/string $# a[] $[]@ rest safe/string compare dup 0= IF
		drop $# a[] $[]@ smove \ overwrite in place
		$# EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    { | w^ ins$0 } ins$0 cell a[] r@ cells $ins r@ a[] $[]! r> ;
: $del[]/ ( addr u $array offset -- )
    \G delete O(log(n)) from pre-sorted array
    { a[] rest } 0 a[] $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup rest safe/string $# a[] $[]@ rest safe/string compare dup 0= IF
		drop $# a[] $[] $off
		a[] $# cells cell $del
		2drop EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT 2drop 2drop ; \ not found

\ insert into sorted string array

: $ins[] ( addr u $array -- pos ) 0 $ins[]# ;
    \G insert O(log(n)) into pre-sorted array
    \G @var{pos} is the insertion offset or -1 if not inserted
: $del[] ( addr u $array -- ) 0 $del[]# ;
    \G delete O(log(n)) from pre-sorted array

\ same with signatures; newest signature replaces older

$41 Constant sigonlysize#
$51 Constant sigsize#
$71 Constant sigpksize#
$91 Constant sigpk2size#
$10 Constant datesize#

: startdate@ ( addr u -- date ) + sigsize# - le-64@ ;
: enddate@ ( addr u -- date ) + sigsize# - 64'+ le-64@ ;
: sigonly@ ( addr u -- addr' u' ) + sigonlysize# - [ sigonlysize# 1- ]L ;
: sigdate@ ( addr u -- addr' u' ) + sigsize# - [ sigsize# 1- ]L ;

: $ins[]sig# ( addr u $array n -- pos )
    \G insert O(log(n)) into pre-sorted array if sigdate is newer
    \G @var{pos} is the insertion offset or -1 if not inserted
    { a[] rest } 0 a[] $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup rest - $# a[] $[]@ rest - compare dup 0= IF
		drop
		2dup rest - + le-64@
		$# a[] $[]@ rest - + le-64@ 64u>=
		IF   $# a[] $[]@ smove  $# \ overwrite in place
		ELSE  2drop  -1  THEN EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    { | w^ ins$0 } ins$0 cell a[] r@ cells $ins r@ a[] $[]! r> ;

: $ins[]sig ( addr u $array -- pos ) sigsize# $ins[]sig# ;
    \G @var{pos} is the insertion offset or -1 if not inserted
: $del[]sig ( addr u $array -- ) sigsize# $del[]# ;
: $rep[]sig ( addr u $array -- ) >r
    \G replace if newer in one-element array
    r@ $[]# IF
	2dup startdate@ 0 r@ $[]@ startdate@ 64u<
	IF  2drop rdrop  EXIT  THEN
    THEN
    0 r> $[]! ;

\ list sorted by sig date

: $ins[]date ( addr u $array -- pos )
    \G insert O(log(n)) into pre-sorted array
    \G @var{pos} is the insertion offset or -1 if not inserted
    { a[] } 0 a[] $[]#
    BEGIN  2dup u<  WHILE  2dup + 2/ { left right $# }
	    2dup startdate@ $# a[] $[]@ startdate@ 64over 64over 64= IF
		64drop 64drop
		2dup $# a[] $[]@ compare dup 0= IF
		    drop 2drop  $# invert  EXIT  THEN
		0<  ELSE  64u<  THEN
	    IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    { | w^ ins$0 } ins$0 cell a[] r@ cells $ins r@ a[] $[]!  r> ;
: $search[]date ( ticks $array -- pos )
    \G search O(log(n)) in pre-sorted array
    \G @var{pos} is the first location of the item >= the requested date
    { a[] } 0 a[] $[]#
    BEGIN  2dup u<  WHILE  2dup + 2/ { left right $# }
	    64dup $# a[] $[]@ startdate@ 64over 64over 64= IF
		64drop 64drop
		0 $# 1- -DO
		    64dup I a[] $[]@ startdate@ 64<> ?LEAVE
		    I to $#
		1 -LOOP
		64drop $#  EXIT  THEN
	    64u< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r r@ a[] $[]@ ?dup-IF
	startdate@ 64u> negate r> +
    ELSE  drop 64drop r>  THEN ;

\ filter entries out of a string array

: $[]filter { addr xt -- }
    \G execute @var{xt} for all elements of the string array @var{addr}.
    \G xt is @var{( addr u -- flag )}, getting one string at a time,
    \G if flag is false, delete the corresponding string.
    0 { idx }  BEGIN  idx addr $[]# <  WHILE
	    idx addr $[]@ xt execute IF
		idx 1+ to idx
	    ELSE
		idx addr $[] $off
		addr idx cells cell $del
	    THEN
    REPEAT ;

: $[]map? { addr xt -- }
    \G execute @var{xt} for all elements of the string array @var{addr}.
    \G xt is @var{( addr u -- flag )}, getting one string at a time
    addr $[]# 0 ?DO  I addr $[]@ xt execute ?LEAVE  LOOP ;

\ colors

: <default> default-color attr! ;
: <warn>    warning-color attr! ;
: <info>    info-color    attr! ;
: <err>     error-color   attr! ;
: <success> success-color attr! ;
: <black>   [ black >fg black >bg or ]l attr! ;
: <white>   [ white >fg white >bg or bold or ]l attr! ;

\ Memory words

\ the policy on allocation and freeing is that both freshly allocated
\ and to-be-freed memory is erased.  This makes sure that no unwanted
\ data will be lurking in that memory, waiting to be leaked out

: alloz ( size -- addr )
    dup >r allocate throw dup r> erase ;
: freez ( addr size -- )
    \G erase and then free - for secret stuff
    over swap erase free throw ;
: ?free ( addr size -- ) >r
    dup @ IF  dup @ r@ freez off  ELSE  drop  THEN  rdrop ;

: allo1 ( size -- addr )
    dup >r allocate throw dup r> $FF fill ;
: allocate-bits ( size -- addr )
    dup >r cell+ allo1 dup r> + off ; \ last cell is off

: ?free+guard ( addr u -- )
    over @ IF  over @ swap 2dup erase  free+guard  off
    ELSE  2drop  THEN ;

\ file stuff

: ?fd ( fd addr u -- fd' ) { addr u } dup ?EXIT drop
    ?.net2o
    addr u r/w open-file dup no-file# = IF
	2drop addr u r/w create-file
    THEN  throw ;

: write@pos-file ( addr u 64pos fd -- ) >r
    64>d r@ reposition-file throw
    r@ write-file throw r> flush-file throw ;

: append-file ( addr u fd -- 64pos ) >r
    r@ file-size throw d>64 64dup { 64: pos } r> write@pos-file pos ;

: touch ( addr u -- )
    w/o create-file throw close-file throw ;

\ copy files

: throw?exists ( throwcode -- )  dup no-file# <> and throw ;

$1F to tmps# \ need more temporaries

Variable tmp-file$
: $tmp-file ( addr u -- addr' u' )
    [: type '+' emit getpid 0 .r ;] tmp-file$ $set
    tmp-file$ $@ ;

: >backup ( addr u -- )
    2dup 2dup [: type '~' emit ;] $tmp rename-file >r
    tmp-file$ $@ 2swap rename-file
    r> throw?exists throw?exists ;

: >new ( addr u -- fd )
    $tmp-file r/w create-file throw ;

: >copy ( addr u -- fd )
    2dup >new { fd1 }
    r/o open-file dup no-file# = IF
	2drop
    ELSE
	throw 0 { fd0 w^ cpy }
	#0. fd0 reposition-file throw
	fd0 cpy $slurp fd0 close-file throw
	cpy $@ fd1 write-file throw cpy $off
	fd1 flush-file throw
    THEN  fd1 ;

: save-file ( addr u xt -- )
    \G save file @var{addr u} by making a copy first,
    \G applying xt ( fd -- ) on that copy, and then
    \G moving the existing file to backup ("~" appended to filename)
    \G and the copy ("+" appended to filename) to the original name.
    >r 2dup >copy r> over >r execute r> close-file throw >backup ;

: new-file ( addr u xt -- )
    \G save file @var{addr u} by making an empty first,
    \G applying xt ( fd -- ) on that file, and then
    \G moving the existing file to backup ("~" appended to filename)
    \G and the new ("+" appended to filename) to the original name.
    >r 2dup >new r> over >r execute r> close-file throw >backup ;

\ help display

: search-help ( pattern xt file-addr u -- )
    open-fpath-file throw
    [: >r BEGIN  refill  WHILE
	      source 2over string-prefix? IF  r@ execute  THEN
      REPEAT rdrop 2drop ;] execute-parsing-named-file ;
compsem: sourcefilename postpone sliteral ['] search-help compile, ;

: .cmd ( addr u -- addr u )
    source 2over nip /string type cr ;

\ single quoted string with escapes of single quote for shell invocation

: 'type' ( addr u -- ) ''' emit
    bounds ?DO  I c@ ''' = IF  .\" '\"'\"'"  ELSE  I c@ emit  THEN  LOOP
    ''' emit ;

\ insert and remove single cell items

: del$one ( addr1 addr2 size -- pos )
    \G @var{pos} is the deletion offset
    >r over @ cell+ - tuck r> $del ;
: next$ ( pos string -- addre addrs )
    $@ rot /string bounds ;
: del$cell ( addr stringaddr -- ) { string }
    string $@ bounds ?DO
	dup I @ = IF
	    string I cell del$one
	    unloop string next$ ?DO NOPE 0
	ELSE  cell  THEN
    +LOOP drop ;

\ unique list of cells

Sema resize-sema

: unique$cell? ( x addr -- flag )
    $@ bounds ?DO  dup I @ = IF  drop false unloop  EXIT  THEN
    cell +LOOP  drop true ;

: +unique$ ( x addr -- )
    [: 2dup unique$cell? IF
	  >r { w^ x } x cell r> $+!
      ELSE  2drop  THEN ;] resize-sema c-section ;

\ xchar tool

: *-width ( addr u -- n )
    0 -rot bounds ?DO  I c@ $C0 $80 within -  LOOP ;

e? max-xchar $100 u< [IF]
    : utf8emit ( xchar -- )
	 '?' over $100 u< select emit ;
    : >utf8$ ( addr u -- addr' u' )
	[: bounds ?DO  I c@ u8emit  LOOP ;] $tmp ;
    : $utf8> ( addr u -- addr' u' )
	[: bounds ?DO  I u8@+ utf8emit
	  I - +LOOP ;] $tmp ;
[ELSE]
    ' xemit alias utf8emit
    ' noop alias >utf8$ immediate
    ' noop alias $utf8> immediate
[THEN]

\ accept* derivative

e? max-xchar $100 < [IF] '*' [ELSE] ( '●' ) '•' [THEN] Value pw*

Variable *insflag

: *type ( addr u -- )
    config:passmode# @ dup 0< IF  drop 2drop  EXIT  THEN
    2 = IF  type  EXIT  THEN
    *-width 0 ?DO  pw* xemit  LOOP ;
: *type1 ( addr u -- )  config:passmode# @ 0<= IF  *type  ELSE  type  THEN ;
: *type2 ( addr u -- )  config:passmode# @ 1 <> IF  *type  EXIT  THEN
    dup IF  2dup over + xchar- over - dup >r 2swap r> /string 2swap
    ELSE  0 0 2swap  THEN
    *-width 0 ?DO  pw* xemit  LOOP
    dup IF  type  ELSE  2drop  THEN ;
: *-width0 ( addr u -- w )
    config:passmode# @ dup 0< IF  drop 2drop 0  EXIT  THEN
    0= IF  *-width  ELSE  x-width  THEN ;
: *-width1 ( addr u -- w )
    config:passmode# @ dup 0< IF  drop 2drop 0  EXIT  THEN
    2 = IF  x-width  ELSE  *-width  THEN ;
: *-width2 ( addr u -- w )
    case  config:passmode# @
	2 of  x-width  endof
	1 of
	    dup IF  2dup over + xchar- over - dup >r 2swap r> /string
		x-width >r *-width r> +  ELSE  nip  THEN  endof
	0 of  *-width  endof
	-1 of  2drop 0  endof
	drop swap
    endcase ;
: .*resizeline ( span addr pos -- span addr pos )
    2dup *insflag @ IF  *-width2  ELSE  *-width1  THEN >r
    setstring$ $@ *-width0 >r
    >edit-rest *-width1 r> r> + +
    dup >r edit-linew @ u< IF
	xedit-startpos  edit-linew @ spaces  edit-linew @ edit-curpos !
    THEN
    r> edit-linew ! ;
: .*all ( span addr pos -- span addr pos )
    xedit-startpos  2dup *insflag @ IF  *type2  ELSE  *type  THEN
    setstring$ $@
    dup IF  ['] *type1 setstring-color color-execute  ELSE  2drop  THEN
    >edit-rest *type  edit-linew @ edit-curpos !  ;
: .*rest ( span addr pos -- span addr pos )
    xedit-startpos
    2dup *insflag @ IF  *-width2  ELSE  *-width1  THEN  edit-curpos !
    2dup *insflag @ IF  *type2  ELSE  *type  THEN ;
: *edit-update ( -- )
    .*resizeline .*all .*rest ;
: (*xins)  *insflag on (xins) ;
: *kill-prefix  *insflag off kill-prefix ;

edit-terminal-c uclass edit-out
end-class *edit-terminal-c

*edit-terminal-c ' new static-a with-allocater Constant *edit-terminal

*edit-terminal edit-out !

' (*xins) is insert-char
' *kill-prefix is everychar
' *edit-update  is edit-update

edit-terminal edit-out !

: accept* ( addr u -- u' )
    \G accept-like input, but types * instead of the character
    \G don't save into history
    get-order n>r history >r  edit-out @ >r  *edit-terminal edit-out !
    0 to history  0 set-order
    ['] accept catch
    r> edit-out !  r> to history  nr> set-order
    throw space ;

\ catch loop

: ?int ( throw-code -- throw-code )  dup -28 = IF  bye  THEN ;

: .loop-err ( throw xt -- )
    .name dup . cr DoError cr ;

: catch-loop { xt -- flag }
    BEGIN   xt catch dup -1 = ?EXIT
	?int dup  WHILE  xt .loop-err  REPEAT
    drop false ;

[IFDEF] EAGAIN
    : ?ior-again ( n -- )
	errno EAGAIN <> and ?ior ;
[THEN]

\ !wrapper: generic wrapper to store a value in a variable
\ and restore it after catching the xt

: !wrapper ( val addr xt -- .. ) { addr xt -- .. }
    addr !@ >r xt catch r> addr ! throw ;

\ evaluate in

: evaluate-in ( addr u voc-addr -- )
    get-order n>r >body 1 set-order ['] evaluate catch
    nr> set-order throw ;

\ blocking event, also available in most recent Gforth

[IFUNDEF] event|
    event: :>restart ( task -- ) restart ;
    
    : event| ( task -- )
	\G send an event and block
	dup up@ = IF \ don't block, just eval if we send to ourselves
	    event> ?events
	ELSE
	    up@ elit, :>restart event> stop
	THEN ;
[THEN]