gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.43 and 1.125

-version 1.43, Fri Dec  3 18:49:51 1999 UTC
+version 1.125, Fri Jan 27 10:43:52 2006 UTC
  Line 1
  Line 1
  Line 1
  \ definitions needed for interpreter only
- \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+ \ Copyright (C) 1995-2000,2004,2005 Free Software Foundation, Inc.
  \ This file is part of Gforth.
  Line 16
  Line 16
  Line 16
  \ You should have received a copy of the GNU General Public License
  \ 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.
  \ \ Revision-Log
  Line 28
  Line 28
  Line 28
  require ./io.fs         \ type ...
  require ./nio.fs        \ . <# ...
  require ./errore.fs     \ .error ...
- require ~+/kernel/version.fs    \ version-string
+ require kernel/version.fs       \ version-string
  require ./../chains.fs
+ has? new-input 0= [IF]
  : tib ( -- c-addr ) \ core-ext t-i-b
      \G @i{c-addr} is the address of the Terminal Input Buffer.
      \G OBSOLESCENT: @code{source} superceeds the function of this word.
- Line 44
+ Line 45
  Line 44
  Line 45
  : (source) ( -- c-addr u )
      tib #tib @ ;
  ' (source) IS source
+ [THEN]
  : (word) ( addr1 n1 char -- addr2 n2 )
    dup >r skip 2dup r> scan  nip - ;
- Line 55
+ Line 57
  Line 55
  Line 57
  : sword  ( char -- addr len ) \ gforth s-word
      \G Parses like @code{word}, but the output is like @code{parse} output.
-     \G @xref{core-idef}
+     \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).
- Line 95
+ Line 97
  Line 95
  Line 97
      dup 0= -&16 and throw ;
  : name-too-long? ( c-addr u -- c-addr u )
-     dup $1F u> -&19 and throw ;
+     dup lcount-mask u> -&19 and throw ;
  \ \ Number parsing                                      23feb93py
  \ number? number                                       23feb93py
  hex
- const Create bases   10 ,   2 ,   A , 100 ,
+ const Create bases   0A , 10 ,   2 ,   0A ,
- \                     16     2    10   character
+ \                    10   16     2     10
  \ !! protect BASE saving wrapper against exceptions
  : getbase ( addr u -- addr' u' )
-     over c@ [char] $ - dup 4 u<
+dup s" 0x" string-prefix? >r
+dup s" 0X" string-prefix? r> or
+     base @ &34 < and if
+         hex 2 /string
+     endif
+     over c@ [char] # - dup 4 u<
      IF
          cells bases + @ base ! 1 /string
      ELSE
          drop
      THEN ;
- : sign? ( addr u -- addr u flag )
+ : sign? ( addr u -- addr1 u1 flag )
      over c@ [char] - =  dup >r
      IF
 /string
      THEN
      r> ;
- : s>unumber? ( addr u -- ud flag )
+ : s'>unumber? ( addr u -- ud flag )
-     base @ >r  dpl on  getbase
+     \ convert string "C" or "C'" to character code
+     dup 0= if
+         false exit
+     endif
+     x@+/string 0 s" '" 2rot string-prefix? ;
+ : s>unumber? ( addr u -- ud flag ) \ gforth
+     \G converts string addr u into ud, flag indicates success
+     dpl on
+     over c@ '' = if
+/string s'>unumber? exit
+     endif
+     base @ >r  getbase
 . 2swap
      BEGIN ( d addr len )
          dup >r >number dup
- Line 140
+ Line 159
  Line 140
  Line 159
      r> base ! ;
  \ ouch, this is complicated; there must be a simpler way - anton
- : s>number? ( addr len -- d f )
+ : s>number? ( addr u -- d f ) \ gforth
-     \ converts string addr len into d, flag indicates success
+     \G converts string addr u into d, flag indicates success
      sign? >r
      s>unumber?
 = IF
- Line 190
+ Line 209
  Line 190
  Line 209
      \G by cross.fs which doesn't have the same functionalty as makedoc.fs
      [char] ) parse 2drop ; immediate
