Diff for /gforth/stuff.fs between versions 1.26 and 1.70

version 1.26, 2003/01/24 22:03:20 version 1.70, 2011/12/31 15:29:25
Line 1 Line 1
 \ miscelleneous words  \ miscelleneous words
   
 \ Copyright (C) 1996,1997,1998,2000 Free Software Foundation, Inc.  \ Copyright (C) 1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
   
 require glocals.fs  require glocals.fs
   
Line 51  AUser CSP Line 50  AUser CSP
 \G @code{system} command.  \G @code{system} command.
   
 : system ( c-addr u -- ) \ gforth  : system ( c-addr u -- ) \ gforth
 \G Pass the string specified by @var{c-addr u} to the host operating system  \G Pass the string specified by @var{c-addr u} to the host operating
 \G for execution in a sub-shell.  \G system for execution in a sub-shell.  The value of the environment
   \G variable @code{GFORTHSYSTEMPREFIX} (or its default value) is
   \G prepended to the string (mainly to support using @code{command.com}
   \G as shell in Windows instead of whatever shell Cygwin uses by
   \G default; @pxref{Environment variables}).
     (system) throw TO $? ;      (system) throw TO $? ;
   
 : sh ( "..." -- ) \ gforth  : sh ( "..." -- ) \ gforth
Line 98  AUser CSP Line 101  AUser CSP
     ur compile-fliterals uw compile-literals      ur compile-fliterals uw compile-literals
     target compile, POSTPONE exit reveal ;      target compile, POSTPONE exit reveal ;
   
 : const-does> ( run-time: w*uw r*ur uw ur "name" -- )  : const-does> ( run-time: w*uw r*ur uw ur "name" -- ) \ gforth
     \G Defines @var{name} and returns.@sp 0      \G Defines @var{name} and returns.
       \G  
     \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the      \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the
     \G code following the @code{const-does>}.      \G code following the @code{const-does>}.
     here >r 0 POSTPONE literal      here >r 0 POSTPONE literal
     POSTPONE (const-does>)      POSTPONE (const-does>)
     POSTPONE ;      POSTPONE ;
     noname : POSTPONE rdrop      noname : POSTPONE rdrop
     lastxt r> cell+ ! \ patch the literal      latestxt r> cell+ ! \ patch the literal
 ; immediate  ; immediate
   
 \ !! rewrite slurp-file using slurp-fid  \ !! rewrite slurp-file using slurp-fid
 : slurp-file ( c-addr1 u1 -- c-addr2 u2 )  : slurp-file ( c-addr1 u1 -- c-addr2 u2 ) \ gforth
     \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents      \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents
     r/o bin open-file throw >r      r/o bin open-file throw >r
     r@ file-size throw abort" file too large"      r@ file-size throw abort" file too large"
Line 118  AUser CSP Line 122  AUser CSP
     2dup r@ read-file throw over <> abort" could not read whole file"      2dup r@ read-file throw over <> abort" could not read whole file"
     r> close-file throw ;      r> close-file throw ;
   
 : slurp-fid { fid -- addr u }  : slurp-fid ( fid -- addr u ) \ gforth
     \G @var{addr u} is the content of the file @var{fid}  \G @var{addr u} is the content of the file @var{fid}
       { fid }
     0 0 begin ( awhole uwhole )      0 0 begin ( awhole uwhole )
         dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew )          dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew )
         rot r@ fid read-file throw ( awhole uwhole uread R: unew )          rot r@ fid read-file throw ( awhole uwhole uread R: unew )
