Menu
▾
▴
win32forth-cvs — CVS Commit List
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(70) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
(38) |
Feb
(4) |
Mar
(11) |
Apr
(49) |
May
(81) |
Jun
(65) |
Jul
(36) |
Aug
(57) |
Sep
(63) |
Oct
(57) |
Nov
(49) |
Dec
(41) |
| 2006 |
Jan
(75) |
Feb
(80) |
Mar
(10) |
Apr
(13) |
May
(100) |
Jun
(100) |
Jul
(77) |
Aug
(87) |
Sep
(80) |
Oct
(124) |
Nov
(39) |
Dec
(41) |
| 2007 |
Jan
(20) |
Feb
(32) |
Mar
(32) |
Apr
(43) |
May
(146) |
Jun
(40) |
Jul
(49) |
Aug
(33) |
Sep
(25) |
Oct
(19) |
Nov
(11) |
Dec
(8) |
| 2008 |
Jan
(4) |
Feb
(11) |
Mar
(31) |
Apr
(40) |
May
(34) |
Jun
(24) |
Jul
(39) |
Aug
(104) |
Sep
(27) |
Oct
(35) |
Nov
(34) |
Dec
(97) |
| 2009 |
Jan
(75) |
Feb
(29) |
Mar
(45) |
Apr
(76) |
May
(121) |
Jun
(103) |
Jul
(67) |
Aug
(28) |
Sep
(22) |
Oct
(39) |
Nov
(9) |
Dec
(15) |
| 2010 |
Jan
(7) |
Feb
(39) |
Mar
(40) |
Apr
(57) |
May
(67) |
Jun
(69) |
Jul
(49) |
Aug
(68) |
Sep
(22) |
Oct
(7) |
Nov
(2) |
Dec
(10) |
| 2011 |
Jan
|
Feb
|
Mar
(10) |
Apr
(4) |
May
(6) |
Jun
(10) |
Jul
(16) |
Aug
(23) |
Sep
(9) |
Oct
|
Nov
(28) |
Dec
(3) |
| 2012 |
Jan
(11) |
Feb
(10) |
Mar
(1) |
Apr
|
May
(4) |
Jun
(3) |
Jul
(3) |
Aug
(4) |
Sep
(2) |
Oct
|
Nov
|
Dec
(1) |
| 2013 |
Jan
|
Feb
(7) |
Mar
(30) |
Apr
(4) |
May
(4) |
Jun
(8) |
Jul
(10) |
Aug
(4) |
Sep
|
Oct
(2) |
Nov
(24) |
Dec
(13) |
| 2014 |
Jan
(7) |
Feb
(2) |
Mar
|
Apr
(1) |
May
(9) |
Jun
|
Jul
(3) |
Aug
(9) |
Sep
|
Oct
(2) |
Nov
|
Dec
(3) |
| 2015 |
Jan
(4) |
Feb
(2) |
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
(1) |
Oct
(4) |
Nov
(7) |
Dec
(39) |
| 2016 |
Jan
(17) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(1) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(1) |
Dec
(2) |
| 2017 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(1) |
Jun
(2) |
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
|
Dec
(2) |
| 2018 |
Jan
|
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2019 |
Jan
|
Feb
|
Mar
(1) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2022 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
(1) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
| 2025 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Dirk B. <db...@us...> - 2006-10-28 09:07:11
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv21373/src/kernel Modified Files: gkernel.f Log Message: Ported: block.f, ctype.f, enum.f, soundvolume.f, array.f and binsearch.f Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.21 retrieving revision 1.22 diff -C2 -d -r1.21 -r1.22 *** gkernel.f 24 Oct 2006 13:30:46 -0000 1.21 --- gkernel.f 28 Oct 2006 09:07:08 -0000 1.22 *************** *** 569,573 **** : sp! ( addr -- ) \ set stack to pointer ! (comp-only) compilation> drop _sp! (copy-code) ; 1 0 in/out --- 569,573 ---- : sp! ( addr -- ) \ set stack to pointer ! (comp-only) compilation> drop _sp! (copy-code) ; 1 0 in/out *************** *** 2159,2169 **** 0 dp-link ! ! create kdp 0 , 0 , 0 , dp-link link, ," syscode" \ system code (aka kode) ! create sdp 0 , 0 , 0 , dp-link link, ," sys" \ system ! create adp 0 , 0 , 0 , dp-link link, ," app" \ application create cdp 0 , 0 , 0 , dp-link link, ," appcode" \ code adp value dp \ data pointer defaults to app space cdp value xdp \ xdp is the default code pointer \ ----------------- Switching section areas -------------------- --- 2159,2171 ---- 0 dp-link ! ! create kdp 0 , 0 , 0 , dp-link link, ," syscode" \ system code (aka kode) ! create sdp 0 , 0 , 0 , dp-link link, ," sys" \ system ! create adp 0 , 0 , 0 , dp-link link, ," app" \ application create cdp 0 , 0 , 0 , dp-link link, ," appcode" \ code adp value dp \ data pointer defaults to app space cdp value xdp \ xdp is the default code pointer + dp value odp + xdp value oxdp \ ----------------- Switching section areas -------------------- *************** *** 2172,2177 **** \ \ IN-xxxx is used in open code to switch HERE ALLOT , W, etc to point ! \ to the specific data area; no save is made of the current DP, so ! \ it has to be reset back explicitly. \ \ >XXXX and XXXX> move to and from a specific data area, and save the --- 2174,2179 ---- \ \ IN-xxxx is used in open code to switch HERE ALLOT , W, etc to point ! \ to the specific data area; the current DP is saved in ODP, so ! \ it can be reseted using IN-PREVIOUS. \ \ >XXXX and XXXX> move to and from a specific data area, and save the *************** *** 2180,2187 **** : get-section ( -- n m ) dp xdp ; ! : set-section ( n m -- ) to xdp to dp ; ! : in-application ( -- ) adp cdp set-section ; \ set the correct pointers ! : in-system ( -- ) sdp kdp set-section ; : in-app? ( -- f ) dp adp = ; \ if the dp is set to adp --- 2182,2199 ---- : get-section ( -- n m ) dp xdp ; ! : save-section ( -- ) get-section to oxdp to odp ; ! : set-section ( n m -- ) save-section to xdp to dp ; ! : in-application ( -- ) \ w32f ! \ *G Activate the application data area. ! adp cdp set-section ; ! ! : in-system ( -- ) \ w32f ! \ *G Activate the system data area. ! sdp kdp set-section ; ! ! : in-previous ( -- ) \ w32f ! \ *G Restore the data area after a call to IN-APPLICATION or IN-SYSTEM. ! odp oxdp set-section ; : in-app? ( -- f ) dp adp = ; \ if the dp is set to adp *************** *** 2385,2398 **** >ct dup @ \ ( xt1 ct ct ) dup ['] execute = if \ can't set if execute (immediate) ! throw_ctexecute throw ! then ['] compile, = if \ it's a standard word cell- \ set the compile action (comp) then ! ; ! : compiles-last ( xt -- ) latestxt @ (compiles-set) ; \ sets xt as compilation for last name ! : compiles-for ( xt <name> -- ) ' (compiles-set) ; \ parsing; set the compilation word --- 2397,2410 ---- >ct dup @ \ ( xt1 ct ct ) dup ['] execute = if \ can't set if execute (immediate) ! throw_ctexecute throw ! then ['] compile, = if \ it's a standard word cell- \ set the compile action (comp) then ! ; ! : compiles-last ( xt -- ) latestxt @ (compiles-set) ; \ sets xt as compilation for last name ! : compiles-for ( xt <name> -- ) ' (compiles-set) ; \ parsing; set the compilation word *************** *** 2445,2459 **** ['] (comp-cons) compiles-last \ make the defined word compile this ; ! : (comp-create) ( xt -- ) >body postpone literal ; 0 1 in/out : create ( -<name>- ) \ pointer ['] dovar dogen ! \ ['] (comp-create) compiles-last \ doesn't work because of DOES> needs fixed ; 0 1 in/out : variable ( "name") \ compile time ( -- n ) \ run time ! create 0 , ['] (comp-cons) compiles-last ; --- 2457,2471 ---- ['] (comp-cons) compiles-last \ make the defined word compile this ; ! : (comp-create) ( xt -- ) >body postpone literal ; 0 1 in/out : create ( -<name>- ) \ pointer ['] dovar dogen ! \ ['] (comp-create) compiles-last \ doesn't work because of DOES> needs fixed ; 0 1 in/out : variable ( "name") \ compile time ( -- n ) \ run time ! create 0 , ['] (comp-cons) compiles-last ; *************** *** 4162,4166 **** : sempty? ( stack -- f ) \ check if empty sdepth 0= ; ! : spop ( stack -- x ) \ pop off stack dup sempty? throw_auxstacku ?throw --- 4174,4178 ---- : sempty? ( stack -- f ) \ check if empty sdepth 0= ; ! : spop ( stack -- x ) \ pop off stack dup sempty? throw_auxstacku ?throw *************** *** 4541,4550 **** |: ;noname ( -- ) \ ; for :noname ! (;noname) postpone unnest \ extra ret to stop see (ret ret is end of definition) latestxt @ ; \ return the xt |: ;name ( -- ) \ ; for : ! (;noname) ofa-calc \ length calculation postpone unnest \ extra ret to stop see (ret ret is end of definition) --- 4553,4562 ---- |: ;noname ( -- ) \ ; for :noname ! (;noname) postpone unnest \ extra ret to stop see (ret ret is end of definition) latestxt @ ; \ return the xt |: ;name ( -- ) \ ; for : ! (;noname) ofa-calc \ length calculation postpone unnest \ extra ret to stop see (ret ret is end of definition) *************** *** 4662,4666 **** execute r> handler ! ! r>drop r>drop r>drop --- 4674,4678 ---- execute r> handler ! ! r>drop r>drop r>drop *************** *** 4691,4695 **** : abort" ( n -<string">- -- ) ! (comp-only) compilation> drop postpone if --- 4703,4707 ---- : abort" ( n -<string">- -- ) ! (comp-only) compilation> drop postpone if |
|
From: Dirk B. <db...@us...> - 2006-10-28 09:07:11
|
Update of /cvsroot/win32forth/win32forth-stc/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv21373/demos Added Files: BANNER.BLK Log Message: Ported: block.f, ctype.f, enum.f, soundvolume.f, array.f and binsearch.f --- NEW FILE: BANNER.BLK --- \ \ BANNER.SEQ Compliments of F83X mod to sequential by Tom Z CREATE CHAR-MATRIX \ build the character generator HEX ( ) 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, ( !) 20 C, 20 C, 20 C, 20 C, 20 C, 00 C, 20 C, 00 C, ( ") 50 C, 50 C, 50 C, 00 C, 00 C, 00 C, 00 C, 00 C, ( #) 50 C, 50 C, F8 C, 50 C, F8 C, 50 C, 50 C, 00 C, ( $) 20 C, 78 C, A0 C, 70 C, 28 C, F0 C, 20 C, 00 C, ( %) C0 C, C8 C, 10 C, 20 C, 40 C, 98 C, 18 C, 00 C, ( &) 40 C, A0 C, A0 C, 40 C, A8 C, 90 C, 68 C, 00 C, ( ') 30 C, 30 C, 10 C, 20 C, 00 C, 00 C, 00 C, 00 C, ( () 20 C, 40 C, 80 C, 80 C, 80 C, 40 C, 20 C, 00 C, ( ) 20 C, 10 C, 08 C, 08 C, 08 C, 10 C, 20 C, 00 C, ( *) 20 C, a8 C, 70 C, 20 C, 70 C, a8 C, 20 C, 00 C, \ ( +) 00 C, 20 C, 20 C, 70 C, 20 C, 20 C, 00 C, 00 C, ( ,) 00 C, 00 C, 00 C, 30 C, 30 C, 10 C, 20 C, 00 C, ( -) 00 C, 00 C, 00 C, 70 C, 00 C, 00 C, 00 C, 00 C, ( .) 00 C, 00 C, 00 C, 00 C, 00 C, 30 C, 30 C, 00 C, ( /) 00 C, 08 C, 10 C, 20 C, 40 C, 80 C, 00 C, 00 C, ( 0) 70 C, 88 C, 98 C, A8 C, C8 C, 88 C, 70 C, 00 C, ( 1) 20 C, 60 C, 20 C, 20 C, 20 C, 20 C, 70 C, 00 C, ( 2) 70 C, 88 C, 08 C, 30 C, 40 C, 80 C, F8 C, 00 C, ( 3) F8 C, 10 C, 20 C, 30 C, 08 C, 88 C, 70 C, 00 C, ( 4) 10 C, 30 C, 50 C, 90 C, F8 C, 10 C, 10 C, 00 C, ( 5) F8 C, 80 C, F0 C, 08 C, 08 C, 88 C, 70 C, 00 C, ( 6) 38 C, 40 C, 80 C, F0 C, 88 C, 88 C, 70 C, 00 C, ( 7) F8 C, 08 C, 10 C, 20 C, 40 C, 40 C, 40 C, 00 C, ( 8) 70 C, 88 C, 88 C, 70 C, 88 C, 88 C, 70 C, 00 C, \ ( 9) 70 C, 88 C, 88 C, 78 C, 08 C, 10 C, E0 C, 00 C, ( :) 00 C, 60 C, 60 C, 00 C, 60 C, 60 C, 00 C, 00 C, ( ;) 00 C, 60 C, 60 C, 00 C, 60 C, 60 C, 40 C, 00 C, ( <) 10 C, 20 C, 40 C, 80 C, 40 C, 20 C, 10 C, 00 C, ( =) 00 C, 00 C, F8 C, 00 C, F8 C, 00 C, 00 C, 00 C, ( >) 40 C, 20 C, 10 C, 08 C, 10 C, 20 C, 40 C, 00 C, ( ?) 70 C, 88 C, 10 C, 20 C, 20 C, 00 C, 20 C, 00 C, ( @) 70 C, 88 C, A8 C, B8 C, B0 C, 80 C, 78 C, 00 C, ( A) 20 C, 70 C, 88 C, 88 C, F8 C, 88 C, 88 C, 00 C, ( B) F0 C, 88 C, 88 C, F0 C, 88 C, 88 C, F0 C, 00 C, ( C) 70 C, 88 C, 80 C, 80 C, 80 C, 88 C, 70 C, 00 C, ( D) F0 C, 48 C, 48 C, 48 C, 48 C, 48 C, F0 C, 00 C, ( E) F8 C, 80 C, 80 C, F0 C, 80 C, 80 C, F8 C, 00 C, ( F) F8 C, 80 C, 80 C, F0 C, 80 C, 80 C, 80 C, 00 C, \ ( G) 78 C, 80 C, 80 C, 80 C, 98 C, 88 C, 78 C, 00 C, ( H) 88 C, 88 C, 88 C, F8 C, 88 C, 88 C, 88 C, 00 C, ( I) 70 C, 20 C, 20 C, 20 C, 20 C, 20 C, 70 C, 00 C, ( J) 08 C, 08 C, 08 C, 08 C, 08 C, 88 C, 78 C, 00 C, ( K) 88 C, 90 C, A0 C, C0 C, A0 C, 90 C, 88 C, 00 C, ( L) 80 C, 80 C, 80 C, 80 C, 80 C, 80 C, F8 C, 00 C, ( M) 88 C, D8 C, A8 C, A8 C, 88 C, 88 C, 88 C, 00 C, ( N) 88 C, 88 C, C8 C, A8 C, 98 C, 88 C, 88 C, 00 C, ( O) 70 C, 88 C, 88 C, 88 C, 88 C, 88 C, 70 C, 00 C, ( P) F0 C, 88 C, 88 C, F0 C, 80 C, 80 C, 80 C, 00 C, ( Q) 70 C, 88 C, 88 C, 88 C, A8 C, 90 C, 68 C, 00 C, ( R) F0 C, 88 C, 88 C, F0 C, A0 C, 90 C, 88 C, 00 C, ( S) 70 C, 88 C, 80 C, 70 C, 08 C, 88 C, 70 C, 00 C, ( T) F8 C, 20 C, 20 C, 20 C, 20 C, 20 C, 20 C, 00 C, \ ( U) 88 C, 88 C, 88 C, 88 C, 88 C, 88 C, 70 C, 00 C, ( V) 88 C, 88 C, 88 C, 88 C, 88 C, 50 C, 20 C, 00 C, ( W) 88 C, 88 C, 88 C, A8 C, A8 C, D8 C, 88 C, 00 C, ( X) 88 C, 88 C, 50 C, 20 C, 50 C, 88 C, 88 C, 00 C, ( Y) 88 C, 88 C, 50 C, 20 C, 20 C, 20 C, 20 C, 00 C, ( Z) F8 C, 08 C, 10 C, 20 C, 40 C, 80 C, F8 C, 00 C, ( [) 78 C, 40 C, 40 C, 40 C, 40 C, 40 C, 78 C, 00 C, ( \) 00 C, 80 C, 40 C, 20 C, 10 C, 08 C, 00 C, 00 C, ( ]) F0 C, 10 C, 10 C, 10 C, 10 C, 10 C, F0 C, 00 C, ( ^) 00 C, 00 C, 20 C, 50 C, 88 C, 00 C, 00 C, 00 C, ( _) 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, F8 C, DECIMAL CREATE BITS ( --- a1 ) 128 C, 64 C, 32 C, 16 C, 8 C, 4 C, 2 C, 1 C, \ : BIT ( N1 --- F1 ) BITS + C@ AND 0= 1+ ; : LC>UC ( c -- ) DUP 96 128 WITHIN 32 AND - ; : BANNER ( a n -- ) BOUNDS 8 0 DO CR 2DUP ?DO I C@ 127 AND LC>UC 32 - 8 * CHAR-MATRIX + J + C@ 7 0 DO DUP I BIT IF ASCII # ELSE BL THEN EMIT LOOP DROP LOOP LOOP 2DROP ; \ : DEMO ( --- ) \ print demonstration message CLS CR s" WELCOME" BANNER s" TO FORTH" BANNER 2 SECONDS CLS CR s" BANNER" BANNER s" PROGRAM" BANNER s" FROM F83X" BANNER ; dbg DEMO |
|
From: Dirk B. <db...@us...> - 2006-10-28 09:01:10
|
Update of /cvsroot/win32forth/win32forth-stc/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19076/lib Log Message: Directory /cvsroot/win32forth/win32forth-stc/src/lib added to the repository |
|
From: Dirk B. <db...@us...> - 2006-10-28 06:34:39
|
Update of /cvsroot/win32forth/win32forth-stc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25893 Modified Files: gkernel.exe Log Message: - New gkernel.exe uploaded; now you can extend the system again after a fresh download. Index: gkernel.exe =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v retrieving revision 1.21 retrieving revision 1.22 diff -C2 -d -r1.21 -r1.22 Binary files /tmp/cvs848k8T and /tmp/cvsOpIxGX differ |
|
From: Dirk B. <db...@us...> - 2006-10-28 06:34:38
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25893/src Modified Files: optliterals.f Log Message: - New gkernel.exe uploaded; now you can extend the system again after a fresh download. Index: optliterals.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** optliterals.f 25 Oct 2006 10:13:32 -0000 1.3 --- optliterals.f 28 Oct 2006 06:34:32 -0000 1.4 *************** *** 32,35 **** --- 32,37 ---- \ ------------------------------------------------------------------------ + cr .( Loading Constants & literals optimisation ) + also optimise definitions |
|
From: George H. <geo...@us...> - 2006-10-25 10:14:25
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv456/win32forth-stc/src Modified Files: float.f optliterals.f primutil.f Log Message: gah:Optimising version of offset, improved 1/f and changed mov-eax,#n to mov-tos,#n to match gkernel.f Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** primutil.f 6 Oct 2006 16:55:59 -0000 1.12 --- primutil.f 25 Oct 2006 10:13:32 -0000 1.13 *************** *** 109,115 **** in-application : offset ( n1 <-name-> -- ) \ compiling ( n2 -- n3 ) \ runtime n3=n1+n2 ! create , does> @ + ; : field+ ( n1 n2 <-name-> -- n3 ) \ compiling n3=n1+n2 stored offset=n1 --- 109,118 ---- in-application + : (comp-offs) ( xt -- ) + 0 swap execute postpone literal postpone + ; + : offset ( n1 <-name-> -- ) \ compiling ( n2 -- n3 ) \ runtime n3=n1+n2 ! create , ['] (comp-offs) compiles-last does> @ + ; : field+ ( n1 n2 <-name-> -- n3 ) \ compiling n3=n1+n2 stored offset=n1 Index: float.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/float.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** float.f 21 Sep 2006 16:26:33 -0000 1.1 --- float.f 25 Oct 2006 10:13:32 -0000 1.2 *************** *** 883,887 **** float; ! code FNEGATE ( fs: r1 -- r2 ) fstack-check_1 >FPU --- 883,888 ---- float; ! code FNEGATE ( fs: r1 -- r2 ) \ ANSI Floating ! \ *G Reverse the sign of r1. fstack-check_1 >FPU *************** *** 890,897 **** float; ! code f2/ ( fs: r1 -- r2 ) fstack-check_1 fld1 - fchs >FPU fscale --- 891,902 ---- float; ! : 1/f ( fs: r1 -- r2 ) \ W32F Floating extra ! \ *G r2 is the reciprocal of r1. ! f1.0 fswap f/ ; ! ! code f2* ( fs: r1 -- r2 ) \ W32F Floating extra ! \ *G Multiply by 2. fstack-check_1 fld1 >FPU fscale *************** *** 900,906 **** float; ! code f2* ( fs: r1 -- r2 ) \ ? overflow error fstack-check_1 fld1 >FPU fscale --- 905,913 ---- float; ! code f2/ ( fs: r1 -- r2 ) \ W32F Floating extra ! \ *G Divide by 2. fstack-check_1 fld1 + fchs >FPU fscale *************** *** 909,913 **** float; ! code FABS ( fs: r1 -- r2 ) fstack-check_1 >FPU --- 916,921 ---- float; ! code FABS ( fs: r1 -- r2 ) \ ANSI Floating ext ! \ *G r2 is the absolute value of r1. fstack-check_1 >FPU *************** *** 1379,1391 **** external - \ rbs January 26th, 2003 --> - \ : F** ( F: r1 r2 -- r3 ) - \ fdup fround fdup f>s f- \ r1 r4 - \ fdup f0= 0= - \ IF \ non-zero fractional part of exponent - \ fover fabs fln f* fexp fswap f**n f* - \ ELSE fdrop f**n - \ THEN ; - : f** ( F: r1 r2 -- r3 ) fswap fln f* fexp ; --- 1387,1390 ---- *************** *** 1469,1473 **** LOOP drop r> true ; ! ' rep-normal alias rep-denormal ( addr u -- n true ) ( f: r -- ) --- 1468,1472 ---- LOOP drop r> true ; ! ' rep-normal alias rep-denormal ( addr u -- n true ) ( f: r -- ) *************** *** 1918,1929 **** : f^2 fdup f* ; - \ : f^x fswap fln f* fexp ; - \ synonym f** f^x - - \ : fsqr f0.5 f** ; synonym fsqr fsqrt \ deprecated - : 1/f -1 f**n ; - : f>r r> rp@ b/float - rp! rp@ f! >r ; \ deprecated --- 1917,1922 ---- Index: optliterals.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** optliterals.f 24 Oct 2006 12:41:42 -0000 1.2 --- optliterals.f 25 Oct 2006 10:13:32 -0000 1.3 *************** *** 76,80 **** : lits>0? ( -- n ) lits sdepth ; : lits>1? ( -- n ) lits sdepth 1 > ; ! variable in-sync in-sync off \ to stop recursion in sync-code --- 76,80 ---- : lits>0? ( -- n ) lits sdepth ; : lits>1? ( -- n ) lits sdepth 1 > ; ! variable in-sync in-sync off \ to stop recursion in sync-code *************** *** 90,94 **** loop cells negate lea-ebp,n[ebp] \ adjust stack ! r> mov-eax,#n \ load eax else drop then --- 90,94 ---- loop cells negate lea-ebp,n[ebp] \ adjust stack ! r> mov-tos,#n \ load eax else drop then *************** *** 108,113 **** ' uniopt compiles-for not ' uniopt compiles-for 0<> ! ' uniopt compiles-for 0< ! ' uniopt compiles-for 0> ' uniopt compiles-for cells --- 108,113 ---- ' uniopt compiles-for not ' uniopt compiles-for 0<> ! ' uniopt compiles-for 0< ! ' uniopt compiles-for 0> ' uniopt compiles-for cells *************** *** 125,129 **** : litstart ( xt -- n ) \ drop the xt, get constant drop lits spop sync-code ; ! : opt@ ( xt -- ) lits>0? if litstart push-eax mov-eax,n else xt-inline, then ; : optc@ ( xt -- ) lits>0? if litstart push-eax movzx-eax,n else xt-inline, then ; --- 125,129 ---- : litstart ( xt -- n ) \ drop the xt, get constant drop lits spop sync-code ; ! : opt@ ( xt -- ) lits>0? if litstart push-eax mov-eax,n else xt-inline, then ; : optc@ ( xt -- ) lits>0? if litstart push-eax movzx-eax,n else xt-inline, then ; *************** *** 153,157 **** then ; ! : opt+! ( xt -- ) lits=1? if --- 153,157 ---- then ; ! : opt+! ( xt -- ) lits=1? if *************** *** 175,179 **** then ; ! ' litstack compiles-for literal ' litsync is sync-code --- 175,179 ---- then ; ! ' litstack compiles-for literal ' litsync is sync-code |
|
From: Alex M. <ale...@us...> - 2006-10-24 13:30:49
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19846 Modified Files: gkernel.f Log Message: arm: correct length of word (ofa) when locals involved Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.20 retrieving revision 1.21 diff -C2 -d -r1.20 -r1.21 *** gkernel.f 24 Oct 2006 12:41:54 -0000 1.20 --- gkernel.f 24 Oct 2006 13:30:46 -0000 1.21 *************** *** 2410,2414 **** \ ---------------------------- Defining Words -------------------------------- ! : mov-eax,#n ( n -- ) \ generate a mov eax, # n sync-code \ generate pending code $C0C7 code-w, code-, ; \ mov eax, # --- 2410,2414 ---- \ ---------------------------- Defining Words -------------------------------- ! : mov-tos,#n ( n -- ) \ generate a mov eax, # n sync-code \ generate pending code $C0C7 code-w, code-, ; \ mov eax, # *************** *** 2428,2432 **** compilation> ( -- xt ) drop postpone dup \ push on stack, generate literal ! mov-eax,#n ; : dogen ( xt <-name-> -- ) \ generate do code --- 2428,2432 ---- compilation> ( -- xt ) drop postpone dup \ push on stack, generate literal ! mov-tos,#n ; : dogen ( xt <-name-> -- ) \ generate do code *************** *** 4537,4550 **** |: (;noname) ( -- ) \ ; internal postpone exit \ this may compile _localfree - postpone unnest \ extra ret to stop see (ret ret is end of definition) postpone [ ?csp \ stop compiling, check stack ; |: ;noname ( -- ) \ ; for :noname ! (;noname) latestxt @ ; \ return the xt |: ;name ( -- ) \ ; for : ofa-calc \ length calculation ! (;noname) reveal ; \ reveal the name defer ; immediate \ changed to suit the type of colon def --- 4537,4553 ---- |: (;noname) ( -- ) \ ; internal postpone exit \ this may compile _localfree postpone [ ?csp \ stop compiling, check stack ; |: ;noname ( -- ) \ ; for :noname ! (;noname) ! postpone unnest \ extra ret to stop see (ret ret is end of definition) ! latestxt @ ; \ return the xt |: ;name ( -- ) \ ; for : + (;noname) ofa-calc \ length calculation ! postpone unnest \ extra ret to stop see (ret ret is end of definition) ! reveal ; \ reveal the name defer ; immediate \ changed to suit the type of colon def |
|
From: Alex M. <ale...@us...> - 2006-10-24 12:41:57
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv30803 Modified Files: gkernel.f gkernext.f gmeta-compiler.f Log Message: arm: prepare for stack effect handling in optimisation code; rename STK- to STE- (stack effects) to avoid confusion with stack words Index: gmeta-compiler.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** gmeta-compiler.f 23 Oct 2006 14:28:58 -0000 1.7 --- gmeta-compiler.f 24 Oct 2006 12:41:54 -0000 1.8 *************** *** 1107,1111 **** : in/out ( n m -- ) 2dup ! stk-o ! stk-i ! last-h @ n>ste dup>r 1+ tsys-c! r> tsys-c! ; --- 1107,1111 ---- : in/out ( n m -- ) 2dup ! ste-o ! ste-i ! last-h @ n>ste dup>r 1+ tsys-c! r> tsys-c! ; Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.19 retrieving revision 1.20 diff -C2 -d -r1.19 -r1.20 *** gkernel.f 23 Oct 2006 17:08:20 -0000 1.19 --- gkernel.f 24 Oct 2006 12:41:54 -0000 1.20 *************** *** 171,180 **** 93 method ! ste: byte 1 stk-i effects input ! byte 2 stk-o effects output -ve indicates stack effects are unknown. ! ofa: msb 15 immediate flag (superceded by ct?) ! lsb 14-0 length of the xt code field ffa: dword ptr to the filename where this xt defined. --- 171,179 ---- 93 method ! ste: byte 1 ste-i effects input ! byte 2 ste-o effects output -ve indicates stack effects are unknown. ! ofa: 15-0 length of the xt code field ffa: dword ptr to the filename where this xt defined. *************** *** 523,526 **** --- 522,526 ---- code ?dup ( n -- n [n] ) \ duplicate top of data stack if non-zero + 1 -1 in/out test eax, eax je short @@1 *************** *** 550,554 **** 0 1 in/out mov -4 [ebp], eax ! stk-adjust mov eax, ebp next; --- 550,554 ---- 0 1 in/out mov -4 [ebp], eax ! ste-adjust mov eax, ebp next; *************** *** 568,573 **** ;g ! 1 0 in/out : sp! ( addr -- ) \ set stack to pointer ! (comp-only) compilation> drop _sp! (copy-code) ; --- 568,574 ---- ;g ! : sp! ( addr -- ) \ set stack to pointer ! (comp-only) compilation> drop _sp! (copy-code) ; ! 1 0 in/out *************** *** 578,583 **** ;g ! 1 0 in/out : rp! ( addr -- ) \ set rstack to pointer (comp-only) compilation> drop _rp! (copy-code) ; gcode _>r \ push n onto the rstack --- 579,585 ---- ;g ! : rp! ( addr -- ) \ set rstack to pointer (comp-only) compilation> drop _rp! (copy-code) ; + 1 0 in/out gcode _>r \ push n onto the rstack *************** *** 587,592 **** ;g ! 1 0 in/out : >r ( n -- ) ( r: -- n ) \ push n onto the rstack (comp-only) compilation> drop _>r (copy-code) ; gcode _r> \ pop n off the rstack --- 589,595 ---- ;g ! : >r ( n -- ) ( r: -- n ) \ push n onto the rstack (comp-only) compilation> drop _>r (copy-code) ; + 1 0 in/out gcode _r> \ pop n off the rstack *************** *** 596,601 **** ;g ! 0 1 in/out : r> ( -- n ) ( r: n -- ) \ pop n off the rstack (comp-only) compilation> drop _r> (copy-code) ; gcode _r@ \ fetch value from rstack --- 599,605 ---- ;g ! : r> ( -- n ) ( r: n -- ) \ pop n off the rstack (comp-only) compilation> drop _r> (copy-code) ; + 0 1 in/out gcode _r@ \ fetch value from rstack *************** *** 605,610 **** ;g ! 0 1 in/out : r@ ( -- n ) ( r: n -- n ) \ fetch value from rstack (comp-only) compilation> drop _r@ (copy-code) ; gcode _dup>r \ push a copy of n1 onto the rstack --- 609,615 ---- ;g ! : r@ ( -- n ) ( r: n -- n ) \ fetch value from rstack (comp-only) compilation> drop _r@ (copy-code) ; + 0 1 in/out gcode _dup>r \ push a copy of n1 onto the rstack *************** *** 612,617 **** ;g ! 1 1 in/out : dup>r ( n -- n ) ( r: -- n ) \ push a copy of n1 onto the rstack (comp-only) compilation> drop _dup>r (copy-code) ; gcode _r>drop \ discard one item off of the rstack --- 617,623 ---- ;g ! : dup>r ( n -- n ) ( r: -- n ) \ push a copy of n1 onto the rstack (comp-only) compilation> drop _dup>r (copy-code) ; + 1 1 in/out gcode _r>drop \ discard one item off of the rstack *************** *** 619,624 **** ;g ! 0 0 in/out : r>drop ( -- ) ( r: n -- ) \ discard one item off of the rstack (comp-only) compilation> drop _r>drop (copy-code) ; gcode _2>r \ push two items onto the rstack --- 625,631 ---- ;g ! : r>drop ( -- ) ( r: n -- ) \ discard one item off of the rstack (comp-only) compilation> drop _r>drop (copy-code) ; + 0 0 in/out gcode _2>r \ push two items onto the rstack *************** *** 629,634 **** ;g ! 2 0 in/out : 2>r ( n1 n2 -- ) ( r: -- n1 n2 ) \ push two items onto the rstack (comp-only) compilation> drop _2>r (copy-code) ; gcode _2r> \ pop two items off the rstack --- 636,642 ---- ;g ! : 2>r ( n1 n2 -- ) ( r: -- n1 n2 ) \ push two items onto the rstack (comp-only) compilation> drop _2>r (copy-code) ; + 2 0 in/out gcode _2r> \ pop two items off the rstack *************** *** 639,644 **** ;g ! 0 2 in/out : 2r> ( -- n1 n2 ) ( r: n1 n2 -- ) \ pop two items off the rstack (comp-only) compilation> drop _2r> (copy-code) ; gcode _2r@ \ fetch top two items on the rstack --- 647,653 ---- ;g ! : 2r> ( -- n1 n2 ) ( r: n1 n2 -- ) \ pop two items off the rstack (comp-only) compilation> drop _2r> (copy-code) ; + 0 2 in/out gcode _2r@ \ fetch top two items on the rstack *************** *** 650,655 **** ;g ! 0 2 in/out : 2r@ ( -- n1 n2 ) ( r: n1 n2 -- n1 n2 ) \ fetch top two items on the rstack (comp-only) compilation> drop _2r@ (copy-code) ; code n>r ( ... n -- r: ... n ) \ move from stack to rstack --- 659,665 ---- ;g ! : 2r@ ( -- n1 n2 ) ( r: n1 n2 -- n1 n2 ) \ fetch top two items on the rstack (comp-only) compilation> drop _2r@ (copy-code) ; + 0 2 in/out code n>r ( ... n -- r: ... n ) \ move from stack to rstack *************** *** 704,716 **** ;g ! 1 1 in/out : _localallocp ( len -- addr ) \ allocate local on rstack (comp-only) compilation> drop __localalloc (copy-code) ; ! 1 1 in/out : _localalloc ( len -- addr ) \ allocate local on rstack (comp-only) compilation> drop __localsave (copy-code) __localalloc (copy-code) ; ! 0 0 in/out : _localfree ( -- ) \ allocate local on rstack (comp-only) compilation> drop __localfree (copy-code) ; \ -------------------- Double Stack Operators ------------------------- --- 714,729 ---- ;g ! : _localallocp ( len -- addr ) \ allocate local on rstack (comp-only) compilation> drop __localalloc (copy-code) ; + 1 1 in/out ! : _localalloc ( len -- addr ) \ allocate local on rstack (comp-only) compilation> drop __localsave (copy-code) __localalloc (copy-code) ; + 1 1 in/out ! : _localfree ( -- ) \ allocate local on rstack (comp-only) compilation> drop __localfree (copy-code) ; + 0 0 in/out \ -------------------- Double Stack Operators ------------------------- *************** *** 5162,5166 **** \ it's in eax.) \ (Step 3) ! \ If there are any uninitialised locals (localstk-localsi>0) then rstack \ space is reserved by subtracting from esp (the stack grows down). \ (Step 4) --- 5175,5179 ---- \ it's in eax.) \ (Step 3) ! \ If there are any uninitialised locals (localste-localsi>0) then rstack \ space is reserved by subtracting from esp (the stack grows down). \ (Step 4) Index: gkernext.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernext.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gkernext.f 21 Sep 2006 16:26:33 -0000 1.1 --- gkernext.f 24 Oct 2006 12:41:54 -0000 1.2 *************** *** 41,52 **** get-current also forth definitions ! variable stk-i -1 stk-i ! \ # of input cells, -ve is unknown ! variable stk-o -1 stk-o ! \ # of output cells, -ve is unknown ! : stk-reset ( -- ) \ reset stack effects ! -1 stk-i ! -1 stk-o ! ; ! : stk-adjust ( -- ) \ generate adjustment offset ! stk-i @ stk-o @ 2dup or 0< not -rot - cells and \ zero if either -ve dup if >r --- 41,55 ---- get-current also forth definitions ! variable ste-i -1 ste-i ! \ # of input cells, -ve is unknown ! variable ste-o -1 ste-o ! \ # of output cells, -ve is unknown ! : ste-reset ( -- ) \ reset stack effects ! ste-i on ste-o on ; ! : ste-zero ( -- ) \ zero stack effects ! ste-i off ste-o off ; ! ! : ste-adjust ( -- ) \ generate adjustment offset ! ste-i @ ste-o @ 2dup or 0< not -rot - cells and \ zero if either -ve dup if >r *************** *** 54,72 **** lea ebp, r@ [ebp] \ !! use lea not add/sub to preserve cc ]macro r> ! then drop stk-reset \ reset ; ! : stk-calc ( in out -- ) \ calculate stack effects ! 2dup or stk-i @ or stk-o @ or 0< \ if any -ve if ! 2drop stk-i on stk-o on \ set both -ve else ! over stk-o @ - dup 0> \ get in stk value if ! dup stk-i +! stk-o +! \ adjust else drop then ! swap - stk-o +! then ; --- 57,75 ---- lea ebp, r@ [ebp] \ !! use lea not add/sub to preserve cc ]macro r> ! then drop ste-reset \ reset ; ! : ste-calc ( in out -- ) \ calculate stack effects ! 2dup or ste-i @ or ste-o @ or 0< \ if any -ve if ! 2drop ste-reset \ set both -ve else ! over ste-o @ - dup 0> \ get in stk value if ! dup ste-i +! ste-o +! \ adjust else drop then ! swap - ste-o +! then ; *************** *** 81,87 **** macro: next; ( -- ) \ terminate code word ! stk-adjust \ adjust stack next c; \ and return ! stk-reset ;macro --- 84,90 ---- macro: next; ( -- ) \ terminate code word ! ste-adjust \ adjust stack next c; \ and return ! ste-reset ;macro |
|
From: Alex M. <ale...@us...> - 2006-10-24 12:41:45
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv30791 Modified Files: extend.f optliterals.f Log Message: arm: prepare for stack effect handling in optimisation code; rename STK- to STE- (stack effects) to avoid confusion with stack words Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** extend.f 23 Oct 2006 17:12:26 -0000 1.12 --- extend.f 24 Oct 2006 12:41:42 -0000 1.13 *************** *** 46,51 **** \ FLOAD src\primhash.f \ primitive hash functions for OOP later *** to be done *** - \ sys-FLOAD src\winlib.f \ windows proc and memory words *** OBSOLETE *** - \ FLOAD src\paths.f \ multi path support words *** to be done *** \ sys-FLOAD src\nforget.f \ forget words *** to be done *** \ sys-FLOAD src\dbgsrc1.f \ source level debugging support part one *** to be done *** --- 46,49 ---- *************** *** 54,68 **** - \ sys-FLOAD src\dthread.f \ display threads *** OBSOLETE *** - \ sys-FLOAD src\order.f \ vocabulary support *** OBSOLETE *** sys-FLOAD src\see.f ! \ sys-FLOAD src\ctype.f \ 'c' style character typing sys-FLOAD src\res\resforth.h \ load the headerfile with a few constants sys-FLOAD src\debug.f sys-FLOAD src\words.f FLOAD src\class.f \ ***** Object Oriented Programming Support ***** - \ FLOAD src\scrnctrl.f \ screen control words *** OBSOLETE *** FLOAD src\mapfile.f \ Windows32 file into memory mapping words - \ sys-FLOAD src\transit.f \ minimal transient support now an extra file FLOAD src\Shell.f \ load SHELL utility words FLOAD src\utils.f \ load other misc utility words --- 52,62 ---- sys-FLOAD src\see.f ! sys-FLOAD src\ctype.f \ 'c' style character typing sys-FLOAD src\res\resforth.h \ load the headerfile with a few constants sys-FLOAD src\debug.f sys-FLOAD src\words.f FLOAD src\class.f \ ***** Object Oriented Programming Support ***** FLOAD src\mapfile.f \ Windows32 file into memory mapping words FLOAD src\Shell.f \ load SHELL utility words FLOAD src\utils.f \ load other misc utility words Index: optliterals.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** optliterals.f 23 Oct 2006 14:27:32 -0000 1.1 --- optliterals.f 24 Oct 2006 12:41:42 -0000 1.2 *************** *** 41,46 **** reset-stack-chain chain-add reset-lits - variable in-sync? in-sync? off \ to stop recursion in sync-code - : mov-n[ebp],eax { n } macro[ mov n [ebp], eax ]macro ; : movzx-eax,n { addr -- } macro[ movzx eax, byte addr ]macro ; --- 41,44 ---- *************** *** 72,83 **** drop lits spush ; \ the xt is of literal, just loose it : lits=1? ( -- n ) lits sdepth 1 = ; : lits>0? ( -- n ) lits sdepth ; : lits>1? ( -- n ) lits sdepth 1 > ; : litsync ( -- ) \ called when code is about to be generated ! in-sync? @ 0= if \ recursing? ! in-sync? on \ no, so set ! lits sdepth dup if \ anything to do? lits spop >r \ save last entry (it's eax) -4 mov-n[ebp],eax \ save eax --- 70,86 ---- drop lits spush ; \ the xt is of literal, just loose it + : execpush ( xt -- ) \ execute op and save result + execute lits spush ; + : lits=1? ( -- n ) lits sdepth 1 = ; : lits>0? ( -- n ) lits sdepth ; : lits>1? ( -- n ) lits sdepth 1 > ; + variable in-sync in-sync off \ to stop recursion in sync-code + : litsync ( -- ) \ called when code is about to be generated ! in-sync @ 0= if \ recursing? ! in-sync on \ no, so set ! lits>0? dup if \ anything to do? lits spop >r \ save last entry (it's eax) -4 mov-n[ebp],eax \ save eax *************** *** 90,99 **** else drop then ! in-sync? off \ we're finished, so reset then ; - - : execpush ( xt -- ) \ execute op and save result - execute lits spush ; : uniopt ( xt -- ) \ unary ops where 1 literal; execute it --- 93,99 ---- else drop then ! in-sync off \ we're finished, so reset then ; : uniopt ( xt -- ) \ unary ops where 1 literal; execute it *************** *** 130,134 **** : optpick ( xt -- ) lits>0? if litstart push-eax cells dup if ! mov-eax,n[ebp] else drop then else xt-inline, then ; --- 130,134 ---- : optpick ( xt -- ) lits>0? if litstart push-eax cells dup if ! mov-eax,n[ebp] else drop then else xt-inline, then ; |
|
From: Alex M. <ale...@us...> - 2006-10-24 12:41:38
|
Update of /cvsroot/win32forth/win32forth-stc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv30776 Modified Files: gkernel.exe Log Message: arm: prepare for stack effect handling in optimisation code; rename STK- to STE- (stack effects) to avoid confusion with stack words Index: gkernel.exe =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v retrieving revision 1.20 retrieving revision 1.21 diff -C2 -d -r1.20 -r1.21 Binary files /tmp/cvsE1HXGZ and /tmp/cvsVxG0hl differ |
|
From: Alex M. <ale...@us...> - 2006-10-23 17:12:29
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv26453 Modified Files: extend.f Log Message: arm: add floats.f back in extend.f Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** extend.f 23 Oct 2006 14:28:50 -0000 1.11 --- extend.f 23 Oct 2006 17:12:26 -0000 1.12 *************** *** 32,36 **** 8 constant B/FLOAT \ default to 8 byte floating point numbers ! \ FLOAD src\float.f \ floating point support FLOAD src\console\keyboard.f \ function and special key constants --- 32,36 ---- 8 constant B/FLOAT \ default to 8 byte floating point numbers ! FLOAD src\float.f \ floating point support FLOAD src\console\keyboard.f \ function and special key constants |
|
From: Alex M. <ale...@us...> - 2006-10-23 17:12:22
|
Update of /cvsroot/win32forth/win32forth-stc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv26407 Modified Files: gkernel.exe Log Message: arm: add floats.f back in extend.f Index: gkernel.exe =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v retrieving revision 1.19 retrieving revision 1.20 diff -C2 -d -r1.19 -r1.20 Binary files /tmp/cvslza2I5 and /tmp/cvscriwMR differ |
|
From: Alex M. <ale...@us...> - 2006-10-23 17:08:23
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24054 Modified Files: gkernel.f Log Message: arm: corrected code generator for exit; wasn't calling sync-code Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.18 retrieving revision 1.19 diff -C2 -d -r1.18 -r1.19 *** gkernel.f 23 Oct 2006 14:28:58 -0000 1.18 --- gkernel.f 23 Oct 2006 17:08:20 -0000 1.19 *************** *** 4478,4482 **** : unnest ( -- ) \ generate a return - sync-code $c3 code-c, ; immediate --- 4478,4481 ---- *************** *** 4490,4493 **** --- 4489,4493 ---- postpone _localfree \ to unwind the stack then + sync-code \ ensure everyting generated code-here tail-call = if \ possible call/ret sequence $e9 code-here 5 - c! \ change to a jump; tail call optimise |
|
From: Alex M. <ale...@us...> - 2006-10-23 17:08:17
|
Update of /cvsroot/win32forth/win32forth-stc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24013 Modified Files: gkernel.exe Log Message: arm: corrected code generator for exit; wasn't calling sync-code Index: gkernel.exe =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v retrieving revision 1.18 retrieving revision 1.19 diff -C2 -d -r1.18 -r1.19 Binary files /tmp/cvscEfPZz and /tmp/cvs5nNp4v differ |
|
From: Alex M. <ale...@us...> - 2006-10-23 14:29:13
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22521 Modified Files: gkernel.f gmeta-compiler.f Log Message: arm: literals optimisation changes Index: gmeta-compiler.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** gmeta-compiler.f 8 Oct 2006 20:39:34 -0000 1.6 --- gmeta-compiler.f 23 Oct 2006 14:28:58 -0000 1.7 *************** *** 250,255 **** ; - in-application \ start in-application - \ ====================================================================== \ Modify assembler to place code into target --- 250,253 ---- *************** *** 258,268 **** in-code? off \ we're building in target - : stack ( n -- ) \ usage; n stack <name> - create here , cells allot ; - : spush ( x stack -- ) cell over +! @ ! ; - : spop ( stack -- x ) - dup dup @ = abort" META: aux cs stack o/flow" dup @ @ -cell rot +! ; - : -stack ( stack -- ) dup ! ; - 20 stack acs --- 256,259 ---- *************** *** 1289,1298 **** : meta-number? ( ^str -- d n ) \ an extensible version of NUMBER ! count temp$ place ! temp$ count ['] number catch if drop false else double? abort" META: Doubles not supported in meta-compiler" [ also hidden ] ! float? abort" META: Floats not supported in metacompiler" [ previous ] drop true then ; --- 1280,1289 ---- : meta-number? ( ^str -- d n ) \ an extensible version of NUMBER ! count temp$ dup>r place ! r> count ['] number catch if drop false else double? abort" META: Doubles not supported in meta-compiler" [ also hidden ] ! float? abort" META: Floats not supported in metacompiler" [ previous ] drop true then ; *************** *** 1342,1346 **** begin token find \ no locals or class words if execute ! else meta-number? if [transition] literal else drop t-in @ >in ! --- 1333,1337 ---- begin token find \ no locals or class words if execute ! else meta-number? if [transition] literal else drop t-in @ >in ! *************** *** 1368,1371 **** --- 1359,1364 ---- : : COLON: ; \ standard colon def + in-application \ start in-application + .olly Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 *** gkernel.f 8 Oct 2006 20:37:41 -0000 1.17 --- gkernel.f 23 Oct 2006 14:28:58 -0000 1.18 *************** *** 49,54 **** ------------------------------------------------------------------------ - Currently requires Win32Forth version 6.10 or greater to meta-compile. - Philosophy ---------- --- 49,52 ---- *************** *** 366,369 **** --- 364,368 ---- -340 equ throw_auxstacku \ " aux stack underflow" -341 equ throw_auxstacko \ " aux stack overflow" + -350 equ throw_ctexecute \ " ct is immediate" \ Warnings *************** *** 406,409 **** --- 405,409 ---- throw_msgs link, throw_auxstacku , ," aux stack underflow" throw_msgs link, throw_auxstacko , ," aux stack overflow" + throw_msgs link, throw_ctexecute , ," ct is immediate" \ Warnings *************** *** 2343,2350 **** : >name ( xt -- nfa ) >ct ct>name ; \ get the name - : compile-for ( xt2 <name> -- ) ' >comp! ; \ parsing; set the compilation word - - : name-compiles ( xt -- ) latestxt @ >comp! ; \ sets xt as compilation for name - \ ------------------------- Code generation words --------------------------- --- 2343,2346 ---- *************** *** 2373,2376 **** --- 2369,2387 ---- code-here to tail-call ; \ possible tail call + : (compiles-set) ( xt1 xt2 -- ) \ set the correct ct token + >ct dup @ \ ( xt1 ct ct ) + dup ['] execute = if \ can't set if execute (immediate) + throw_ctexecute throw + then + ['] compile, = if \ it's a standard word + cell- \ set the compile action (comp) + then ! ; + + : compiles-last ( xt -- ) + latestxt @ (compiles-set) ; \ sets xt as compilation for last name + + : compiles-for ( xt <name> -- ) + ' (compiles-set) ; \ parsing; set the compilation word + \ The kernel has no assembler, so there's no "postponed assembly" possible. \ To overcome this, the code is pre-assembled using "gcode" and copied *************** *** 2386,2399 **** \ ---------------------------- Defining Words -------------------------------- ! $C0C7 equ mov-eax-#n \ cheap assembler... ! $C1C7 equ mov-ecx-#n ! ! : moveax#, ( n -- ) \ generate a mov eax, # n sync-code \ generate pending code ! mov-eax-#n code-w, code-, ; \ mov eax, # ! : movecx#, ( n -- ) \ generate a mov ecx, # n sync-code \ generate pending code ! mov-ecx-#n code-w, code-, ; \ mov ecx, # 2 equ body-off \ the offset where a body is --- 2397,2407 ---- \ ---------------------------- Defining Words -------------------------------- ! : mov-eax,#n ( n -- ) \ generate a mov eax, # n sync-code \ generate pending code ! $C0C7 code-w, code-, ; \ mov eax, # ! : mov-ecx,#n ( n -- ) \ generate a mov ecx, # n sync-code \ generate pending code ! $C1C7 code-w, code-, ; \ mov ecx, # 2 equ body-off \ the offset where a body is *************** *** 2407,2422 **** compilation> ( -- xt ) drop postpone dup \ push on stack, generate literal ! moveax#, ; : dogen ( xt <-name-> -- ) \ generate do code header \ header ! here movecx#, xt-jmp, \ name -> mov ecx, # here | jmp xt ofa-calc \ length calculation _next (copy-code) ; \ stops disasm - 0 1 in/out : create ( -<name>- ) \ pointer - ['] dovar dogen - ; - : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal --- 2415,2426 ---- compilation> ( -- xt ) drop postpone dup \ push on stack, generate literal ! mov-eax,#n ; : dogen ( xt <-name-> -- ) \ generate do code header \ header ! here mov-ecx,#n xt-jmp, \ name -> mov ecx, # here | jmp xt ofa-calc \ length calculation _next (copy-code) ; \ stops disasm : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal *************** *** 2426,2436 **** ['] doval dogen , dp> ! ['] (comp-cons) name-compiles \ make the defined word compile this ; 0 1 in/out : variable ( "name") \ compile time ( -- n ) \ run time ! here 0 , constant ! ; : (comp-val) ( n -- ) --- 2430,2447 ---- ['] doval dogen , dp> ! ['] (comp-cons) compiles-last \ make the defined word compile this ! ; ! ! : (comp-create) ( xt -- ) >body postpone literal ; ! ! 0 1 in/out : create ( -<name>- ) \ pointer ! ['] dovar dogen ! \ ['] (comp-create) compiles-last \ doesn't work because of DOES> needs fixed ; 0 1 in/out : variable ( "name") \ compile time ( -- n ) \ run time ! create 0 , ! ['] (comp-cons) compiles-last ; : (comp-val) ( n -- ) *************** *** 2439,2443 **** 0 1 in/out : value ( n -<name>- ) \ self fetching value ['] doval dogen , ! ['] (comp-val) name-compiles \ make the defined word compile this ; --- 2450,2454 ---- 0 1 in/out : value ( n -<name>- ) \ self fetching value ['] doval dogen , ! ['] (comp-val) compiles-last \ make the defined word compile this ; *************** *** 3024,3028 **** "parse type compilation> drop ! [s"] postpone type ; --- 3035,3039 ---- "parse type compilation> drop ! postpone s" postpone type ; *************** *** 4133,4139 **** cell over +! @ ! ; ! : sempty? ( stack -- f ) \ check if empty ! dup @ cell- = ; : spop ( stack -- x ) \ pop off stack dup sempty? throw_auxstacku ?throw --- 4144,4153 ---- cell over +! @ ! ; ! : sdepth ( stack -- n ) ! dup @ cell- swap - 2 rshift ; + : sempty? ( stack -- f ) \ check if empty + sdepth 0= ; + : spop ( stack -- x ) \ pop off stack dup sempty? throw_auxstacku ?throw *************** *** 4154,4161 **** xor throw_mismatch ?throw ; ! : >mark ( -- addr ) code-here ; \ mark a link for later resolution by : <resolve ( orig -- ) \ fixup relative jump at orig dup code-here swap - swap cell- ! ; : >resolve ( dest -- ) \ fixup relative jump to dest code-here - code-here cell- ! ; --- 4168,4177 ---- xor throw_mismatch ?throw ; ! : >mark ( -- addr ) sync-code code-here ; \ mark a link for later resolution by : <resolve ( orig -- ) \ fixup relative jump at orig + sync-code dup code-here swap - swap cell- ! ; : >resolve ( dest -- ) \ fixup relative jump to dest + sync-code code-here - code-here cell- ! ; *************** *** 4438,4441 **** --- 4454,4458 ---- : [ ( -- ) + sync-code state off ['] (interpret-i) is (interpret) ; immediate \ turn off compiling *************** *** 4497,4500 **** --- 4514,4518 ---- : (ofa-calc) ( ofa -- ) + sync-code \ ensure all generated code-here swap - \ length of the code last @ n>ofa w! \ save length *************** *** 4538,4542 **** : : ( -<name>- -- ) \ forth's primary function defining word header hide ! ['] ;name (:noname) \ set the named ; word ; --- 4556,4560 ---- : : ( -<name>- -- ) \ forth's primary function defining word header hide ! ['] ;name (:noname) \ set the named ; word ; *************** *** 4548,4552 **** 0 to localstk \ can have its own locals cs-leave -stack \ clear the stack used for leave addresses ! code-here latestxt @ >ct ! \ make the defined word compile this ; --- 4566,4570 ---- 0 to localstk \ can have its own locals cs-leave -stack \ clear the stack used for leave addresses ! code-here latestxt @ (compiles-set) \ make the defined word compile this ; *************** *** 4586,4590 **** \ the user's code, and that it is still fetchable through >BODY. \ ! \ DOES> has a dependancy on movecx#, which generates this code; \ \ ( $...... C7C1nnnnnnnn ) mov ecx, # $nnnnnnnn --- 4604,4608 ---- \ the user's code, and that it is still fetchable through >BODY. \ ! \ DOES> has a dependancy on mov-ecx,#n which generates this code; \ \ ( $...... C7C1nnnnnnnn ) mov ecx, # $nnnnnnnn *************** *** 4782,4786 **** #wordlist dup \ wid address header code-here swap voc>vxt ! \ set the xt for this name ! movecx#, ['] dovoc xt-jmp, \ set ecx, jmp to dovoc postpone unnest postpone unnest ; --- 4800,4804 ---- #wordlist dup \ wid address header code-here swap voc>vxt ! \ set the xt for this name ! mov-ecx,#n ['] dovoc xt-jmp, \ set ecx, jmp to dovoc postpone unnest postpone unnest ; *************** *** 5454,5458 **** ' >body postpone literal postpone @ ; ! ' to alias is immediate \ is or to works with defer & value \ -------------------- Task support & initialisation ------------------------ --- 5472,5476 ---- ' >body postpone literal postpone @ ; ! ' to alias is \ immediate \ is or to works with defer & value \ -------------------- Task support & initialisation ------------------------ |
|
From: Alex M. <ale...@us...> - 2006-10-23 14:28:57
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22503 Modified Files: extend.f optinline.f Log Message: arm: literals optimisation changes Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** extend.f 6 Oct 2006 16:57:02 -0000 1.10 --- extend.f 23 Oct 2006 14:28:50 -0000 1.11 *************** *** 5,16 **** sys-fload src\primutil.f sys-fload src\module.f \ scoping support for modules sys-fload src\interpif.f \ interpretive conditionals fload src\numconv.f \ general number conversions - sys-fload src\optinline \ inline optimiser sys-fload src\486asm.f \ jim's 486 assembler sys-fload src\asmmac.f \ jim's 486 macros sys-fload src\asmwin32.f \ next for win32forth fload src\console\console.f \ console i/o extracted from primutil.f fload src\console\console2.f \ console i/o extracted from primutil.f --- 5,22 ---- sys-fload src\primutil.f + + sys-fload src\optinline \ inline optimiser + sys-fload src\module.f \ scoping support for modules sys-fload src\interpif.f \ interpretive conditionals fload src\numconv.f \ general number conversions sys-fload src\486asm.f \ jim's 486 assembler sys-fload src\asmmac.f \ jim's 486 macros sys-fload src\asmwin32.f \ next for win32forth + + sys-fload src\optliterals \ literals optimiser + + fload src\console\console.f \ console i/o extracted from primutil.f fload src\console\console2.f \ console i/o extracted from primutil.f *************** *** 26,30 **** 8 constant B/FLOAT \ default to 8 byte floating point numbers ! FLOAD src\float.f \ floating point support FLOAD src\console\keyboard.f \ function and special key constants --- 32,36 ---- 8 constant B/FLOAT \ default to 8 byte floating point numbers ! \ FLOAD src\float.f \ floating point support FLOAD src\console\keyboard.f \ function and special key constants Index: optinline.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/optinline.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** optinline.f 6 Oct 2006 12:16:23 -0000 1.2 --- optinline.f 23 Oct 2006 14:28:50 -0000 1.3 *************** *** 35,164 **** \ ------------------------------------------------------------------------ : xt-inline, ( xt -- ) \ inline the xt dup >name n>ofa \ get the length w@ copy-code ; \ and copy the code : inline ( -- ) \ code will be inlined tail-call 0= if \ there's a tail-call, so not inlineable ! ['] xt-inline, name-compiles then ; \ set some optimisation for constants in the kernel ! ' (comp-cons) compile-for false ! ' (comp-cons) compile-for true ! ' (comp-cons) compile-for null ! ' (comp-cons) compile-for cell ! ' (comp-cons) compile-for -cell ! \ set the words we will inline ! ' xt-inline, compile-for cells ! ' xt-inline, compile-for cells+ ! ' xt-inline, compile-for cells- ! ' xt-inline, compile-for cell+ ! ' xt-inline, compile-for cell- ! ' xt-inline, compile-for +cells ! ' xt-inline, compile-for -cells ! ' xt-inline, compile-for char+ ! ' xt-inline, compile-for drop ! ' xt-inline, compile-for dup ! ' xt-inline, compile-for swap ! ' xt-inline, compile-for over ! ' xt-inline, compile-for rot ! ' xt-inline, compile-for -rot ! ' xt-inline, compile-for ?dup ! ' xt-inline, compile-for nip ! ' xt-inline, compile-for tuck ! ' xt-inline, compile-for pick ! ' xt-inline, compile-for 2drop ! ' xt-inline, compile-for 2nip ! ' xt-inline, compile-for 2dup ! ' xt-inline, compile-for 2swap ! ' xt-inline, compile-for 2over ! ' xt-inline, compile-for @ ! ' xt-inline, compile-for ! ! ' xt-inline, compile-for +! ! ' xt-inline, compile-for c@ ! ' xt-inline, compile-for sc@ ! ' xt-inline, compile-for c! ! ' xt-inline, compile-for c+! ! ' xt-inline, compile-for w@ ! ' xt-inline, compile-for sw@ ! ' xt-inline, compile-for w! ! ' xt-inline, compile-for w+! ! ' xt-inline, compile-for 2@ ! ' xt-inline, compile-for 2! ! ' xt-inline, compile-for 0= ! ' xt-inline, compile-for not ! ' xt-inline, compile-for 0<> ! ' xt-inline, compile-for 0< ! ' xt-inline, compile-for 0> ! ' xt-inline, compile-for = ! ' xt-inline, compile-for <> ! ' xt-inline, compile-for < ! ' xt-inline, compile-for > ! ' xt-inline, compile-for <= ! ' xt-inline, compile-for >= ! ' xt-inline, compile-for u< ! ' xt-inline, compile-for u> ! ' xt-inline, compile-for min ! ' xt-inline, compile-for max ! ' xt-inline, compile-for 0max ! ' xt-inline, compile-for umin ! ' xt-inline, compile-for umax ! ' xt-inline, compile-for and ! ' xt-inline, compile-for or ! ' xt-inline, compile-for xor ! ' xt-inline, compile-for invert ! ' xt-inline, compile-for lshift ! ' xt-inline, compile-for rshift ! ' xt-inline, compile-for arshift ! ' xt-inline, compile-for incr ! ' xt-inline, compile-for decr ! ' xt-inline, compile-for cincr ! ' xt-inline, compile-for cdecr ! ' xt-inline, compile-for on ! ' xt-inline, compile-for off ! ' xt-inline, compile-for toggle ! ' xt-inline, compile-for d= ! ' xt-inline, compile-for d0< ! ' xt-inline, compile-for d0= ! ' xt-inline, compile-for d< ! ' xt-inline, compile-for d> ! ' xt-inline, compile-for d<> ! ' xt-inline, compile-for + ! ' xt-inline, compile-for negate ! ' xt-inline, compile-for - ! ' xt-inline, compile-for under+ ! ' xt-inline, compile-for abs ! ' xt-inline, compile-for 2* ! ' xt-inline, compile-for 2/ ! ' xt-inline, compile-for u2/ ! ' xt-inline, compile-for 1+ ! ' xt-inline, compile-for 1- ! ' xt-inline, compile-for 2+ ! ' xt-inline, compile-for 2- ! ' xt-inline, compile-for d2* ! ' xt-inline, compile-for d2/ ! ' xt-inline, compile-for um* ! ' xt-inline, compile-for um/mod ! ' xt-inline, compile-for m* ! ' xt-inline, compile-for sm/rem ! ' xt-inline, compile-for * ! ' xt-inline, compile-for /mod ! ' xt-inline, compile-for / ! ' xt-inline, compile-for mod ! ' xt-inline, compile-for */ ! ' xt-inline, compile-for */mod ! ' xt-inline, compile-for d+ ! ' xt-inline, compile-for d- ! ' xt-inline, compile-for dnegate ! ' xt-inline, compile-for s>d ! ' xt-inline, compile-for d>s ! ' xt-inline, compile-for count ! ' xt-inline, compile-for wcount ! ' xt-inline, compile-for lcount ! ' xt-inline, compile-for zcount ! ' xt-inline, compile-for perform ! ' xt-inline, compile-for bounds --- 35,175 ---- \ ------------------------------------------------------------------------ + vocabulary optimise + + also optimise definitions + : xt-inline, ( xt -- ) \ inline the xt dup >name n>ofa \ get the length w@ copy-code ; \ and copy the code + + previous definitions also optimise : inline ( -- ) \ code will be inlined tail-call 0= if \ there's a tail-call, so not inlineable ! ['] xt-inline, compiles-last then ; + definitions + \ set some optimisation for constants in the kernel ! ' (comp-cons) compiles-for bl ! ' (comp-cons) compiles-for false ! ' (comp-cons) compiles-for true ! ' (comp-cons) compiles-for null ! ' (comp-cons) compiles-for cell ! ' (comp-cons) compiles-for -cell ! \ set the words we will inline ! ' xt-inline, compiles-for cells ! ' xt-inline, compiles-for cells+ ! ' xt-inline, compiles-for cells- ! ' xt-inline, compiles-for cell+ ! ' xt-inline, compiles-for cell- ! ' xt-inline, compiles-for +cells ! ' xt-inline, compiles-for -cells ! ' xt-inline, compiles-for char+ ! ' xt-inline, compiles-for drop ! ' xt-inline, compiles-for dup ! ' xt-inline, compiles-for swap ! ' xt-inline, compiles-for over ! ' xt-inline, compiles-for rot ! ' xt-inline, compiles-for -rot ! ' xt-inline, compiles-for ?dup ! ' xt-inline, compiles-for nip ! ' xt-inline, compiles-for tuck ! ' xt-inline, compiles-for pick ! ' xt-inline, compiles-for 2drop ! ' xt-inline, compiles-for 2nip ! ' xt-inline, compiles-for 2dup ! ' xt-inline, compiles-for 2swap ! ' xt-inline, compiles-for 2over ! ' xt-inline, compiles-for @ ! ' xt-inline, compiles-for ! ! ' xt-inline, compiles-for +! ! ' xt-inline, compiles-for c@ ! ' xt-inline, compiles-for sc@ ! ' xt-inline, compiles-for c! ! ' xt-inline, compiles-for c+! ! ' xt-inline, compiles-for w@ ! ' xt-inline, compiles-for sw@ ! ' xt-inline, compiles-for w! ! ' xt-inline, compiles-for w+! ! ' xt-inline, compiles-for 2@ ! ' xt-inline, compiles-for 2! ! ' xt-inline, compiles-for 0= ! ' xt-inline, compiles-for not ! ' xt-inline, compiles-for 0<> ! ' xt-inline, compiles-for 0< ! ' xt-inline, compiles-for 0> ! ' xt-inline, compiles-for = ! ' xt-inline, compiles-for <> ! ' xt-inline, compiles-for < ! ' xt-inline, compiles-for > ! ' xt-inline, compiles-for <= ! ' xt-inline, compiles-for >= ! ' xt-inline, compiles-for u< ! ' xt-inline, compiles-for u> ! ' xt-inline, compiles-for min ! ' xt-inline, compiles-for max ! ' xt-inline, compiles-for 0max ! ' xt-inline, compiles-for umin ! ' xt-inline, compiles-for umax ! ' xt-inline, compiles-for and ! ' xt-inline, compiles-for or ! ' xt-inline, compiles-for xor ! ' xt-inline, compiles-for invert ! ' xt-inline, compiles-for lshift ! ' xt-inline, compiles-for rshift ! ' xt-inline, compiles-for arshift ! ' xt-inline, compiles-for incr ! ' xt-inline, compiles-for decr ! ' xt-inline, compiles-for cincr ! ' xt-inline, compiles-for cdecr ! ' xt-inline, compiles-for on ! ' xt-inline, compiles-for off ! ' xt-inline, compiles-for toggle ! ' xt-inline, compiles-for d= ! ' xt-inline, compiles-for d0< ! ' xt-inline, compiles-for d0= ! ' xt-inline, compiles-for d< ! ' xt-inline, compiles-for d> ! ' xt-inline, compiles-for d<> ! ' xt-inline, compiles-for + ! ' xt-inline, compiles-for negate ! ' xt-inline, compiles-for - ! ' xt-inline, compiles-for under+ ! ' xt-inline, compiles-for abs ! ' xt-inline, compiles-for 2* ! ' xt-inline, compiles-for 2/ ! ' xt-inline, compiles-for u2/ ! ' xt-inline, compiles-for 1+ ! ' xt-inline, compiles-for 1- ! ' xt-inline, compiles-for 2+ ! ' xt-inline, compiles-for 2- ! ' xt-inline, compiles-for d2* ! ' xt-inline, compiles-for d2/ ! ' xt-inline, compiles-for um* ! ' xt-inline, compiles-for um/mod ! ' xt-inline, compiles-for m* ! ' xt-inline, compiles-for sm/rem ! ' xt-inline, compiles-for * ! ' xt-inline, compiles-for /mod ! ' xt-inline, compiles-for / ! ' xt-inline, compiles-for mod ! ' xt-inline, compiles-for */ ! ' xt-inline, compiles-for */mod ! ' xt-inline, compiles-for d+ ! ' xt-inline, compiles-for d- ! ' xt-inline, compiles-for dnegate ! ' xt-inline, compiles-for s>d ! ' xt-inline, compiles-for d>s ! ' xt-inline, compiles-for count ! ' xt-inline, compiles-for wcount ! ' xt-inline, compiles-for lcount ! ' xt-inline, compiles-for zcount ! ' xt-inline, compiles-for perform ! ' xt-inline, compiles-for bounds ! ! previous definitions |
|
From: Alex M. <ale...@us...> - 2006-10-23 14:28:46
|
Update of /cvsroot/win32forth/win32forth-stc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22492 Modified Files: gkernel.exe Log Message: arm: literals optimisation changes Index: gkernel.exe =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 Binary files /tmp/cvsn7Vfnz and /tmp/cvsH5pcix differ |
|
From: Alex M. <ale...@us...> - 2006-10-23 14:27:47
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22099 Added Files: optliterals.f Log Message: arm: literals optimisation --- NEW FILE: optliterals.f --- \ $Id: optliterals.f,v 1.1 2006/10/23 14:27:32 alex_mcdonald Exp $ \ \ --------------------------- Change Block ------------------------------- \ \ \ ------------------------- End Change Block ----------------------------- \ \ Experimental: a fully optimising, STC based, ANS Forth compliant kernel \ \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) \ Dirk Busch (dirk.yahoo @ schneider-busch.de) \ George Hubert (georgeahubert at yahoo.co.uk) \ \ This program is free software; you can redistribute it and/or modify it \ under the terms of the GNU General Public License as published by the \ Free Software Foundation; either version 2 of the License, or <at your \ option> any later version. \ \ This program is distributed in the hope that it will be useful, but \ WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU \ General Public License for more details. \ \ You should have received a copy of the GNU General Public License along \ with this program; if not, write to the Free Software Foundation, Inc., \ 675 Mass Ave, Cambridge, MA 02139, USA. \ \ ------------------------------------------------------------------------ \ \ constants & literals optimisation \ \ ------------------------------------------------------------------------ also optimise definitions 100 stack lits : reset-lits ( -- ) \ clear the stack lits -stack ; reset-stack-chain chain-add reset-lits variable in-sync? in-sync? off \ to stop recursion in sync-code : mov-n[ebp],eax { n } macro[ mov n [ebp], eax ]macro ; : movzx-eax,n { addr -- } macro[ movzx eax, byte addr ]macro ; : mov-n[ebp],#n { n off } macro[ mov off [ebp], dword # n ]macro ; : lea-ebp,n[ebp] { n } macro[ lea ebp, n [ebp] ]macro ; : mov-eax,n { addr } macro[ mov eax, addr ]macro ; : mov-eax,n[ebp] { off } macro[ mov eax, off [ebp] ]macro ; : pop-eax { } 0 mov-eax,n[ebp] 4 lea-ebp,n[ebp] ; : push-eax { } -4 mov-n[ebp],eax -4 lea-ebp,n[ebp] ; : shl-eax,n { n } macro[ shl eax, n ]macro ; : shr-eax,n { n } macro[ shr eax, n ]macro ; : and-eax,#n { n } macro[ and eax, # n ]macro ; : or-eax,#n { n } macro[ or eax, # n ]macro ; : xor-eax,#n { n } macro[ xor eax, # n ]macro ; : mov-n,eax { n } macro[ mov n , eax ]macro ; : add-n,eax { n } macro[ add n , eax ]macro ; : mov-n,#n { addr n } macro[ mov addr , dword # n ]macro ; : add-n,#n { addr n } macro[ add addr , dword # n ]macro ; : add-eax,#n { n } macro[ add eax, # n ]macro ; : sub-eax,#n { n } n negate add-eax,#n ; : mov-n,al { n } macro[ mov n , al ]macro ; : mov-n,#c { addr n } macro[ mov addr , # n ]macro ; : loop-add { n } macro[ add [esp], dword # n jno 0 ]macro ; : setcc { } macro[ cmp eax, # 1 sbb eax, eax ]macro ; : litstack ( n xt -- ) \ stack literal drop lits spush ; \ the xt is of literal, just loose it : lits=1? ( -- n ) lits sdepth 1 = ; : lits>0? ( -- n ) lits sdepth ; : lits>1? ( -- n ) lits sdepth 1 > ; : litsync ( -- ) \ called when code is about to be generated in-sync? @ 0= if \ recursing? in-sync? on \ no, so set lits sdepth dup if \ anything to do? lits spop >r \ save last entry (it's eax) -4 mov-n[ebp],eax \ save eax lits sdepth 0 ?do \ do for n-1 entries lits spop over negate i + cells mov-n[ebp],#n \ generate a move loop cells negate lea-ebp,n[ebp] \ adjust stack r> mov-eax,#n \ load eax else drop then in-sync? off \ we're finished, so reset then ; : execpush ( xt -- ) \ execute op and save result execute lits spush ; : uniopt ( xt -- ) \ unary ops where 1 literal; execute it lits>0? if lits spop swap execpush else xt-inline, then ; : binopt ( xt -- ) \ binary ops where 2 literals; execute it lits>1? if lits s2pop swap rot execpush else xt-inline, then ; ' uniopt compiles-for invert ' uniopt compiles-for negate ' uniopt compiles-for 0= ' uniopt compiles-for not ' uniopt compiles-for 0<> ' uniopt compiles-for 0< ' uniopt compiles-for 0> ' uniopt compiles-for cells ' binopt compiles-for <> ' binopt compiles-for < ' binopt compiles-for > ' binopt compiles-for <= ' binopt compiles-for >= ' binopt compiles-for arshift ' binopt compiles-for * ' binopt compiles-for / : litstart ( xt -- n ) \ drop the xt, get constant drop lits spop sync-code ; : opt@ ( xt -- ) lits>0? if litstart push-eax mov-eax,n else xt-inline, then ; : optc@ ( xt -- ) lits>0? if litstart push-eax movzx-eax,n else xt-inline, then ; : optpick ( xt -- ) lits>0? if litstart push-eax cells dup if mov-eax,n[ebp] else drop then else xt-inline, then ; : opt+ ( xt -- ) lits=1? if litstart add-eax,#n else binopt then ; : opt- ( xt -- ) lits=1? if litstart sub-eax,#n else binopt then ; : optlshift ( xt -- ) lits=1? if litstart shl-eax,n else binopt then ; : optrshift ( xt -- ) lits=1? if litstart shr-eax,n else binopt then ; : optand ( xt -- ) lits=1? if litstart and-eax,#n else binopt then ; : optor ( xt -- ) lits=1? if litstart or-eax,#n else binopt then ; : optxor ( xt -- ) lits=1? if litstart xor-eax,#n else binopt then ; : opt= ( xt -- ) lits=1? if litstart sub-eax,#n setcc else binopt then ; : opt! ( xt -- ) lits=1? if litstart mov-n,eax pop-eax else lits>1? if drop lits s2pop mov-n,#n else xt-inline, then then ; : opt+! ( xt -- ) lits=1? if litstart add-n,eax pop-eax else lits>1? if drop lits s2pop add-n,#n else xt-inline, then then ; : optc! ( xt -- ) lits=1? if litstart mov-n,al pop-eax else lits>1? if drop lits s2pop mov-n,#c else xt-inline, then then ; ' litstack compiles-for literal ' litsync is sync-code ' opt+ compiles-for + ' opt- compiles-for - ' opt@ compiles-for @ ' optc@ compiles-for c@ ' optpick compiles-for pick ' optlshift compiles-for lshift ' optrshift compiles-for rshift ' optand compiles-for and ' optor compiles-for or ' optxor compiles-for xor ' opt! compiles-for ! ' opt+! compiles-for +! ' optc! compiles-for c! ' opt= compiles-for = :noname drop postpone cell postpone + ; compiles-for cell+ :noname drop postpone -cell postpone + ; compiles-for cell- :noname drop 1 postpone literal postpone + ; dup compiles-for 1+ compiles-for char+ previous definitions |
|
From: George H. <geo...@us...> - 2006-10-23 08:38:24
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13156/win32forth/apps/Win32ForthIDE Modified Files: EdCommand.f ScintillaMDI.f Log Message: gah:Added code to highlight the searched string only rather than the whole line when finding text in files. Index: EdCommand.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdCommand.f,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** EdCommand.f 13 Oct 2006 03:55:11 -0000 1.9 --- EdCommand.f 23 Oct 2006 08:38:17 -0000 1.10 *************** *** 175,178 **** --- 175,181 ---- SetFocus: ActiveBrowser SetBrowseMode: ActiveBrowser + \ find-buf count findtext$: ActiveBrowser place findtext$: ActiveBrowser +null + \ SearchNext: ActiveBrowser + find-buf FindTextinLine: ActiveBrowser Update ELSE drop beep Index: ScintillaMDI.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/ScintillaMDI.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** ScintillaMDI.f 21 Oct 2006 11:11:47 -0000 1.7 --- ScintillaMDI.f 23 Oct 2006 08:38:17 -0000 1.8 *************** *** 205,208 **** --- 205,211 ---- then ;M + :M FindTextinLine: ( adddr -- ) + SearchAnchor: ChildWindow FindMode swap 1+ SearchNext: ChildWindow drop ;M + :M GetCurrentLine: ( -- #line ) GetCurrentPos: ChildWindow *************** *** 366,370 **** ReleaseBuffer: EditFile ;m ! \ remove trailing white space char's (spaces and tabs) form the end \ of all lines in the file :M StripTrailingSpaces: { \ lineStart lineEnd -- } --- 369,373 ---- ReleaseBuffer: EditFile ;m ! \ remove trailing white space char's (spaces and tabs) from the end \ of all lines in the file :M StripTrailingSpaces: { \ lineStart lineEnd -- } *************** *** 387,391 **** LOOP ;M ! \ make shure that the last line of the file ends with a line end marker :M EnsureFinalNewLine: { \ maxLines endDoc appendNewLine -- } GetLineCount: ChildWindow to maxLines --- 390,394 ---- LOOP ;M ! \ make sure that the last line of the file ends with a line end marker :M EnsureFinalNewLine: { \ maxLines endDoc appendNewLine -- } GetLineCount: ChildWindow to maxLines |
|
From: George H. <geo...@us...> - 2006-10-21 11:11:51
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22249/win32forth/apps/Win32ForthIDE Modified Files: EdMenu.f EdRemote.f Main.f ScintillaMDI.f Log Message: gah:Fixed search previous (needs a toolbar icon for it though). Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v retrieving revision 1.31 retrieving revision 1.32 diff -C2 -d -r1.31 -r1.32 *** Main.f 21 Oct 2006 09:11:10 -0000 1.31 --- Main.f 21 Oct 2006 11:11:47 -0000 1.32 *************** *** 105,109 **** : Below ( -- ) THREAD_PRIORITY_BELOW_NORMAL GetCurrentThread SetThreadPriority drop ; - : Above ( -- ) THREAD_PRIORITY_ABOVE_NORMAL GetCurrentThread SetThreadPriority drop ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 105,108 ---- *************** *** 572,576 **** :M DefaultIcon: ( -- hIcon ) ! s" res\SciEditMDI.ico" Prepend<home>\ LoadIconFile ;M :M GetFileName: ( -- addr ) --- 571,575 ---- :M DefaultIcon: ( -- hIcon ) ! s" src\res\SciEditMDI.ico" Prepend<home>\ LoadIconFile ;M :M GetFileName: ( -- addr ) *************** *** 802,806 **** : NewRemoteChild ( -- ) \ open a new child window used to open a file ! \ remotly by the Win32Forth console ActiveRemote 0= if NewEditWnd ActiveChild to ActiveRemote --- 801,805 ---- : NewRemoteChild ( -- ) \ open a new child window used to open a file ! \ remotely by the Win32Forth console ActiveRemote 0= if NewEditWnd ActiveChild to ActiveRemote *************** *** 903,907 **** FCONTROL VK_F3 IDM_FIND_TEXT ACCELENTRY 0 VK_F3 IDM_FIND_NEXT ACCELENTRY ! \ FSHIFT VK_F3 IDM_FIND_PREVIOUS ACCELENTRY FALT 'D' IDM_INSERT_DATE ACCELENTRY --- 902,906 ---- FCONTROL VK_F3 IDM_FIND_TEXT ACCELENTRY 0 VK_F3 IDM_FIND_NEXT ACCELENTRY ! FSHIFT VK_F3 IDM_FIND_PREVIOUS ACCELENTRY FALT 'D' IDM_INSERT_DATE ACCELENTRY *************** *** 988,996 **** : Main ( -- ) - \ Removed setting the thread priority of the main task. It block's the system ! \ too mutch and isn't realy needed (Montag, Oktober 09 2006, dbu). ! \ above ! start: Frame GetHandle: frame hwndOwner ! DefaultPrinter \ initialise PSD and PD --- 987,992 ---- : Main ( -- ) \ Removed setting the thread priority of the main task. It block's the system ! \ too much and isn't realy needed (Montag, Oktober 09 2006, dbu). start: Frame GetHandle: frame hwndOwner ! DefaultPrinter \ initialise PSD and PD Index: EdRemote.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdRemote.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** EdRemote.f 13 Oct 2006 03:55:11 -0000 1.4 --- EdRemote.f 21 Oct 2006 11:11:47 -0000 1.5 *************** *** 130,135 **** ed-filename count (OpenRemoteFile) \ switch if already loaded ed-line @ GotoLine: ActiveRemote ! \ NewRemoteChild ! \ ed-line @ ed-filename count LoadHyperFile: ActiveRemote \ load the file wParam ED_OPEN_BROWSE = SetBrowseMode: ActiveRemote \ browsing? then --- 130,134 ---- ed-filename count (OpenRemoteFile) \ switch if already loaded ed-line @ GotoLine: ActiveRemote ! ed-line @ ed-filename count LoadHyperFile: ActiveRemote \ load the file wParam ED_OPEN_BROWSE = SetBrowseMode: ActiveRemote \ browsing? then Index: EdMenu.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdMenu.f,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** EdMenu.f 13 Oct 2006 03:55:11 -0000 1.13 --- EdMenu.f 21 Oct 2006 11:11:47 -0000 1.14 *************** *** 62,66 **** :MenuItem me_find "Se&arch...\tCtrl+F" IDM_FIND_TEXT DoCommand ; :MenuItem me_findnext "Search &next\tF3" IDM_FIND_NEXT DoCommand ; ! \ :MenuItem me_findprev "Search &prev\tShift+F3" IDM_FIND_PREVIOUS DoCommand ; MenuSeparator :MenuItem me_findinfiles "Find Text in Files...\tCtrl+Shift+F" IDM_FIND_IN_FILES DoCommand ; --- 62,66 ---- :MenuItem me_find "Se&arch...\tCtrl+F" IDM_FIND_TEXT DoCommand ; :MenuItem me_findnext "Search &next\tF3" IDM_FIND_NEXT DoCommand ; ! :MenuItem me_findprev "Search &prev\tShift+F3" IDM_FIND_PREVIOUS DoCommand ; MenuSeparator :MenuItem me_findinfiles "Find Text in Files...\tCtrl+Shift+F" IDM_FIND_IN_FILES DoCommand ; *************** *** 241,245 **** dup Enable: me_find dup Enable: me_findnext ! \ dup Enable: me_findprev dup Enable: me_date dup Enable: me_date&time --- 241,245 ---- dup Enable: me_find dup Enable: me_findnext ! dup Enable: me_findprev dup Enable: me_date dup Enable: me_date&time *************** *** 308,312 **** GetTextLength: ActiveChild Enable: me_find ?Find: ActiveChild Enable: me_findnext ! \ ?Find: ActiveChild Enable: me_findprev ?BrowseMode: ActiveChild not Enable: me_date ?BrowseMode: ActiveChild not Enable: me_date&time --- 308,312 ---- GetTextLength: ActiveChild Enable: me_find ?Find: ActiveChild Enable: me_findnext ! ?Find: ActiveChild Enable: me_findprev ?BrowseMode: ActiveChild not Enable: me_date ?BrowseMode: ActiveChild not Enable: me_date&time Index: ScintillaMDI.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/ScintillaMDI.f,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** ScintillaMDI.f 13 Oct 2006 03:55:11 -0000 1.6 --- ScintillaMDI.f 21 Oct 2006 11:11:47 -0000 1.7 *************** *** 199,203 **** ?Find: self if ! GetSelectionEnd: ChildWindow SetSelectionStart: ChildWindow SearchAnchor: ChildWindow FindMode FindText$ 1+ SearchPrev: ChildWindow INVALID_POSITION <> --- 199,203 ---- ?Find: self if ! \ GetSelectionEnd: ChildWindow SetSelectionStart: ChildWindow SearchAnchor: ChildWindow FindMode FindText$ 1+ SearchPrev: ChildWindow INVALID_POSITION <> |
|
From: George H. <geo...@us...> - 2006-10-21 10:55:05
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15517/win32forth/src Modified Files: Utils.f Log Message: gah:Added documentation Index: Utils.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Utils.f,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** Utils.f 3 Oct 2006 07:44:22 -0000 1.13 --- Utils.f 21 Oct 2006 10:54:55 -0000 1.14 *************** *** 51,55 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! : .platform ( -- ) cr ." Platform: Windows " winver case --- 51,56 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! : .platform ( -- ) \ W32F Tools extra in-system ! \ *G Display the Windows platform the system is running on. cr ." Platform: Windows " winver case *************** *** 84,92 **** IN-APPLICATION ! : MessageBox ( szText szTitle style hOwnerWindow -- result ) dup NULL = if drop call GetActiveWindow then \ better use a valid handle >r 3reverse r> Call MessageBox ; ! : ?MessageBox ( flag adr len -- ) asciiz swap if z" Notice!" --- 85,97 ---- IN-APPLICATION ! : MessageBox ( szText szTitle style hOwnerWindow -- result ) \ W32F ! \ *G Display a standard windows message box, with the title sztitle and message sztext, ! \ ** where both strings are null terminated. Style is one of the standard window message ! \ ** box styles. If hOwnerWindow is null then the active window is used as the owner. dup NULL = if drop call GetActiveWindow then \ better use a valid handle >r 3reverse r> Call MessageBox ; ! : ?MessageBox ( flag addr len -- ) \ W32F ! \ *G If flag is true display the text addr len in a modal information message box. asciiz swap if z" Notice!" *************** *** 95,99 **** then drop ; ! : ?ErrorBox ( flag adr len -- ) asciiz swap if z" Application Error" --- 100,106 ---- then drop ; ! : ?ErrorBox ( flag addr len -- ) \ W32F ! \ *G If flag is true display the text addr len in a modal warning message box. If OK is ! \ ** pressed then perform an abort, if cancel is pressed terminate the application. asciiz swap if z" Application Error" *************** *** 106,110 **** then ; ! : ?TerminateBox ( flag adr len -- ) asciiz swap if z" Error Notice!" --- 113,119 ---- then ; ! : ?TerminateBox ( flag addr len -- ) \ W32F ! \ *G If flag is true display the text addr len in a modal stop message box. When OK is ! \ ** pressed terminate the application. asciiz swap if z" Error Notice!" *************** *** 115,119 **** then ; ! : ErrorBox ( adr len -- ) asciiz z" Application Error" --- 124,129 ---- then ; ! : ErrorBox ( addr len -- ) \ W32F ! \ *G Display the text addr len in a modal error message box. asciiz z" Application Error" *************** *** 121,125 **** NULL MessageBox drop ; ! : .ErrorBox ( n - ) \ displays n in a MessageBox 0 (d.) ErrorBox ; --- 131,136 ---- NULL MessageBox drop ; ! : .ErrorBox ( n - ) \ W32F ! \ *G Display the number n in a modal error message box. 0 (d.) ErrorBox ; *************** *** 216,223 **** EXTERNAL \ external definitions start here ! : $edit ( line filename | dummy -1 -- ) ['] do-edit [$edit] ; ! : $browse ( line filename | dummy -1 -- ) ['] do-browse [$edit] ; --- 227,236 ---- EXTERNAL \ external definitions start here ! : $edit ( line filename | dummy -1 -- ) \ W32F ! \ *G Open the file, filename in the editor at line, in edit mode. ['] do-edit [$edit] ; ! : $browse ( line filename | dummy -1 -- ) \ W32F ! \ *G Open the file, filename in the editor at line, in browse mode. ['] do-browse [$edit] ; *************** *** 797,804 **** in-system ! : 2literal ( d1 -- ) swap POSTPONE LITERAL POSTPONE LITERAL ; immediate ! : MACRO ( "name <char> ccc<char>" -- ) : char parse POSTPONE sliteral --- 810,828 ---- in-system ! : 2literal ( x1 x2 -- ) \ ANSI Double ! \ *G \b Interpretation: \d Interpretation semantics for this word are undefined. \n ! \ ** \b Compilation: \d ( x1 x2 -- ) ! \ ** Append the run-time semantics below to the current definition. \n ! \ ** \b Run-time: \d ( -- x1 x2 ) ! \ ** Place cell pair x1 x2 on the stack. swap POSTPONE LITERAL POSTPONE LITERAL ; immediate ! : MACRO ( "name <char> ccc<char>" -- ) \ W32F (Wil Baden) ! \ *G Create a definiton, "name and store the text cccc delimited by <char> so that when ! \ ** "name is used the code is compiled or executed according to state. \n ! \ ** \b Note: \d Because "name uses evaluate then the actual interpretation is sensitive to the ! \ ** search order when "name is compiled or interpreted, \b not \d when defined. \n ! \ ** Also "name should not be postponed into a word or stored into a deferred word, ! \ ** which is called in a turnkeyed application (it causes the application to crash). : char parse POSTPONE sliteral |
|
From: Dirk B. <db...@us...> - 2006-10-21 09:11:12
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8310/apps/Win32ForthIDE Modified Files: EdToolbar.f Main.f Log Message: - Fixed the browse-button in the toolbar. Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v retrieving revision 1.30 retrieving revision 1.31 diff -C2 -d -r1.30 -r1.31 *** Main.f 13 Oct 2006 03:55:11 -0000 1.30 --- Main.f 21 Oct 2006 09:11:10 -0000 1.31 *************** *** 1019,1026 **** ' my-hello is default-hello - &forthdir count &appdir place \ create Win32ForthIDE.exe in the Win32Forth folder 0 0 ' Main ' Application catch Win32ForthIde.exe checkstack &appdir off \ make sure that the remote I/O will still work after the IDE is compiled also hidden ' uninit-shared-forth is uninit-shared-type previous --- 1019,1027 ---- ' my-hello is default-hello \ create Win32ForthIDE.exe in the Win32Forth folder + &forthdir count &appdir place 0 0 ' Main ' Application catch Win32ForthIde.exe checkstack &appdir off + \ make sure that the remote I/O will still work after the IDE is compiled also hidden ' uninit-shared-forth is uninit-shared-type previous Index: EdToolbar.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdToolbar.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** EdToolbar.f 13 Oct 2006 03:55:11 -0000 1.7 --- EdToolbar.f 21 Oct 2006 09:11:10 -0000 1.8 *************** *** 433,436 **** --- 433,437 ---- GetTextLength: ActiveChild IDM_FIND_TEXT EnableButton: ControlToolbar ?Find: ActiveChild IDM_FIND_NEXT EnableButton: ControlToolbar + GetTextLength: ActiveChild IDM_BROWSE EnableButton: ControlToolbar else false IDM_SAVE EnableButton: ControlToolbar |
|
From: Dirk B. <db...@us...> - 2006-10-21 09:09:13
|
Update of /cvsroot/win32forth/win32forth/apps/Console-Games In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7478/apps/Console-Games Added Files: strek.f tetris.f Log Message: - two console games added --- NEW FILE: strek.f --- \ Super Star Trek \ \ Translated from the book BASIC COMPUTER GAMES, edited by \ David Ahl, 1978, New York: Workman Publishing. \ \ Original program by Mike Mayfield, May 16, 1978 \ \ Revisions: \ 2006-10-14 ported to ANS-Forth by Krishna Myneni, \ Creative Consulting for Research and Education \ (kri...@be...) \ 2006-10-15 new random number generator, additional \ logic for ShieldControl and DamageControl when \ docked at starbase. km \ 2006-10-21 ported to win32forth (dbu) \ \ Here is the original BASIC header: \ \ SUPER STARTREK - MAY 16, 1978 - REQUIRES 24K MEMORY [...1556 lines suppressed...] ; previous \ override default-hello with our own one ' strek-hello is default-hello \ and create the turnkey app. &forthdir count &appdir place 0 0 ' strek APPLICATION StarTrek.exe 1 pause-seconds bye [else] strek [then] --- NEW FILE: tetris.f --- \ tt.pfe Tetris for terminals, redone in ANSI-Forth. \ Written 05Apr94 by Dirk Uwe Zoller, \ e-mail du...@ro.... \ Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS" \ \ Please copy and share this program, modify it for your system \ and improve it as you like. But don't remove this notice. \ \ Thank you. \ - Changed for Win32Forth \ Sonntag, März 14 2004 by Dirk Busch (dbu) \ - Changed to display the next piece \ Samstag, März 20 2004 by Dirk Busch (dbu) only forth also definitions decimal true value create-turnkey? \ set to false when you don't want a turnkey app warning off \ Variables, constants bl bl 2constant empty \ an empty position variable wiping \ if true: wipe brick, else draw brick 2 constant col0 \ position of the pit 0 constant row0 10 constant wide \ size of pit in brick positions 20 constant deep 0x20004 value left-key \ customize if you don't like them 0x20006 value rot-key \ currently this values are for the 0x20005 value right-key \ arrow key's in Win32Forth 0x20007 value drop-key char P value pause-key 12 value refresh-key char Q value quit-key variable score variable pieces variable levels variable delay variable brow \ where the brick is variable bcol \ stupid random number generator variable seed : randomize time&date + + + + + seed ! ; 1 cells 4 = [IF] 0x10450405 Constant generator : rnd ( -- n ) seed @ generator um* drop 1+ dup seed ! ; : random ( n -- 0..n-1 ) rnd um* nip ; [ELSE] : random \ max --- n ; return random number < max seed @ 13 * [ hex ] 07FFF [ decimal ] and dup seed ! swap mod ; [THEN] \ Access pairs of characters in memory: : 2c@ dup 1+ c@ swap c@ ; : 2c! dup >r c! r> 1+ c! ; : d<> d= 0= ; \ Drawing primitives: : 2emit emit emit ; : position \ row col --- ; cursor to the position in the pit 2* col0 + swap row0 + at-xy ; : stone \ c1 c2 --- ; draw or undraw these two characters wiping @ if 2drop 2 spaces else 2emit then ; \ Define the pit where bricks fall into: : def-pit create wide deep * 2* allot does> rot wide * rot + 2* + ; def-pit pit : empty-pit deep 0 do wide 0 do empty j i pit 2c! loop loop ; \ Displaying: : draw-bottom \ --- ; redraw the bottom of the pit deep -1 position [char] + dup stone wide 0 do [char] = dup stone loop [char] + dup stone ; : draw-frame \ --- ; draw the border of the pit deep 0 do i -1 position [char] | dup stone i wide position [char] | dup stone loop draw-bottom ; : bottom-msg \ addr cnt --- ; output a message in the bottom of the pit deep over 2/ wide swap - 2/ position type ; : draw-line \ line --- dup 0 position wide 0 do dup i pit 2c@ 2emit loop drop ; : draw-pit \ --- ; draw the contents of the pit deep 0 do i draw-line loop ; : show-key \ char --- ; visualization of that character dup bl < if [char] @ or [char] ^ emit emit space else [char] ` emit emit [char] ' emit then ; : show-help \ --- ; display some explanations 30 1 at-xy ." ***** T E T R I S *****" 30 2 at-xy ." =======================" 30 4 at-xy ." Use keys:" 32 5 at-xy ." 'arrow left' Move left" 32 6 at-xy ." 'arrow right' Move right" 32 7 at-xy ." 'arrow up' Rotate" 32 8 at-xy ." 'arrow down' Drop" 32 9 at-xy pause-key show-key ." Pause" 32 10 at-xy refresh-key show-key ." Refresh" 32 11 at-xy quit-key show-key ." Quit" 30 16 at-xy ." Score: Next piece:" 30 17 at-xy ." Pieces:" 30 18 at-xy ." Levels:" 0 22 at-xy ." ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ====" 0 23 at-xy ." ==================== Win32Forth port 2004 by Dirk Busch ======================" ; : update-score \ --- ; display current score 38 16 at-xy score @ 3 .r 38 17 at-xy pieces @ 3 .r 38 18 at-xy levels @ 3 .r ; : refresh \ --- ; redraw everything on screen page draw-frame draw-pit show-help update-score ; \ Define shapes of bricks: : def-brick create 4 0 do ' execute 0 do dup i chars + c@ c, loop drop refill drop loop does> rot 4 * rot + 2* + ; def-brick brick1 s" " s" ###### " s" ## " s" " def-brick brick2 s" " s" <><><><>" s" " s" " def-brick brick3 s" " s" {}{}{}" s" {} " s" " def-brick brick4 s" " s" ()()() " s" () " s" " def-brick brick5 s" " s" [][] " s" [][] " s" " def-brick brick6 s" " s" @@@@ " s" @@@@ " s" " def-brick brick7 s" " s" %%%% " s" %%%% " s" " \ this brick is actually in use: def-brick brick s" " s" " s" " s" " \ this brick will come next: def-brick next-brick s" " s" " s" " s" " def-brick scratch s" " s" " s" " s" " create bricks ' brick1 , ' brick2 , ' brick3 , ' brick4 , ' brick5 , ' brick6 , ' brick7 , create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c, variable brick-value : is-next-brick \ brick --- ; activate a shape of brick >body ['] next-brick >body 32 cmove ; : get-next-brick \ --- ; select the next brick by random 1 pieces +! 7 random bricks over cells + @ is-next-brick brick-val swap chars + c@ brick-value ! ; : is-brick \ brick --- ; activate a shape of brick >body ['] brick >body 32 cmove ; : new-brick \ --- ; select brick, count it ['] next-brick is-brick brick-value @ score +! get-next-brick ; : rotleft 4 0 do 4 0 do j i brick 2c@ 3 i - j scratch 2c! loop loop ['] scratch is-brick ; : rotright 4 0 do 4 0 do j i brick 2c@ i 3 j - scratch 2c! loop loop ['] scratch is-brick ; : draw-brick \ row col 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + position j i brick 2c@ stone then loop loop 2drop ; : show-brick wiping off draw-brick ; : hide-brick wiping on draw-brick ; : draw-next-brick \ row col --- 4 0 do 4 0 do j i next-brick 2c@ empty d<> if over j + over i + position j i next-brick 2c@ stone then loop loop 2drop ; : show-next-brick wiping off draw-next-brick ; : hide-next-brick wiping on draw-next-brick ; : put-brick \ row col --- ; put the brick into the pit 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + pit j i brick 2c@ rot 2c! then loop loop 2drop ; : remove-brick \ row col --- ; remove the brick from that position 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + pit empty rot 2c! then loop loop 2drop ; : test-brick \ row col --- flag ; could the brick be there? 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + over dup 0< swap deep >= or over dup 0< swap wide >= or 2swap pit 2c@ empty d<> or or if unloop unloop 2drop false exit then then loop loop 2drop true ; : move-brick \ rows cols --- flag ; try to move the brick brow @ bcol @ remove-brick swap brow @ + swap bcol @ + 2dup test-brick if brow @ bcol @ hide-brick 2dup bcol ! brow ! 2dup show-brick put-brick true else 2drop brow @ bcol @ put-brick false then ; : rotate-brick \ flag --- flag ; left/right, success brow @ bcol @ remove-brick dup if rotright else rotleft then brow @ bcol @ test-brick over if rotleft else rotright then if brow @ bcol @ hide-brick if rotright else rotleft then brow @ bcol @ put-brick brow @ bcol @ show-brick true else drop false then ; : insert-brick \ row col --- flag ; introduce a new brick 2dup test-brick if 2dup bcol ! brow ! 2dup put-brick draw-brick true else false then ; : drop-brick \ --- ; move brick down fast begin 1 0 move-brick 0= until ; : move-line \ from to --- over 0 pit over 0 pit wide 2* cmove draw-line dup 0 pit wide 2* blank draw-line ; : line-full \ line-no --- flag true wide 0 do over i pit 2c@ empty d= if drop false leave then loop nip ; : remove-lines \ --- deep deep begin swap begin 1- dup 0< if 2drop exit then dup line-full while 1 levels +! 10 score +! repeat swap 1- 2dup <> if 2dup move-line then again ; : to-upper \ char --- char ; convert to upper case dup [char] a >= over [char] z <= and if bl - then ; : interaction \ --- flag case key to-upper left-key of 0 -1 move-brick drop endof right-key of 0 1 move-brick drop endof rot-key of 0 rotate-brick drop endof drop-key of drop-brick endof pause-key of S" paused " bottom-msg key drop draw-bottom endof refresh-key of refresh endof quit-key of false exit endof endcase true ; : initialize \ --- ; prepare for playing randomize empty-pit refresh 0 score ! 0 pieces ! 0 levels ! 100 delay ! get-next-brick ; : adjust-delay \ --- ; make it faster with increasing score levels @ dup 50 < if 100 over - else dup 100 < if 62 over 4 / - else dup 500 < if 31 over 16 / - else 0 then then then delay ! drop ; : play-game \ --- ; play one tetris game begin 15 30 hide-next-brick new-brick 15 30 show-next-brick -1 3 insert-brick while begin 4 0 do 35 13 at-xy delay @ ms key? if interaction 0= if unloop exit then then loop 1 0 move-brick 0= until remove-lines update-score adjust-delay repeat ; forth definitions : tt \ --- ; play the tetris game initialize s" Press any key " bottom-msg key drop draw-bottom begin play-game s" Again? " bottom-msg key to-upper [char] Y = while initialize repeat create-turnkey? if bye \ quit our turnkey application else 0 23 at-xy cr then ; \ create a turnkey application create-turnkey? [IF] : set-console-title ( -- ) Z" Tetris" CONHNDL call SetWindowText drop ; also hidden : tetris-hello ( -- ) \ startup stuff \ default initialization (needed for all turnkey apps) init-console if initialization-chain do-chain then exception@ if bye then \ our own initialization menu-off \ close menubar ['] _interpret is interpret \ close the statusbar Destroy: ConsoleStatusbar set-console-title \ set window title init-screen \ show console get-commandline \ copy commandline to SOURCE default-application \ and run our app ; previous \ override default-hello with our own one ' tetris-hello is default-hello \ and create the turnkey app. &forthdir count &appdir place 0 0 ' tt APPLICATION tetris.exe 1 pause-seconds bye [else] TT [then] |
|
From: Dirk B. <db...@us...> - 2006-10-21 09:07:48
|
Update of /cvsroot/win32forth/win32forth/apps/Console-Games In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv6723/Console-Games Log Message: Directory /cvsroot/win32forth/win32forth/apps/Console-Games added to the repository |
|
From: Dirk B. <db...@us...> - 2006-10-18 15:58:41
|
Update of /cvsroot/win32forth/win32forth/apps/WinEd In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv31424/apps/WinEd Modified Files: Ed_FindInFiles.F Ed_Version.F Log Message: Added a Bugfix from Robert L. (Bob) Smith for the "Find in files" dialog. Index: Ed_Version.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_Version.F,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Ed_Version.F 28 Aug 2005 07:28:07 -0000 1.4 --- Ed_Version.F 18 Oct 2006 15:58:28 -0000 1.5 *************** *** 1,5 **** \ $Id$ ! 30200 value wined_version# \ Version numbers: v.ww.rr --- 1,5 ---- \ $Id$ ! 30201 value wined_version# \ Version numbers: v.ww.rr *************** *** 325,326 **** --- 325,330 ---- - Removed WinEd's internal console window - Removed the "Forth Instances" display from the status bar + + \ changes for Version 3.02.01 + dbu Mittwoch, Oktober 18 2006 + - Added a Bugfix from Robert L. (Bob) Smith for the FindInFiles dialog. Index: Ed_FindInFiles.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_FindInFiles.F,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Ed_FindInFiles.F 26 Aug 2006 15:25:32 -0000 1.4 --- Ed_FindInFiles.F 18 Oct 2006 15:58:28 -0000 1.5 *************** *** 22,26 **** 0 value total-found 0 value maxName \ longest filename length without the path ! \ October 3rd, 2000 - 9:46 tjz \ on my 256 megabyte machine, this upper limit of occurances to find works well --- 22,26 ---- 0 value total-found 0 value maxName \ longest filename length without the path ! \ October 3rd, 2000 - 9:46 tjz \ on my 256 megabyte machine, this upper limit of occurances to find works well *************** *** 78,82 **** IF TRUE to search-aborted? THEN ! ELSE 3drop TRUE to search-aborted? THEN --- 78,82 ---- IF TRUE to search-aborted? THEN ! ELSE 3drop TRUE to search-aborted? THEN *************** *** 347,351 **** get-parameters DestroyWindow: self ! SetFocus: DocWindow ENDOF \ done ID_FILELIST OF do-list-box ENDOF --- 347,351 ---- get-parameters DestroyWindow: self ! SetFocus: DocWindow ENDOF \ done ID_FILELIST OF do-list-box ENDOF *************** *** 381,385 **** cursor-line find-top-margin 2 / - VPosition: DocWindow no-highlight ! hlst 1+ to hled refresh-screen Refresh: FilesList --- 381,392 ---- cursor-line find-top-margin 2 / - VPosition: DocWindow no-highlight ! cursor-line #line" dup >r \ rls October 14th, 2006 - 18:04 ! find-buf count xsearch \ rls ! IF r> swap - dup \ rls ! to hcst to mcst drop \ rls ! hcst find-buf count nip + to hced \ rls ! ELSE r> drop 2drop \ rls ! THEN \ rls ! \ hlst 1+ to hled \ rls refresh-screen Refresh: FilesList |
1040 messages has been excluded from this view by a project administrator.