- : \ ( -- ) \ thisone- core-ext,block-ext backslash
+ : \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ thisone- core-ext,block-ext backslash
      \G ** this will not get annotated. The alias in glocals.fs will instead **
      \G It does not work to use "wordset-" prefix since this file is glossed
      \G by cross.fs which doesn't have the same functionalty as makedoc.fs
- Line 203
+ Line 222
  Line 203
  Line 222
      [ [THEN] ]
      source >in ! drop ; immediate
- : \G ( -- ) \ gforth backslash-gee
+ : \G ( compilation 'ccc<newline>' -- ; run-time -- ) \ gforth backslash-gee
      \G Equivalent to @code{\} but used as a tag to annotate definition
      \G comments into documentation.
      POSTPONE \ ; immediate
- Line 227
+ Line 246
  Line 227
  Line 246
    cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
  end-struct wordlist-struct
+ has? f83headerstring [IF]
  : f83find      ( addr len wordlist -- nt / false )
      wordlist-id @ (f83find) ;
+ [ELSE]
+ : f83find      ( addr len wordlist -- nt / false )
+     wordlist-id @ (listlfind) ;
+ [THEN]
  : initvoc               ( wid -- )
    dup wordlist-map @ hash-method perform ;
- Line 255
+ Line 279
  Line 255
  Line 279
  \ \ header, finding, ticks                              17dec92py
- hex
+ \ The constants are defined as 32 bits, but then erased
-constant alias-mask \ set when the word is not an alias!
+ \ and overwritten by the right ones
-constant immediate-mask
-constant restrict-mask
+ has? f83headerstring [IF]
+     \ to save space, Gforth EC limits words to 31 characters
+     $80 constant alias-mask
+     $40 constant immediate-mask
+     $20 constant restrict-mask
+     $1f constant lcount-mask
+ [ELSE]
+ $80000000 constant alias-mask
+bits/char 1 - lshift
+ -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
+                           [ELSE] 0 1 cells 1- times c, [THEN]
+ $40000000 constant immediate-mask
+bits/char 2 - lshift
+ -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
+                           [ELSE] 0 1 cells 1- times c, [THEN]
+ $20000000 constant restrict-mask
+bits/char 3 - lshift
+ -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
+                           [ELSE] 0 1 cells 1- times c, [THEN]
+ $1fffffff constant lcount-mask
+bits/char 3 - lshift 1 -
+ -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
+                           [ELSE] -1 1 cells 1- times c, [THEN]
+ [THEN]
  \ higher level parts of find
- Line 266
+ Line 313
  Line 266
  Line 313
      \ true becomes 1, false -1
 = 2* 1+ ;
+ : ticking-compile-only-error ( ... -- )
+     -&2048 throw ;
  : compile-only-error ( ... -- )
      -&14 throw ;
- Line 277
+ Line 327
  Line 277
  Line 327
      then
  [ [THEN] ] ;
- : (x>int) ( cfa b -- xt )
+ : (x>int) ( cfa w -- xt )
      \ get interpretation semantics of name
      restrict-mask and
      if
- Line 286
+ Line 336
  Line 286
  Line 336
          (cfa>int)
      then ;
+ has? f83headerstring [IF]
  : name>string ( nt -- addr count ) \ gforth     head-to-string
      \g @i{addr count} is the name of the word represented by @i{nt}.
-     cell+ count $1F and ;
+     cell+ count lcount-mask and ;
  : ((name>))  ( nfa -- cfa )
      name>string + cfaligned ;
- : (name>x) ( nfa -- cfa b )
+ : (name>x) ( nfa -- cfa w )
-     \ cfa is an intermediate cfa and b is the flags byte of nfa
+     \ cfa is an intermediate cfa and w is the flags cell of nfa
      dup ((name>))
      swap cell+ c@ dup alias-mask and 0=
      IF
          swap @ swap
      THEN ;
