needs mem/scratch
unit lib/func

$400 const LDAALLOTED
$100 const LDASZ
LDAALLOTED newscratchpad bindalloc[ lda[

: nlitn ( ... n -- ) \ Optimized version of multiple litn
  dup not if drop exit then
  dup 1 = if drop litn exit then
  dup 4* dup ps-,
  PSP) swap 4- +) !, swap i) @,
  1- 0 do PSP) i 4* +) !n, loop ;
: nbind> code> dip >r nlitn r> bbr, | ;
: >[:] lda[ bind> ]alloc ;
: n>[:] lda[ nbind> ]alloc ;

:~ abort"ill-formed lambda!" ;
: embed[ ( -- aj ad ) here ['] ~ bbr, here ;
: ]embed ( aj ad -- ad ) here rot realias ;

:> ( -- ) ( run: -- aj al ) embed[ pushlr, ;
:> ( -- 0 a ) lda[ 0 LDASZ reserve here 4+ dup , compile] ;
compiling [: immediate

: :] over if popexit, ]embed litn else
  nip [compile] ; here over - LDASZ > if ."WARNING: lambda size > LDASZ" then
  ]alloc then ; immediate
: valid# ( xt -- ) dup 4- @ <> ?abort"invalid lambda!" ;

\ Function manipulation
: times 0 do dup execute loop drop ;
: timesi 0 do i over execute loop drop ;
: some# not ?abort"some# on empty value!" ;

: _onempty, ( xt -- xt: -- )
  PSP) testz, ifz, swap execute exit, [compile] then ;

\ @+ on a PS item
: _MOD@+, ( n -- ) PSP) over +) S>) @, S) MOD) @+, PSP) swap +) S>) !, ;
:~ ( acc a u xt -- n )
  [: 8 ps+, drop, :] _onempty,
  pushlr, RSP) -!, PSP) 8 +) @, PSP) @!, PSP) 8 +) !,
  [compile] begin
    4 _MOD@+, RSP) brr, dup,
    1 PSP) 8 +) -n, ?brnz,
  12 ps+, 4 rs+, popexit, ;
code cfold[] 8b ~
code fold[] 32b ~

:~ [: drop, 4 ps+, poplr, :] _onempty, A) &) !, 4 _MOD@+, 1 PSP) -n, ;
: reduce[] [ 32b ~ ] rot> A> fold[] 1 ;
: creduce[] [ 8b ~ ] rot> A> cfold[] 1 ;

:~ ( sz -- )
  ['] drop, _onempty,
  pushlr, RSP) -!, 12 ps-, \ allocate three cells on stack
  PSP) 16 +) S>) @, PSP) 8 +) S>) !, PSP) 4 +) S>) !,
  ( a u ar aw n n ) \ a read, a write, duplicate of data
  [compile] begin
    8 _MOD@+, PSP) !, RSP) brr,
    W) &) testz, ifnz,
      PSP) 4 +) A>) @,
      PSP) S>) @, A) MOD) S>) !+,
      PSP) 4 +) A>) !,
      [compile] then
    1 PSP) 12 +) -n, ?brnz,
  PSP) 4 +) @, 16 ps+,
  PSP) -, ( sz ) ?dup if i) >>, then
  4 rs+, popexit, ;
code filter[] 32b 2 ~
code cfilter[] 8b 0 ~

:~
  [: drop, 4 ps+, :] _onempty,
  pushlr, RSP) -!, 4 ps-,
  PSP) 4 +) S>) @, PSP) S>) !,
  ( a u' u n ) \ u' is modified, u left intact
  [compile] begin
    8 _MOD@+, RSP) brr,
    W) &) testz, ifnz,
      PSP) S>) @+, PSP) S>) -,
      PSP) 4 +) S>) !,
      1 i) @, 4 ps+, 4 rs+,
      popexit, [compile] then
    1 PSP) 4 +) -n, ?brnz,
  12 ps+, 4 rs+, popexit, ;
code find[] 32b ~
code cfind[] 8b ~

:~ ( sz -- )
  [: drop, 4 ps+, :] _onempty,
  pushlr, RSP) -!,
  PSP) S>) @, ( sz ) ?dup if i) S>) <<, then
  PSP) 4 +) dir) S>) +,
  [compile] begin
    PSP) 4 +) S>) @, S) MOD) -@, PSP) 4 +) S>) !,
    RSP) brr, W) &) testz, ifnz,
      PSP) S>) @+, 1 i) S>) -, PSP) S>) !, \ ~ dipnip
      1 i) @, 4 rs+, popexit, [compile] then
    1 PSP) -n, ?brnz,
  8 ps+, 4 rs+, popexit, ;
code rfind[] 32b 2 ~
code rcfind[] 8b 0 ~

:~ ( a u xt -- )
  [: 8 ps+, drop, :] _onempty,
  pushlr, RSP) -!, [compile] begin
    PSP) 4 +) S>) @, S) MOD) @,
    RSP) brr,
    PSP) 4 +) S>) @, S) MOD) !+, PSP) 4 +) S>) !,
    1 PSP) -n, ?brnz,
  8 ps+, drop, 4 rs+, popexit, ;
code map[] 32b ~
code cmap[] 8b ~