win32forth-cvs

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

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

Modified Files:
	gkernel.f gmeta-compiler.f 
Log Message:
arm: more support for type system

Index: gmeta-compiler.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** gmeta-compiler.f	31 Oct 2006 00:06:53 -0000	1.9
--- gmeta-compiler.f	30 Nov 2006 20:17:32 -0000	1.10
***************
*** 633,636 ****
--- 633,659 ----
  [THEN]
  
+ ALSO ASSEMBLER DEFINITIONS
+ 
+ : label   a;  tcode-here constant ;
+ 
+ : (end-code)
+       a;
+       in-meta  check-labels
+       [ asm-hidden ]  ?finished ?unres  [ assembler ]  ?csp
+       in-code? off
+       ;
+ 
+ ' (end-code) is end-code
+ ' (end-code) is ;c
+ 
+ PREVIOUS DEFINITIONS
+ 
+ : ofa-meta  ( -- )
+       tcode-here ofa-h -           \ length of code section
+       last-h @ n>ofa tsys-w!       \ save it
+       ;
+       
+ ' ofa-meta is ofa-calc
+ 
  : init-assembler  ( -- )        \ prepare for assembly code
          [ assembler ] clear-labels 
***************
*** 661,688 ****
              >r code r>
              t-align t-here t-ecxaddr make-tjmp, \ name -> mov ecx, # here | jmp xt
!             macro[ next c; ]macro ;
! 
! ALSO ASSEMBLER DEFINITIONS
! 
! : label   a;  tcode-here constant ;
! 
! : (end-code)
!       a;
!       in-meta  check-labels
!       [ asm-hidden ]  ?finished ?unres  [ assembler ]  ?csp
!       in-code? off
!       ;
! 
! ' (end-code) is end-code
! ' (end-code) is ;c
! 
! PREVIOUS DEFINITIONS
! 
! : ofa-meta  ( -- )
!       tcode-here ofa-h -           \ length of code section
!       last-h @ n>ofa tsys-w!       \ save it
!       ;
!       
! ' ofa-meta is ofa-calc
  
  \ ======================================================================
--- 684,689 ----
              >r code r>
              t-align t-here t-ecxaddr make-tjmp, \ name -> mov ecx, # here | jmp xt
!             macro[ c; ]macro  
!             ofa-meta ;
  
  \ ======================================================================
***************
*** 721,726 ****
               mov     ecx, # r@
               jmp     s" 't-ptr dovoc" evaluate
-              next
               (end-code)
          ]macro r>drop
          in-application
--- 722,727 ----
               mov     ecx, # r@
               jmp     s" 't-ptr dovoc" evaluate
               (end-code)
+              ofa-meta
          ]macro r>drop
          in-application
***************
*** 763,767 ****
          cr
          ct-link
!         begin   @ dup
          while dup
            ctlink>ptr tsys-there
--- 764,768 ----
          cr
          ct-link
!         begin   @ dup                                    
          while dup
            ctlink>ptr tsys-there
***************
*** 1017,1023 ****
              >r code 
              r@ t-literal
!             macro[
!                 next c;
!             ]macro r>drop
              ;
  
--- 1018,1022 ----
              >r code 
              r@ t-literal
!             macro[ next c; ]macro r>drop
              ;
  
***************
*** 1114,1118 ****
          2dup
          ste-o ! ste-i !
!         last-h @ n>ste dup>r 1+ tsys-c! r> tsys-c! ;
          
  \ ======================================================================
--- 1113,1117 ----
          2dup
          ste-o ! ste-i !
!         last-h @ n>ste dup>r 1+ tsys-c! r> tsys-c! ; 
          
  \ ======================================================================

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
*** gkernel.f	22 Nov 2006 00:07:14 -0000	1.26
--- gkernel.f	30 Nov 2006 20:17:32 -0000	1.27
***************
*** 244,251 ****
  \ --------------------------   Primitives  -----------------------------
  
- gcode _next
-                 next
-                 ;g
- 
  code dovar  ( -- n )                          \ variable
                  mov     -4 [ebp], eax
--- 244,247 ----
***************
*** 2457,2475 ****
              then ;
  
  \ ---------------------------- Defining Words --------------------------------
  
