win32forth-cvs

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

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

Modified Files:
	dis486.f optinline.f optliterals.f 
Log Message:
arm: support for type system; :noname colon-sys is xt

Index: dis486.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** dis486.f	4 Oct 2006 10:27:22 -0000	1.4
--- dis486.f	13 Nov 2006 00:49:19 -0000	1.5
***************
*** 1065,1102 ****
  
          repeat 3drop ;
  
! : next?         ( a1 -- f1 )
!                 next-seq count tuck compare ;
  
! : rest          ( -- )
!                 begin
!                   dup cr inst
!                   start/stop
!                   swap next? 0=                \ NEXT ?
!                 until drop
                  ;
  
! : see           ( -- )
                  defined ?missing
!                 dup >name n>ofa w@ over +      \ length to disassemble
                  swap
                  begin
!                   2dup - 0> over next? 0= or   \ anything left?
                  while
                    cr inst
                    start/stop
                  repeat
                  ."  ( end )" 2drop
                  ;
  
! hidden
! 
! decimal
! 
! forth definitions
! 
! : rest rest ;
! : see  see  ;
! 
! ONLY FORTH ALSO DEFINITIONS
! 
--- 1065,1109 ----
  
          repeat 3drop ;
+         
+ \ create ttable
+ \  tval , ," value"
+ \  tvar
+ \  tcon
+ \  tusr
+ \  tdef
+ \  tloc
+ \  tcol
  
!         
! : desc-stack    ( n -- )
!                 dup 0< if drop ." ? " else . then ;
!         
! also forth definitions
  
! : describe      ( xt -- )
!                 >name cr
!                 dup ." : " count type
!                 dup (in/out@) swap 
!                   ."  ( " desc-stack
!                   ." -- " desc-stack
!                 dup ." ) "oper-col ." ( len=" n>ofa w@ .
!                 dup ." type=" n>tfa c@ .
!                     ." flag=" n>flg c@ h.2 ."  )"
                  ;
  
! : see           ( <name> -- )
                  defined ?missing
!                 dup describe
!                 dup >name n>ofa w@ over +         \ length to disassemble
                  swap
                  begin
!                   2dup - 0>                       \ anything left?
                  while
                    cr inst
                    start/stop
                  repeat
+                 next-inst c@ $c3 = if cr inst then
                  ."  ( end )" 2drop
                  ;
  
! only forth also definitions

Index: optliterals.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** optliterals.f	5 Nov 2006 23:34:56 -0000	1.8
--- optliterals.f	13 Nov 2006 00:49:19 -0000	1.9
***************
*** 36,42 ****
  [undefined] optimise [if] 
    vocabulary optimise
-   : xt-inline,    ( xt -- )                       \ inline the xt
-                 dup >name n>ofa                 \ get the length
-                 w@ copy-code ;                  \ and copy the code
  [then]
  
--- 36,39 ----
***************
*** 76,84 ****
  ))
  
! :noname drop 4 postpone literal ; compiles-for cell
  :noname drop postpone cell  postpone + ; compiles-for cell+
  :noname drop postpone -cell postpone + ; compiles-for cell-
  :noname drop postpone cells postpone + ; compiles-for cells+
  :noname drop 1 postpone literal postpone - ; compiles-for 1-
  :noname drop 1 postpone literal postpone + ; dup compiles-for 1+ compiles-for char+
  
--- 73,83 ----
  ))
  
! :noname drop cell postpone literal ; compiles-for cell
  :noname drop postpone cell  postpone + ; compiles-for cell+
  :noname drop postpone -cell postpone + ; compiles-for cell-
  :noname drop postpone cells postpone + ; compiles-for cells+
  :noname drop 1 postpone literal postpone - ; compiles-for 1-
+ :noname drop 2 postpone literal postpone - ; compiles-for 2-
+ :noname drop 2 postpone literal postpone + ; compiles-for 2+
  :noname drop 1 postpone literal postpone + ; dup compiles-for 1+ compiles-for char+
  
***************
*** 161,167 ****
             drop lits spush ;              \ the xt is of literal, just loose it
  
- : execpush ( xt -- )                      \ execute op and save result
-            execute lits spush ;
- 
  : lits=1?  ( -- n ) lits sdepth 1 = ;
  : lits>0?  ( -- n ) lits sdepth ;
--- 160,163 ----
***************
*** 170,182 ****
  variable in-sync in-sync off            \ to stop recursion in sync-code
  
! : litsync  ( -- )                         \ called when code is about to be generated
             in-sync @ 0= if               \ recursing?
               in-sync on                  \ no, so set
               std-adjust
!              lits>0? dup if               \ anything to do?
!                -4 mov-n[ebp],tos          \ save tos
!                lits spop #n->tos          \ load tos
!                lits sdepth 0 ?do          \ do for n-1 entries
!                  lits spop over i - 
                   #n->std[]               \ generate a move
                 loop
--- 166,178 ----
  variable in-sync in-sync off            \ to stop recursion in sync-code
  
! : litsync  ( -- )                        \ called when code is about to be generated
             in-sync @ 0= if               \ recursing?
               in-sync on                  \ no, so set
               std-adjust
!              lits>0? dup if              \ anything to do?
!                -4 mov-n[ebp],tos         \ save tos
!                lits spop 0 #n->std[]     \ load tos
!                lits sdepth 0 ?do         \ do for n-1 entries
!                  lits spop over i -
                   #n->std[]               \ generate a move
                 loop
***************
*** 191,195 ****
  ' litsync is sync-code
  
! : opt/     ( xt -- ) lits>1? if lits s2pop swap rot execpush else xt-inline, then ;
  
  : opt=     sub-tos,#n setcc ;
--- 187,191 ----
  ' litsync is sync-code
  
! : opt/     ( xt -- ) lits>1? if lits s2pop swap rot execute lits spush else xt-inline, then ;
  
  : opt=     sub-tos,#n setcc ;

Index: optinline.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optinline.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** optinline.f	28 Oct 2006 09:07:08 -0000	1.4
--- optinline.f	13 Nov 2006 00:49:19 -0000	1.5
***************
*** 39,54 ****
  also optimise definitions
  
- : xt-inline,    ( xt -- )                       \ inline the xt
-                 dup >name n>ofa                 \ get the length
-                 w@ copy-code ;                  \ and copy the code
  
- previous definitions also optimise
- 
- : inline        ( -- )                          \ code will be inlined
-                 tail-call 0= if                 \ there's a tail-call, so not inlineable
-                   ['] xt-inline, compiles-last
-                 then ;
- 
- definitions
  
  \ set some optimisation for constants in the kernel
--- 39,43 ----