Diff for /gforth/extend.fs between versions 1.34 and 1.53

version 1.34, 1999/03/29 22:52:28 version 1.53, 2003/01/26 20:56:37
Line 1 Line 1
 \ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw  \ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw
   
 \ Copyright (C) 1995,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1998,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 Line 16
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ May be cross-compiled  \ May be cross-compiled
Line 25  decimal Line 25  decimal
   
 \ .(                                                    12may93jaw  \ .(                                                    12may93jaw
   
 : .(   ( "ccc<paren>" -- ) \ core-ext dot-paren  : .(   ( compilation&interpretation "ccc<paren>" -- ) \ core-ext dot-paren
   \G Parse a string @var{ccc} delimited by a @code{)} (right    \G Compilation and interpretation semantics: Parse a string @i{ccc}
   \G parenthesis). Display the string. This is often used to display    \G delimited by a @code{)} (right parenthesis). Display the
   \G progress information during compilation; see examples below.    \G string. This is often used to display progress information during
     \G compilation; see examples below.
   [char] ) parse type ; immediate    [char] ) parse type ; immediate
   
 \ VALUE 2>R 2R> 2R@                                     17may93jaw  \ VALUE 2>R 2R> 2R@                                     17may93jaw
Line 36  decimal Line 37  decimal
 \ !! 2value  \ !! 2value
   
 : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal  : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
     \G Compile appropriate code such that, at run-time, cell pair @var{w1, w2} are      \G Compile appropriate code such that, at run-time, cell pair @i{w1, w2} are
     \G placed on the stack. Interpretation semantics are undefined.      \G placed on the stack. Interpretation semantics are undefined.
     swap postpone Literal  postpone Literal ; immediate restrict      swap postpone Literal  postpone Literal ; immediate restrict
   
 ' drop alias d>s ( d -- n ) \ double            d_to_s  ' drop alias d>s ( d -- n ) \ double            d_to_s
   
 : m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash  : m*/ ( d1 n2 u3 -- dquot ) \ double m-star-slash
       \G dquot=(d1*n2)/u3, with the intermediate result being triple-precision.
       \G In ANS Forth u3 can only be a positive signed number.
     >r s>d >r abs -rot      >r s>d >r abs -rot
     s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*      s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
     swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap      swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
