Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src POINTER.F, 1.3, 1.4 extend.f, 1.14, 1.15 forget.f, 1.1, 1.2 optliterals.f, 1.5, 1.6 primutil.f, 1.14, 1.15
|
From: George H. <geo...@us...> - 2006-10-30 09:16:56
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25595/win32forth-stc/src Modified Files: POINTER.F extend.f forget.f optliterals.f primutil.f Log Message: gah:Marker Anew and Mark (but not forget) working. Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** primutil.f 28 Oct 2006 09:07:08 -0000 1.14 --- primutil.f 30 Oct 2006 09:15:14 -0000 1.15 *************** *** 46,50 **** in-system ! : ANEW BL WORD DROP ; immediate \ *** to be done *** : IS-DEFAULT BL WORD 2DROP ; immediate \ *** to be done *** : DEPRECATED ; immediate \ *** to be done *** --- 46,50 ---- in-system ! \ : ANEW BL WORD DROP ; immediate \ *** to be done *** : IS-DEFAULT BL WORD 2DROP ; immediate \ *** to be done *** : DEPRECATED ; immediate \ *** to be done *** *************** *** 149,153 **** new-sys-chain forget-chain \ chain of types of things to forget ! new-sys-chain post-forget-chain \ chain of types of things to forget in-application --- 149,153 ---- new-sys-chain forget-chain \ chain of types of things to forget ! \ new-sys-chain post-forget-chain \ chain of types of things to forget in-application Index: forget.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/forget.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** forget.f 21 Sep 2006 16:26:33 -0000 1.1 --- forget.f 30 Oct 2006 09:15:14 -0000 1.2 *************** *** 1,45 **** ! \ NFORGET.F ! \ nforget.f beta 2003/02/13 rbs Various changes as documented below ! \ -rbs 10/24/02 added trim-WinLibs and trim-WinProcs to a new post-forget-chain ! ! \ -rbs new DO-MARK does not generate redef warnings when marked word is ! \ executed, also resets vocabulary to ONLY FORTH ALSO DEFINITIONS. ! \ -rbs do-marker changed to reset voc also December 10th, 2002 ! \ -rbs new DO-MARK does not generate redef warnings when marked word is ! \ executed, also resets vocabulary to ONLY FORTH ALSO DEFINITIONS. ! \ This is a modified version of FORGET.F for dual dictionaries, ! \ by Stephen M. Brault. ! \ Received: 05 Feb 96 05:26:38 EST ! \ From: "Stephen M. Brault" <721...@co...> ! \ February 5th, 1996 - 22:43 tjz ! \ Renamed _TRIM? to SYS-TRIM? which describes its function. ! \ Renamed TRIM to FULL-TRIM, to avoid a name conflict with the original ! \ simple version of TRIM which is used in other areas of the system, and ! \ takes slightly different parameters. ! \ Notice that TRIM? is deferred, so its function can be changed to make ! \ FULL-TRIM trim things other than the dictionary if desired. ! cr .( Loading Forget Wordset...) ! \ FORGET limitations: ! \ 1) You cannot directly forget an IN-SYSTEM word since ! \ it would require extra work to determine the new DP. ! \ You can indirectly forget an IN-SYSTEM word by forgetting ! \ an earlier IN-APPLICATION word. ! variable fence \ cannot forget below this address ! : sys-trim? ( nfa addr -- f ) \ TRUE if forgetting nfa removes addr from dict ! tuck sys-origin dup sys-size + between ! if \ addr is IN-SYSTEM or TRANSIENT ! name>link sys-here \ so use nfa as trim address ! else \ addr is IN-APPLICATION ! name>xt app-here \ so use cfa as trim address ! then between ; \ ?Won't work across the 2Gb line defer trim? ' sys-trim? is trim? --- 1,71 ---- ! \ $Id$ ! \ --------------------------- 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 at win32forth.org) ! \ 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. ! \ ! \ ------------------------------------------------------------------------ ! \ ! \ Marker Empty and Anew ! \ ! \ ------------------------------------------------------------------------ ! cr .( Loading Forget Wordset...) ! \ NOTE ! \ 1) Forget no longer works. ! \ 2) Markers now reset the user area. ! \ Structure of Mark and Marker pfa ! 0 cell field+ >me ! cell field+ >pre-adp ! cell field+ >pre-cdp ! cell field+ >pre-sdp ! cell field+ >pre-kdp ! cell field+ >pre-user ! 0 field+ >forget-extra drop ! variable fence \ cannot forget below this address ! : in-space? ( addr ?dp -- f ) ! \ *G Returns true if addr is between the origin and top of the space represented ! \ ** by ?dp (adp, cdp, sdp, kdp or any transient space created by the user). ! dup @ swap 2 cells+ @ between ; ! : (sys-trim?) ( nfa addr -- addr pre-?dp ?dp-top ) ! \ Previous dp top of dp of the correct space for addr ( or 0 -1 if not in any ! \ dictionary space). ! swap name>xt >body ! over adp in-space? if >pre-adp @ adp 2 cells+ @ exit then ! over cdp in-space? if >pre-cdp @ cdp 2 cells+ @ exit then ! over sdp in-space? if >pre-sdp @ sdp 2 cells+ @ exit then ! over kdp in-space? if >pre-kdp @ kdp 2 cells+ @ exit then ! drop 0 -1 ; \ dirty trick ! : sys-trim? ( nfa addr -- f ) ! \ *G TRUE if forgetting nfa removes addr from dict. ! (sys-trim?) between ; defer trim? ' sys-trim? is trim? *************** *** 65,107 **** repeat dup sys-chain-link full-trim ; ! : trim-defer ( nfa -- nfa ) \ trim deferred word list to nfa ! dup defer-list full-trim ! defer-list ! begin @ ?dup ! while 2dup cell- @ ! trim? \ if forgetting IS word ! if dup cell+ @ \ revert to default ! over cell- ! ! then ! repeat ; ! ! forget-chain chain-add trim-defer ! ! : trim-handles ( nfa -- nfa ) \ trim handles list ! dup handles-list full-trim ; ! ! forget-chain chain-add trim-handles ! : trim-WinLibs ! winlib-link ! begin @ dup ! while dup here > ! if dup @ dup winlib-link ! winlib-last ! ! else drop exit ! then ! repeat drop ; ! post-forget-chain chain-add trim-WinLibs : trim-WinProcs ! winproc-link ! begin @ dup ! while dup here > ! if dup @ dup winproc-link ! winproc-last ! ! else drop exit ! then ! repeat drop ; ! post-forget-chain chain-add trim-WinProcs : vtrim ( nfa voc-thread -- ) \ trim VOC-THREAD back to nfa --- 91,121 ---- repeat dup sys-chain-link full-trim ; ! \ : trim-defer ( nfa -- nfa ) \ trim deferred word list to nfa ! \ dup defer-list full-trim ! \ defer-list ! \ begin @ ?dup ! \ while 2dup cell- @ ! \ trim? \ if forgetting IS word ! \ if dup cell+ @ \ revert to default ! \ over cell- ! ! \ then ! \ repeat ; ! \ ! \ forget-chain chain-add trim-defer ! \ ! \ : trim-handles ( nfa -- nfa ) \ trim handles list ! \ dup handles-list full-trim ; ! \ ! \ forget-chain chain-add trim-handles ! : trim-WinLibs ( nfa -- nfa ) ! dup winlib-link full-trim winlib-link @ winlib-last ! ; ! forget-chain chain-add trim-WinLibs : trim-WinProcs ! dup winproc-link full-trim winproc-link @ winproc-last ! ; ! forget-chain chain-add trim-WinProcs : vtrim ( nfa voc-thread -- ) \ trim VOC-THREAD back to nfa *************** *** 110,206 **** loop 2drop ; ! : (forget) ( cfa -- ) \ assumes count follows name ! dup app-here u> \ if in system area ! over @ ['] FORTH @ <> and \ but not a vocabulary ! abort" in system or transient dictionary" ! dup cell+ ResetSrcInfo ! >name ! dup fence @ 1- trim? abort" in protected dictionary" ! voc-link 2dup full-trim ! begin @ ?dup ! while 2dup vlink>voc vtrim ! repeat forget-chain do-chain \ do forget-chain before trimming it trim-chains context #vocs cells+ context do dup i @ trim? ! if [ ' forth vcfa>voc ] literal i ! then ! cell +loop ! dup name>link sdp ! \ update SYS-HERE ! name>xt dup dp @ u< \ if new address is in application space ! IF dp ! \ then update HERE ! post-forget-chain do-chain \ post-forget chain ! ELSE drop ! THEN ! voc-also \ reset look-aside table if present ; ! : forget ( -<name>xt- ) bl word count ! current @ search-wordlist ?missing ( cfa ) (forget) ; ! : do-mark ( -- ) \ mark must redefine the name that was forgotten ! \ -rbs modified to reset vocabs and not generate redef warnings when marked ! \ word is executed. ! does> { does-adr \ mark-name$ -- } ! MAXSTRING LocalAlloc: mark-name$ ! s" mark " mark-name$ place ! does-adr body> dup >name nfa-count mark-name$ +place ! (forget) ! \ -rbs ! \ forth definitions ! s" ONLY FORTH ALSO DEFINITIONS" evaluate ! WARNING @ WARNING OFF ! mark-name$ count evaluate ! WARNING ! ! ; ! : mark ( -<name>xt- ) ! >application create save-source do-mark application> ; ! \ January 27th, 1999 - 11:27 tjz ! \ modified MARKER to preserve and restore the search order : do-marker ( -- ) ! does> dup>r @ (forget) ! r> cell+ dup @ current ! \ restore current ! cell+ context #vocs cells move ; \ restore context search list ! : marker ( -<name>xt- ) ( ANS) ! >application ! WARNING @ WARNING OFF ! create ! WARNING ! ! save-source here body> , ! current @ , \ save current ! context here #vocs cells allot #vocs cells move \ save context search list ! do-marker ! application> ; ! \ POSSIBLY ( "name" -- ) ! \ Execute _name_ if it exists; otherwise, do nothing. Useful ! \ implementation factor of `ANEW`. ! : possibly ( "name" -- ) parse-word find-name ?dup if name>xt execute then ; ! \ ANEW ( "name" -- )( Run: -- ) ! \ Compiler directive used in the form: `ANEW _name_`. If the word ! \ _name_ already exists, it and all subsequent words are ! \ forgotten from the current dictionary, then a `MARKER` word ! \ _name_ is created. This is usually placed at the start of a ! \ file. When the code is reloaded, any prior version is ! \ automatically pruned from the dictionary. ! \ ! \ Executing _name_ will also cause it to be forgotten, since ! \ it is a `MARKER` word. \ ! \ Useful implementation factor of `EMPTY`. ! ! : anew ( "name" -- )( run: -- ) >in @ possibly >in ! marker ; here fence ! ! ! ! --- 124,212 ---- loop 2drop ; ! : (forget) ( pfa -- ) ! dup >me @ forget-chain do-chain \ do forget-chain before trimming it trim-chains context #vocs cells+ context do dup i @ trim? ! if [ ' forth >body ] literal i ! then ! cell +loop swap ! dup >pre-adp @ adp ! ! dup >pre-cdp @ cdp ! ! dup >pre-sdp @ sdp ! ! dup >pre-kdp @ kdp ! ! >pre-user @ next-user ! ! voc-link 2dup full-trim ! begin @ ?dup ! while 2dup vlink>voc ! vtrim ! repeat drop ! \ voc-also \ reset look-aside table if present ; ! : forget ( -<name>- ) bl word count ! current @ search-wordlist ?missing ! drop ." Forget no longer works. Use Marker or Anew instead" cr ; ! : Get-marking-info ( -- user kdp sdp cdp adp ) ! next-user @ kdp @ sdp @ cdp @ adp @ ; ! : Save-marking-info ( user kdp sdp cdp adp -- ) ! , , , , , ; ! : Save-search-order ( -- ) ! get-current , \ save current ! get-order dup , 0 ?do , loop ; \ save context search list ! ! : (Restore-search-order) ( addr n -- wid1...widn ) ! -if swap dup @ >r cell+ swap 1- recurse r> ! else 2drop then ; ! ! : Restore-search-order ( addr -- ) ! >forget-extra dup @ set-current \ restore current ! cell+ dup @ dup>r swap cell+ swap ! (Restore-search-order) r> set-order ; \ restore context search list : do-marker ( -- ) ! does> dup cell+ @ fence @ < ! abort" Attempt to forget in protected part of the dictionary!" ! dup Restore-search-order (forget) ; ! : mark ( -<name>- ) ! in-previous in-system create last @ , ! get-current get-order only forth also definitions ! Get-marking-info rot >forget-extra 2 cells+ ! get-order dup>r 0 ?do drop loop r> cells+ -rot save-marking-info ! save-search-order set-order set-current ! do-marker in-previous ; ! : marker ( -<name>- ) ( ANS) ! in-previous in-system ! \ WARNING @ WARNING OFF ! Get-marking-info create last @ , Save-marking-info ! \ WARNING ! ! \ save-source here body> , ! save-search-order do-marker in-previous ; ! : POSSIBLY ( "name" -- ) ! \ *G Execute _name_ if it exists; otherwise, do nothing. Useful ! \ ** implementation factor of `ANEW`. ! BL WORD FIND ?dup AND IF EXECUTE THEN ; ! : ANEW ( "name" -- )( Run: -- ) ! \ *G Compiler directive used in the form: `ANEW _name_`. If the word ! \ ** _name_ already exists, it and all subsequent words are ! \ ** forgotten from the current dictionary, then a `MARKER` word ! \ ** _name_ is created. This is usually placed at the start of a ! \ ** file. When the code is reloaded, any prior version is ! \ ** automatically pruned from the dictionary. \ ! \ *P Executing _name_ will also cause it to be forgotten, since ! \ ** it is a `MARKER` word. ! >IN @ POSSIBLY >IN ! MARKER ; here fence ! ! \s Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** extend.f 28 Oct 2006 09:07:08 -0000 1.14 --- extend.f 30 Oct 2006 09:15:14 -0000 1.15 *************** *** 22,25 **** --- 22,26 ---- fload src\console\console2.f \ console i/o extracted from primutil.f sys-fload src\dotwords.f \ dot support words + sys-FLOAD src\forget.f \ forget words FLOAD src\paths.f \ multi path support words sys-fload src\imageman.f \ fsave, application & turnkey words *************** *** 39,42 **** --- 40,46 ---- FLOAD src\registry.f \ Win32 Registry support + here fence ! mark empty \ Prevent forgetting anything before this + \ move this down as newer files are added + \ FLOAD src\lib\array.f \ Array words \ FLOAD src\lib\binsearch.f \ Binary search *************** *** 53,57 **** \ FLOAD src\primhash.f \ primitive hash functions for OOP later *** 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 *** --- 57,60 ---- Index: POINTER.F =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/POINTER.F,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** POINTER.F 5 Oct 2006 08:46:14 -0000 1.3 --- POINTER.F 30 Oct 2006 09:15:13 -0000 1.4 *************** *** 9,14 **** \ [ phy_pointer ][ link ][ size_bytes ] | - in-application - internal --- 9,12 ---- *************** *** 26,35 **** : Pointer ( bytes -<name>- ) \ make a pointer "name" ! get-section 2>r in-application \ always in app space 128 max \ at least 160 bytes create 0 , \ initialize to unallocated PHEAD link, \ link into chain , \ lay in size in bytes ! 2r> set-section does> \ back to where we came from dup @ if @ exit then \ ok, straight fetch dup (pointerlock) --- 24,33 ---- : Pointer ( bytes -<name>- ) \ make a pointer "name" ! in-previous in-application \ always in app space 128 max \ at least 160 bytes create 0 , \ initialize to unallocated PHEAD link, \ link into chain , \ lay in size in bytes ! in-previous does> \ back to where we came from dup @ if @ exit then \ ok, straight fetch dup (pointerlock) *************** *** 41,59 **** abort" Failed to allocate POINTER" ; ! \ Forgetting and decompiling to be done. ! \ in-system ! \ ! \ : TRIM-POINTERS ( a1 -- a1 ) ! \ PHEAD ! \ BEGIN @ ?DUP ! \ WHILE 2DUP TRIM? ! \ IF DUP CELL- @ ?DUP ! \ IF RELEASE ! \ THEN ! \ THEN ! \ REPEAT DUP PHEAD FULL-TRIM ; ! \ ! \ forget-chain chain-add trim-pointers ! \ \ : (.Pointer) ( pfa -- ) \ dup 2 cells+ @ 10 U,.R ." bytes at: " --- 39,60 ---- abort" Failed to allocate POINTER" ; ! \ Decompiling to be done. ! ! in-system ! ! internal ! ! : TRIM-POINTERS ( a1 -- a1 ) ! PHEAD ! BEGIN @ ?DUP ! WHILE 2DUP TRIM? ! IF DUP CELL- @ ?DUP ! IF RELEASE ! THEN ! THEN ! REPEAT DUP PHEAD FULL-TRIM ; ! ! forget-chain chain-add trim-pointers ! \ : (.Pointer) ( pfa -- ) \ dup 2 cells+ @ 10 U,.R ." bytes at: " *************** *** 91,94 **** --- 92,97 ---- external + in-previous + : %UnPointer ( cfa -- ) \ deallocate pointer given the cfa IsPointer? >BODY DUP @ 0<> \ only if non-zero (added missing 0<> February 6th, 2004 - 18:35 dbu) *************** *** 124,128 **** drop postpone dup ' >body postpone literal postpone (resizepointer) ; ! \ in-system \ These words need to be compile\interpret words --- 127,131 ---- drop postpone dup ' >body postpone literal postpone (resizepointer) ; ! in-system \ These words need to be compile\interpret words *************** *** 158,162 **** MAXSTRING Pointer ; ! in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 161,165 ---- MAXSTRING Pointer ; ! in-previous \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Index: optliterals.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** optliterals.f 28 Oct 2006 09:07:08 -0000 1.5 --- optliterals.f 30 Oct 2006 09:15:14 -0000 1.6 *************** *** 53,71 **** : 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 --- 53,71 ---- : 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 } n -1 <> if macro[ and eax, # n ]macro then ; ! : or-eax,#n { n } n if macro[ or eax, # n ]macro then ; ! : xor-eax,#n { n } n if macro[ xor eax, # n ]macro then ; ! : 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 } n if macro[ add addr , dword # n ]macro then ; ! : add-eax,#n { n } n if macro[ add eax, # n ]macro then ; ! : 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 *************** *** 114,118 **** ' uniopt compiles-for cells ! ' binopt compiles-for <> ' binopt compiles-for < ' binopt compiles-for > --- 114,118 ---- ' uniopt compiles-for cells ! \ ' binopt compiles-for <> ' binopt compiles-for < ' binopt compiles-for > *************** *** 144,147 **** --- 144,149 ---- : 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 sub-eax,#n setcc + macro[ not eax ]macro else binopt then ; : opt! ( xt -- ) *************** *** 195,198 **** --- 197,201 ---- ' optc! compiles-for c! ' opt= compiles-for = + ' opt<> compiles-for <> |