Line 131  AUser CSP Line 136  AUser CSP
   
 \ ]] ... [[  \ ]] ... [[
   
 : compile-literal ( n -- )  : [[ ( -- ) \ gforth left-bracket-bracket
     postpone literal ;  
   
 : [[ ( -- )  
 \G switch from postpone state to compile state  \G switch from postpone state to compile state
     \ this is only a marker; it is never really interpreted      \ this is only a marker; it is never really interpreted
     compile-only-error ; immediate      compile-only-error ; immediate
   
 : postponer ( c-addr u -- )  [ifdef] compiler1
     2dup find-name dup if ( c-addr u nt )  : compile-literal ( n -- )
       postpone literal ;
   
   : compile-compile-literal ( n -- )
       compile-literal postpone compile-literal ;
   
   : compile-2literal ( n1 n2 -- )
       postpone 2literal ;
   
   : compile-compile-2literal ( n1 n2 -- )
       compile-2literal postpone compile-2literal ;
   
   : postponer1 ( c-addr u -- ... xt )
       2dup find-name
       [ifdef] run-prelude run-prelude [then]
       dup if ( c-addr u nt )
         nip nip name>comp          nip nip name>comp
         2dup [comp'] [[ d= if          2dup [comp'] [[ d= if
             2drop ['] compiler is parser              2drop ['] compiler1 is parser1 ['] noop
         else          else
             postpone,              ['] postpone,
         endif          endif
     else      else
         drop          drop
         2dup snumber? dup if          2dup 2>r snumber? dup if
             0> IF              0> IF
                 swap postpone literal postpone compile-literal                  ['] compile-compile-2literal
               ELSE
                   ['] compile-compile-literal
             THEN              THEN
             postpone Literal postpone compile-literal              2rdrop
             2drop  
         ELSE          ELSE
             drop no.extensions              drop 2r> no.extensions
         THEN          THEN
     then ;      then ;
   
 : ]] ( -- )  : ]] ( -- ) \ gforth right-bracket-bracket
     \ switch into postpone state      \G switch into postpone state
     ['] postponer is parser state on ; immediate restrict      ['] postponer1 is parser1 state on ; immediate restrict
   [then]
   
   [ifdef] compiler-r
   : postponer-r ( addr u -- ... xt )
       forth-recognizer do-recognizer
       over [ s" [[" find-name ] Literal =
       IF  2drop [comp'] ] drop ELSE  ['] >postpone  THEN ;
   
   : ]] ( -- ) \ gforth right-bracket-bracket
       \G switch into postpone state
       ['] postponer-r is parser1 state on ; immediate restrict
   [then]
   
   comp'  literal drop alias postpone-literal
   comp' 2literal drop alias postpone-2literal
   comp' fliteral drop alias postpone-fliteral
   comp' sliteral drop alias postpone-sliteral
   
   : ]]L ( postponing: x -- ; compiling: -- x ) \ gforth right-bracket-bracket-l
   \G Shortcut for @code{]] literal}.
       ]] postpone-literal ]] [[ ; immediate
   
   : ]]2L ( postponing: x1 x2 -- ; compiling: -- x1 x2 ) \ gforth right-bracket-bracket-two-l
   \G Shortcut for @code{]] 2literal}.
       ]] postpone-2literal ]] [[ ; immediate
   
   : ]]FL ( postponing: r -- ; compiling: -- r ) \ gforth right-bracket-bracket-f-l
   \G Shortcut for @code{]] fliteral}.
       ]] postpone-fliteral ]] [[ ; immediate
   
   : ]]SL ( postponing: addr1 u -- ; compiling: -- addr2 u ) \ gforth right-bracket-bracket-s-l
   \G Shortcut for @code{]] sliteral}; if the string already has been
   \G allocated permanently, you can use @code{]]2L} instead.
       ]] postpone-sliteral ]] [[ ; immediate
   
 \ f.rdp  \ f.rdp
   
 : move-right ( c-addr u1 u2 cfill -- )  : push-right ( c-addr u1 u2 cfill -- )
     \ move string at c-addr u1 right by u2 chars (without exceeding      \ move string at c-addr u1 right by u2 chars (without exceeding
     \ the original bound); fill the gap with cfill      \ the original bound); fill the gap with cfill
     >r dup >r rot dup >r ( u1 u2 c-addr R: cfill u2 c-addr )      >r over min dup >r rot dup >r ( u1 u2 c-addr R: cfill u2 c-addr )
     dup 2swap /string cmove>      dup 2swap /string cmove>
     r> r> r> fill ;      r> r> r> fill ;
   
 : f>buf-rdp { f: rf c-addr ur nd up -- } \ gforth  : f>buf-rdp-try { f: rf c-addr ur nd up um1 -- um2 }
 \G Convert @i{rf} into a string at @i{c-addr ur}.  The conversion      \ um1 is the mantissa length to try, um2 is the actual mantissa length
 \G rules and the meanings of @i{ur nd up} are the same as for      c-addr ur um1 /string '0 fill
 \G @code{f.rdp}.      rf c-addr um1 represent if { nexp fsign }
     rf c-addr ur represent if { nexp fsign }  
         nd nexp + up >=          nd nexp + up >=
         ur nd - 1- dup { beforep } fsign + nexp 0 max >= and if          ur nd - 1- dup { beforep } fsign + nexp 0 max >= and if
             \ fixed-point notation              \ fixed-point notation
             c-addr ur beforep nexp - dup { befored } '0 move-right              c-addr ur beforep nexp - dup { befored } '0 push-right
               befored 1+ ur >= if \ <=1 digit left, will be pushed out by '.'
                   rf fabs f2* 0.1e nd s>d d>f f** f> if \ round last digit
                       '1 c-addr befored + 1- c!
                   endif
               endif
             c-addr beforep 1- befored min dup { beforez } 0 max bl fill              c-addr beforep 1- befored min dup { beforez } 0 max bl fill
             fsign if              fsign if
                 '- c-addr beforez 1- 0 max + c!                  '- c-addr beforez 1- 0 max + c!
             endif              endif
             c-addr ur beforep /string 1 '. move-right              c-addr ur beforep /string 1 '. push-right
               nexp nd +
         else \ exponential notation          else \ exponential notation
             c-addr ur 1 /string 1 '. move-right              c-addr ur 1 /string 1 '. push-right
             fsign if              fsign if
                 c-addr ur 1 '- move-right                  c-addr ur 1 '- push-right
             endif              endif
             nexp 1- s>d tuck dabs <<# #s rot sign 'E hold #> { explen }              nexp 1- s>d tuck dabs <<# #s rot sign 'E hold #> { explen }
             explen 1+ fsign - ur > if \ exponent too large              ur explen - 1- fsign + { mantlen }
               mantlen 0< if \ exponent too large
                 drop c-addr ur '* fill                  drop c-addr ur '* fill
             else              else
                 c-addr ur + 0 explen negate /string move                  c-addr ur + 0 explen negate /string move
             endif              endif
             #>>              #>> mantlen
         endif          endif
     else \ inf or nan      else \ inf or nan
         if \ negative          if \ negative
             c-addr ur 1 '- move-right              c-addr ur 1 '- push-right
         endif          endif
         drop          drop ur
         \ !! align in some way?          \ !! align in some way?
     endif ;      endif
       1 max ur min ;
   
 : f>str-rdp ( rf ur +nd up -- c-addr ur ) \ gforth  : f>buf-rdp ( rf c-addr +nr +nd +np -- ) \ gforth
 \G Convert @i{rf} into a string at @i{c-addr ur}.  The conversion  \G Convert @i{rf} into a string at @i{c-addr nr}.  The conversion
 \G rules and the meanings of @i{ur +nd up} are the same as for  \G rules and the meanings of @i{nr nd np} are the same as for
   \G @code{f.rdp}.
       \ first, get the mantissa length, then convert for real.  The
       \ mantissa length is wrong in a few cases because of different
       \ rounding; In most cases this does not matter, because the
       \ mantissa is shorter than expected and the final digits are 0;
       \ but in a few cases the mantissa gets longer.  Then it is
       \ conceivable that you will see a result that is rounded too much.
       \ However, I have not been able to construct an example where this
       \ leads to an unexpected result.
       swap 0 max swap 0 max
       fdup 2over 2over 2 pick f>buf-rdp-try f>buf-rdp-try drop ;
   
   : f>str-rdp ( rf +nr +nd +np -- c-addr nr ) \ gforth
   \G Convert @i{rf} into a string at @i{c-addr nr}.  The conversion
   \G rules and the meanings of @i{nr +nd np} are the same as for
 \G @code{f.rdp}.  The result in in the pictured numeric output buffer  \G @code{f.rdp}.  The result in in the pictured numeric output buffer
 \G and will be destroyed by anything destroying that buffer.  \G and will be destroyed by anything destroying that buffer.
     rot holdptr @ 1- 0 rot negate /string ( rf +nd up c-addr ur )      rot holdptr @ 1- 0 rot negate /string ( rf +nd np c-addr nr )
     over holdbuf u< -&17 and throw      over holdbuf u< -&17 and throw
     2tuck 2>r f>buf-rdp 2r> ;      2tuck 2>r f>buf-rdp 2r> ;
   
 : f.rdp ( rf ur +nd up -- ) \ gforth  : f.rdp ( rf +nr +nd +np -- ) \ gforth
 \G Print float @i{rf} formatted.  The total width of the output is  \G Print float @i{rf} formatted.  The total width of the output is
 \G @i{nr}, the number of digits after the decimal point is @i{+nd},  \G @i{nr}.  For fixed-point notation, the number of digits after the
 \G the minimum number of significant digits for fixed-point notation  \G decimal point is @i{+nd} and the minimum number of significant
 \G is @i{up}.  @code{Set-precision} has no effect on @code{f.rdp}.  \G digits is @i{np}.  @code{Set-precision} has no effect on
 \G Fixed-point notation is used if the number of siginicant digits  \G @code{f.rdp}.  Fixed-point notation is used if the number of
 \G would be larger than @i{up} and if the number of digits before the  \G siginicant digits would be at least @i{np} and if the number of
 \G decimal point would fit.  If fixed-point notation is not used,  \G digits before the decimal point would fit.  If fixed-point notation
 \G exponential notation is used, and if that does not fit, asterisks  \G is not used, exponential notation is used, and if that does not
 \G are printed.  We recommend using @i{ur}>=7 to avoid the risk of  \G fit, asterisks are printed.  We recommend using @i{nr}>=7 to avoid
 \G numbers not fitting at all.  We recommend @i{ur}>=@i{up}+5 to avoid  \G the risk of numbers not fitting at all.  We recommend
 \G cases where @code{f.rdp} switches to exponential notation because  \G @i{nr}>=@i{np}+5 to avoid cases where @code{f.rdp} switches to
 \G fixed-point notation would have too few significant digits, yet  \G exponential notation because fixed-point notation would have too
 \G exponential notation offers fewer significant digits.  We recomment  \G few significant digits, yet exponential notation offers fewer
 \G @i{ur}>=@i{nd}+2, if you want to have fixed-point notation for some  \G significant digits.  We recommend @i{nr}>=@i{nd}+2, if you want to
 \G numbers.  Currently, trailing digits are cut off.  \G have fixed-point notation for some numbers.  We recommend
   \G @i{np}>@i{nr}, if you want to have exponential notation for all
   \G numbers.
     f>str-rdp type ;      f>str-rdp type ;
   
 0 [if]  0 [if]
Line 256  AUser CSP Line 332  AUser CSP
         10e f*          10e f*
     loop ;      loop ;
 [then]  [then]
   
   : f.s ( -- ) \ gforth f-dot-s
   \G Display the number of items on the floating-point stack, followed
   \G by a list of the items (but not more than specified by
   \G @code{maxdepth-.s}; TOS is the right-most item.
       ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 
       ?DO  dup i - 1- floats fp@ + f@ 16 5 11 f.rdp space LOOP  drop ; 
   
   \ defer stuff
   
   [ifundef] defer@ : defer@ >body @ ; [then]
   
   :noname    ' defer@ ;
   :noname    postpone ['] postpone defer@ ;
   interpret/compile: action-of ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth
   \G @i{Xt} is the XT that is currently assigned to @i{name}.
   
   ' action-of
   comp' action-of drop
   interpret/compile: what's ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth-obsolete
   \G Old name of @code{action-of}
   
   
   : typewhite ( addr n -- ) \ gforth
   \G Like type, but white space is printed instead of the characters.
       \ bounds u+do
       0 max bounds ?do
           i c@ #tab = if \ check for tab
               #tab
           else
               bl
           then
           emit
       loop ;
   
   \ w and l stuff
   
   environment-wordlist >order
   
   16 address-unit-bits / 1 max constant /w ( -- u ) \ gforth slash-w
   \G address units for a 16-bit value
       
   32 address-unit-bits / 1 max constant /l ( -- u ) \ gforth slash-l
   \G address units for a 32-bit value
   
   previous
   
   [ifdef] uw@
   \ Open firmware names
   ' uw@ alias w@ ( addr -- u )
   ' ul@ alias l@ ( addr -- u )
   \ ' sw@ alias <w@ ( addr -- n )
   [then]
   
   \ safe output redirection
   
   : outfile-execute ( ... xt file-id -- ... ) \ gforth
       \G execute @i{xt} with the output of @code{type} etc. redirected to
       \G @i{file-id}.
       outfile-id { oldfid } try
           to outfile-id execute 0
       restore
           oldfid to outfile-id
       endtry
       throw ;
   
   : infile-execute ( ... xt file-id -- ... ) \ gforth
       \G execute @i{xt} with the input of @code{key} etc. redirected to
       \G @i{file-id}.
       infile-id { oldfid } try
           to infile-id execute 0
       restore
           oldfid to infile-id
       endtry
       throw ;
   
   \ safe BASE wrapper
   
   : base-execute ( i*x xt u -- j*x ) \ gforth
       \G execute @i{xt} with the content of @code{BASE} being @i{u}, and
       \G restoring the original @code{BASE} afterwards.
       base @ { oldbase } \ use local, because TRY blocks the return stack
       try
           base ! execute 0
       restore
           oldbase base !
       endtry
       throw ;
   
   \ th
   
   : th ( addr1 u -- addr2 )
       cells + ;
   
   \ \\\ - skip to end of file
   
   : \\\ ( -- ) \ gforth
       \G skip remaining source file
       source-id dup 0> IF
           >r r@ file-size throw r> reposition-file throw
           BEGIN  refill 0= UNTIL  postpone \  THEN ; immediate
   
   \ WORD SWORD
   
   : sword  ( char -- addr len ) \ gforth-obsolete s-word
   \G Parses like @code{word}, but the output is like @code{parse} output.
   \G @xref{core-idef}.
       \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
       \ dpANS6 A.6.2.2008 have a word with that name that behaves
       \ differently (like NAME).
       source 2dup >r >r >in @ over min /string
       rot dup bl = IF
           drop (parse-white)
       ELSE
           (word)
       THEN
   [ has? new-input [IF] ]
       2dup input-lexeme!
   [ [THEN] ]
       2dup + r> - 1+ r> min >in ! ;
   
   : word   ( char "<chars>ccc<char>-- c-addr ) \ core
       \G Skip leading delimiters. Parse @i{ccc}, delimited by
       \G @i{char}, in the parse area. @i{c-addr} is the address of a
       \G transient region containing the parsed string in
       \G counted-string format. If the parse area was empty or
       \G contained no characters other than delimiters, the resulting
       \G string has zero length. A program may replace characters within
       \G the counted string. OBSOLESCENT: the counted string has a
       \G trailing space that is not included in its length.
       sword here place  bl here count + c!  here ;

Removed from v.1.26  
changed lines
  Added in v.1.70


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