Diff for /gforth/extend.fs between versions 1.43 and 1.68

version 1.43, 2000/09/10 19:50:33 version 1.68, 2011/08/10 13:55:02
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,2003,2005,2007,2009,2010 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ 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, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  
   
   
 \ May be cross-compiled  \ May be cross-compiled
Line 25  decimal Line 24  decimal
   
 \ .(                                                    12may93jaw  \ .(                                                    12may93jaw
   
 : .(   ( compilation,interpretation "ccc<paren>" -- ) \ core-ext dot-paren  : .(   ( compilation&interpretation "ccc<paren>" -- ) \ core-ext dot-paren
   \G Compilation and interpretation semantics: Parse a string @i{ccc}    \G Compilation and interpretation semantics: Parse a string @i{ccc}
   \G delimited by a @code{)} (right parenthesis). Display the    \G delimited by a @code{)} (right parenthesis). Display the
   \G string. This is often used to display progress information during    \G string. This is often used to display progress information during
Line 36  decimal Line 35  decimal
   
 \ !! 2value  \ !! 2value
   
   [ifundef] 2literal
 : 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 @i{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
   [then]
   
 ' drop alias d>s ( d -- n ) \ double            d_to_s  ' drop alias d>s ( d -- n ) \ double            d_to_s
   
Line 48  decimal Line 49  decimal
     \G In ANS Forth u3 can only be a positive signed number.      \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
     r> IF dnegate THEN ;      [ 1 -3 mod 0< ] [if]
           -rot r> IF IF 1. d+ THEN dnegate ELSE drop THEN
       [else]
           nip swap r> IF dnegate THEN
       [then] ;
   
 \ CASE OF ENDOF ENDCASE                                 17may93jaw  \ CASE OF ENDOF ENDCASE                                 17may93jaw
   
Line 58  decimal Line 63  decimal
 0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext  0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext
     immediate      immediate
   
   : ?of ( compilation  -- of-sys ; run-time  f -- ) \ gforth
       1+ >r POSTPONE if r> ; immediate
   
 : of ( compilation  -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext  : of ( compilation  -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
     \ !! the implementation does not match the stack effect      \ !! the implementation does not match the stack effect
     1+ >r      postpone over postpone = postpone ?of postpone drop ; immediate
     postpone over postpone = postpone if postpone drop  
     r> ; immediate  
   
 : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time  -- ) \ core-ext end-of  : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time  -- ) \ core-ext end-of
     >r postpone else r> ; immediate      >r postpone else r> ; immediate
Line 73  decimal Line 79  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 @i{ccc} delimited by a @code{"}      \G Compilation: parse a string @i{ccc} delimited by a @code{"}
     \G (double quote). At run-time, return @i{c-addr} which      \G (double quote). At run-time, return @i{c-addr} which
Line 97  decimal Line 98  decimal
   
 \ CONVERT                                               17may93jaw  \ CONVERT                                               17may93jaw
   
 : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext  : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext-obsolescent
     \G OBSOLESCENT: superseded by @code{>number}.      \G Obsolescent: superseded by @code{>number}.
     char+ true >number drop ;      char+ true >number drop ;
   
 \ ERASE                                                 17may93jaw  \ ERASE                                                 17may93jaw
Line 123  decimal Line 124  decimal
     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 132  decimal Line 133  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
Line 181  decimal Line 183  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-obsolescent
 \G @code{Variable} -- @i{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
 \G 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-obsolescent
     \G Receive a string of at most @i{+n} characters, and store it      \G Receive a string of at most @i{+n} characters, and store it
     \G in memory starting at @i{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
Line 198  variable span ( -- c-addr ) \ core-ext Line 200  variable span ( -- c-addr ) \ core-ext
     \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}.
       everyline
     0 rot over      0 rot over
     BEGIN ( maxlen span c-addr pos1 )      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          >r 2over = r> or
     UNTIL      UNTIL
     2 pick swap /string type      2 pick swap /string type
Line 212  variable span ( -- c-addr ) \ core-ext Line 215  variable span ( -- c-addr ) \ core-ext
 \ defined afterwards) when executing the mark.  \ defined afterwards) when executing the mark.
   
 : included-files-mark ( -- u )  : included-files-mark ( -- u )
     included-files 2@ nip      included-files @ ;
     blk @ 0=  
     if \ not input from blocks  
         source-id 1 -1 within  
         if \ input from file  
             1- \ do not include the last file (hopefully this is the  
                \ currently included file)  
         then  
     then ;    
   
 \ hmm, most of the saving appears to be pretty unnecessary: we could  \ hmm, most of the saving appears to be pretty unnecessary: we could
 \ derive the wordlists and the words that have to be kept from the  \ derive the wordlists and the words that have to be kept from the
Line 240  variable span ( -- c-addr ) \ core-ext Line 235  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
     included-files 2@ drop over @ included-files 2! cell+      included-files @ over @ min included-files ! cell+
     \ rest of marker!      \ rest of marker!
     dup @ swap cell+ ( here rest-of-marker )      dup @ swap cell+ ( here rest-of-marker )
     dup @ voclink ! cell+      dup @ voclink ! cell+
Line 267  variable span ( -- c-addr ) \ core-ext Line 264  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 drop
   [THEN]
     @ udp !  dp !      @ udp !  dp !
     \ clean up vocabulary stack      \ clean up vocabulary stack
     0 vp @ 0      0 vp @ 0

Removed from v.1.43  
changed lines
  Added in v.1.68


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