! 1 constant tval
! 2 constant tvar 
  3 constant tcon 
! 4 constant tusr 
  5 constant tdef
  6 constant tloc
  7 constant tcol
  
! : mov-tos,#n  ( n -- )                          \ generate a mov eax, # n
              sync-code                         \ generate pending code
              $C0C7 code-w, code-, ;            \ mov eax, #
  
! : mov-ecx,#n  ( n -- )                          \ generate a mov ecx, # n
              sync-code                         \ generate pending code
              $C1C7 code-w, code-, ;            \ mov ecx, #
--- 2453,2478 ----
              then ;
  
+ : unnest    ( -- )                            \ generate a return
+             $c3 code-c, ; immediate
+ 
  \ ---------------------------- Defining Words --------------------------------
  
! 1 constant tval                               \ constants for type system
! 2 constant tvar                               \ in support of TO and +TO
  3 constant tcon 
! 4 constant tusr
  5 constant tdef
  6 constant tloc
  7 constant tcol
+ 8 constant tvoc
+ 9 constant tflt
+ 10 constant tstr
+ 11 constant tobj
  
! : mov-tos,#n  ( n -- )                        \ generate a mov eax, # n
              sync-code                         \ generate pending code
              $C0C7 code-w, code-, ;            \ mov eax, #
  
! : mov-ecx,#n  ( n -- )                        \ generate a mov ecx, # n
              sync-code                         \ generate pending code
              $C1C7 code-w, code-, ;            \ mov ecx, #
***************
*** 2491,2496 ****
              tfa!                              \ set the type
              here mov-ecx,#n xt-jmp,             \ name -> mov ecx, # here | jmp xt
!             ofa-calc                          \ length calculation
!             _next (copy-code) ;                 \ stops disasm
  
  : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal
--- 2494,2498 ----
              tfa!                              \ set the type
              here mov-ecx,#n xt-jmp,             \ name -> mov ecx, # here | jmp xt
!             ofa-calc ;                        \ length calculation
  
  : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal
***************
*** 2508,2512 ****
  0 1 in/out : create    ( -<name>- )           \ pointer
              ['] dovar tvar dogen
!             ['] (comp-create) compiles-last   \ doesn't work because of DOES> needs fixed
              ;
  
--- 2510,2514 ----
  0 1 in/out : create    ( -<name>- )           \ pointer
              ['] dovar tvar dogen
!             ['] (comp-create) compiles-last   \ doesn't work because of DOES> , needs fixed ???
              ;
  
***************
*** 3180,3186 ****
  : _dosconsole   ( fl -- )                        \ true = open, false = close
                  if call AllocConsole drop
!                   STD_OUTPUT_HANDLE call getstdhandle to stdout
!                   STD_INPUT_HANDLE  call getstdhandle to stdin
!                   STD_ERROR_HANDLE  call getstdhandle to stderr
                  else call FreeConsole drop
                  then ;
--- 3182,3188 ----
  : _dosconsole   ( fl -- )                        \ true = open, false = close
                  if call AllocConsole drop
!                   STD_OUTPUT_HANDLE call GetStdHandle to stdout
!                   STD_INPUT_HANDLE  call GetStdHandle to stdin
!                   STD_ERROR_HANDLE  call GetStdHandle to stderr
                  else call FreeConsole drop
                  then ;
***************
*** 4550,4556 ****
  0 value localstk                       \ support for locals (including localalloc)
  
- : unnest        ( -- )                 \ generate a return  
-                 $c3 code-c, ; immediate
- 
  \ EXIT compiles _LOCALFREE, but leaves LOCALSTK alone so that ; can
  \ also compile _LOCALFREE
--- 4552,4555 ----
***************
*** 4875,4881 ****
  |: (voc)        ( #threads -<name>- -- )
                  #wordlist dup                          \ wid address
!                 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 
                  ;
  
--- 4874,4881 ----
  |: (voc)        ( #threads -<name>- -- )
                  #wordlist dup                          \ wid address
!                 header tvoc tfa!                       \ header, it's vocabulary
!                 code-here swap voc>vxt !               \ set the xt for this name
!                 mov-ecx,#n ['] dovoc xt-jmp,           \ set ecx, jmp to dovoc
!                 ofa-calc 
                  ;