win32forth-cvs

[Alex M. <ale...@us...>]

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

Modified Files:
	gkernel.f gkernext.f 
Log Message:
arm: support for type system; :noname colon-sys is xt

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.24
retrieving revision 1.25
diff -C2 -d -r1.24 -r1.25
*** gkernel.f	5 Nov 2006 23:34:42 -0000	1.24
--- gkernel.f	13 Nov 2006 00:49:28 -0000	1.25
***************
*** 2311,2314 ****
--- 2311,2317 ----
  : >ffa@  ( nfa -- ffa ) n>ffa @  ;   \ get the file field
  
+ : tfa!   ( type -- )                 \ set the type
+          last @ n>tfa c! ;
+ 
  \ --------------------------- Compiling words -------------------------------
  
***************
*** 2422,2425 ****
--- 2425,2437 ----
  : (copy-code) ( addr -- ) count copy-code ;   \ routine to copy the code
  
+ : xt-inline, ( xt -- )                        \ inline the xt
+             dup >name n>ofa                   \ get the length
+             w@ copy-code ;                    \ and copy the code
+ 
+ : inline    ( -- )                            \ code will be inlined
+             tail-call 0= if                   \ there's a tail-call, so not inlineable
+               ['] xt-inline, compiles-last
+             then ;
+ 
  \ ---------------------------- Defining Words --------------------------------
  
***************
*** 2430,2433 ****
--- 2442,2446 ----
  5 constant tdef
  6 constant tloc
+ 7 constant tcol
  
  : mov-tos,#n  ( n -- )                          \ generate a mov eax, # n
***************
*** 2453,2457 ****
  : dogen     ( xt type-of-name <-name-> -- )   \ generate do code
              header                            \ header
!             last @ n>tfa c!                   \ set the type
              here mov-ecx,#n xt-jmp,             \ name -> mov ecx, # here | jmp xt
              ofa-calc                          \ length calculation
--- 2466,2470 ----
  : dogen     ( xt type-of-name <-name-> -- )   \ generate do code
              header                            \ header
!             tfa!                              \ set the type
              here mov-ecx,#n xt-jmp,             \ name -> mov ecx, # here | jmp xt
              ofa-calc                          \ length calculation
***************
*** 4514,4518 ****
  0 value localstk                       \ support for locals (including localalloc)
  
! : unnest        ( -- )                 \ generate a return
                  $c3 code-c, ; immediate
  
--- 4527,4531 ----
  0 value localstk                       \ support for locals (including localalloc)
  
! : unnest        ( -- )                 \ generate a return  
                  $c3 code-c, ; immediate
  
***************
*** 4559,4577 ****
                  ofa (ofa-calc) ;
  
! |: (;noname)    ( -- )                 \ ; internal
                  postpone exit          \ this may compile _localfree
                  postpone [ ?csp        \ stop compiling, check stack
                  ;
  
- |: ;noname      ( -- )                 \ ; for :noname
-                 (;noname)
-                 postpone unnest        \ extra ret to stop see (ret ret is end of definition)
-                 latestxt @
-                 ;
- 
  |: ;name        ( -- )                 \ ; for :
!                 (;noname)
!                 ofa-calc               \ length calculation
!                 postpone unnest        \ extra ret to stop see (ret ret is end of definition)
                  reveal ;               \ reveal the name
  
--- 4572,4583 ----
                  ofa (ofa-calc) ;
  
! |: ;noname      ( -- )                 \ ; for :noname
                  postpone exit          \ this may compile _localfree
                  postpone [ ?csp        \ stop compiling, check stack
                  ;
  
  |: ;name        ( -- )                 \ ; for :
!                 ;noname
!                 ofa 1+ (ofa-calc)      \ length calculation (don't include the ret)
                  reveal ;               \ reveal the name
  
***************
*** 4581,4585 ****
  
  |: (:noname)    ( xt -- )              \ defining for headerless
-                 is ;                   \ set the ; word
                  0 to localstk          \ clear locals stack counter
                  0 to tail-call         \ will be non-zero if we have any calls
--- 4587,4590 ----
***************
*** 4591,4601 ****
                  ['] xt-call, code-,    \ the comp field
                  -cell code-,           \ ptr to the comp field
!                 code-here latestxt !   \ the xt
!                 ['] ;noname (:noname)  \ set the noname ; word
                  ;
  
  : :             ( -<name>- -- )        \ forth's primary function defining word
                  header hide
!                 ['] ;name (:noname)    \ set the named ; word
                  ;
  
--- 4596,4609 ----
                  ['] xt-call, code-,    \ the comp field
                  -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)
                  ;
  
  : :             ( -<name>- -- )        \ forth's primary function defining word
                  header hide
!                 tcol tfa!              \ type is a colon-def
!                 ['] ;name is ;         \ set the named ; word
!                 (:noname)
                  ;
  
***************
*** 4846,4850 ****
                  header code-here swap voc>vxt !        \ set the xt for this name
                  mov-ecx,#n ['] dovoc xt-jmp,             \ set ecx, jmp to dovoc
!                 postpone unnest postpone unnest
                  ;
  
--- 4854,4858 ----
                  header code-here swap voc>vxt !        \ set the xt for this name
                  mov-ecx,#n ['] dovoc xt-jmp,             \ set ecx, jmp to dovoc
!                 postpone unnest 
                  ;
  
***************
*** 5365,5369 ****
                    >local
                    "header                             \ build a header
!                   tloc last @ n>tfa c!                \ mark as a local
                    local>
                    localstk cells [ local-ptrs cell- ] literal \ table is zero offset
--- 5373,5377 ----
                    >local
                    "header                             \ build a header
!                   tloc tfa!                           \ mark as a local
                    local>
                    localstk cells [ local-ptrs cell- ] literal \ table is zero offset
***************
*** 5503,5506 ****
--- 5511,5515 ----
  : defer     ( -<name>- )                      \ create a deferred word
              header                            \ create a defer
+             tdef tfa!                         \ set as type=defer
              jmp[], ['] defer-err ,            \ the jump
              ofa-calc                          \ length calculation

Index: gkernext.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernext.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** gkernext.f	24 Oct 2006 12:41:54 -0000	1.2
--- gkernext.f	13 Nov 2006 00:49:28 -0000	1.3
***************
*** 80,84 ****
                  a;
                  ofa-calc                \ resolve the optimizer field address
!                 ret ret                 \ double ret to stop decompiler
                  ;macro
  
--- 80,84 ----
                  a;
                  ofa-calc                \ resolve the optimizer field address
!                 ret            
                  ;macro