Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.41, 1.42 gmeta-compiler.f, 1.14, 1.15
|
From: Alex M. <ale...@us...> - 2007-07-12 21:00:31
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3305/src/kernel Modified Files: gkernel.f gmeta-compiler.f Log Message: arm: correct compiler; metat generating incorrect code for smart compile, (words using compilation> in the kernel like IF etc) and simplified the kernel once this was fixed. Index: gmeta-compiler.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** gmeta-compiler.f 13 May 2007 22:13:26 -0000 1.14 --- gmeta-compiler.f 12 Jul 2007 21:00:18 -0000 1.15 *************** *** 572,577 **** drop endcase ! dup cell- \ comp field ! xt-xt-call, swap tsys-! \ point at xt-call, ct>name n>ffa xt-fptr swap tsys-! \ update the ffa ; --- 572,579 ---- drop endcase ! dup cell- \ comp field ! dup tsys-@ ct-call, = if \ if it's a ct-call, placeholder ! xt-xt-call, swap tsys-! \ point at xt-call, ! else drop then ct>name n>ffa xt-fptr swap tsys-! \ update the ffa ; *************** *** 694,698 **** : immediate ( -- ) ! ct-execute last-h @ name>ct tsys-! \ set the xt-call, token to execute ; --- 696,700 ---- : immediate ( -- ) ! ct-execute last-h @ name>ct tsys-! \ set the compile, token to execute ; *************** *** 1319,1325 **** [transition] exit \ exit current definition tcode-here \ this xt ! last-h @ name>ct tsys-! \ set xt2 token t; ! t: break $cc tcode-c, t; --- 1321,1327 ---- [transition] exit \ exit current definition tcode-here \ this xt ! last-h @ name>ct cell- tsys-! \ set xt2 token t; ! t: break $cc tcode-c, t; Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.41 retrieving revision 1.42 diff -C2 -d -r1.41 -r1.42 *** gkernel.f 6 Jul 2007 09:06:39 -0000 1.41 --- gkernel.f 12 Jul 2007 21:00:18 -0000 1.42 *************** *** 2330,2338 **** \ : x swap ; inline ! : >ct ( xt -- ct ) dup cell- @ + ; \ given an xt, get the ct : >comp ( xt -- comp ) >ct cell- ; \ point to the comp field : >comp! ( xt2 xt1 -- ) >comp ! ; \ set the compile word - : >ct-exec ( xt -- ) >ct 2@ execute ; \ execute the ct : >name ( xt -- nfa ) >ct ct>name ; \ get the name \ ------------------------- Code generation words --------------------------- --- 2330,2344 ---- \ : x swap ; inline ! : >ct ( xt -- ct ) dup cell- @ + ; \ given an xt, get the ct (rel addr) : >comp ( xt -- comp ) >ct cell- ; \ point to the comp field : >comp! ( xt2 xt1 -- ) >comp ! ; \ set the compile word : >name ( xt -- nfa ) >ct ct>name ; \ get the name + : _>ct-exec ( xt -- ) >ct 2@ execute ; \ execute the ct + + defer >ct-exec ' _>ct-exec is >ct-exec \ defered for exits + + : _compile, ( xt -- ) dup >comp @ execute ; \ compile xt on the stack + + defer compile, ' _compile, is compile, \ ------------------------- Code generation words --------------------------- *************** *** 2346,2351 **** defer sync-code ' noop is sync-code - : compile, ( xt -- ) dup >comp @ execute ; \ compile xt on the stack - : xt-reladdr, ( xt -- ) \ generate relative address code-here - cell- code-, ; \ the xt relative adjusted --- 2352,2355 ---- *************** *** 2364,2381 **** 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. --- 2368,2376 ---- code-here to tail-call ; \ possible tail call ! : compiles-for ( xt <name> -- ) ! ' >comp! ; \ parsing; set the compilation word : compiles-last ( xt -- ) ! latestxt @ >comp! ; \ sets xt as compilation for last name \ The kernel has no assembler, so there's no "postponed assembly" possible. *************** *** 2402,2406 **** : inline ( -- ) \ code will be inlined tail-call 0= if \ there's no calls, so inlineable ! ['] xt-inline, compiles-last \ tail-call is set for any call then ; --- 2397,2401 ---- : inline ( -- ) \ code will be inlined tail-call 0= if \ there's no calls, so inlineable ! ['] xt-inline, compiles-last \ as tail-call is set for any call then ; *************** *** 2795,2802 **** postpone >ct-exec ; ! : [compile] ( -<name>- ) \ compile immediate word (comp-only) \ compile only ! compilation> ( -- xt ) drop ' dup >ct @ ['] compile, <> if postpone literal postpone >ct-exec --- 2790,2798 ---- postpone >ct-exec ; ! (( ! -- REMOVED as immediacy is difficult to determine using smart compile, : [compile] ( -<name>- ) \ compile immediate word (comp-only) \ compile only ! compilation> ( -- xt ) drop \ this code may not work! use POSTPONE ' dup >ct @ ['] compile, <> if postpone literal postpone >ct-exec *************** *** 2805,2808 **** --- 2801,2805 ---- then ; + )) \ -------------------- String Literals -------------------------------------- *************** *** 4258,4262 **** 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 --- 4255,4261 ---- 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 *************** *** 4273,4281 **** ;g - gcode _-?branch \ test & branch for -if - test eax, eax \ set the cond code - jz 0 \ dest (forward direction) - ;g - gcode _branch \ unconditional branch jmp 0 \ dest --- 4272,4275 ---- *************** *** 4285,4291 **** _?branch (copy-code) ; - : -?branch ( -- ) \ test & branch for -if - _-?branch (copy-code) ; - : branch ( -- ) \ generate unconditional jump _branch (copy-code) ; --- 4279,4282 ---- *************** *** 4306,4310 **** (comp-only) \ compile only compilation> ( -- xt ) drop ! -?branch >mark 2 ; 1 1 in/out \ jump will get filled in later : then ( c: orig -- ) \ resolve the forward jump --- 4297,4302 ---- (comp-only) \ compile only compilation> ( -- xt ) drop ! postpone dup ! postpone if ; 1 1 in/out : then ( c: orig -- ) \ resolve the forward jump *************** *** 4627,4636 **** ofa (ofa-calc) ; ! defer ; immediate \ changed to suit the type of colon def ! |: ;noname ( -- ) \ ; for :noname postpone exit \ this may compile _localfree postpone [ ?csp \ stop compiling, check stack - ['] (comp-only) is ; ; --- 4619,4630 ---- ofa (ofa-calc) ; ! : ; ( -- ) \ dummy compile for ; ! (comp-only) ! compilation> ; ! |: ;noname ( -- ) \ ; for :noname + drop \ because after compilation> postpone exit \ this may compile _localfree postpone [ ?csp \ stop compiling, check stack ; *************** *** 4639,4642 **** --- 4633,4637 ---- ofa 1+ (ofa-calc) \ length calculation (don't include the ret) reveal ; \ reveal the name + \ Words to support : *************** *** 4653,4657 **** -cell code-, \ ptr to the comp field code-here dup latestxt ! \ the xt, leave a copy on the stack (colon-sys) ! ['] ;noname is ; \ set the noname ; word (:noname) ; 0 0 in/out --- 4648,4652 ---- -cell code-, \ ptr to the comp field code-here dup latestxt ! \ the xt, leave a copy on the stack (colon-sys) ! ['] ;noname ['] ; >comp! \ set the noname ; word (:noname) ; 0 0 in/out *************** *** 4660,4664 **** header hide tcol tfa! \ type is a colon-def ! ['] ;name is ; \ set the named ; word (:noname) ; 0 0 in/out --- 4655,4659 ---- header hide tcol tfa! \ type is a colon-def ! ['] ;name ['] ; >comp! \ set the named ; word (:noname) ; 0 0 in/out *************** *** 4717,4723 **** r@ 1+ \ code for does> (after ret) last @ name>xt \ last name created ( xt nfa ) ! dup >ct @ ['] execute <> if \ if this isn't an immediate ! ['] xt-call, over (compiles-set) \ reset the standard compile word ! then addr-off + dup>r \ xt for create, jump part - cell- \ make relative --- 4712,4716 ---- r@ 1+ \ code for does> (after ret) last @ name>xt \ last name created ( xt nfa ) ! ['] xt-call, over >comp! \ reset the standard compile word addr-off + dup>r \ xt for create, jump part - cell- \ make relative *************** *** 4748,4751 **** --- 4741,4752 ---- code-here compiles-last \ make the defined word compile this ; + + : compile-only> ( -- ) \ shorthand for (comp-only) comp + (comp-only) + compilation> drop + postpone (comp-only) + postpone compilation> + postpone drop + ; \ -------------------- Error Handler -------------------------------- *************** *** 5377,5381 **** \ Code to fetch local values ! gcode _localn mov -4 [ebp], eax lea ebp, -4 [ebp] --- 5378,5382 ---- \ Code to fetch local values ! gcode _localn mov -4 [ebp], eax lea ebp, -4 [ebp] *************** *** 5454,5457 **** --- 5455,5459 ---- : (local) ( addr cnt -- ) \ create name in locals vocab + (comp-only) compilation> drop dup if \ looks like std vocab header 1 +to localstk \ total count of stack parms *************** *** 5505,5509 **** 2dup s" \" str= >r \ is it { [...] \ ... 2dup s" |" str= r> or not \ is it { [...] | ... ! if (local) \ no, it's a local else 2drop 0 to locflg then \ onto uninited locals repeat --- 5507,5511 ---- 2dup s" \" str= >r \ is it { [...] \ ... 2dup s" |" str= r> or not \ is it { [...] | ... ! if postpone (local) \ no, it's a local else 2drop 0 to locflg then \ onto uninited locals repeat *************** *** 5524,5528 **** 2dup s" |" str= not while ! (local) \ declare a local repeat 2drop localsgen, \ compile runtime code (equiv of 0 0 (local)) --- 5526,5530 ---- 2dup s" |" str= not while ! postpone (local) \ declare a local repeat 2drop localsgen, \ compile runtime code (equiv of 0 0 (local)) |
