win32forth-cvs

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27557/win32forth-stc/src

Modified Files:
	primhash.f 
Log Message:
gah: Converted code for STC (work in progress).

Index: primhash.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primhash.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** primhash.f	13 Mar 2007 23:48:16 -0000	1.1
--- primhash.f	18 Apr 2007 09:13:04 -0000	1.2
***************
*** 2,50 ****
  \ 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 ----------------
--- 2,67 ----
  \ 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)
! \                         Dirk Busch    (dirk at win32forth.org)
! \                         George Hubert (georgeahubert at yahoo.co.uk)
! \   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...)
  
! : sys-reserve ( n -- )
!                 get-section 2>r                        \ save dp and xdp
!                 in-system here over allot swap erase   \ move to in-system
!                 2r> set-section ;
  
! 7 #vocabulary classes
  
! sys-here ' classes >body -                    \ voc-pfa-size
!           2 dup
!           4 + cells sys-reserve                 \ extra for a class
!           swap constant voc-pfa-size
  
! also classes get-current swap definitions
  
! constant #mlists \ Number of method lists; must be a non-zero power of 2.
  
+ set-current previous
  
  \ ---------------- 32-bit Hash Function for Objects ----------------
***************
*** 67,87 ****
                  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
--- 84,121 ----
                  next    c;
  
  \ -------------------- Method/Ivar Search --------------------
  
! CODE ((FINDM))  ( SelID addr -- xt t | f )
!                 mov     edx, 0 [ebp]            \ selector id
!                 mov     ecx, edx
!                 and     ecx, # also classes #mlists 1- cells previous
!                 add     eax, ecx
! @@1:            mov     eax, 0 [eax]            \ follow link
!                 test    eax, eax                \ end of list?
                  je      short @@2
!                 cmp     edx, 4 [eax]            \ selectors match?
                  jne     short @@1
!                 mov     eax, 8 [eax]            \ method cfa
!                 mov     0 [ebp], eax
!                 mov     eax, # -1               \ and true flag
!                 ret
! @@2:            lea     ebp, 4 [ebp]
!                 next    c;
  
+ CODE ((FINDV))  ( SelID addr -- 'ivar t | f )
+                 mov     edx, 0 [ebp]            \ selector id
+ @@1:            mov     eax, 0 [eax]            \ follow link
+                 test    eax, eax                \ end of list?
+                 je      short @@2
+                 cmp     edx, 4 [eax]            \ selectors match?
+                 jne     short @@1
+                 add     eax, # 8                \ ivar structure
+                 mov     0 [ebp], eax
+                 mov     eax, # -1               \ and true flag
+                 ret
+ @@2:            lea     ebp, 4 [ebp]
+                 next    c;
  
+ ((
  \ -------------------- Runtime for Methods --------------------
  \ m0cfa is executed when the object address is on the stack
***************
*** 151,160 ****
  \ return the base of the current object
  
  CODE ^BASE      ( -- addr )
!                 push    ebx
!                 mov     ebx, OP [UP]
                  next    c;
  
! 
  \ -------------------- Runtime for Instance Variables --------------------
  
--- 185,200 ----
  \ return the base of the current object
  
+ ))
+ 
+ ' exit alias exitm
+ 
  CODE ^BASE      ( -- addr )
!                 0 1 in/out
!                 mov     -4 [ebp], eax
!                 mov     eax, OP [UP]
!                 lea     ebp, -4 [ebp]
                  next    c;
  
! ((
  \ -------------------- Runtime for Instance Variables --------------------
  
***************
*** 272,292 ****
                  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 )
--- 312,352 ----
                  next    c;
  
+ ))
  
  \ -------------------- Object pointer --------------------
  
! : OP@  OP @ ;   \ to allow UP to be kept in the EBX register
  : OP!  OP ! ;
  
! \ -------------------- Operations on OP ------------------
  
! \ Note these will probably be renamed when extensions are proposed
! \ for Forth200X
  
! in-system
  
! : PushOP  ( R: -- oldOP )
!                (comp-only) compilation> drop
!                macro[ push OP [UP] ]macro ;
  
! : PopOP   ( R: oldOP -- )
!                (comp-only) compilation> drop
!                macro[ pop OP [UP] ]macro ;
! 
! : lit>OP     ( n -- )
!                (comp-only) compilation> drop
!                >r macro[ mov OP [UP], # r> ]macro ;
! 
! : lit+OP     ( n -- )
!                (comp-only) compilation> drop
!                >r macro[ add OP [UP], # r> ]macro ;
! 
! in-previous
! 
! \ -------------------- Find Name for Hashed Value --------------------
! 
! 79 #vocabulary hashed
! 
! ' hashed >body constant hash-wid
  
  : (unhash)  ( hash-val -- addr len flag )
***************
*** 295,302 ****
                  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
--- 355,362 ----
                  begin   @ ?dup
                  while   ( hash-val link-field )
!                         2dup link>name name>xt >body @ =
                          if      nip ( discard hash value )
!                                 link>name
! \				dup LATEST-NFA ! \ save nfa for other use (Sonntag, März 13 2005 dbu)
  				count ( addr len )
                                  true unloop exit
***************
*** 318,321 ****
--- 378,385 ----
  ' drop is clash
  
+ \ Temporary hack
+ : "constant    ( n addr len -- )
+                 s" constant " pad place pad +place pad count evaluate ;
+ 
  : add-hash  ( addr len hash-val -- )
          >r 2dup hash-wid search-wordlist
***************
*** 323,332 ****
                  r> 4drop  ( already found )
          else
!                 hash-wid swap-current >r
!                 "header docon ,
                  r> set-current
!                 r> dup , clash
          then ;
! 
  0 value obj-save
  
--- 387,396 ----
                  r> 4drop  ( already found )
          else
!                 hash-wid swap-current r@ swap >r -rot
!                 ( "header docon , , ) "constant \ needs adding to kernel
                  r> set-current
!                 r> clash
          then ;
! ((
  0 value obj-save
  
***************
*** 351,355 ****
          else    ."  self "
          then    ;
! 
  IN-APPLICATION
  
--- 415,419 ----
          else    ."  self "
          then    ;
! ))
  IN-APPLICATION