gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.109 and 1.191

-version 1.109, Wed Dec  8 12:47:30 2004 UTC
+version 1.191, Mon Jul 23 14:15:52 2012 UTC
  Line 1
  Line 1
  Line 1
  \ definitions needed for interpreter only
- \ Copyright (C) 1995-2000 Free Software Foundation, Inc.
+ \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010 Free Software Foundation, Inc.
  \ This file is part of Gforth.
  \ Gforth is free software; you can redistribute it and/or
  \ 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.
  \ This program is distributed in the hope that it will be useful,
  Line 15
  Line 15
  Line 15
  \ GNU General Public License for more details.
  \ 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.
  \ \ Revision-Log
- Line 29
+ Line 28
  Line 29
  Line 28
  require ./nio.fs        \ . <# ...
  require ./errore.fs     \ .error ...
  require kernel/version.fs       \ version-string
- require ./../chains.fs
  has? new-input 0= [IF]
  : tib ( -- c-addr ) \ core-ext t-i-b
- Line 53
+ Line 51
  Line 53
  Line 51
  \ (word) should fold white spaces
  \ this is what (parse-white) does
- \ word parse                                           23feb93py
+ \ parse                                           23feb93py
- : sword  ( char -- addr len ) \ gforth 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
-dup + 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 ;
  : parse    ( char "ccc<char>" -- c-addr u ) \ core-ext
  \G Parse @i{ccc}, delimited by @i{char}, in the parse
  \G area. @i{c-addr u} specifies the parsed string within the
  \G parse area. If the parse area was empty, @i{u} is 0.
-     >r  source  >in @ over min /string  over  swap r>  scan >r
+     >r  source  >in @ over min /string ( c-addr1 u1 )
-     over - dup r> IF 1+ THEN  >in +! ;
+     over  swap r>  scan >r
+     over - dup r> IF 1+ THEN  >in +!
+ [ has? new-input [IF] ]
+dup input-lexeme!
+ [ [THEN] ] ;
  \ name                                                 13feb93py
- Line 89
+ Line 70
  Line 89
  Line 70
  : (name) ( -- c-addr count ) \ gforth
      source 2dup >r >r >in @ /string (parse-white)
+ [ has? new-input [IF] ]
+dup input-lexeme!
+ [ [THEN] ]
 dup + r> - 1+ r> min >in ! ;
  \    name count ;
  [THEN]
- Line 101
+ Line 85
  Line 101
  Line 85
  \ \ Number parsing                                      23feb93py
- \ number? number                                       23feb93py
+ \ (number?) number                                       23feb93py
  hex
- const Create bases   0A , 10 ,   2 ,   0A
+ const Create bases   0A , 10 ,   2 ,   0A ,
  \                    10   16     2     10
  \ !! protect BASE saving wrapper against exceptions
  : getbase ( addr u -- addr' u' )
 dup s" 0x" string-prefix? >r
 dup s" 0X" string-prefix? r> or
-     base @ #33 < and if
+     base @ &34 < and if
          hex 2 /string
      endif
      over c@ [char] # - dup 4 u<
- Line 121
+ Line 105
  Line 121
  Line 105
          drop
      THEN ;
- : sign? ( addr u -- addr u flag )
+ : sign? ( addr u -- addr1 u1 flag )
      over c@ [char] - =  dup >r
      IF
 /string
      THEN
      r> ;
+ : ?dnegate ( d1 f -- d2 )
+     if
+         dnegate
+     then ;
+ has? os 0= [IF]
+ : x@+/string ( addr u -- addr' u' c )
+     over c@ >r 1 /string r> ;
+ [THEN]
  : s'>unumber? ( addr u -- ud flag )
      \ convert string "C" or "C'" to character code
      dup 0= if
          false exit
      endif
-     over c@ >r
+     x@+/string 0 s" '" 2rot string-prefix? ;
-/string s" '" 2swap string-prefix?
-     r> 0 rot ;
- : s>unumber? ( addr u -- ud flag )
+ : s>unumber? ( c-addr u -- ud flag ) \ gforth
+     \G converts string c-addr u into ud, flag indicates success
+     dpl on
      over c@ '' = if
 /string s'>unumber? exit
      endif
-     base @ >r  dpl on  getbase
+     base @ >r  getbase sign?
-. 2swap
+     over if
+         >r 0. 2swap
      BEGIN ( d addr len )
          dup >r >number dup
      WHILE \ there are characters left
          dup r> -
      WHILE \ the last >number parsed something
