\ list by Lcc Wizard for win32forth v4.2 0671 needs heap.f :class list address length \ :m idx: ( -- a ) entry-idx ;m :m b/idx: ( -- n ) b/entry-idx ;m : >entry-idx ( #entry - idx-adr ) \ b/entry-idx * entry-idx + ; 2* entry-idx +cells ; : >entry-idx-adr ( a -- a ) >entry-idx cell+ ; \ : >entry-idx-len ( a -- a ) >entry-idx ; ' >entry-idx alias >entry-idx-len : free-entry-idx ( -- ) entry-idx ?dup if hfree drop then 0 to entry-idx 0 to entry-idx-blen ; : ?extend-entry-idx ( n -- ) \ n entry-idxs to add >r #total-entry r@ + b/entry-idx * entry-idx-blen u> if entry-idx-blen 0= if r@ 8 umax b/entry-idx * to entry-idx-blen entry-idx-blen halloc to entry-idx else entry-idx-blen 1024000 umin entry-idx-blen + r@ #total-entry + b/entry-idx * umax to entry-idx-blen entry-idx-blen entry-idx hrealloc ?memfull to entry-idx \ ." extend entry-idx " entry-idx-blen . \ cr then then r>drop ; : free-entry ( #entry -- ) >entry-idx-adr @ ?dup if hfree drop then ; : null-entries ( #entry n -- ) >r >entry-idx b/entry-idx r> * erase ; : null-entry ( #entry -- ) 1 null-entries ; : resize-entry ( n #entry -- ) \ resize entry buf size >r dup r@ >entry-idx-len @ = if drop else dup 0= if drop r@ free-entry r@ null-entry else r@ >entry-idx-len @ 0= if dup halloc else dup r@ >entry-idx-adr @ hrealloc ?memfull then \ r@ >entry-idx-adr ! \ r@ >entry-idx-len ! swap r@ >entry-idx 2! then then r>drop ; \ ============== :m init: ( -- ) 0 to #total-entry 0 to entry-idx 0 to entry-idx-blen ;m :m classinit: ( -- ) classinit: super init: self ;m :m free: ( -- ) #total-entry 0 ?do i free-entry loop 0 to #total-entry free-entry-idx ;m :m off: ( -- ) free: self ;m /* : insert-move { src-a src-n dst-a dst-n dst-offset -- } dst-a dst-offset + dup src-n + dst-n dst-offset - move src-a dst-a dst-offset + src-n move ; */ : insert-fill { dst-a dst-n dst-offset cnt char -- } dst-a dst-offset + dup cnt + dst-n dst-offset - move dst-a dst-offset + cnt char fill ; :m #ins-null-entries: ( #entry n -- ) { ii -- } ii ?extend-entry-idx /* #total-entry umin dup>r >entry-idx dup b/entry-idx ii * + #total-entry r@ - b/entry-idx * move r@ ii null-entries ii +to #total-entry r>drop */ #total-entry umin >r 0 >entry-idx #total-entry b/entry-idx * b/entry-idx r> * b/entry-idx ii * 0 insert-fill ii +to #total-entry ;m :m #get: ( #entry -- a n ) dup 0 #total-entry within if >entry-idx 2@ else drop 0.0 then ;m :m #put: ( a n #entry -- ) dup #total-entry u< 0= if dup 1+ #total-entry - #total-entry swap #ins-null-entries: self then 2dup resize-entry >entry-idx-adr @ swap move ;m :m #insert: ( a n #entry -- ) \ insert dup 1 #ins-null-entries: self #put: self ;m :m add: ( a n -- ) #total-entry #put: self ;m :m #swap: ( #entry #entry -- ) { ii jj \ tmp -- } b/entry-idx localalloc: tmp ii >entry-idx tmp b/entry-idx cmove jj >entry-idx ii >entry-idx b/entry-idx cmove tmp jj >entry-idx b/entry-idx cmove ;m :m #multi-delete: ( #entry n -- ) { ii -- } dup>r 0 #total-entry within if r@ #total-entry r@ - ii umin 0 ?do dup i + free-entry loop drop r@ ii + >entry-idx r@ >entry-idx #total-entry r@ ii + 2dup u> if - else 2drop 0 then b/entry-idx * move #total-entry ii - 0max r@ umax to #total-entry #total-entry 0= if \ ." Free Entry-idx" cr free-entry-idx then then r>drop ;m :m #delete: ( #entry -- ) 1 #multi-delete: self ;m :m #total: ( -- n ) #total-entry ;m : total-len ( -- len ) 0 #total-entry 0 ?do i #get: self nip + loop ; \ -------------- \ : traverse-func ( a n -- break? ) :m traverse: { traverse-func -- } #total-entry 0 ?do i #get: self traverse-func execute ?leave loop ;m :m list: ( -- ) \ list all entries ." ---" cr #total-entry 0 ?do i . ." : " i #get: self type cr loop ." --- Length= " total-len . ." Press key!" key drop cr cls ;m ;class in-system : t ( -- ) { \ tt -- } new> list to tt cls init: tt \ s" a" 0 #insert: tt s" a" 0 #put: tt s" " 0 #put: tt 0 #get: tt s" " compare 0= 0= if s" Error 1" errorbox then s" a" 0 #put: tt s" b" add: tt s" c" add: tt s" d" add: tt s" e" add: tt list: tt ." -1 #get: =" -1 #get: tt type cr s" put at 0" 0 #put: tt ." del 10 entry at 4" cr 4 10 #multi-delete: tt list: tt ." Ins at 1" cr s" Ins at 1" 1 #insert: tt 1 #get: tt s" Ins at 1" compare 0= 0= if s" Error #ins" errorbox then list: tt ." put at 7" s" put at 7" 7 #put: tt cr list: tt ." del 1000 at 0" 0 1000 #multi-delete: tt cr list: tt 3 10000 #multi-delete: tt time-reset 100000 0 ?do \ pad 256 blank \ i (.) pad place \ pad 1+ 1024 i (.) add: tt loop .elapsed cr \ list: tt ." press key!" key drop cr time-reset free: tt .elapsed cr tt dispose ; in-application