\

anew -efforts

CR

.( I guess I can write anything I want as long as I put it in )

\   VOCABULARY CoSy    ALSO CoSy DEFINITIONS

\ --- \/  FLOORED MODULO FNS - from ansi standard  \/ ----

: /_MOD ( n1 n2 -- n3 n4) >R S>D R> FM/MOD ;
: /_  ( n1 n2 -- n3)  /_MOD SWAP DROP ;
: _MOD ( n1 n2 -- n3)   /_MOD DROP ;
: */_MOD ( n1 n2 n3 -- n4 n5)  >R M* R> FM/MOD ;
: */_  ( n1 n2 n3 -- n4 )   */_MOD SWAP DROP ;

\ --- /\  FLOORED MODULO FNS - from ansi standard  /\ ----

\ --- \/ Helpers & utilities                       \/ ----

: @+  @ 1+  ;   \ recommended by Charles Moore
                \  http://www.ultratechnology.com/rmvideo.htm 990522

: @-  @ 1-  ;   \ for symmetry

: @+!> dup @+ dup>r swap ! r> ;     \ auto increment counter
: @-!> dup @- dup>r swap ! r> ;     \ auto decrement

 \ Better , post in(de)crement so current value is number items
 \ and next index to be addressed .
: @>+! dup @ dup>r 1+ swap ! r> ;     \ auto increment counter
: @>-! dup @ dup>r 1- swap ! r> ;     \ auto decrement

: yn?  s"  [Y/N]: " type   key  dup emit  dup 121 = swap 89 = or ;

: KB  0x1000 * ;
: MB  0x1000000 * ;

: ndrop  0 ?do  drop  loop ;

: s_ depth ndrop ;   \ Clear stack

SYS-WARNING-OFF

: >>  $10 dump ;
: >>> $20 dump ;

SYS-WARNING-ON


: .D  base @ >r decimal . r> base ! ;   \ . output decimal

\ --- /\ Helpers & utilities                       /\ ----

: sn ( n -- -1|0|1 ) dup 0< swap 0> - ;         \ sign of n

: <sn ( n0 n1 -- -1|0|1 )  - negate sn ;        \ 1 iff n0 < n1 , -1 iff n0 > n1

: ~~  0<> negate ;              \ converts FORTH logic ( TRUE = -1 ) to
                                \ I-logic : Iverson logic ( TRUE = 1 )
: ~ 0= negate ;

2147483647 constant 0I          \ Integer Infinity
0I 1 + constant 0N              \ Integer NotANumber

((    / commented out
 : ~DO { n0 n1 | inc -- }  2dup - sign to inc    \ automatic inc , dec
    ?DO

 cr .(  2003 12 17 4 37 40 )

 \ | +stackmon

 \ | : wv wview ;


 \ | : dt SYSTIME&DATE 6 0 DO U. LOOP ;

 \ | : ldt TIME&DATE 6 0 DO U. LOOP ;


: -> defined  if

))