-         dup 1- dpl ! over c@ [char] . =
+                     dup 1- dpl ! over c@ dp-char @ =
      WHILE \ the current char is '.'
 /string
      REPEAT  THEN \ there are unparseable characters left
-drop false
+drop rdrop false
      ELSE
-         rdrop 2drop true
+             rdrop 2drop r> ?dnegate true
      THEN
+     ELSE
+         drop 2drop 0. false THEN
      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
          rdrop false
      ELSE \ no characters left, all ok
-         r>
+         r> ?dnegate
-         IF
-             dnegate
-         THEN
          true
      THEN ;
- Line 188
+ Line 182
  Line 188
  Line 182
 +
      THEN ;
- : number? ( string -- string 0 / n -1 / d 0> )
+ : (number?) ( string -- string 0 / n -1 / d 0> )
      dup >r count snumber? dup if
          rdrop
      else
- Line 196
+ Line 190
  Line 196
  Line 190
      then ;
  : number ( string -- d )
-     number? ?dup 0= abort" ?"  0<
+     (number?) ?dup 0= abort" ?"  0<
      IF
          s>d
      THEN ;
- Line 227
+ Line 221
  Line 227
  Line 221
      \G comments into documentation.
      POSTPONE \ ; immediate
+ has? ec [IF]
+     AVariable forth-wordlist
+     : find-name ( c-addr u -- nt | 0 ) \ gforth
+         \g Find the name @i{c-addr u} in the current search
+         \g order. Return its @i{nt}, if found, otherwise 0.
+         forth-wordlist (f83find) ;
+ [ELSE]
  \ \ object oriented search list                         17mar93py
  \ word list structure:
- Line 261
+ Line 262
  Line 261
  Line 262
  Create f83search ( -- wordlist-map )
      ' f83find A,  ' drop A,  ' drop A, ' drop A,
- here G f83search T A, NIL A, NIL A, NIL A,
+ here f83search A, NIL A, NIL A, NIL A,
  AValue forth-wordlist \ variable, will be redefined by search.fs
  AVariable lookup        forth-wordlist lookup !
- Line 277
+ Line 278
  Line 277
  Line 278
  ' lookup is context
  forth-wordlist current !
+ : (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} for the definition
+     \G named by the string at @i{c-addr count}.  If the definition is
+     \G not found, return 0. If the definition is found return 1 (if
+     \G the definition is immediate) or -1 (if the definition is not
+     \G immediate) together with the @i{xt}.  In Gforth, the @i{xt}
+     \G returned represents the interpretation semantics.  ANS Forth
+     \G does not specify clearly what @i{xt} represents.
+     (search-wordlist) dup if
+         (name>intn)
+     then ;
+ : find-name ( c-addr u -- nt | 0 ) \ gforth
+     \g Find the name @i{c-addr u} in the current search
+     \g order. Return its @i{nt}, if found, otherwise 0.
+     lookup @ (search-wordlist) ;
+ [THEN]
  \ \ header, finding, ticks                              17dec92py
  \ The constants are defined as 32 bits, but then erased
- Line 284
+ Line 306
  Line 284
  Line 306
  has? f83headerstring [IF]
      \ to save space, Gforth EC limits words to 31 characters
+     \ also, there's no predule concept in Gforth EC
      $80 constant alias-mask
      $40 constant immediate-mask
      $20 constant restrict-mask
      $1f constant lcount-mask
  [ELSE]
