Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f,1.21,1.22
|
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 |
