win32forth-cvs

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

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

Modified Files:
	switch.f 
Log Message:
gah: corrected some stack comments and dexed file.

Index: switch.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/switch.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** switch.f	20 Jun 2005 07:40:48 -0000	1.2
--- switch.f	16 May 2008 09:14:28 -0000	1.3
***************
*** 27,30 ****
--- 27,53 ----
  \ See Switches.txt for information about switches
  
+ \ *! p-switch W32F switch
+ \ *T Using Switches
+ 
+ \ *P Switches are a cross between chains and case structures. Like chains they can be defined where they need to be
+ \ ** compiled and extended by later code. Like case structures they perform different operations depending on the
+ \ ** value on the top of the stack. Unlike CASE the comparators are stored as a single cell so cannot be a
+ \ ** non-constant value. Also they pass the input value to a default case if no match is found in the linked cases,
+ \ ** whereas with CASE one has to add code to handle a default case. For more information on switches see
+ \ ** Forth Dimensions Volume 20 Issue 3 (Page 19 onwards).
+ 
+ \ *S STRUCTURE OF A SWITCH
+ 
+ \ *E HEADER OF SWITCH                      SWITCH CELL
+ \ **  | DOSWITCH      CFA of SWITCH
+ \ **  | SWITCH LINK   First case/null ---> SWITCH LINK Next case/null --->
+ \ **  | XT            Default              COMPARATOR  Value to match
+ \ **  | SWITCHES LINK Next switch/null __  XT          Word to run if matched
+ \ **  V                                  |
+ \ **                                     V
+ 
+ \ *S GLOSSARY
+ 
+ 
  Only Forth also definitions decimal \ gah 14mar03 Make sure of search order
  
***************
*** 64,70 ****
  external
  
! \ Define a new switch -<name>- whose default action is xt and open it for
! \ adding conditions
! : :SWITCH ( xt -<name>- -- head )
    NOSTACK
    (SWITCH) HERE 0 , SWAP ,
--- 87,93 ----
  external
  
! : :SWITCH ( xt -<name>- -- head )  \              FORTH            SYSTEM
! \ *G Define a switch -<name>- that executes the procedure whose xt is on the stack ( with the input argument on top
! \ ** of the stack ) if no matching condition has been added to the switch and open it for adding conditions.
    NOSTACK
    (SWITCH) HERE 0 , SWAP ,
***************
*** 72,78 ****
    dup to current-switch ;  \ gah 9mar03 for security
  