+ [ELSE]
+ : name>string ( nt -- addr count ) \ gforth     head-to-string
+     \g @i{addr count} is the name of the word represented by @i{nt}.
+     cell+ dup cell+ swap @ lcount-mask and ;
+ : ((name>))  ( nfa -- cfa )
+     name>string + cfaligned ;
+ : (name>x) ( nfa -- cfa w )
+     \ cfa is an intermediate cfa and w is the flags cell of nfa
+     dup ((name>))
+     swap cell+ @ dup alias-mask and 0=
+     IF
+         swap @ swap
+     THEN ;
+ [THEN]
  : name>int ( nt -- xt ) \ gforth
      \G @i{xt} represents the interpretation semantics of the word
      \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
      \G @code{compile-only}), @i{xt} is the execution token for
-     \G @code{compile-only-error}, which performs @code{-14 throw}.
+     \G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
      (name>x) (x>int) ;
  : name?int ( nt -- xt ) \ gforth
-     \G Like @code{name>int}, but perform @code{-14 throw} if @i{nt}
+     \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
      \G has no interpretation semantics.
      (name>x) restrict-mask and
      if
-         compile-only-error \ does not return
+         ticking-compile-only-error \ does not return
      then
      (cfa>int) ;
- Line 330
+ Line 397
  Line 330
  Line 397
      ;
  : (name>intn) ( nfa -- xt +-1 )
-     (name>x) tuck (x>int) ( b xt )
+     (name>x) tuck (x>int) ( w xt )
      swap immediate-mask and flag-sign ;
- const Create ???  0 , 3 c, char ? c, char ? c, char ? c,
+ const Create ???  0 , 3 , char ? c, char ? c, char ? c,
  \ ??? is used by dovar:, must be created/:dovar
  [IFDEF] forthstart
- Line 342
+ Line 409
  Line 342
  Line 409
  : head? ( addr -- f )
      \G heuristic check whether addr is a name token; may deliver false
-     \G positives; addr must be a valid address
+ \G positives; addr must be a valid address; returns 1 for
+ \G particularly unsafe positives
      \ we follow the link fields and check for plausibility; two
      \ iterations should catch most false addresses: on the first
      \ iteration, we may get an xt, on the second a code address (or
      \ some code), which is typically not in the dictionary.
-0 do
+     \ we added a third iteration for working with code and ;code words.
+0 do
          dup dup aligned <> if \ protect @ against unaligned accesses
              drop false unloop exit
          then
- Line 358
+ Line 427
  Line 358
  Line 427
                  drop false unloop exit
              then ( addr1 )
          else \ 0 in the link field, no further checks
-drop true unloop exit
+drop 1 unloop exit \ this is very unsure, so return 1
          then
      loop
      \ in dubio pro:
      drop true ;
- : >head ( cfa -- nt ) \ gforth  to-head
+ : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
-     $21 cell do ( cfa )
+     \ also heuristic
-         dup i - count $9F and + cfaligned over alias-mask + =
+     dup forthstart - max-name-length @ float+ cell+ min cell max cell ?do ( cfa )
+         dup i - dup @ [ alias-mask lcount-mask or ] literal
+         [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
+         -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
+         [ELSE] -1 1 cells 1- times c, [THEN] ]
+         and ( cfa len|alias )
+         swap + cell+ cfaligned over alias-mask + =
          if ( cfa )
              dup i - cell - dup head?
              if
- Line 379
+ Line 454
  Line 379
  Line 454
  [ELSE]
- : >head ( cfa -- nt ) \ gforth  to-head
+ : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
-     $21 cell do ( cfa )
+     $25 cell do ( cfa )
-         dup i - count $9F and + cfaligned over alias-mask + =
+         dup i - dup @ [ alias-mask lcount-mask or ] literal
+         [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
+         -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
+         [ELSE] -1 1 cells 1- times c, [THEN] ]
+         and ( cfa len|alias )
+         swap + cell + cfaligned over alias-mask + =
          if ( cfa ) i - cell - unloop exit
          then
          cell +loop