Line 70  decimal Line 73  decimal
   
 \ C"                                                    17may93jaw  \ C"                                                    17may93jaw
   
 : (c")     "lit ;  
   
 : CLiteral  
     postpone (c") here over char+ allot  place align ; immediate restrict  
   
 : C" ( compilation "ccc<quote>" -- ; run-time  -- c-addr ) \ core-ext c-quote  : C" ( compilation "ccc<quote>" -- ; run-time  -- c-addr ) \ core-ext c-quote
     \G Compilation: parse a string @var{ccc} delimited by a @code{"}      \G Compilation: parse a string @i{ccc} delimited by a @code{"}
     \G (double quote). At run-time, return @var{c-addr} which      \G (double quote). At run-time, return @i{c-addr} which
     \G specifies the counted string @var{ccc}.  Interpretation      \G specifies the counted string @i{ccc}.  Interpretation
     \G semantics are undefined.      \G semantics are undefined.
     [char] " parse postpone CLiteral ; immediate restrict      [char] " parse postpone CLiteral ; immediate restrict
   
 \ [COMPILE]                                             17may93jaw  \ [COMPILE]                                             17may93jaw
   
 : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile  : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
     comp' drop compile, ; immediate      comp' drop
       dup [ comp' exit drop ] literal = if
           execute \ EXIT has default compilation semantics, perform them
       else
           compile,
       then ; immediate
   
 \ CONVERT                                               17may93jaw  \ CONVERT                                               17may93jaw
   
Line 95  decimal Line 98  decimal
   
 \ ERASE                                                 17may93jaw  \ ERASE                                                 17may93jaw
   
 : erase ( addr len -- ) \ core-ext  : erase ( addr u -- ) \ core-ext
     \G If @var{len}>0, clear all bits in each location of a memory region      \G Clear all bits in @i{u} aus starting at @i{addr}.
     \G of @var{len} address units starting at address @var{addr}.  
     \ !! dependence on "1 chars 1 ="      \ !! dependence on "1 chars 1 ="
     ( 0 1 chars um/mod nip )  0 fill ;      ( 0 1 chars um/mod nip )  0 fill ;
 : blank ( c-addr u -- ) \ string  : blank ( c-addr u -- ) \ string
     \G If @var{u}>0, store the character value for a space in each      \G Store the space character into @i{u} chars starting at @i{c-addr}.
     \G location of a memory region  
     \G of @var{u} character units starting at address @var{c-addr}.  
     bl fill ;      bl fill ;
   
 \ SEARCH                                                02sep94py  \ SEARCH                                                02sep94py
   
 : search ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) \ string  : search ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) \ string
     \G Search the string specified by @var{c-addr1, u1} for the string      \G Search the string specified by @i{c-addr1, u1} for the string
     \G specified by @var{c-addr2, u2}. If @var{flag} is true: match was found      \G specified by @i{c-addr2, u2}. If @i{flag} is true: match was found
     \G at @var{c-addr3} with @var{u3} characters remaining. If @var{flag} is false:      \G at @i{c-addr3} with @i{u3} characters remaining. If @i{flag} is false:
     \G no match was found; @var{c-addr3, u3} are equal to @var{c-addr1, u1}.      \G no match was found; @i{c-addr3, u3} are equal to @i{c-addr1, u1}.
     \ not very efficient; but if we want efficiency, we'll do it as primitive      \ not very efficient; but if we want efficiency, we'll do it as primitive
     2>r 2dup      2>r 2dup
     begin      begin
         dup r@ >=          dup r@ >=
     while      while
         over 2r@ swap -text 0= if          2dup 2r@ string-prefix? if
             2swap 2drop 2r> 2drop true exit              2swap 2drop 2r> 2drop true exit
         endif          endif
         1 /string          1 /string
Line 127  decimal Line 127  decimal
   
 \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw  \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw
   
   [IFUNDEF] source-id
 : source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d  : source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
     \G Return 0 (the input source is the user input device), -1 (the      \G Return 0 (the input source is the user input device), -1 (the
     \G input source is a string being processed by @code{evaluate}) or      \G input source is a string being processed by @code{evaluate}) or
     \G a @var{fileid} (the input source is the file specified by      \G a @i{fileid} (the input source is the file specified by
     \G @var{fileid}).      \G @i{fileid}).
     loadfile @ dup 0= IF  drop sourceline# 0 min  THEN ;      loadfile @ dup 0= IF  drop sourceline# 0 min  THEN ;
   
 : save-input ( -- xn .. x1 n ) \ core-ext  : save-input ( -- xn .. x1 n ) \ core-ext
     \G The @var{n} entries @var{xn - x1} describe the current state of the      \G The @i{n} entries @i{xn - x1} describe the current state of the
     \G input source specification, in some platform-dependent way that can      \G input source specification, in some platform-dependent way that can
     \G be used by @code{restore-input}.      \G be used by @code{restore-input}.
     >in @      >in @
     loadfile @      loadfile @
     if      if
         loadfile @ file-position throw          loadfile @ file-position throw
           [IFDEF] #fill-bytes #fill-bytes @ [ELSE] #tib @ 1+ [THEN] 0 d-
     else      else
         blk @          blk @
         linestart @          linestart @
Line 153  decimal Line 155  decimal
   
 : restore-input ( xn .. x1 n -- flag ) \ core-ext  : restore-input ( xn .. x1 n -- flag ) \ core-ext
     \G Attempt to restore the input source specification to the state      \G Attempt to restore the input source specification to the state
     \G described by the @var{n} entries @var{xn - x1}. @var{flag} is      \G described by the @i{n} entries @i{xn - x1}. @i{flag} is
     \G true if the restore fails.      \G true if the restore fails.  In Gforth it fails pretty often
       \G (and sometimes with a @code{throw}).
     6 <> -12 and throw      6 <> -12 and throw
     source-id <> -12 and throw      source-id <> -12 and throw
     >tib !      >tib !
Line 162  decimal Line 165  decimal
     loadfile @ 0<>      loadfile @ 0<>
     if      if
         loadfile @ reposition-file throw          loadfile @ reposition-file throw
           refill 0= -36 and throw \ should never throw
     else      else
         linestart !          linestart !
         blk !          blk !
Line 173  decimal Line 177  decimal
     r> loadline !      r> loadline !
     >in !      >in !
     false ;      false ;
   [THEN]
 \ This things we don't need, but for being complete... jaw  \ This things we don't need, but for being complete... jaw
   
 \ EXPECT SPAN                                           17may93jaw  \ EXPECT SPAN                                           17may93jaw
   
 variable span ( -- c-addr ) \ core-ext  variable span ( -- c-addr ) \ core-ext
 \ VARIABLE: @var{c-addr} is the address of a cell that stores the  \G @code{Variable} -- @i{c-addr} is the address of a cell that stores the
 \ length of the last string received by @code{expect}. OBSOLESCENT.  \G length of the last string received by @code{expect}. OBSOLESCENT.
   
 : expect ( c-addr +n -- ) \ core-ext  : expect ( c-addr +n -- ) \ core-ext
     \G Receive a string of at most @var{+n} characters, and store it      \G Receive a string of at most @i{+n} characters, and store it
     \G in memory starting at @var{c-addr}. The string is      \G in memory starting at @i{c-addr}. The string is
     \G displayed. Input terminates when the <return> key is pressed or      \G displayed. Input terminates when the <return> key is pressed or
     \G @var{+n} characters have been received. The normal Gforth line      \G @i{+n} characters have been received. The normal Gforth line
     \G editing capabilites are available. The length of the string is      \G editing capabilites are available. The length of the string is
     \G stored in @code{span}; it does not include the <return>      \G stored in @code{span}; it does not include the <return>
     \G character. OBSOLESCENT: superceeded by @code{accept}.      \G character. OBSOLESCENT: superceeded by @code{accept}.
Line 232  variable span ( -- c-addr ) \ core-ext Line 236  variable span ( -- c-addr ) \ core-ext
     REPEAT      REPEAT
     drop      drop
     \ remember udp      \ remember udp
     udp @ , ;      udp @ ,
       \ remember dyncode-ptr
       here ['] noop , compile-prim1 finish-code ;
   
 : marker! ( mark -- )  : marker! ( mark -- )
     \ reset included files count; resize will happen on next add-included-file      \ reset included files count; resize will happen on next add-included-file
Line 259  variable span ( -- c-addr ) \ core-ext Line 265  variable span ( -- c-addr ) \ core-ext
     REPEAT      REPEAT
     drop      drop
     \ restore udp and dp      \ restore udp and dp
   [IFDEF] forget-dyncode
       dup cell+ @ forget-dyncode 0= abort" gforth bug"
   [THEN]
     @ udp !  dp !      @ udp !  dp !
     \ clean up vocabulary stack      \ clean up vocabulary stack
     0 vp @ 0      0 vp @ 0
Line 272  variable span ( -- c-addr ) \ core-ext Line 281  variable span ( -- c-addr ) \ core-ext
     THEN ;      THEN ;
   
 : marker ( "<spaces> name" -- ) \ core-ext  : marker ( "<spaces> name" -- ) \ core-ext
     \G Create a definition, @var{name} (called a @var{mark}) whose      \G Create a definition, @i{name} (called a @i{mark}) whose
     \G execution semantics are to remove itself and everything       \G execution semantics are to remove itself and everything 
     \G defined after it.      \G defined after it.
     marker, Create A,      marker, Create A,

Removed from v.1.34  
changed lines
  Added in v.1.53


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>