\ 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 : 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 \ ==================================== \ 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@ over swap idx bits@ byte = if @ else c@ then ; )) : i@ idx @ ; \ index fetch , cell : i! idx ! ; \ index store , cell : ib@ idx c@ ; \ index fetch , byte : ib! idx c! ; : 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+> value ; : -> 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 / * ; -1 value TypeI : int TypeI swap ! ; \ convert type to int : int> dup TypeI 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 ! ) -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 ; : str ( c-addr n -- OBadr ) \ store a string dup byteVecInit dup >r \ c-ad n Oadr obbody swap cmove r> ; : VecInit ( n type -- ) CASE 0 OF cellVecInit endof -1 OF intVecInit endof -8 OF byteVecInit endof ENDCASE ; : 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 ; \ /\ DICTIONARY /\ ========================================== /\ \ \/ OPERATORS \/ ============================================ \/ \ Best to handle typing outside of loops . : 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 obadr ref0del r ; : scanI { RA fn | R -- R } \ scan over interger vecs . RA i# intVecInit to 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 : 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 ; : eachMbir { CSob f | CSadr -- CSadr } \ `each Monadic resulting byte in iteger out CSob i# cellVecInit to 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 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 ; : 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 \/ ============================================ \/ : 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 ; (( : _ { LA RA | t R -- R } \ cut Arthur Whitney's def . LA RA 2refs+ LA ' BL= eachMbir LA i# cellVecInit to R RA @ to 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 )) : 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 refs+> 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 refs- 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 )) : iprt ['] . eachM ; ( iv -- ) \ list contents of Int vec . : 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 \/ \/ \/ \ \ 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 ! 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 /\ ))