- Line 389
+ Line 469
  Line 389
  Line 469
  [THEN]
- ' >head ALIAS >name
+ cell% 2* 0 0 field >body ( xt -- a_addr ) \ core
+ \G Get the address of the body of the word represented by @i{xt} (the
+ \G address of the word's data field).
+ drop drop
+ cell% -2 * 0 0 field body> ( xt -- a_addr )
+     drop drop
+ has? standardthreading has? compiler and [IF]
+ ' @ alias >code-address ( xt -- c_addr ) \ gforth
+ \G @i{c-addr} is the code address of the word @i{xt}.
+ : >does-code ( xt -- a_addr ) \ gforth
+ \G If @i{xt} is the execution token of a child of a @code{DOES>} word,
+ \G @i{a-addr} is the start of the Forth code after the @code{DOES>};
+ \G Otherwise @i{a-addr} is 0.
+     dup @ dodoes: = if
+         cell+ @
+     else
+         drop 0
+     endif ;
+ ' ! alias code-address! ( c_addr xt -- ) \ gforth
+ \G Create a code field with code address @i{c-addr} at @i{xt}.
- : body> 0 >body - ;
+ : does-code! ( a_addr xt -- ) \ gforth
+ \G Create a code field at @i{xt} for a child of a @code{DOES>}-word;
+ \G @i{a-addr} is the start of the Forth code after @code{DOES>}.
+     dodoes: over ! cell+ ! ;
+ ' drop alias does-handler! ( a_addr -- ) \ gforth
+ \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
+ \G @i{a-addr} points just behind a @code{DOES>}.
+cells constant /does-handler ( -- n ) \ gforth
+ \G The size of a @code{DOES>}-handler (includes possible padding).
+ [THEN]
  : (search-wordlist)  ( addr count wid -- nt | false )
      dup wordlist-map @ find-method perform ;
  : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search
-     \G Search the word list identified by @i{wid}
+     \G Search the word list identified by @i{wid} for the definition
-     \G for the definition named by the string at @i{c-addr count}.
+     \G named by the string at @i{c-addr count}.  If the definition is
-     \G If the definition is not found, return 0. If the definition
+     \G not found, return 0. If the definition is found return 1 (if
-     \G is found return 1 (if the definition is immediate) or -1
+     \G the definition is immediate) or -1 (if the definition is not
-     \G (if the definition is not immediate) together with the @i{xt}.
+     \G immediate) together with the @i{xt}.  In Gforth, the @i{xt}
-     \G The @i{xt} returned represents the interpretation semantics.
+     \G returned represents the interpretation semantics.  ANS Forth
+     \G does not specify clearly what @i{xt} represents.
      (search-wordlist) dup if
          (name>intn)
      then ;
- Line 424
+ Line 541
  Line 424
  Line 541
     then ;
  : find ( c-addr -- xt +-1 | c-addr 0 ) \ core,search
-     \G Search all word lists in the current search order
+     \G Search all word lists in the current search order for the
-     \G for the definition named by the counted string at @i{c-addr}.
+     \G definition named by the counted string at @i{c-addr}.  If the
-     \G If the definition is not found, return 0. If the definition
+     \G definition is not found, return 0. If the definition is found
-     \G is found return 1 (if the definition is immediate) or -1
+     \G return 1 (if the definition has non-default compilation
-     \G (if the definition is not immediate) together with the @i{xt}.
+     \G semantics) or -1 (if the definition has default compilation
+     \G semantics).  The @i{xt} returned in interpret state represents
+     \G the interpretation semantics.  The @i{xt} returned in compile
+     \G state represented either the compilation semantics (for
+     \G non-default compilation semantics) or the run-time semantics
+     \G that the compilation semantics would @code{compile,} (for
+     \G default compilation semantics).  The ANS Forth standard does
+     \G not specify clearly what the returned @i{xt} represents (and
+     \G also talks about immediacy instead of non-default compilation
+     \G semantics), so this word is questionable in portable programs.
+     \G If non-portability is ok, @code{find-name} and friends are
+     \G better (@pxref{Name token}).
      dup count sfind dup
      if
          rot drop
- Line 460
+ Line 588
  Line 460
  Line 588
  \ interpret                                            10mar92py
- Defer parser ( c-addr u -- )
+ Defer parser1 ( c-addr u -- ... xt)
- Defer name ( -- c-addr count ) \ gforth
+ \ "... xt" is the action to be performed by the text-interpretation of c-addr u
- \ get the next word from the input buffer
- ' (name) IS name
+ : parser ( c-addr u -- ... )
- Defer compiler-notfound ( c-addr count -- )
+ \ text-interpret the word/number c-addr u, possibly producing a number
- Defer interpreter-notfound ( c-addr count -- )
+     parser1 execute ;
+ Defer parse-name ( "name" -- c-addr u ) \ gforth
+ \G Get the next word from the input buffer
+ ' (name) IS parse-name
+ ' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete
+ \G old name for @code{parse-name}
+ ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
+ \G old name for @code{parse-name}
+ Defer compiler-notfound1 ( c-addr count -- ... xt )
+ Defer interpreter-notfound1 ( c-addr count -- ... xt )
  : no.extensions  ( addr u -- )
 drop -&13 throw ;
- ' no.extensions IS compiler-notfound
+ ' no.extensions IS compiler-notfound1
- ' no.extensions IS interpreter-notfound
+ ' no.extensions IS interpreter-notfound1
- : interpret ( ?? -- ?? ) \ gforth
+ Defer before-word ( -- ) \ gforth
-     \ interpret/compile the (rest of the) input buffer
+ \ called before the text interpreter parses the next word
+ ' noop IS before-word
+ : interpret1 ( ... -- ... )
  [ has? backtrace [IF] ]
      rp@ backtrace-rp0 !
  [ [THEN] ]
      BEGIN
-         ?stack name dup
+         ?stack before-word name dup
      WHILE
-         parser
+         parser1 execute
      REPEAT
 drop ;
+ : interpret ( ?? -- ?? ) \ gforth
+     \ interpret/compile the (rest of the) input buffer
+ [ has? backtrace [IF] ]
+     backtrace-rp0 @ >r
+ [ [THEN] ]
+     ['] interpret1 catch
+ [ has? backtrace [IF] ]
+     r> backtrace-rp0 !
+     [ [THEN] ]
+     throw ;
  \ interpreter                                   30apr92py
  \ not the most efficient implementations of interpreter and compiler
- : interpreter ( c-addr u -- )
+ : interpreter1 ( c-addr u -- ... xt )
 dup find-name dup
      if
-         nip nip name>int execute
+         nip nip name>int
      else
          drop
 dup 2>r snumber?
          IF
-rdrop
+rdrop ['] noop
          ELSE
-r> interpreter-notfound
+r> interpreter-notfound1
          THEN
      then ;
- ' interpreter  IS  parser
+ ' interpreter1  IS  parser1
  \ \ Query Evaluate                                      07apr93py
  has? file 0= [IF]
  : sourceline# ( -- n )  1 ;
+ [ELSE]
+ has? new-input 0= [IF]
+ Variable #fill-bytes
+ \G number of bytes read via (read-line) by the last refill
+ [THEN]
  [THEN]
+ has? new-input 0= [IF]
  : refill ( -- flag ) \ core-ext,block-ext,file-ext
      \G Attempt to fill the input buffer from the input source.  When
      \G the input source is the user input device, attempt to receive
- Line 529
+ Line 690
  Line 529
  Line 690
      tib /line
      [ has? file [IF] ]
          loadfile @ ?dup
-         IF    read-line throw
+         IF    (read-line) throw #fill-bytes !
          ELSE
              [ [THEN] ]
          sourceline# 0< IF 2drop false EXIT THEN
- Line 547
+ Line 708
  Line 547
  Line 708
      [ has? file [IF] ]
          blk off loadfile off
          [ [THEN] ]
-     tib /line accept #tib ! 0 >in ! ;
+     refill drop ;
+ [THEN]
  \ save-mem extend-mem
- Line 558
+ Line 720
  Line 558
  Line 720
      dup allocate throw
      swap 2dup r> -rot move ;
+ : free-mem-var ( addr -- )
+     \ addr is the address of a 2variable containing address and size
+     \ of a memory range; frees memory and clears the 2variable.
+     dup 2@ drop dup
+     if ( addr mem-start )
+         free throw
+0 rot 2!
+     else
+drop
+     then ;
  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
      \ extend memory block allocated from the heap by u aus
-     \ the (possibly reallocated piece is addr2 u2, the extension is at addr
+     \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
      over >r + dup >r resize throw
      r> over r> + -rot ;
  [THEN]
  \ EVALUATE                                              17may93jaw
- has? file 0= [IF]
+ has? file 0= has? new-input 0= and [IF]
  : push-file  ( -- )  r>
    tibstack @ >r  >tib @ >r  #tib @ >r
    >tib @ tibstack @ = IF  r@ tibstack +!  THEN
- Line 578
+ Line 751
  Line 578
  Line 751
    r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
  [THEN]
+ has? new-input 0= [IF]
  : evaluate ( c-addr u -- ) \ core,block
      \G Save the current input source specification. Store @code{-1} in
      \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
      \G @code{0} and make the string @i{c-addr u} the input source
      \G and input buffer. Interpret. When the parse area is empty,
      \G restore the input source specification.
+ [ has? file [IF] ]
+     s" *evaluated string*" loadfilename>r
+ [ [THEN] ]
      push-file #tib ! >tib !
      >in off
      [ has? file [IF] ]
          blk off loadfile off -1 loadline !
          [ [THEN] ]
      ['] interpret catch
-     pop-file throw ;
+     pop-file
+ [ has? file [IF] ]
+     r>loadfilename
+ [ [THEN] ]
+     throw ;
+ [THEN]
  \ \ Quit                                                13feb93py
- Line 600
+ Line 782
  Line 600
  Line 782
  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
- : (Query)  ( -- )
-     [ has? file [IF] ]
-         loadfile off  blk off loadline off
-         [ [THEN] ]
-     refill drop ;
  : (quit) ( -- )
      \ exits only through THROW etc.
- \    sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer
-     \ stored in the system's CATCH frame, so the stack depth will be 0
-     \ after the next THROW it catches (it may be off due to BOUNCEs or
-     \ because process-args left something on the stack)
      BEGIN
-         .status cr (query) interpret prompt
+         .status
-     AGAIN ;
+         ['] cr catch if
+             >stderr cr ." Can't print to stdout, leaving" cr
+             \ if stderr does not work either, already DoError causes a hang
+(bye)
+         endif
+         refill WHILE
+             interpret prompt
+     REPEAT
+     bye ;
  ' (quit) IS 'quit
  \ \ DOERROR (DOERROR)                                   13jun93jaw
 Constant max-errors
+has? file 2 and + Constant /error
  Variable error-stack  0 error-stack !
- max-errors 6 * cells allot
+ max-errors /error * cells allot
  \ format of one cell:
  \ source ( addr u )
  \ >in
  \ line-number
  \ Loadfilename ( addr u )
+ : error> ( -- addr u >in line# [addr u] )
+     -1 error-stack +!
+     error-stack dup @
+     /error * cells + cell+
+     /error cells bounds DO
+         I @
+         cell +LOOP ;
+ : >error ( addr u >in line# [addr u] -- )
+     error-stack dup @ dup 1+
+     max-errors 1- min error-stack !
+     /error * cells + cell+
+     /error 1- cells bounds swap DO
+         I !
+         -1 cells +LOOP ;
  : dec. ( n -- ) \ gforth
      \G Display @i{n} as a signed decimal number, followed by a space.
      \ !! not used...
      base @ decimal swap . base ! ;
- : dec.r ( u -- ) \ gforth
+ : dec.r ( u n -- ) \ gforth
-     \G Display @i{u} as a unsigned decimal number
+     \G Display @i{u} as a unsigned decimal number in a field @i{n}
-     base @ decimal swap 0 .r base ! ;
+     \G characters wide.
+     base @ >r decimal .r r> base ! ;
  : hex. ( u -- ) \ gforth
      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
- Line 644
+ Line 841
  Line 644
  Line 841
      \ !! not used...
      [char] $ emit base @ swap hex u. base ! ;
- : typewhite ( addr u -- ) \ gforth
+ : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
-     \G Like type, but white space is printed instead of the characters.
+ \G Adjust the string specified by @i{c-addr, u1} to remove all
-     bounds ?do
+ \G trailing spaces. @i{u2} is the length of the modified string.
-         i c@ #tab = if \ check for tab
+     BEGIN
-             #tab
+         dup
-         else
+     WHILE
-             bl
+- 2dup + c@ bl <>
-         then
+     UNTIL  1+  THEN ;
-         emit
-     loop ;
  DEFER DOERROR
- Line 668
+ Line 863
  Line 668
  Line 863
    ELSE  .error
    THEN ;
- : .error-frame ( throwcode addr1 u1 n1 n2 addr2 u2 -- throwcode )
+ : umin ( u1 u2 -- u )
- \ addr2 u2:     filename of included file
+dup u>
+     if
+         swap
+     then
+     drop ;
+ Defer mark-start
+ Defer mark-end
+ :noname ." >>>" ; IS mark-start
+ :noname ." <<<" ; IS mark-end
+ : .error-line ( addr1 u1 n1 -- )
+     \ print error ending at char n1 in line addr1 u1
+     \ should work with UTF-8 (whitespace check looks ok)
+     over umin \ protect against wrong n1
+     swap >r ( addr1 n1 R: u1 )
+     -trailing 1- \ last non-space
+>r  BEGIN \ search for the first non-space
+dup + c@ bl >  WHILE
+         r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
+     ( addr1 n2 r: u1 namelen )
+dup type mark-start
+     r> -rot r> swap /string ( namelen addr2 u2 )
+     >r swap 2dup type mark-end ( addr2 namelen r: u2 )
+     r> swap /string type ;
+ : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )
+ \ addr2 u2:     filename of included file - optional
  \ n2:           line number
  \ n1:           error position in input line
  \ addr1 u1:     input line
    cr error-stack @
-   IF
+   IF ( throwcode addr1 u1 n1 n2 [addr2 u2] )
+ [ has? file [IF] ] \ !! unbalanced stack effect
       ." in file included from "
-      type ." :" dec.r  drop 2drop
+     type ." :"
+ [ [THEN] ] ( throwcode addr1 u1 n1 n2 )
+dec.r  drop 2drop
+   ELSE ( throwcode addr1 u1 n1 n2 [addr2 u2] )
+ [ has? file [IF] ]
+       type ." :"
+ [ [THEN] ] ( throwcode addr1 u1 n1 n2 )
+       dup 0 dec.r ." : " 4 pick .error-string
+       IF \ if line# non-zero, there is a line
+           cr .error-line
    ELSE
-      type ." :" dec.r ." : " 3 pick .error-string cr
+drop drop
-      dup 2over type cr drop
+       THEN
-      nip -trailing 1- ( line-start index2 )
->r  BEGIN
-dup + c@ bl >  WHILE
-                   r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
-      ( line-start index1 )
-      typewhite
-      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
-                   [char] ^ emit
-      loop
    THEN ;
  : (DoError) ( throw-code -- )
    [ has? os [IF] ]
        >stderr
    [ [THEN] ]
-   sourceline# IF
+   source >in @ sourceline# [ has? file [IF] ] \ !! unbalanced stack effect
-       source >in @ sourceline# 0 0 .error-frame
+       sourcefilename
-   THEN
+   [ [THEN] ] .error-frame
    error-stack @ 0 ?DO
-     -1 error-stack +!
+     error>
-     error-stack dup @ 6 * cells + cell+
-cells bounds DO
-       I @
-     cell +LOOP
      .error-frame
    LOOP
    drop
- Line 719
+ Line 938
  Line 719
  Line 938
      \G Empty the return stack, make the user input device
      \G the input source, enter interpret state and start
      \G the text interpreter.
-     rp0 @ rp! handler off clear-tibstack >tib @ >r
+     rp0 @ rp! handler off clear-tibstack
+     [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]
      BEGIN
          [ has? compiler [IF] ]
-         postpone [
+             [compile] [
          [ [THEN] ]
+         \ stack depths may be arbitrary here
          ['] 'quit CATCH dup
      WHILE
          <# \ reset hold area, or we may get another error
-         DoError r@ >tib ! r@ tibstack !
+             DoError
+             \ stack depths may be arbitrary still (or again), so clear them
+             clearstacks
+             [ has? new-input [IF] ] clear-tibstack
+             [ [ELSE] ] r@ >tib ! r@ tibstack !
+             [ [THEN] ]
      REPEAT
-     drop r> >tib ! ;
+     drop [ has? new-input [IF] ] clear-tibstack
+     [ [ELSE] ] r> >tib !
+     [ [THEN] ] ;
  \ \ Cold Boot                                           13feb93py
  : (bootmessage)
-     ." GForth " version-string type
+     ." Gforth " version-string type
-     ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
+     ." , Copyright (C) 1995-2004,2005 Free Software Foundation, Inc." cr
-     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
+     ." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
  [ has? os [IF] ]
       cr ." Type `bye' to exit"
  [ [THEN] ] ;
- Line 752
+ Line 980
  Line 752
  Line 980
  ' noop IS 'cold
- Variable init8
+ AVariable init8 NIL init8 !
  : cold ( -- ) \ gforth
+ [ has? backtrace [IF] ]
+     rp@ backtrace-rp0 !
+ [ [THEN] ]
  [ has? file [IF] ]
-     pathstring 2@ fpath only-path
+     os-cold
-     init-included-files
  [ [THEN] ]
+     set-encoding-fixed-width
      'cold
      init8 chainperform
  [ has? file [IF] ]
+     s" *the terminal*" loadfilename 2!
      process-args
      loadline off
  [ [THEN] ]
      bootmessage
      quit ;
+ has? new-input 0= [IF]
  : clear-tibstack ( -- )
  [ has? glocals [IF] ]
      lp@ forthstart 7 cells + @ -
- Line 779
+ Line 1012
  Line 779
  Line 1012
      [ [THEN] ]
  [ [THEN] ]
      dup >tib ! tibstack ! #tib off >in off ;
+ [THEN]
- : boot ( path **argv argc -- )
+ : boot ( path n **argv argc -- )
      main-task up!
  [ has? os [IF] ]
-     stdout TO outfile-id
+     os-boot
-     stdin  TO infile-id
- \ !! [ [THEN] ]
- \ !! [ has? file [IF] ]
-     argc ! argv ! pathstring 2!
  [ [THEN] ]
      sp@ sp0 !
+ [ has? peephole [IF] ]
+     \ only needed for greedy static superinstruction selection
+     \ primtable prepare-peephole-table TO peeptable
+ [ [THEN] ]
+ [ has? new-input [IF] ]
+     current-input off
+ [ [THEN] ]
      clear-tibstack
      rp@ rp0 !
  [ has? floating [IF] ]
      fp@ fp0 !
  [ [THEN] ]
-     ['] cold catch DoError cr
+     handler off
+     ['] cold catch dup -&2049 <> if \ broken pipe?
+         DoError cr
+     endif
  [ has? os [IF] ]
 (bye) \ !! determin exit code from throw code?
  [ [THEN] ]

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.43
 


changed lines


 
Added in v.1.125
 Legend:



Removed from v.1.43
 


changed lines


 
Added in v.1.125
-Removed from v.1.43
+Added in v.1.125

CVS Admin

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.43 and 1.125

ViewCVS and CVS Help