\ \ mark golden 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 /\ ---- : @+ @ 1+ ; \ recommended by Charles Moore \ http://www.ultratechnology.com/rmvideo.htm 990522 : 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 : >> $10 dump ; : >>> $20 dump ; : 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 0I 1 + constant 0N : hw! ( n adr -- ) \ store 16 bit value in hi word of cell 2 + w! ; \ not needed : swap 10 lshift over w@ or swap ! ; : hw@ @ hiword ; (( / commented out : ~DO { n0 n1 | inc -- } 2dup - sign to inc \ automatic inc , dec ?DO )) cr .( 2003 12 17 4 37 40 ) \ | +stackmon \ | : wv wview ; : .D base @ >r decimal . r> base ! ; \ . output decimal \ | : dt SYSTIME&DATE 6 0 DO U. LOOP ; \ | : ldt TIME&DATE 6 0 DO U. LOOP ; anew g1 \ ==================================== \ s" nil" drop value nil s" |) " drop value |) s" (>) " drop value (>) s" (| " drop value (| 8 constant byte : alloc allocate abort" allocation failure " ; ( 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 free abort" free failure " ; (( : abortFree" ( adr F -- adr | free & abort ) if free 1 abort" )) \ | ALIAS: ` addr 0 alloc value r1 : >r1 ( ob -- ob ) \ Temp handle holder . Frees old value when assigned new r1 freeA dup to r1 ; 0 alloc value r2 : >r2 ( ob -- ob ) \ Another Temp handle holder . r2 freeA dup to r2 ; : rplc ( `p0 new -- ) \ free and replace pointer at `p0 over @ freeA swap ! ; : 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 . : bits! `BnR hw! ; : bits@ `BnR hw@ ; : refs! `BnR w! ; : refs@ `BnR w@ ; : refs+ `BnR 1 swap w+! ; : refs- dup `BnR dup w@ 1 - dup \ decrement refs & free if 0 if swap w! else 2drop freeA then ; : cellVecInit ( n - objAdr ) \ make header and allocate space for n cells dup cells oballoc ( n objAdr ) dup cell+ rot swap ! \ # of items dup cell byte * over bits! \ item size in bits refs+ ; 0 cellVecInit value v0 \ empty vector v0 value dic \ initialize dictionary s" dic " drop value `dic : i# ( adr -- number_of_items ) cell + @ ; \ APL ` rho : obsize ( addr -- n ) \ # bytes in whole object , aligned dup cell+ @ swap bits@ byte / * aligned 3 cells + ; : obdup ( adr -- newadr ) dup obsize dup alloc dup >r swap cmove r> ; : obparms \ # cells and address dup cell+ @ over bits@ byte / * ; : dataddr \ obbody , # bytes dup obbody swap dup i# swap bits@ byte / * ; : 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 : intVecInit ( n - objAdr ) \ make header and allocate space for int vec of length n cellVecInit dup -1 swap ! ; \ 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 refs+ ; : str ( c-addr n -- OBadr ) \ store a string dup byteVecInit dup >r \ c-ad n Oadr obbody swap cmove r> ; : sym \ symbol bl 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! refs+ \ 8 bit bytes . obbody swap cmove r> ; : enc ( addr -- addr ) \ enclose 1 cellVecInit swap over obbody ! ; : ?enc ( lst -- Iflag ) \ return 1 if enclosed else 0 @ ~ ; : 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 : ,l ( O0 O1 -- O2 ) \ most basic catination of objects . Lisp like 2 cellVecInit dup obbody dup 4 pick swap ! 2 pick swap cell+ ! nip nip ; : cL { p0 p1 | n0 n1 adr -- adr } \ catinate Lists p0 @ 0<> p1 @ 0<> or if p0 @ p1 @ = abort" nonce " then 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 dataddr adr obbody swap move else p0 adr obbody ! then p1 ?enc if p1 dataddr adr obbody n0 cells+ swap move else p1 adr obbody n0 cells+ ! then adr ; : cLr ( `l0 p1 -- ) \ catinate lists , replace over @ swap cL 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> ; \ : si ( n - i# n ) 0 ?do i loop ; \ Stack Iota ; : acrossI { obadr fn | n r -- res } \ result returning "/" on integer lists obadr i# to n obadr obbody to obadr 0 to r n 0 ?do r obadr i cells+ @ fn execute to r loop r ; : across { obadr fn | r -- r } \ result returning "/" \ obadr i# abort" nonce : prototype " obadr 0 i@ to r obadr i# 1 ?do r obadr i i@ fn execute to r loop r ; : eachM { CSob f -- } \ `each Monadic , no result , eg , printing CSob i# 0 ?do CSob i i@ \ f CSob itemadr f execute loop ; \ 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 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 AO ; : nth ( CSob n -- CSadr ) \ `each Monadic resulting 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 ! ; )) : 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 ; (( : 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 int vec " I0 ['] + across intVecInit to I1 -1 to I1i I0 i# 0 ?do I0 i i@ 0 ?do j I1 +to I1i I1i i! loop loop I1 ; : strmatch { s0 s1 -- 0|1 } \ match obj str , I-logic . s0 dataddr s1 dataddr str= negate ; : wheresym ( str dic -- i ) 0 i@ ['] strmatch eachRightR dup >r & r> freeA dup >r 0 i@ r> freea ; : Valadr ( str -- adr of value ) dic 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 \ : csasgn ( adr ; name -- encVadr ) \ CoSy assign \ sym swap ,l enc ; \ : csasgn ( adr ; name -- : cs-> ( adr ; name -- ; dictionary entry ) csasgn dic swap cl \ newadr dic free abort" free failure " addr dic ! ; )) : dicasgn { dic nm val -- } dic 0 idx nm cLr dic 1 idx val cLr ; (( : cs-> ( adr ; name -- ; dictionary entry ) )) (( : cs-> { dic nm vl | t0 -- ; dictionary entry } BREAKPOINT dic 0 idx dup to t0 @ dup >r r@ nm cl t0 ! r> freeA dic 1 idx dup to t0 @ dup >r r@ vl cl t0 ! r> freeA ; dic sym .I s" .R " str )) (( 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 ; )) 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) : 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 \/ \/ \/ \ \ INTERPRETER \ /\ /\ /\ /\ \ \ | base @ decimal CR ldt base ! hex cr .( ln 469 ) anew C0 (( \ /\ END OF COMPILED SECTION /\ : lcd \ from Forth Primer begin swap over mod \ body dup 0= \ condition until drop . ; ))