Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src primhash.f,NONE,1.1
|
From: Alex M. <ale...@us...> - 2007-03-13 23:48:21
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv6049 Added Files: primhash.f Log Message: arm: start work on class support --- NEW FILE: primhash.f --- \ $Id: primhash.f,v 1.1 2007/03/13 23:48:16 alex_mcdonald Exp $ \ PRIMHASH.F primitive hash functions (( --------------------------- Change Block ------------------------------- arm 15/08/2005 22:56:45 First version 0.1 STC based kernel ------------------------- End Change Block ----------------------------- Experimental: a fully optimising, STC based, ANS Forth compliant kernel Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) The original Win32Forth system was public domain; this kernel (and currently the kernel alone) is GPL. Although the basic structure of Win32Forth and many of its capabilities are employed in this code, most of the original Win32Forth kernel has been completely rewritten. The original code was originally developed by Tom Zimmer, Andrew McKewan with minor contributions by others and placed in the public domain. I acknowledge their copyrighted contributions and the structure and some of the methods and concepts employed in this further development. The assembler is Copyright [c] 1994, 1995, by Jim Schneider and is issued under the LGPL. 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. ------------------------------------------------------------------------ )) cr .( Loading Primitive Hash...) \ ---------------- 32-bit Hash Function for Objects ---------------- code method-hash ( addr len -- hash-val ) 2 1 in/out mov edx, 0 [ebp] \ edx = address test eax, eax \ eax=0? jz short @@4 \ yes, bail out mov ecx, eax \ ecx = count, eax=result(includes count) @@1: rol eax, # 7 xor al, 0 [edx] \ add in next byte add edx, # 1 sub ecx, # 1 jnz short @@1 @@3: test eax, eax \ make sure it's negative js short @@2 @@4: not eax @@2: lea ebp, 4 [ebp] next c; \s \ -------------------- Method/Ivar Search -------------------- CODE ((FINDM)) ( SelID addr -- 0cfa t | f ) pop eax \ selector id @@1: mov ebx, 0 [ebx] \ follow link test ebx, ebx \ end of list? je short @@2 cmp eax, 4 [ebx] \ selectors match? jne short @@1 add ebx, # 8 \ method cfa push ebx mov ebx, # -1 \ and true flag @@2: next c; \ -------------------- Runtime for Methods -------------------- \ m0cfa is executed when the object address is on the stack \ m1cfa is executed when the ivar offset is compile in-line CFA-CODE M0CFA mov -4 [ebp], esi mov ecx, OP [UP] mov -8 [ebp], ecx mov ecx, LP [UP] mov -12 [ebp], ecx sub ebp, # 12 mov OP [UP], ebx \ get object address mov LP [UP], ebp \ LP = ebp pop ebx lea esi, 8 [eax] \ get new ip (skip m1cfa) mov ecx, 8 [eax] \ get locals count test ecx, ecx jnz MOVE-LOCALS \ we need to set up locals mov eax, 4 [esi] \ optimised next add esi, # 8 exec c; CFA-CODE M1CFA mov ecx, 0 [esi] \ get inline offset add esi, # 4 \ esi past offset mov -4 [ebp], esi mov esi, OP [UP] mov -8 [ebp], esi mov esi, LP [UP] mov -12 [ebp], esi sub ebp, # 12 add OP [UP], ecx \ add offset to object address mov LP [UP], ebp \ LP = ebp lea esi, 4 [eax] \ get new ip (skip m1cfa) mov ecx, 4 [eax] \ get locals count test ecx, ecx jnz MOVE-LOCALS \ we need to set up locals mov eax, 4 [esi] \ optimised next add esi, # 8 exec c; \ end of method definition \ EXITM was lost in Version 6.07.00 \ readded here for compatiblity September 8th, 2003 - 12:53 dbu NCODE UNNESTM ( -- ) mov ebp, LP [UP] xchg esp, ebp pop LP [UP] \ restore local pointer pop OP [UP] \ restore object pointer pop esi \ restore ip xchg esp, ebp next c; ' UNNESTM ALIAS EXITM \ -------------------- Runtime for Objects -------------------- CFA-CODE DOOBJ push ebx lea ebx, 8 [eax] next c; \ return the base of the current object CODE ^BASE ( -- addr ) push ebx mov ebx, OP [UP] next c; \ -------------------- Runtime for Instance Variables -------------------- \ These are the "non-object" instance variables. They have the same \ names and syntax as the regular Forth versions. They are defined in \ the META vocabulary and will be found when inside a class definition. \ The Offset from OP stored at cfa+15 \ bytes runtime CFA-CODE (&IV) push ebx mov ebx, 4 [eax] \ get ivar offset add ebx, OP [UP] \ add to base of current object next c; \ single byte (8bit) instance variables CFA-CODE (IVC@) push ebx mov eax, 4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object movzx ebx, byte ptr 0 [eax] \ fetch value next c; CFA-CODE (IVC!) mov eax, -4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object mov 0 [eax], bl \ store value pop ebx next c; CFA-CODE (IVC+!) mov eax, -8 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object add 0 [eax], bl \ add value pop ebx next c; \ word number (16bit) instance variables CFA-CODE (IVW@) push ebx mov eax, 4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object movzx ebx, word ptr 0 [eax] \ fetch WORD value next c; CFA-CODE (IVW!) mov eax, -4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object mov 0 [eax], bx \ store WORD value pop ebx next c; CFA-CODE (IVW+!) mov eax, -8 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object add 0 [eax], bx \ add WORD value pop ebx next c; \ single number (32bit) instance variables CFA-CODE (IV@) push ebx mov eax, 4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object mov ebx, 0 [eax] \ fetch value next c; CFA-CODE (IV!) mov eax, -4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object mov 0 [eax], ebx \ store value pop ebx next c; CFA-CODE (IV+!) mov eax, -8 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object add 0 [eax], ebx \ add value pop ebx next c; \ double number (64bit) instance variable CFA-CODE (IVD@) push ebx mov eax, 4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object mov ecx, 4 [eax] \ fetch value at cell + mov ebx, 0 [eax] \ fetch value push ecx next c; CFA-CODE (IVD!) mov eax, -4 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object mov 0 [eax], ebx \ store value pop ebx mov 4 [eax], ebx \ store value pop ebx next c; CFA-CODE (IVD+!) mov eax, -8 [eax] \ get ivar offset add eax, OP [UP] \ add to base of current object pop ecx add 4 [eax], ecx \ add low part first adc 0 [eax], ebx \ add high part with carry pop ebx next c; \ -------------------- Object pointer -------------------- : OP@ OP @ ; \ to allow UP to be kept in the EDX register : OP! OP ! ; \ -------------------- Find Name for Hashed Value -------------------- 79 #vocabulary hashed ' hashed vcfa>voc constant hash-wid 7 #vocabulary classes sys-here ' classes >body - \ voc-pfa-size 5 cells sys-reserve \ extra for a class constant voc-pfa-size : (unhash) ( hash-val -- addr len flag ) hash-wid dup voc#threads cells+ hash-wid ( hash-wid end to hash-wid ) do i begin @ ?dup while ( hash-val link-field ) 2dup link> >body @ = if nip ( discard hash value ) l>name dup LATEST-NFA ! \ save nfa for other use (Sonntag, März 13 2005 dbu) count ( addr len ) true unloop exit then repeat cell +loop drop S" Unknown" false ; : unhash ( hash-val -- addr len ) (unhash) drop ; : ?unhash ( hash-val -- f1 ) (unhash) nip nip ; IN-SYSTEM defer clash ( hash-val -- ) ' drop is clash : add-hash ( addr len hash-val -- ) >r 2dup hash-wid search-wordlist if r> 4drop ( already found ) else hash-wid swap-current >r "header docon , r> set-current r> dup , clash then ; 0 value obj-save : .M0NAME ( a1 -- ) [ 1 cells ] literal - @ unhash type space ; : .M1NAME ( a1 a2 -- a3 ) [ 2 cells ] literal - @ unhash type cell+ ( a1 becomes a3 ) \ skip next cell also dup @ ?dup if obj-save if obj-save cell - @ \ should use obj>CLASS, not yet there voc-pfa-size cell+ + \ should use IFA, not yet there begin @ 2dup 3 cells+ @ u< 0= start/stop until nip dup if cell+ @ unhash space type else drop ." ???" then space else ." NULL " then else ." self " then ; IN-APPLICATION |