anew g1  \ ==================================== \

 s" nil" drop value nil

 s"  |) " drop value |)
 s"  (>) " drop value (>)
 s"  (| " drop value (|

8 constant byte

: sEach  { f } ( ... n f -- )    \ apply f to n items on stack
  0 ?do f execute loop ;         \ non resulting only .

\ DYNAMIC  \/ ================================================== \/

\ FOR DEBUGGING \/  ====================================

variable allocTrace  256 cells allot
variable ATptr 0 ATptr !
: AT+> dup allocTrace ATptr @>+! cells+ ! ; \ store allocated addrs .

variable freeTrace  256 cells allot
variable FTptr 0 FTptr !
: FT+ freeTrace FTptr @>+! cells+ ! ; \ store allocated addrs .

\ FOR DEBUGGING /\  ====================================

: alloc allocate abort" allocation failure " AT+> ;  ( bytes -- adr )

: oballoc 3 cells + aligned alloc ;  ( bytes -- addr )  \ allocate n bytes  + 3 cells
       \ header cells for ( type ; i# ( rho ) ; ( refs ; bits % cell ) )

  0 value buf  0 value bpos
: allocBuf 100 kb allocate abort" Buffer allocation failure " to buf
  0 to bpos ;

: freeA dup free abort" free failure " FT+ ;

: freeW dup free if ." WARNING : free failure " else FT+ then  ;

((
: abortFree" ( adr F -- adr | free & abort )
  if free 1 abort"
))

\ | ALIAS: ` addr

: ?enc ( lst -- Iflag )         \ return 1 if enclosed else 0
  @ ~ ;

: i# ( adr -- number_of_items ) cell + @ ;  		\ APL  ` rho

: obbody ( obadr - obBodyAdr )
   3 cells+  ;

: `BnR 2 cells+ ;       \ top half of 3rd cell is item size in bits
                        \ bottom word of 3rd cell is reference count .

: hw! ( n adr -- )              \ store 16 bit value in hi word of cell
  2 + w! ;              \ not needed :   swap 10 lshift over w@ or swap ! ;

: hw@ 2 + w@ ;

: bits! `BnR hw! ;
: bits@ `BnR hw@ ;

: obsize ( addr -- n )  \ # bytes in whole object , aligned
   dup cell+ @ swap bits@ byte / * aligned 3 cells + ;

: Idx    ( adr n -- adr of nth item in list ) \ modulo indexing
  over i# _mod over bits@ byte / * obbody + ;

: i@ idx @ ;   : i! idx ! ;     \ index fetch and store

: refs! `BnR w! ;
: refs@ `BnR sw@ ;

: refs0 0 swap refs! ;
: refs+ `BnR 1 swap w+! ; ( obadr -- )
: refs+> dup refs+ ;      ( obadr -- obadr )

: 2refs+> dup refs+ over refs+ ;

: refs- dup refs@ 1 -     ( obadr -- )
  dup 0> if swap refs!
  else over ?enc
   if over i# 0 ?do over i i@ recurse loop then
    drop freeA then ;      \ decrement refs & free if 0

: 2refs-  refs- refs- ;

: ref0del dup refs@ 0 = if refs- else drop then ;

 \ Thursday, June 02 2005 - 11:49 \ I am concluding it is vital
 \ for functions to free .. locally created obs w ref0del if
 \ not returned as result , but leave input parameters alone .
 \ input parameters consumed should be freed if 0 refs .


: cellVecInit ( n - objAdr )    \ make header and allocate space for n cells
   dup cells oballoc            ( n objAdr )
   dup 0 swap !
   dup cell+ rot swap !         \ # of items
   dup cell byte * over bits!   \ item size in bits
   refs0 ;

0 cellVecInit refs+> value v0        \ empty vector

v0 refs+> value t0
: >t0 ( ob -- ob )      \ Temp handle holder . Frees old value when assigned new
   t0 refs-
   dup refs+> to t0 ;

v0 refs+> value t1
: >t1 ( ob -- ob )      \ Temp handle holder . Frees old value when assigned new
   t1 refs-
   dup refs+> to t1 ;

v0 refs+> value t2
: >t2 ( ob -- ob )      \ Another Temp handle holder .
   t2 refs-
   dup refs+> to t2 ;


  : =>  refs+> variable  ! ;

: -> swap refs+> swap ! ;

: obdup ( adr -- newadr )
  dup obsize dup alloc dup >r swap cmove r>
  dup refs0 ;

: obparms                               \ # cells and address
   dup cell+ @ over bits@ byte / *       ;

: dataddr                               \ obbody , # bytes
   dup obbody swap dup i# swap bits@ byte / * ;

: int -1 swap ! ;          \ convert type to int
: int> dup -1 swap ! ;          \ convert type to int , returning 

: intVecInit ( n - objAdr )     \ make header and allocate space for int vec of length n
   cellVecInit
   dup int ;              \ integer vector type -1
                                \ ( too complex :  s" INTV" drop @
                                \ over ! )

: byteVecInit ( bytes - OA )    \ make header and allocate space for n bytes
   dup oballoc dup -8  swap !   ( n objAdr )  \ type vec of 8 bit items
   dup cell+ rot swap !         \ # of items
   dup byte over bits!          \ item size in bits
   refs0 ;

: str ( c-addr n -- OBadr )     \ store a string
  dup byteVecInit dup >r        \ c-ad n Oadr
  obbody swap cmove r> ;


: sym                           \ symbol
   parse-word                   ( c-addr len ) \ of next word
   dup aligned oballoc          ( c-addr len addr )
                                \  s" NAME" drop @ over !       ( c-addr len addr )
   dup >r 4 over !              \  symbol type 4
   2dup cell+ !                 \ c-addr len addr  \ # chars ( bytes ) stored
   dup byte over bits! refs0    \ 8 bit bytes .
   obbody swap cmove  r> ;

: enc     ( addr -- addr )      \ enclose
  1 cellVecInit swap refs+> over obbody ! ;

: encatom ( CSob -- CSob )      \ Enclose iff not enclosed .
  dup @ 0<> if enc then ;       \ An atom is anything other than a general list .

: enc>1 ( CSob -- CSob )        \ Enclose iff i# > 1
  dup i# 1 <> if enc endif ;

: ~encabort ( CSob -- CSob )    \ Abort if not enclosed
  dup @ 0<> abort" not enclosed " ;

: dsc 0 i@ ;            \ disclose


\ DICTIONARY  \/ ============================================ \/

s" dic " drop value `dic

: ,l ( O0 O1 -- O2 )    \ most basic catination of objects . Lisp like
  2 cellVecInit dup obbody dup
  4 pick refs+> swap  ! 2 pick refs+> swap cell+ ! nip nip ;

 v0 v0 ,l refs+> value dic
\ v0  value dic                  \ initialize dictionary

: cL         { p0 p1 | n0 n1 adr -- adr }               \ catinate Lists
   p0 @ 0<> p1 @ 0<> or  if p0 @ p1 @ = abort" nonce " then
        \ at least one arg must be enclosed . unenclosed is added as single item
   p0 ?enc if  p0 i#  else  1  then to n0
   p1 ?enc if  p1 i#  else  1  then to n1

   n0 n1 + cellVecInit to adr
   p0 ?enc if p0 i# 0 ?do p0 i i@ refs+> adr i i! loop
          else  p0 refs+> adr obbody !  then
   p1 ?enc if p1 i# 0 ?do p1 i i@ refs+> adr n0 i + i! loop
          else p1 refs+> adr n0 i! then
   adr ;


: rplc ( new p0 -- )   \ free and replace pointer at `p0
  dup @ refs- swap refs+> swap ! ;

: cLr ( `l0 p1 -- )             \ catinate lists , replace
  over @ swap  cL swap rplc ;

((
: apnditem { lst itm | nwlst -- nwlst )  \ for enc lsts
   lst @ ~encabort
   obsize cell+ cellVecInit to lst      \ resize abort" resize failure " \ will likely fail
   cell+ incr dup i# 1-
))

\ : reasgn ( addr name vadr0 -- )       \

: iota ( n -- adr )
  dup intVecInit
  dup obbody rot                \  adr bodyadr n
  0 ?do i over i cells+ ! loop
  drop ;

: s>m ( n-items n addr - )              \ move n cells from stack to memory
  sp@ 2 cells+ swap rot cells cmove ;

: intVec ( n-items n -- oAdr )
  dup intVecInit dup >r obbody s>m r@ i# ndrop r> ;

: mem>iv ( adr n -- obadr )     \ copy n cells from memory to IV
  dup intVecInit dup>r 0 idx swap cells cmove r> ;

        \ : si ( n - i# n )  0 ?do i loop ;    \ Stack Iota ;

: acrossY  { proto obadr fn | n r -- res }    \ dYadic result returning "/"
   obadr i# to n  obadr obbody to obadr  proto to r
   n 0 ?do r obadr i cells+ @ fn execute to r  loop
   r ;

: across  { obadr fn | r -- r } \ result returning "/"
   \ bombs on empty args    \ obadr i#  abort" nonce : prototype "
   obadr 0 i@ to r
   obadr i# 1 ?do r obadr i i@ fn execute to r  loop
   r ;

 \ done \ NB : it might be possible to move this before , and use it in  refs- .
: eachM { CSob f -- }           \ `each Monadic , no result , eg , printing
   CSob i# 0 ?do CSob i i@     \ f CSob itemadr
   f execute  loop CSob ref0del ;            \ f CSob

: eachMr { CSob f | CSadr -- CSadr }      \ `each Monadic resulting
   CSob i# cellVecInit to CSadr
   CSadr i# 0 ?do CSob i i@
    f execute CSadr i i! loop
   CSob ref0del CSadr ;

: eachRightR { LA RA f | AO -- AO }             \ eachRight resulting
   RA i# cellVecInit to AO
   RA i# 0 ?do LA RA i i@
    f execute AO i i! loop
   LA ref0del RA ref0del AO ;

: eachLeftR ( LA RA f -- AO )             \ eachRight resulting
   >r swap r> eachRightR ;

: take { CSob n | s nwob -- nwob }              \ APL take / reshape
  n abs dup cellVecInit to nwob  n sn to s
   0 ?do CSob i s * i@ nwob obbody i cells+ !
     loop  nwob CSob ref0del ;

: conform { LA RA | t0 t1  -- r0 r1 }       \ take shorter list to length of longer
  LA i# RA i#
   2dup > if  drop RA swap take  LA swap    \ take RA to length of LA
        else   nip LA swap take  RA         \ take LA to length of RA
        then ;
((
: aapply ( LA RA f -- r )   \ "atomic" apply .
  ;
))

: nth ( CSob n -- CSadr )       \
   over i# cellVecInit         \ CSob Result
   dup i# 0 ?do 2 pick i idx @ \ CSob Res itemadr
   2 pick idx @
   over i idx !                 \ CSob Res
   loop nip nip ;

: flip { CSob | nadr nbdy -- CSadr }    \ Transpose object .
   CSob ~encabort  i#  0= if v0 else
   CSob 0 i@ i# cellVecInit dup to nadr obbody to nbdy
    nadr i# 0 ?do CSob i nth nbdy i cells+ ! loop nadr
   then ;

((
: lst>dic ( lst -- dic )
  dup @ abort" not list "
  dup 0 i@ i# 2 3 within? 0= abort" must be # 2 or 3 "
  flip dup `dic swap ! ;

: dic>lst ( dic -- lst )
  dup @ `dic <> abort" not dictionary "
  flip dup 0 swap ! ;

 : til ( ob fn -- n )
 0 1 0 2 0 1 depth nrev depth intvec >r1
))

: &  { I0 | I1 I1i -- I1 }   \ for each item of I0 return val n reps of corresponding index
    	\ ( Arthur Whitney def of ' where , and even his symbol )
        \ example of use of extended def ( from Marco Pescosolido , soln to EE McDonnell's
    	\  K finger exercises # 39  )
    	\  x[|>&y]  reverse subsets , EEMD : "infixes" , of lengths  y  of list x .
    \ I0 @ -1 <> abort" not vec "
   I0 i# 0= if I0 exit then
   I0 ['] + across intVecInit to I1  -1 to I1i
   I0 i# 0 ?do I0 i i@ 0 ?do j I1 1 +to I1i I1i i! loop
   loop I0 ref0del  I1  ;

: strmatch { s0 s1 -- 0|1 }     \ match obj str , I-logic .
  s0 dataddr s1 dataddr str= negate  s0 ref0del  s1 ref0del  ;

: ?sym ( lst str  -- i )     \ returns index of first occurance of sym in dic names
    2refs+> 2dup 2>r swap ['] strmatch eachrightR int>
    & dup 0 i@ swap refs- 2r> 2refs- ;

: wheresym { dic str -- i }     \ returns index of first occurance of sym in dic names
   dic refs+ str refs+ dic 0 i@ str ?sym dic refs- str refs- ;

: Valadr ( str -- adr of value )
   dic swap wheresym dic 1 i@ swap idx ;

: v@ Valadr @ ;     : v! Valadr ! ;


((
: match1st  ( CSob -- flag )
  dup dscl
))

: So ( cadr u -- )      \ output string
   0 ?do i over + @ emit loop drop ;

: nameprnt ( CSadr -- )
  \ dup @ 4 <> abort" not name "
   dup 3 cells+ swap cell+ @ So ;

: namelst  cr nameprnt ;

: dnames ( dic -- ) 0 i@  ['] namelst eachM ;

((
: z ( ... Fadr0 Fadr1 -- ... )          \ compoZe , takes 2 fn tags
   >r execute r> execute ;              \ not clear worth anything
))

: dicasgn { val nm dic -- }
  dic 0 idx  nm  cLr
  dic 1 idx  val  cLr ;


: cs->  ( adr ; name --  ; dictionary entry )
   sym  dic dicasgn ;


((
   lst @ 0<> if lst obsize to n
              lst buff bufpos @ + n cmove
              bufpos dup @ n + swap ! exit then
   lst buff bufpos + 3 cmove
    bufpos dup @ 3 + swap !
   lst i# 0 ?do lst i idx @ recurse
   ;

 : walkleaves { lst fn | n -- }
   lst @ 0<> if lst
              lst buff bufpos @ + n .s cmove
              bufpos dup @ n + swap !
              exit then
   lst buff bufpos @ + 3 cells .s cmove
    bufpos dup @ 3 cells + swap !
   lst i# 0 ?do lst i idx @ recurse
              loop ;
))

nostack     \ suppresses stack change warnings

 DEFER (storelst)
: storelst { lst -- clst cells }    \ convert allocated list to linear form
  allocBuf lst (storelst)
  buf bpos resize abort" resize failure "  bpos ;

 :noname { lst |  n -- }
   lst @ 0<> if lst obsize to n
              lst buf bpos + n cmove
              bpos n + to bpos
              exit then
   lst buf bpos + 3 cells cmove
    bpos 3 cells + to bpos
   lst i# 0 ?do lst i idx @ recurse
              loop ;
 is  (storelst)

   DEFER (rstrlst)
: restorelst ( clst -- lst )        \ convert linear form back to allocated
   buf >r to buf  0 to bpos (rstrlst)   \ memory tree structure
   r> to buf ;

 :noname { | n0 n1 lst -- lst }
     buf bpos + dup to n0 @             \  BREAKPOINT
      0<> if n0 obsize aligned to n1
       n1 alloc to lst
        n0 lst n1 cmove bpos n1 + to bpos lst
      else
       n0 i# dup to n1 cellVecInit to lst      \ item is type 0
       bpos 3 cells + to bpos
      n1 0 ?do recurse lst i idx !
     loop lst then ;
 is  (rstrlst)

nostack1

: savelst ( lst c-adr n -- )    \ write list to file c-adr n
   r/w open-file abort" file error " >r
   storelst r@ write-file abort" file write error "
   r> close-file abort" file close error " ;

: readfile { | F Aob -- Aob }
  bl parse-word r/w open-file abort" File open error "  to F
  F file-size abort" File-size request error "
  abort" File too large "       \ 1st cell of D int non 0 .
  dup dup byteVecInit  dup to Aob  obbody       \
  rot f read-file abort" read-file error "
  f close-file abort" close-file error "
   <> abort" read length error "  Aob ;

: restorefile  readfile
  dup obbody restorelst swap freeA ;

: duplst ( lst -- nwlst )
  storelst drop dup restorelst swap freeA ;

\ restorefile c:\VFXFORTH\USER\dic.csy to dic

\ dic s" D:\MPEFORTH\VFXFORTH\USER\dic.csy" savelst


((
\ INTERPRETER \/ \/ \/ \

: CSparse  ( str -- )




\ INTERPRETER \ /\ /\ /\ /\ \
))

\ | base @ decimal  CR ldt   base !

hex

cr  .( ln 469 )

anew C0
\   TEST

\  sym i10 >r1  a iota >r2

\ fload 'C:\PROGRAM FILES\WIN32FORTH\COSY\test.f'

((              \ /\ END OF COMPILED SECTION /\

))
