|  C:\reva\CoSy\RE.f


needs os/shell
needs util/locals
needs math/floats
needs asm
| needs debugger

include CoSy/CSauxstack

0 [IF]		| \/ vestigal & not particularly useful words 
: h help ;
: yn?  ."  [Y/N]: " key dup emit lc dup 'y = ; 
: sEach { f } ( ... n f -- )    | apply f to n items on stack
  0 ?do f execute loop ;         | non resulting only .

: >entry last repeat @ 0; 2dup cell+ @ =if nip ;; then again ;
: xt>name >entry 9 + count ;

: .Rstk  ( n strt -- ) | types n items in return stack starting strt above self
   dup cells rp@ + swap 0 ?do dup i cells+ @ xt>name type space loop drop ;

[THEN]		| /\ vestigal & not particularly useful words 

: .> dup . ;
: D> dup : DMP 32 dump ;


: $. base @ >r hex . r> base ! ;
: $.s  base @ >r hex .s r> base ! ;
: #. base @ >r decimal . r> base ! ;


: stkprmpt $.s cr " ok> " type ; ' stkprmpt >defer prompt
  | set default prompt to show stack in hex . use  undo  to reset to original

: put [ $89adc389 , $ad9e04 3, ;	( ... i n -- ... )	| inverse of pick . stores i n down in stack .
: ndrop 0 ?do  drop  loop ;	| should be optimized

: v' ' >body ; ( valuename -- addrOfData ) | like ' for values and constants


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

: @-  @ 1-  ;   | for symmetry

: >r> dup >rr ;		| same as ... dup >r ... 


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

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

: w+! dup w@ rot + swap w! ; 

: hw! ( n adr -- ) 2 + w! ; 	| store 16 bit value in hi word of cell
: hw@ 2 + w@ ; 

: cells+ cells + ;

32 constant bl		| blank
8 constant byte
4 constant cell 

$7FFFFFFF constant 0I		| integer infinity . ( Largest pos Number )  
					| 2147483647 
0I 1 + constant 0N	| integer `null ( missing value ) , NotANumber

: K*  $400 * ;
: M*  $100000 * ;

| --- \/  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  /\ ----


  [DEFINED] Golden [IF] Golden 
  [THEN] mark Golden 
 
 | Iverson logic : 
 
: =I =if 1 ;; then 0 ;
: <>I <>if 1 ;; then 0 ;
: >I >if 1 ;; then 0 ;
: <I <if 1 ;; then 0 ;

: ~ not negate ;	| similar to w32f 0<> 
: ~~ not ~ ;	| converts FORTH ( Moore ) logic ( TRUE = -1 ) to
                  	| I-logic : Iverson logic ( TRUE = 1 )

: sn ( n -- -1|0|1 ) dup 0 >I swap 0 <I - ;	| sign of n
: <sn ( n0 n1 -- -1|0|1 )  - negate sn ;	| 1 iff n0 < n1 , -1 iff n0 > n1

: str= cmp ~ ;

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

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

variable DEBUGGING  DEBUGGING on

0 [IF]		| too fancy for now 

variable allocTrace  256 cells allot
variable ATptr 0 ATptr !

: AT+>  dup  CR ."   Allocate " $.   3 3 .Rstk
 dup allocTrace ATptr @>+! cells+ ! ; | store allocated addrs .

variable freeTrace  256 cells allot
variable FTptr 0 FTptr !
: FT+ dup    ."   Free " >>  3 3 .Rstk
   freeTrace FTptr @>+! cells+ ! ; | store allocated addrs .
[THEN]

DEBUGGING [IF] 

: AT+> ."  allocating " dup $. cr ;
: FT+> ."  freeing " dup $. cr ;

: allocate prior allocate AT+> ;  ( bytes -- a )
: free FT+> prior free ;

[ELSE]

: AT+> : FT+> ;

[THEN]

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

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

: oballoc 3 cells + aligned dup allocate 
  dup rot 0 fill ;  ( bytes -- addr )
       | allocate n bytes  + 3 cells
       | header cells for ( type ; i# ( rho ) ; ( refs ; bits % cell ) )
       | 0 fills the allocated memory . This could be reduced to just the
       | 3 head cells for speed .

: obbody ( obadr - obBodyAdr ) 3cell+  ;

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


: `BnR 2cell+ ;       | top half of 3rd cell is item size in bits
                      | bottom word of 3rd cell is reference count .
: bits! `BnR hw! ;
: bits@ `BnR hw@ ;

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

: refs0 0 swap refs! ;

DEBUGGING [IF]
: refs+ ( obadr -- )  dup ."  r+ " $. 
  `BnR 1 swap w+! ; 
[ELSE]
: refs+ ( obadr -- ) `BnR 1 swap w+! ; 
[THEN] 

: refs+> dup refs+ ;      ( obadr -- obadr )
: 2refs+  refs+ refs+ ;		| useful for LA RA 
: 2refs+> 2dup 2refs+ ;

| \/ LIST TYPES \/

0 constant Type0 

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


-1 constant TypeI
: int TypeI swap ! ;          | convert type to int
: int> dup int ;          | convert type to int , returning

: intVecInit ( n - objAdr )     | make header and allocate space for int vec of length n
   cellVecInit
   dup -1 swap ! ;              | integer vector type -1
                                | ( too complex :  " INTV" drop @
                                | over ! )
 
: intVec ( n-items n -- oAdr )
  dup intVecInit >r> obbody s>m r@ i# ndrop r> ; 


-8 value TypeB

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


-2 constant TypeF 

: floatVecInit	( n - objAdr )	| make header and allocate space for float vec of length n
   dup floats oballoc	( n objAdr )
   dup TypeF swap !				| type 0
   dup cell+ rot swap !			| # of items
   dup 10 byte * over bits!   | item size in bits 
   refs0 ;

0 [IF]
$4d7e6d value TypeInterval		| " m~M" ( min to Max )
: interval ( LA RA -- interval )  | really just a pair of endpoints
  | w b useful to optimse indexing . 
  2 intVec dup TypeInterval swap ! ;
[THEN]  

: 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 , cell 
: ic@ idx @ ;		: ic! idx ! ;	| index fetch and store , cell 
: ib@ idx c@ ;		: ib! idx c! ;	| index fetch & store , byte
: if@ idx f@ ;		: if! idx f! ;	| index fetch & store , float

choices: ifetch
 ' ic@ Type0 choice
 ' ic@ TypeI choice
 ' ib@ TypeB choice
 ' if@ TypeF choice
 ' throw default 
 
: i@ ( a i -- item ) 
  over @ ifetch ;

choices: istore
 ' ic! Type0 choice
 ' ic! TypeI choice
 ' ib! TypeB choice
 ' if! TypeF choice
 ' throw default 
 
: i! ( item a i -- ) 
  over @ istore ;
   

: ?enc ( lst -- Iflag )         | return 1 if enclosed else 0
  @ ~ ;
: ~encabort ( CSob -- CSob )    | Abort if not enclosed
  dup @ throw ;
  
: enc     ( addr -- addr )      | enclose
  1 cellVecInit swap refs+> over obbody ! ;
 
: encatom ( CSob -- CSob )      | Enclose iff not enclosed .
  dup @ 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 then ;

: dsc 0 i@ ;            | disclose


DEBUGGING [IF]
: refs- ( obadr -- )	| decrements reference count , frees if 0 .
 dup ."  r- " $. 
  dup refs@ 1 -   
  dup 0 >if swap refs!
  else over ?enc
   if over i# 0 ?do over i ic@ refs- loop then
    drop free then ;      | decrement refs & free if 0
[ELSE]
: refs- ( obadr -- )	| decrements reference count , frees if 0 .
  dup refs@ 1 -   
  dup 0 >if swap refs!
  else over ?enc
   if over i# 0 ?do over i ic@ refs- loop then
    drop free then ;      | decrement refs & free if 0
[THEN] 

: 2refs-  refs- refs- ;

: ref0del dup refs@ 0if free else drop then ;	| free if refs = 0 .
 | 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 .
 
: 2ref0del ref0del ref0del ;

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


0 cellVecInit refs+> constant v0        | empty vector 

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

: obdup ( adr -- newadr ) 
  dup obsize dup allocate dup >r swap move r@ refs0 r> ;

: oban				| obbody , # bytes
   dup obbody swap dup i# swap bits@ byte / * ; 

|  : IVcat 				| join int vecs .

: i(		| input integers up til " )i" -- IV |
  100 K* dup intVecInit              
   swap 0do parsews >single 
    if over i ic! 
   else 
    " )i" cmp if free $6f2f69 throw then	| i/o error 
    i over cell+ ! i 3 + cells resize leave 
   then loop ;

: f( 	| input floats up til " )f" . return FV .
  100 K* dup floatVecInit	| I'm trusting that resize really frees unused mem
   swap 0do parsews >float 
     if dup i if!  
     else 
      " )f" cmp if free $6f2f69 throw then 	| i/o error 
      i over cell + ! i floats 3 cells + resize leave
	 then loop ; 


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

: s" p: " str ; ( | character up to " -- CV )
  
: sym                           | symbol
   parsews                ( c-addr len ) | of next word
   dup aligned oballoc          ( c-addr len addr )
                                |  " 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 move  r> ;


0 [IF]
: VecInit  ( n type -- )
  CASE
    0  OF cellVecInit  endof
   -1  OF intVecInit   endof
   -8  OF byteVecInit  endof
  ENDCASE ;
[THEN]

| \/ OPERATORS   \/ ========================================== \/

: longer ( LA RA -- lengthOfLonger )  
   i# swap i# max ;

0 [IF]
: 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 .
  ;
[THEN]

|  Best to handle typing outside of loops .


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

0 [IF]
: acrossIc  ( RA f -- r )		| result returning "/" on integer lists 
   0 -rot 		| r RA f   
   over i# 
     0 ?do 2 pick 2 pick i i@ 2 pick execute 2 put  loop
   drop ref0del ;   
[THEN]

: acrossC  ( RA f -- r )	 | result returning "/" on cell lists 
   over 0 i@		| RA f r	| bombs on empty arg . use acrossYc		 	  
   2 pick i# 
     1 ?do 2 pick i i@ 2 pick execute loop
   >r drop ref0del r> ;

: acrossYc  ( r0 RA f -- r )	| result returning "/" on cell lists 
	rot		| RA f r			| LA is initial result 	  
   2 pick i# 
     0 ?do 2 pick i i@ 2 pick execute loop
   >r drop ref0del r> ;


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

| -------- 

: scanI  { RA fn | R -- R }     | scan over interger vecs .
  RA i# intVecInit lto R  RA 0 i@ R 0 i!
  RA i# 1 ?do R i 1- i@  RA i i@ fn execute R i i! loop
  RA ref0del  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 

: eachMbr ( bV f -- r )			| `each Monadic byte resulting
   over i# dup byteVecInit 
   swap 0 ?do 2 pick i ib@
   2 pick execute over i ib! loop
   nip swap ref0del ;

: eachMcr { CSob f | CSadr -- CSadr }	| `each Monadic resulting
   CSob obdup lto CSadr			| f must not change type .
   CSadr i# 0 ?do CSob i i@
    f execute CSadr i i! loop
   CSob ref0del CSadr ;

: eachDcr ( LA RA f -- R )		| each Dyadic on cells , resulting   
  -rot 2dup longer dup intVecInit	| f LA RA n r 
  swap 0 ?do 2 pick i ic@ 2 pick i ic@ 5 pick	| f LA RA r LAi RAi
   execute over i ic! loop		| f LA RA r 
  -rot 2ref0del nip ;


: eachMfr ( CSob f -- CSadr )	| `each Monadic floating resulting
   over i# floatVecInit temp ! 
   over i# 0 ?do over i if@ dup execute temp @ i if! loop
   drop ref0del temp @ ;

: eachDfr ( LA RA f -- r ) 	| each Dyadic on floats , resulting 
  -rot 2dup longer dup floatVecInit temp !
   0 ?do over i if@ dup i if@ 2 pick execute temp @ i if! loop
   2ref0del drop temp @ ; 
  
  
: eachMbir { CSob f | CSadr -- CSadr }      | `each Monadic resulting byte in integer out
   CSob i# cellVecInit lto CSadr
   CSadr i# 0 ?do CSob i ib@
    f execute CSadr i i! loop
   CSob ref0del CSadr ;

   
: eachRightR { LA RA f | AO -- AO }             | eachRight resulting 
   RA i# cellVecInit lto 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 ;

   : eachRightRb { LA RA f | AO -- AO }      | eachRight resulting Byte
   RA i# byteVecInit to AO
   RA i# 0 ?do LA RA i ib@
    f execute AO i ib! loop
   LA ref0del RA ref0del AO ;

| /| OPERATORS /| ============================================ /\
| \/ FUNCTIONS \/ ============================================ \/

: longer ( LA RA -- lengthOfLonger )  
   i# swap i# max ;

  
: S. ( StrAdr -- )      | output string
   oban type ;
 

: +i ['] + eachDcr ;	| add 2 integer vecs 
: -i ['] - eachDcr ;	| subtract 2 integer vecs 
: *i ['] * eachDcr ;	| * 2 integer vecs 
: /i ['] / eachDcr ;	| div 2 integer vecs 
: _modi ['] _mod eachDcr ;	| _mod 2 integer vecs 
: mini ['] min eachDcr ;	| min 2 integer vecs 
: maxi ['] max eachDcr ;	| max 2 integer vecs 
: =i ['] =I eachDcr ;	| = ( Iverson logic ) 2 integer vecs 
: <>i ['] <>I eachDcr ;	| not equal ( Iverson logic ) 2 integer vecs 
: <i ['] <I eachDcr ;	| < ( Iverson logic ) 2 integer vecs 
: >i ['] >I eachDcr ;	| > 2 integer vecs 

: I. ['] . eachM ;	| output integer list .


: i>f ( intVec -- floatVec )
  dup i# dup floatVecInit temp !
   0 ?do dup i ic@ temp @ i idx swap s>f f! loop 
  ref0del temp @ ;

: F. ['] f. eachM ;
  
: pi* fpi f* ;		| this is the monadic circle fn in APL


0 [IF]
: +I ( LA RA -- sum ) 
  over @ over @  2dup 
   =if drop TypeI =if +i ;
[THEN]

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

| =========== /\ END OF MATERIAL COVERED AS OF 060510 /\ ============= |


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

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

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


: &  { 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 <>if 1953393022 throw then   | " ~int" 
    I0 refs+> i# 0if I0 ;then
    I0 ['] + across intVecInit lto I1  -1 to I1i
    I0 i# 0 ?do I0 i i@ 0 ?do j I1 1 +lto I1i I1i i! loop
            loop I0 refs- I1  ;

: nth ( CSob n -- CSadr )  	| extracts nth item from each item of CSob  
   over i# cellVecInit 		| CSob Result
   dup i# 0 ?do 2 pick i i@ 	| CSob Res itemadr
   2 pick i@
   over i i!			| CSob Res 
   loop nip nip ; 


|  \/ UTILITY VARIABLES \/


: => refs+> variable,  ;  ( ob "name" -- )  | stores ob at name
 | see also  rplc 

| for values | : -> ' dup execute refs- swap refs+> swap cell + ! ;


 v0 refs+> variable, t0
 v0 refs+> variable, t1
 v0 refs+> variable, t2 

: >t0 ( ob -- )      | Temp handle holder . Frees old value when assigned new
   t0 rplc ;

0 [IF]		| These seem no longer to be useful . Simple vars as above better .  
| : >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 ;

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

[THEN]


  
| /\ UTILITY VARIABLES /\
   

  
0 [IF]   | STOP COMPILING \/ \/ |  

: _ ( LA RA | t -- ob )
 2 s>x 1 x@ 2 x@ 2refs+
 1 x@ i# cellVecInit 
 xreset ;
 
: _ { LA RA | t R -- R }    | cut Arthur Whitney's def .
 LA RA 2refs+
 LA i# cellVecInit to R  RA @ lto t
 R i# 1- 0 ?do LA i i@ LA i 1+ i@           | for all but last sec
   swap - t VecInit refs+> R i i!
    LA obbody t CASE
     TypeB OF
  loop
   LA RA 2refs- ;

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


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

: ,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	| initialize dictionary

" dic " drop value `dic
 
: cL         { l0 l1 | n0 n1 adr -- adr }               | catinate Lists
   l0 @  l1 @  or  if l0 @ l1 @ = 1852796515 * throw then	| "nonc"
  | at least one arg must be enclosed or must be dif types .
  | unenclosed is added as single item
   l0 ?enc if  l0 i#  else  1  then lto n0
   l1 ?enc if  l1 i#  else  1  then lto n1
 
   n0 n1 + cellVecInit lto adr
  l0 ?enc if l0 i# 0 ?do l0 i i@ refs+> adr i i! loop
          else  l0 refs+> adr obbody !  then
   l1 ?enc if l1 i# 0 ?do l1 i i@ refs+> adr n0 i + i! loop
          else l1 refs+> adr n0 i! then
     | l0 l1 n0 n1 .s reset  | debugging 
	  adr ;

: cLr ( p0 l1 -- )		| catinate lists , replace pointed to  
  over @ swap cL swap rplc ;


  
0 [IF]   | STOP COMPILING \/ \/ |  
: apnditem { lst itm | nwlst -- nwlst )  | for enc lsts
   obsize cell+ cellVecInit to lst      | resize abort" resize failure " | will likely fail
   cell+ incr dup i# 1-
[THEN]	| RESTART COMPILING /\ /\ |


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


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

	
: csasgn  ( adr ; name -- encVadr ) | CoSy assign
  sym swap ,l ;


| : reasgn ( addr name vadr0 -- )       

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

0 [IF]

 t0 @ sym Q0 cL >t0  t0 @ sym Q1 cL >t0  t0 @ dup cL >t0  t0 @ dup enc  cL >t0



: 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


: strmatch { s0 s1 -- 0|1 }     | match obj str , I-logic .
  s0 oban  s1 oban 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 rplc ;

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

: iprt  ['] . eachM ;   ( iv -- )   | list contents of Int vec .

: 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

))


0 [IF]   | STOP COMPILING \/ \/ |  

((
   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 ;
))

((  | quite messed up 

0 value buf  0 value bpos
: allocBuf 100 K* allocate to buf  0 to bpos ;

 defer (storelst)
: storelst ( lst -- clst cells )    | convert allocated list to linear form
  allocBuf  (storelst)
  buf bpos resize abort" resize failure "  bpos ;

 :: ( lst -- )
   dup @ 0<> if lst obsize 
              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)

: 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 free ;

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

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



| ------
 


\ INTERPRETER \/ \/ \/ \

 \ Intrinsic types ; need no further structure
s" nil" drop value nil
s" pars" drop value pars


s"  " str cs-> INP
v0 refs+> value Parsed

: bl= bl = negate ;

\ : CSparse  ( str -- )
\  INP



\ INTERPRETER \ /\ /\ /\ /\ \

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

))

\ | base @ decimal  CR ldt   base !


cr  .( ln 635 )

hex

anew C0
\   TEST

\  sym i10 >r1  a iota >r2

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

((              \ /\ END OF COMPILED SECTION /\

))

variable lastloc  

: loc ( args locs -- ) 
  2dup + 2 + 

[THEN]