+ \ 32-bit systems cannot generate large 64-bit constant in the
+ \ cross-compiler, so we kludge it by generating a constant and then
+ \ storing the proper value into it (and that's another kludge).
  $80000000 constant alias-mask
 bits/char 1 - lshift
  -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
- Line 301
+ Line 327
  Line 301
  Line 327
 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
+ $10000000 constant prelude-mask
-bits/char 3 - lshift 1 -
+bits/char 4 - lshift
+ -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
+                           [ELSE] 0 1 cells 1- times c, [THEN]
+ $0fffffff constant lcount-mask
+bits/char 4 - lshift 1 -
  -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                            [ELSE] -1 1 cells 1- times c, [THEN]
  [THEN]
- Line 329
+ Line 359
  Line 329
  Line 359
  : (x>int) ( cfa w -- xt )
      \ get interpretation semantics of name
-     restrict-mask and
+     restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
      if
          drop ['] compile-only-error
      else
- Line 337
+ Line 367
  Line 337
  Line 367
      then ;
  has? f83headerstring [IF]
- : name>string ( nt -- addr count ) \ gforth     head-to-string
+ : name>string ( nt -- addr count ) \ gforth     name-to-string
      \g @i{addr count} is the name of the word represented by @i{nt}.
      cell+ count lcount-mask and ;
- Line 352
+ Line 382
  Line 352
  Line 382
          swap @ swap
      THEN ;
  [ELSE]
- : name>string ( nt -- addr count ) \ gforth     head-to-string
+ : name>string ( nt -- addr count ) \ gforth     name-to-string
      \g @i{addr count} is the name of the word represented by @i{nt}.
      cell+ dup cell+ swap @ lcount-mask and ;
- Line 368
+ Line 398
  Line 368
  Line 398
      THEN ;
  [THEN]
- : name>int ( nt -- xt ) \ gforth
+ : name>int ( nt -- xt ) \ gforth name-to-int
      \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{ticking-compile-only-error}, which performs @code{-2048 throw}.
      (name>x) (x>int) ;
- : name?int ( nt -- xt ) \ gforth
+ : name?int ( nt -- xt ) \ gforth name-question-int
      \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
      \G has no interpretation semantics.
-     (name>x) restrict-mask and
+     (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
      if
          ticking-compile-only-error \ does not return
      then
- Line 393
+ Line 423
  Line 393
  Line 423
          interpret/compile-comp @
      then
  [ [THEN] ]
-     r> immediate-mask and flag-sign
+     r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign
      ;
  : (name>intn) ( nfa -- xt +-1 )
      (name>x) tuck (x>int) ( w xt )
-     swap immediate-mask and flag-sign ;
+     swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ;
+ [IFDEF] prelude-mask
+ : name>prelude ( nt -- xt )
+     dup cell+ @ prelude-mask and if
+         [ -1 cells ] literal + @
+     else
+         drop ['] noop
+     then ;
+ [THEN]
  const Create ???  0 , 3 , char ? c, char ? c, char ? c,
  \ ??? is used by dovar:, must be created/:dovar
- Line 407
+ Line 446
  Line 407
  Line 446
  \ if we have a forthstart we can define head? with it
  \ otherwise leave out the head? check
+ : one-head? ( addr -- f )
+ \G heuristic check whether addr is a name token; may deliver false
+ \G positives; addr must be a valid address
+     dup dup aligned <>
+     if
+         drop false exit \ heads are aligned
+     then
+     dup cell+ @ alias-mask and 0= >r
+     name>string dup $20 $1 within if
+         rdrop 2drop false exit \ realistically the name is short
+     then
+     over + cfaligned over - 2dup bounds ?do \ should be a printable string
+         i c@ bl < if
+drop unloop rdrop false exit
+         then
+     loop
+     + r> if \ check for valid aliases
+         @ dup forthstart here within
+         over ['] noop ['] lit-execute 1+ within or
+         over dup aligned = and
+= if
+             drop false exit
+         then
+     then \ check for cfa - must be code field or primitive
+     dup @ tuck 2 cells - = swap
+     docol:  ['] lit-execute @ 1+ within or ;
  : head? ( addr -- f )
  \G heuristic check whether addr is a name token; may deliver false
  \G positives; addr must be a valid address; returns 1 for
- Line 417
+ Line 483
  Line 417
  Line 483
      \ some code), which is typically not in the dictionary.
      \ we added a third iteration for working with code and ;code words.
 0 do
-         dup dup aligned <> if \ protect @ against unaligned accesses
+         dup one-head? 0= if
              drop false unloop exit
-         then
+         endif
-         dup @ dup
+         dup @ dup 0= if
-         if ( addr addr1 )
+drop 1 unloop exit
-             dup rot forthstart within
+         else
-             if \ addr1 is outside forthstart..addr, not a head
+             dup rot forthstart within if
                  drop false unloop exit
-             then ( addr1 )
+             then
-         else \ 0 in the link field, no further checks
-drop 1 unloop exit \ this is very unsure, so return 1
          then
      loop
-     \ in dubio pro:
      drop true ;
  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
      \ also heuristic
-     dup forthstart - max-name-length @ float+ cell+ min cell max cell ?do ( cfa )
+     dup forthstart - max-name-length @
+     [ has? float [IF] ] float+ [ [ELSE] ] cell+ [ [THEN] ] 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
- Line 469
+ Line 534
  Line 469
  Line 534
  [THEN]
- cell% 2* 0 0 field >body ( xt -- a_addr ) \ core
+ cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
  \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
- Line 492
+ Line 557
  Line 492
  Line 557
          drop 0
      endif ;
- ' ! alias code-address! ( c_addr xt -- ) \ gforth
+ has? prims [IF]
+     : flash! ! ;
+     : flashc! c! ;
+ [THEN]
+ has? flash [IF] ' flash! [ELSE] ' ! [THEN]
+ alias code-address! ( c_addr xt -- ) \ gforth
  \G Create a code field with code address @i{c-addr} at @i{xt}.
- : does-code! ( a_addr xt -- ) \ gforth
+ : any-code! ( a-addr cfa code-addr -- )
+     \ for implementing DOES> and ;ABI-CODE, maybe :
+     \ code-address is stored at cfa, a-addr at cfa+cell
+     over ! cell+ ! ;
+ : 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+ ! ;
+     [ has? flash [IF] ]
+     dodoes: over flash! cell+ flash!
- ' drop alias does-handler! ( a_addr -- ) \ gforth
+     [ [ELSE] ]
- \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
+     dodoes: any-code!
- \G @i{a-addr} points just behind a @code{DOES>}.
+     [ [THEN] ] ;
 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} for the definition
-     \G named by the string at @i{c-addr count}.  If the definition is
-     \G not found, return 0. If the definition is found return 1 (if
-     \G the definition is immediate) or -1 (if the definition is not
-     \G immediate) together with the @i{xt}.  In Gforth, the @i{xt}
-     \G returned represents the interpretation semantics.  ANS Forth
-     \G does not specify clearly what @i{xt} represents.
-     (search-wordlist) dup if
-         (name>intn)
-     then ;
- : find-name ( c-addr u -- nt | 0 ) \ gforth
-     \g Find the name @i{c-addr u} in the current search
-     \g order. Return its @i{nt}, if found, otherwise 0.
-     lookup @ (search-wordlist) ;
  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
      find-name dup
      if ( nt )
- Line 565
+ Line 621
  Line 565
  Line 621
  \ ticks in interpreter
  : (') ( "name" -- nt ) \ gforth
-     name name-too-short?
+     parse-name name-too-short?
      find-name dup 0=
      IF
          drop -&13 throw
- Line 588
+ Line 644
  Line 588
  Line 644
  \ interpret                                            10mar92py
- Defer parser ( c-addr u -- )
+ Defer parser1 ( c-addr u -- ... xt)
- Defer parse-word ( "name" -- c-addr u ) \ gforth
+ \ "... xt" is the action to be performed by the text-interpretation of c-addr u
+ : parser ( c-addr u -- ... )
+ \ text-interpret the word/number c-addr u, possibly producing a number
+     parser1 execute ;
+ has? ec [IF]
+     ' (name) Alias parse-name
+     : no.extensions  2drop -&13 throw ;
+     ' no.extensions Alias compiler-notfound1
+     ' no.extensions Alias interpreter-notfound1
+ [ELSE]
+ Defer parse-name ( "name" -- c-addr u ) \ gforth
  \G Get the next word from the input buffer
- ' (name) IS parse-word
+ ' (name) IS parse-name
- ' parse-word alias name ( -- c-addr u ) \ gforth-obsolete
+ ' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete
- \G old name for @code{parse-word}
+ \G old name for @code{parse-name}
- Defer compiler-notfound ( c-addr count -- )
+ ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
- Defer interpreter-notfound ( c-addr count -- )
+ \G old name for @code{parse-name}
  : no.extensions  ( addr u -- )
 drop -&13 throw ;
- ' no.extensions IS compiler-notfound
- ' no.extensions IS interpreter-notfound
+ has? recognizer 0= [IF]
+ Defer compiler-notfound1 ( c-addr count -- ... xt )
+ Defer interpreter-notfound1 ( c-addr count -- ... xt )
+ ' no.extensions IS compiler-notfound1
+ ' no.extensions IS interpreter-notfound1
+ [THEN]
  Defer before-word ( -- ) \ gforth
  \ called before the text interpreter parses the next word
  ' noop IS before-word
+ [THEN]
+ has? backtrace [IF]
  : interpret1 ( ... -- ... )
- [ has? backtrace [IF] ]
      rp@ backtrace-rp0 !
- [ [THEN] ]
      BEGIN
-         ?stack before-word name dup
+         ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-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 ;
+ [ELSE]
+ : interpret ( ... -- ... )
+     BEGIN
+         ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
+     WHILE
+         parser1 execute
+     REPEAT
+drop ;
+ [THEN]
  \ interpreter                                   30apr92py
+ [IFDEF] prelude-mask
+ : run-prelude ( nt|0 -- nt|0 )
+     \ run the prelude of the name identified by nt (if present).  This
+     \ is used in the text interpreter and similar stuff.
+     dup if
+         dup name>prelude execute
+     then ;
+ [THEN]
+ has? recognizer 0= [IF]
  \ not the most efficient implementations of interpreter and compiler
- : interpreter ( c-addr u -- )
+ : interpreter1 ( c-addr u -- ... xt )
-dup find-name dup
+dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] 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
+ [THEN]
  \ \ Query Evaluate                                      07apr93py
- Line 661
+ Line 751
  Line 661
  Line 751
  [THEN]
  has? new-input 0= [IF]
+ : input-start-line ( -- )  >in off ;
  : 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 676
+ Line 767
  Line 676
  Line 767
      \G and return true; otherwise, return false.  A successful result
      \G includes receipt of a line containing 0 characters.
      [ has? file [IF] ]
-         blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
+         blk @  IF  1 blk +!  true  EXIT  THEN
          [ [THEN] ]
      tib /line
      [ has? file [IF] ]
- Line 685
+ Line 776
  Line 685
  Line 776
          ELSE
              [ [THEN] ]
          sourceline# 0< IF 2drop false EXIT THEN
-         accept true
+         accept eof @ 0=
          [ has? file [IF] ]
          THEN
 loadline +!
          [ [THEN] ]
-     swap #tib ! 0 >in ! ;
+     swap #tib !
+     input-start-line ;
  : query   ( -- ) \ core-ext
      \G Make the user input device the input source. Receive input into
- Line 753
+ Line 845
  Line 753
  Line 845
      s" *evaluated string*" loadfilename>r
  [ [THEN] ]
      push-file #tib ! >tib !
-     >in off
+     input-start-line
      [ has? file [IF] ]
          blk off loadfile off -1 loadline !
          [ [THEN] ]
- Line 769
+ Line 861
  Line 769
  Line 861
  Defer 'quit
+ has? os [IF]
  Defer .status
+ [ELSE]
+     [IFUNDEF] bye
+         : (bye)     ( 0 -- ) \ back to DOS
+             drop 5 emit ;
+         : bye ( -- )  0 (bye) ;
+     [THEN]
+ [THEN]
  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
  : (quit) ( -- )
      \ exits only through THROW etc.
      BEGIN
-         .status
+         [ has? ec [IF] ] cr [ [ELSE] ]
-         ['] cr catch if
+         .status ['] cr catch if
-             >stderr cr ." Can't print to stdout, leaving" cr
+             [ has? OS [IF] ] >stderr [ [THEN] ]
+             cr ." Can't print to stdout, leaving" cr
              \ if stderr does not work either, already DoError causes a hang
 (bye)
-         endif
+         endif [ [THEN] ]
-         query interpret prompt
+         refill  WHILE
-     AGAIN ;
+             interpret prompt
+     REPEAT
+     bye ;
  ' (quit) IS 'quit
  \ \ DOERROR (DOERROR)                                   13jun93jaw
+ has? os [IF]
 Constant max-errors
+has? file 2 and + Constant /error
  Variable error-stack  0 error-stack !
- max-errors has? file [IF] 6 [ELSE] 4 [THEN] * cells allot
+ max-errors /error * cells allot
  \ format of one cell:
- \ source ( addr u )
+ \ source ( c-addr u )
- \ >in
+ \ last parsed lexeme ( c-addr u )
  \ line-number
  \ Loadfilename ( addr u )
- : error> ( -- addr u >in line# [addr u] )
+ : error> ( --  c-addr1 u1 c-addr2 u2 line# [addr u] )
      -1 error-stack +!
      error-stack dup @
-     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+
+     /error * cells + cell+
-     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO
+     /error cells bounds DO
          I @
          cell +LOOP ;
- : >error ( addr u >in line# [addr u] -- )
+ : >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- )
      error-stack dup @ dup 1+
      max-errors 1- min error-stack !
-     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+
+     /error * cells + cell+
-     [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO
+     /error 1- cells bounds swap DO
          I !
          -1 cells +LOOP ;
+ : input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )
+     \ error data for the current input, to be used by >error or .error-frame
+     source over >r save-mem over r> -
+     input-lexeme 2@ >r + r> sourceline#
+     [ has? file [IF] ] sourcefilename [ [THEN] ] ;
  : 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 828
+ Line 942
  Line 828
  Line 942
      \ !! not used...
      [char] $ emit base @ swap hex u. base ! ;
- : typewhite ( addr n -- ) \ gforth
- \G Like type, but white space is printed instead of the characters.
-     \ bounds u+do
-max bounds ?do
-         i c@ #tab = if \ check for tab
-             #tab
-         else
-             bl
-         then
-         emit
-     loop ;
  : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
  \G Adjust the string specified by @i{c-addr, u1} to remove all
  \G trailing spaces. @i{u2} is the length of the modified string.
- Line 862
+ Line 964
  Line 862
  Line 964
    ELSE  .error
    THEN ;
- : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )
+ [IFUNDEF] umin
- \ addr2 u2:     filename of included file - optional
+ : umin ( u1 u2 -- u )
+dup u>
+     if
+         swap
+     then
+     drop ;
+ [THEN]
+ Defer mark-start
+ Defer mark-end
+ :noname ." >>>" ; IS mark-start
+ :noname ." <<<" ; IS mark-end
+ : part-type ( addr1 u1 u -- addr2 u2 )
+     \ print first u characters of addr1 u1, addr2 u2 is the rest
+     over umin 2 pick over type /string ;
+ : .error-line ( c-addr1 u1 c-addr2 u2 -- )
+     \ print error in line c-addr1 u1, where the error-causing lexeme
+     \ is c-addr2 u2
+     >r 2 pick - part-type ( c-addr3 u3 R: u2 )
+     mark-start r> part-type mark-end ( c-addr4 u4 )
+     type ;
+ : .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode )
+     \ addr3 u3: filename of included file - optional
  \ n2:           line number
- \ n1:           error position in input line
+     \ addr2 u2: parsed lexeme (should be marked as causing the error)
  \ addr1 u1:     input line
-   cr error-stack @
+     error-stack @
-   IF
+     IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
- [ has? file [IF] ]
+         [ has? file [IF] ] \ !! unbalanced stack effect
-     ." in file included from "
+           over IF
+               cr ." in file included from "
      type ." :"
- [ [THEN] ]
+dec.r  2drop 2drop
-     dec.r  drop 2drop
    ELSE
+drop 2drop 2drop drop
+           THEN
+           [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
+     ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
  [ has? file [IF] ]
-       type ." :"
+             cr type ." :"
- [ [THEN] ]
+             [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
-       dup >r dec.r ." : " 3 pick .error-string
+         dup 0 dec.r ." : " 5 pick .error-string
-       r> IF \ if line# non-zero, there is a line
+         IF \ if line# non-zero, there is a line
-           cr dup 2over type cr drop
+             cr .error-line
-           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
        ELSE
-drop drop
+drop 2drop
        THEN
    THEN ;
- Line 899
+ Line 1022
  Line 899
  Line 1022
    [ has? os [IF] ]
        >stderr
    [ [THEN] ]
-   source >in @ sourceline# [ has? file [IF] ]
+   input-error-data .error-frame
-       sourcefilename
-   [ [THEN] ] .error-frame
    error-stack @ 0 ?DO
      error>
      .error-frame
- Line 914
+ Line 1035
  Line 914
  Line 1035
  ' (DoError) IS DoError
+ [ELSE]
+     : dec.  base @ >r decimal . r> base ! ;
+     : DoError ( throw-code -- )
+         cr source drop >in @ type ." <<< "
+         dup -2 =  IF  "error @ type  drop  EXIT  THEN
+         .error ;
+ [THEN]
  : quit ( ?? -- ?? ) \ core
      \G Empty the return stack, make the user input device
      \G the input source, enter interpret state and start
- Line 939
+ Line 1068
  Line 939
  Line 1068
      [ [ELSE] ] r> >tib !
      [ [THEN] ] ;
+ : do-execute ( xt -- ) \ Gforth
+     \G C calling us
+     catch dup IF  DoError cr  THEN  (bye) ;
  \ \ Cold Boot                                           13feb93py
- : (bootmessage)
+ : gforth ( -- )
      ." Gforth " version-string type
-     ." , Copyright (C) 1995-2003 Free Software Foundation, Inc." cr
+     ." , Copyright (C) 1995-2011 Free Software Foundation, Inc." cr
      ." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
  [ has? os [IF] ]
       cr ." Type `bye' to exit"
  [ [THEN] ] ;
- defer bootmessage
+ defer bootmessage ( -- ) \ gforth
+ \G Hook (deferred word) executed right after interpreting the OS
+ \G command-line arguments.  Normally prints the Gforth startup
+ \G message.
+ has? file [IF]
  defer process-args
+ [THEN]
- ' (bootmessage) IS bootmessage
+ ' gforth IS bootmessage
+ has? os [IF]
  Defer 'cold ( -- ) \ gforth  tick-cold
- \ hook (deferred word) for things to do right before interpreting the
+ \G Hook (deferred word) for things to do right before interpreting the
- \ command-line arguments
+ \G OS command-line arguments.  Normally does some initializations that
+ \G you also want to perform.
  ' noop IS 'cold
+ [THEN]
- AVariable init8 NIL init8 !
  : cold ( -- ) \ gforth
  [ has? backtrace [IF] ]
- Line 969
+ Line 1108
  Line 969
  Line 1108
  [ has? file [IF] ]
      os-cold
  [ [THEN] ]
+ [ has? os [IF] ]
+     set-encoding-fixed-width
      'cold
-     init8 chainperform
+ [ [THEN] ]
  [ has? file [IF] ]
-     s" *the terminal*" loadfilename 2!
      process-args
      loadline off
  [ [THEN] ]
      bootmessage
-     quit ;
+(bye) ;
  has? new-input 0= [IF]
  : clear-tibstack ( -- )
- Line 987
+ Line 1127
  Line 987
  Line 1127
      [ has? os [IF] ]
      r0 @ forthstart 6 cells + @ -
      [ [ELSE] ]
-     sp@ $10 cells +
+     sp@ cell+
      [ [THEN] ]
  [ [THEN] ]
-     dup >tib ! tibstack ! #tib off >in off ;
+     dup >tib ! tibstack ! #tib off
+     input-start-line ;
  [THEN]
  : boot ( path n **argv argc -- )
-     main-task up!
+ [ has? no-userspace 0= [IF] ]
+     next-task 0= IF  main-task up!
+     ELSE
+         next-task @ 0= IF
+             throw-entry main-task udp @ throw-entry next-task -
+             /string >r swap r> move
+             next-task dup next-task 2!  normal-dp dpp !
+         THEN
+     THEN
+ [ [THEN] ]
  [ has? os [IF] ]
      os-boot
  [ [THEN] ]
+ [ has? rom [IF] ]
+     ram-shadow dup @ dup -1 <> >r u> r> and IF
+         ram-shadow 2@  ELSE
+         ram-mirror ram-size  THEN  ram-start swap move
+ [ [THEN] ]
      sp@ sp0 !
  [ has? peephole [IF] ]
      \ only needed for greedy static superinstruction selection
- Line 1007
+ Line 1162
  Line 1007
  Line 1162
      current-input off
  [ [THEN] ]
      clear-tibstack
+0 includefilename 2!
      rp@ rp0 !
  [ has? floating [IF] ]
      fp@ fp0 !
  [ [THEN] ]
+ [ has? os [IF] ]
      handler off
      ['] cold catch dup -&2049 <> if \ broken pipe?
          DoError cr
      endif
+ [ [ELSE] ]
+     cold
+ [ [THEN] ]
  [ has? os [IF] ]
-(bye) \ !! determin exit code from throw code?
+     -1 (bye) \ !! determin exit code from throw code?
  [ [THEN] ]
  ;

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



Removed from v.1.109
 


changed lines


 
Added in v.1.191
 Legend:



Removed from v.1.109
 


changed lines


 
Added in v.1.191
-Removed from v.1.109
+Added in v.1.191

CVS Admin

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.109 and 1.191

ViewCVS and CVS Help