[Win32forth-cvs] win32forth-stc/src dis486.f,1.19,1.20

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

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

Modified Files:
	dis486.f 
Log Message:
arm: support for extensibly describing different types of words

Index: dis486.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** dis486.f	10 May 2007 06:28:16 -0000	1.19
--- dis486.f	14 May 2007 16:01:00 -0000	1.20
***************
*** 1031,1034 ****
--- 1031,1060 ----
  : desc-stack    ( n -- )
                  dup 0< if drop ." ? " else . then ;
+                 
+ variable desc-list 0 desc-list !                     \ list of desc-hows
+ 
+ : desc-how      ( xt type -- )                       \ how to see an xt
+                 here >r 0 , , , r>                   \ link, type, xt
+                 desc-list add-link ;                 \ add in the link
+ 
+ :noname ( xt nfa -- ) swap execute . ." value " .id                       ; tval desc-how \ for value
+ :noname ( xt nfa -- ) ." variable " .id ." ( is " execute @ 10. ." ) "    ; tvar desc-how \ for variable
+ :noname ( xt nfa -- ) swap execute . ." constant " .id                    ; tcon desc-how \ for constant
+ :noname ( xt nfa -- ) swap >body @ . ." user " .id                        ; tusr desc-how \ for user
+ :noname ( xt nfa -- ) ." defer " .id ." ( is " defer@ .name ." )"         ; tdef desc-how \ for defer
+ :noname ( xt nfa -- ) ." : " .id drop                                     ; tcol desc-how \ for colon
+ :noname ( xt nfa -- ) ." vocabulary " .id drop                            ; tvoc desc-how \ for vocabulary
+ :noname ( xt nfa -- ) ." create " .id ." ( addr " execute $. ." ) "       ; tcre desc-how \ for create
+ :noname ( xt nfa -- ) 0 rot execute . ." offset " .id                     ; toff desc-how \ for offset
+ 
+ : desc-type     ( xt nfa type -- )                   \ find entry and execute
+                 desc-list                            \ fetch entry from linked
+                 begin @ dup                          \ list and cehck if match on type
+                 while
+                   2dup cell+ @ = if                  \ type entry, check type
+                     nip 2 cells+ @ execute exit      \ matches, so execute
+                   then
+                 repeat 
+                 2drop ." ? " .id drop ;              \ default
  
  also forth definitions
***************
*** 1052,1080 ****
  \ *bug needs to check for :noname type xts
  : describe      ( xt -- )
!                 dup>r >name cr
!                 
!                 \ do the header piece;
!                 dup dup n>tfa c@
!                 case
!                   tval of r@ execute . ." value "    .id                         endof
!                   tcon of r@ execute . ." constant " .id                         endof
!                   tvar of ." variable " .id ." ( is " r@ execute @ 10. ." ) "    endof
!                   tcre of ." create "   .id ." ( addr " r@ execute $. ." ) "     endof
!                   tcol of ." : " .id                                             endof
!                   tdef of ." defer " .id ." ( is " r@ defer@ .name ." )"         endof
!                   tvoc of ." vocabulary " .id                                    endof
!                   toff of 0 r@ execute . ." offset " .id                         endof
!                   swap ." : " .id ." ( no type )"
!                 endcase
  
                  \ stack effects
!                 dup (in/out@) swap
!                   ." ( " desc-stack
!                   ." -- " desc-stack
!                 dup ." ) "
  
                  \ compile information
                  oper-col ." \ "
-                 r>                                \ get the xt
                  dup >comp @ dup                   \ fetch the comp xt
                  case
--- 1078,1091 ----
  \ *bug needs to check for :noname type xts
  : describe      ( xt -- )
!                 cr
!                 dup >name 2dup dup>r dup n>tfa c@   \ xt nfa xt nfa type (r: nfa)
!                 desc-type                           \ do the type of the name
  
                  \ stack effects
!                 (in/out@) swap                      \ nfa, get in/out
!                   ." ( " desc-stack ." -- " desc-stack ." ) "
  
                  \ compile information
                  oper-col ." \ "
                  dup >comp @ dup                   \ fetch the comp xt
                  case
***************
*** 1093,1102 ****
  
                  \ misc head info
                  cr oper-col ." \ len=" n>ofa w@ .
!                 dup ." type=" n>tfa c@ .
!                 dup ." flag=" n>flg c@ h.2
  
                  \ tell user where the word was loaded
!                 cr oper-col ." \ " .viewinfo
                  ;
  
--- 1104,1114 ----
  
                  \ misc head info
+                 r@                                 \ get back nfa
                  cr oper-col ." \ len=" n>ofa w@ .
!                 r@ ." type=" n>tfa c@ .
!                 r@ ." flag=" n>flg c@ h.2
  
                  \ tell user where the word was loaded
!                 cr oper-col ." \ " r> .viewinfo
                  ;