[gforth] / gforth / extend.fs  

gforth: gforth/extend.fs

Diff for /gforth/extend.fs between version 1.42 and 1.70

version 1.42, Sat Sep 9 20:32:58 2000 UTC version 1.70, Sat Dec 31 15:29:25 2011 UTC
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,2011 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 
Line 24 
   
 \ .(                                                    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 
Line 35 
   
 \ !! 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 
Line 49 
     \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
   
 \ just as described in dpANS5  \ just as described in dpANS5
   
 0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext  [ifundef] cs-drop
     immediate  : 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  : 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 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  : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
     postpone drop      >r cs-drop postpone drop r> n-thens ; immediate
     0 ?do postpone then loop ; immediate  
   
 \ C"                                                    17may93jaw  : 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")     "lit ;  
   
 : CLiteral  \ C"                                                    17may93jaw
     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{"}
Line 97 
Line 115 
   
 \ 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 
Line 141 
     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 
Line 150 
   
 \ 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 146 
Line 165 
     >in @      >in @
     loadfile @      loadfile @
     if      if
         loadfile @ file-position throw #fill-bytes @ 0 d- \ !! bug for CRLF and EOF          loadfile @ file-position throw
           [IFDEF] #fill-bytes #fill-bytes @ [ELSE] #tib @ 1+ [THEN] 0 d-
     else      else
         blk @          blk @
         linestart @          linestart @
Line 180 
Line 200 
     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 197 
Line 217 
     \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 211 
Line 232 
 \ 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 239 
Line 252 
     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 266 
Line 281 
     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

Generate output suitable for use with a patch program
Legend:
Removed from v.1.42  
changed lines
  Added in v.1.70
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help