--- gforth/extend.fs 2009/12/31 15:32:35 1.65 +++ gforth/extend.fs 2011/08/12 16:53:19 1.69 @@ -1,6 +1,6 @@ \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw -\ Copyright (C) 1995,1998,2000,2003,2005,2007,2009 Free Software Foundation, Inc. +\ Copyright (C) 1995,1998,2000,2003,2005,2007,2009,2010 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -60,21 +60,39 @@ decimal \ just as described in dpANS5 -0 CONSTANT case ( compilation -- case-sys ; run-time -- ) \ core-ext - immediate +[ifundef] cs-drop +: CS-DROP ( dest -- ) \ gforth + dest? 2drop ; +[then] + +: case ( compilation -- case-sys ; run-time -- ) \ core-ext + postpone begin 0 ; immediate + +: ?of ( compilation -- of-sys ; run-time f -- ) \ gforth + >r POSTPONE if r> ; immediate : of ( compilation -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext \ !! the implementation does not match the stack effect - 1+ >r - postpone over postpone = postpone if postpone drop - r> ; immediate + postpone over postpone = postpone ?of postpone drop ; immediate : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ core-ext end-of - >r postpone else r> ; immediate + >r postpone else 1 cs-roll r> 1+ ; immediate + +: contof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) + \ like @code{endof}, but loops back to the @code{case} + >r 1 cs-pick postpone again postpone then r> ; immediate + +: n-thens ( orig1 ... origu u -- ) + 0 ?do postpone then loop ; : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case - postpone drop - 0 ?do postpone then loop ; immediate + >r cs-drop postpone drop r> n-thens ; immediate + +: nextcase ( compilation case-sys -- ; run-time x -- ) \ gforth-undocumented + \ like ENDCASE, but start again from the beginning if this is + \ reached by fallthrough + >r postpone drop postpone again r> n-thens ; immediate + \ C" 17may93jaw @@ -199,9 +217,10 @@ variable span ( -- c-addr ) \ core-ext-o \G editing capabilites are available. The length of the string is \G stored in @code{span}; it does not include the \G character. OBSOLESCENT: superceeded by @code{accept}. + everyline 0 rot over BEGIN ( maxlen span c-addr pos1 ) - key decode ( maxlen span c-addr pos2 flag ) + xkey decode ( maxlen span c-addr pos2 flag ) >r 2over = r> or UNTIL 2 pick swap /string type