! \ Define a new switch -<name>- whose default action is -<default>- and open
! \ it for adding conditions
! : [SWITCH ( -<name>- -- head )
    nostack                 \ rbs
    (switch)  HERE 0 ,  ' ,
--- 95,101 ----
    dup to current-switch ;  \ gah 9mar03 for security
  
! : [SWITCH ( -<name>- -<default>- -- head )   \    FORTH            SYSTEM
! \ *G Define a new switch -<name>- whose default action is -<default>- and open
! \ ** it for adding conditions.
    nostack                 \ rbs
    (switch)  HERE 0 ,  ' ,
***************
*** 81,87 ****
     ;
  
! \ Define a new switch -<name>- whose default action is the following inline
! \ forth code
! : SWITCH: ( -<name>- -<code ;>- -- head )      \ gah 13mar03
    nostack (switch) here 0 ,
    dup to current-switch
--- 104,112 ----
     ;
  
!  \ gah 13mar03
! : SWITCH: ( -<name>- -<code ;>- -- head )     \   FORTH            SYSTEM
! \ *G Define a new switch -<name>- whose default action is the following inline
! \ ** forth code (up to the terminating ;). The forth words can call the switch
! \ ** -<name>- as a recursive call with -<name>- .
    nostack (switch) here 0 ,
    dup to current-switch
***************
*** 95,101 ****
  \ gah 23mar03 eliminated <SWITCH
  
! 
! \ Open existing SWITCH -<name>- for additional conditions
! : [+SWITCH ( -<name>- -- head )
    nostack                      \ rbs turn off stack checking
    ' dup @ doswitch = 0=        \ gah 3mar03 added test for valid switch
--- 120,125 ----
  \ gah 23mar03 eliminated <SWITCH
  
! : [+SWITCH ( -<name>- -- head )    \              FORTH            SYSTEM
! \ *G Open existing SWITCH -<name>- for additional conditions.
    nostack                      \ rbs turn off stack checking
    ' dup @ doswitch = 0=        \ gah 3mar03 added test for valid switch
***************
*** 105,122 ****
  internal
  
! \ Error if switch not open for additional conditions
! : SWITCH-OPEN  current-switch 0= abort" No switch is open !" ;
  
- \ Error if not link
  : NOT-LINK ( head n -- head n )
       over current-switch <> abort" Not valid switch link !" ;
  
! \ Check for errors
! : RUN-ERROR switch-open not-link ;
  
  external
  
! \ Close SWITCH structure
! : SWITCH] ( head -- )
    switch-open
    dup current-switch <> abort" Not trying to close valid switch !"
--- 129,148 ----
  internal
  
! : SWITCH-OPEN   ( -- )
! \ Error if switch not open for additional conditions.
!      current-switch 0= abort" No switch is open !" ;
  
  : NOT-LINK ( head n -- head n )
+ \ Error if not link.
       over current-switch <> abort" Not valid switch link !" ;
  
! : RUN-ERROR   ( -- )
! \ Check for errors.
!      switch-open not-link ;
  
  external
  
! : SWITCH] ( head -- ) \                           FORTH            SYSTEM
! \ *G Close SWITCH structure. An error occurs if head is not the head of the currently open switch.
    switch-open
    dup current-switch <> abort" Not trying to close valid switch !"
***************
*** 124,134 ****
    0 to current-switch DROP ;
  
! \ Add a condition that runs -<word>-
! : RUNS ( head n -<word>- -- )
    run-error
    ' 3reverse dup link, -rot , , ;
  
! \ Add a condition that runs the code up to ;
! : RUN: ( head n -<words ;>- -- )
    run-error
    over link, , here cell allot
--- 150,163 ----
    0 to current-switch DROP ;
  
! : RUNS ( head n -<word>- -- head ) \              FORTH            SYSTEM
! \ *G Add a condition to the currently open switch structure that runs -<word>- if the value n is passed to the
! \ ** switch. An error occurs if head is not the head of the currently open switch, or no switch is open.
    run-error
    ' 3reverse dup link, -rot , , ;
  
! : RUN: ( head n -<words ;>- -- head ) \           FORTH            SYSTEM
! \ *G Add a condition to the currently open switch structure that runs the following forth words up to ; if the
! \ ** value n is passed to the switch. An error occurs if head is not the head of the currently open switch, or no
! \ ** switch is open.
    run-error
    over link, , here cell allot
***************
*** 137,142 ****
  internal
  
- \ trim down the switch linked list
  : trim-switches   ( nfa -- nfa )
          switch-link
          begin   @ ?dup
--- 166,171 ----
  internal
  
  : trim-switches   ( nfa -- nfa )
+ \ trim down the switch linked list.
          switch-link
          begin   @ ?dup
***************
*** 148,159 ****
  defined unknown? nip 0= [IF]
  
- \ Return true if xt is an unnamed definition
  : UNKNOWN?  ( xt -- f )
            >NAME NAME> ['] [UNKNOWN] = ;
  
  [THEN]
  
- \ Print out a condition
  : .CONDITION  ( link -- )
       dup cell+ @ . cell+ Cell+ @ dup unknown?
       if ." RUN:" >body .pfa
--- 177,188 ----
  defined unknown? nip 0= [IF]
  
  : UNKNOWN?  ( xt -- f )
+ \ Return true if xt is an unnamed definition.
            >NAME NAME> ['] [UNKNOWN] = ;
  
  [THEN]
  
  : .CONDITION  ( link -- )
+ \ Print out a condition.
       dup cell+ @ . cell+ Cell+ @ dup unknown?
       if ." RUN:" >body .pfa
***************
*** 161,181 ****
       then cr ;
  
- \ Print out all conditions
  : .CONDITIONS  ( link -- )
       cr begin ?dup While
       dup .condition @ repeat ;
  
- \ Print default
  : .DEFAULT ( xt -- )
       ." default ( n -- ) " 2 cells + @ dup unknown?
       if ." does: " >body .pfa
       else .name then ;
  
- \ Print Switch
  : (.SWITCH) ( xt -- )
      dup cr .default >body @ .conditions ;
  
- \ Used by SEE
  : _.SWITCH  ( xt -- xt|0)
    -if dup @ doswitch = if ." is a switch"
     (.switch) 0 then then ;
--- 190,210 ----
       then cr ;
  
  : .CONDITIONS  ( link -- )
+ \ Print out all conditions.
       cr begin ?dup While
       dup .condition @ repeat ;
  
  : .DEFAULT ( xt -- )
+ \ Print default.
       ." default ( n -- ) " 2 cells + @ dup unknown?
       if ." does: " >body .pfa
       else .name then ;
  
  : (.SWITCH) ( xt -- )
+ \ Print Switch.
      dup cr .default >body @ .conditions ;
  
  : _.SWITCH  ( xt -- xt|0)
+ \ Used by SEE.
    -if dup @ doswitch = if ." is a switch"
     (.switch) 0 then then ;
***************
*** 185,195 ****
  external
  
! \ Used interactively
! : .SWITCH ( xt -- )
      dup @ doswitch <> abort" expects the xt of a SWITCH"
      cr dup .name (.switch) ;
  
! \ Print out list of all switches
! : .SWITCHES
      cr switch-link begin @ ?dup while
      dup -3 cells + .switch repeat ;
--- 214,227 ----
  external
  
! : .SWITCH ( xt -- ) \                             FORTH            SYSTEM
! \ *G Print out all the conditions defined for this switch.Using SEE -< name >- on a switch has the same effect.
! \ ** Conditions are listed default first followed by the others with in the order they are found i.e. the later
! \ ** they are defined the earlier they are in the list.
      dup @ doswitch <> abort" expects the xt of a SWITCH"
      cr dup .name (.switch) ;
  
! : .SWITCHES \                                     FORTH            SYSTEM
! \ *G Print out all the defined switches.The more recently a switch has been defined the earlier it comes in the
! \ ** list.
      cr switch-link begin @ ?dup while
      dup -3 cells + .switch repeat ;
***************
*** 197,202 ****
  internal also bug
  
- \ Nest into switch when debugging
  : DBG-NEST-SWITCH  ( xt false | true -- xt false | true )
     dup ?exit                                       \ exit if already dealt with
     over @ doswitch = if drop ." SWITCH nesting "   \ is this a switch
--- 229,234 ----
  internal also bug
  
  : DBG-NEST-SWITCH  ( xt false | true -- xt false | true )
+ \ Nest into switch when debugging.
     dup ?exit                                       \ exit if already dealt with
     over @ doswitch = if drop ." SWITCH nesting "   \ is this a switch
***************
*** 213,218 ****
  \in-system-ok dbg-nest-chain chain-add dbg-nest-switch
  
- \ Print this is a switch
  : .WORD-TYPE-SWITCH  ( xt false | true -- xt false | true )
      dup ?exit
      over @ doswitch = if
--- 245,250 ----
  \in-system-ok dbg-nest-chain chain-add dbg-nest-switch
  
  : .WORD-TYPE-SWITCH  ( xt false | true -- xt false | true )
+ \ Print this is a switch.
      dup ?exit
      over @ doswitch = if
***************
*** 226,228 ****
  in-application
  
!