[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

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

version 1.10, Sun Nov 22 21:44:05 1998 UTC version 1.43, Fri Dec 3 18:49:51 1999 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
   \ Copyright (C) 1995,1996,1997,1998 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
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ 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
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
 \ \ Revision-Log  \ \ Revision-Log
   
 \       put in seperate file                            14sep97jaw  \       put in seperate file                            14sep97jaw
   
 \ \ input stream primitives                             23feb93py  \ \ input stream primitives                             23feb93py
   
 : tib ( -- c-addr ) \ core-ext  require ./basics.fs     \ bounds decimal hex ...
     \ obsolescent  require ./io.fs         \ type ...
   require ./nio.fs        \ . <# ...
   require ./errore.fs     \ .error ...
   require ~+/kernel/version.fs    \ version-string
   require ./../chains.fs
   
   : 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.
     >tib @ ;      >tib @ ;
   
 Defer source ( -- addr count ) \ core  Defer source ( -- c-addr u ) \ core
 \ used by dodefer:, must be defer  \ used by dodefer:, must be defer
   \G @i{c-addr} is the address of the input buffer and @i{u} is the
   \G number of characters in it.
   
 : (source) ( -- addr count )  : (source) ( -- c-addr u )
     tib #tib @ ;      tib #tib @ ;
 ' (source) IS source  ' (source) IS source
   
Line 25 
Line 53 
   
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : sword  ( char -- addr len ) \ gforth  : sword  ( char -- addr len ) \ gforth s-word
   \G parses like @code{word}, but the output is like @code{parse} output      \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    \ 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    \ dpANS6 A.6.2.2008 have a word with that name that behaves
   \ differently (like NAME).    \ differently (like NAME).
Line 34 
Line 63 
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN    rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
   2dup + r> - 1+ r> min >in ! ;    2dup + r> - 1+ r> min >in ! ;
   
 : word   ( char -- addr ) \ core  : 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 ;    sword here place  bl here count + c!  here ;
   
 : parse    ( char -- addr len ) \ core-ext  : 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  over  swap r>  scan >r
   over - dup r> IF 1+ THEN  >in +! ;    over - dup r> IF 1+ THEN  >in +! ;
   
Line 45 
Line 85 
   
 [IFUNDEF] (name) \ name might be a primitive  [IFUNDEF] (name) \ name might be a primitive
   
 : (name) ( -- c-addr count )  : (name) ( -- c-addr count ) \ gforth
     source 2dup >r >r >in @ /string (parse-white)      source 2dup >r >r >in @ /string (parse-white)
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
Line 64 
Line 104 
 hex  hex
 const Create bases   10 ,   2 ,   A , 100 ,  const Create bases   10 ,   2 ,   A , 100 ,
 \                     16     2    10   character  \                     16     2    10   character
 \ !! this saving and restoring base is an abomination! - anton  
   
   \ !! protect BASE saving wrapper against exceptions
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     over c@ [char] $ - dup 4 u<      over c@ [char] $ - dup 4 u<
     IF      IF
Line 74 
Line 114 
         drop          drop
     THEN ;      THEN ;
   
 : s>number ( addr len -- d )  : sign? ( addr u -- addr u flag )
     base @ >r  dpl on      over c@ [char] - =  dup >r
     over c@ '- =  dup >r  
     IF      IF
         1 /string          1 /string
     THEN      THEN
     getbase  dpl on  0 0 2swap      r> ;
     BEGIN  
   : s>unumber? ( addr u -- ud flag )
       base @ >r  dpl on  getbase
       0. 2swap
       BEGIN ( d addr len )
         dup >r >number dup          dup >r >number dup
     WHILE      WHILE \ there are characters left
         dup r> -          dup r> -
     WHILE      WHILE \ the last >number parsed something
         dup dpl ! over c@ [char] . =          dup 1- dpl ! over c@ [char] . =
     WHILE      WHILE \ the current char is '.'
         1 /string          1 /string
     REPEAT  THEN      REPEAT  THEN \ there are unparseable characters left
         2drop rdrop dpl off          2drop false
     ELSE      ELSE
         2drop rdrop r>          rdrop 2drop true
       THEN
       r> base ! ;
   
   \ ouch, this is complicated; there must be a simpler way - anton
   : s>number? ( addr len -- d f )
       \ converts string addr len into d, flag indicates success
       sign? >r
       s>unumber?
       0= IF
           rdrop false
       ELSE \ no characters left, all ok
           r>
         IF          IF
             dnegate              dnegate
         THEN          THEN
     THEN          true
     r> base ! ;      THEN ;
   
   : s>number ( addr len -- d )
       \ don't use this, there is no way to tell success
       s>number? drop ;
   
 : snumber? ( c-addr u -- 0 / n -1 / d 0> )  : snumber? ( c-addr u -- 0 / n -1 / d 0> )
     s>number dpl @ 0=      s>number? 0=
     IF      IF
         2drop false  EXIT          2drop false  EXIT
     THEN      THEN
     dpl @ dup 0> 0= IF      dpl @ dup 0< IF
         nip          nip
       ELSE
           1+
     THEN ;      THEN ;
   
 : number? ( string -- string 0 / n -1 / d 0> )  : number? ( string -- string 0 / n -1 / d 0> )
Line 123 
Line 184 
   
 \ \ Comments ( \ \G  \ \ Comments ( \ \G
   
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ thisone- core,file    paren
       \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
     [char] ) parse 2drop ; immediate      [char] ) parse 2drop ; immediate
   
 : \ ( -- ) \ core-ext backslash  : \ ( -- ) \ 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
       [ has? file [IF] ]
     blk @      blk @
     IF      IF
         >in @ c/l / 1+ c/l * >in !          >in @ c/l / 1+ c/l * >in !
         EXIT          EXIT
     THEN      THEN
       [ [THEN] ]
     source >in ! drop ; immediate      source >in ! drop ; immediate
   
 : \G ( -- ) \ gforth backslash  : \G ( -- ) \ gforth backslash-gee
       \G Equivalent to @code{\} but used as a tag to annotate definition
       \G comments into documentation.
     POSTPONE \ ; immediate      POSTPONE \ ; immediate
   
 \ \ object oriented search list                         17mar93py  \ \ object oriented search list                         17mar93py
Line 151 
Line 222 
   
 struct  struct
   cell% field wordlist-map \ pointer to a wordlist-map-struct    cell% field wordlist-map \ pointer to a wordlist-map-struct
   cell% field wordlist-id \ not the same as wid; representation depends on implementation    cell% field wordlist-id \ linked list of words (for WORDS etc.)
   cell% field wordlist-link \ link field to other wordlists    cell% field wordlist-link \ link field to other wordlists
   cell% field wordlist-extend \ points to wordlist extensions (eg hashtables)    cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
 end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
Line 172 
Line 243 
 AVariable lookup        forth-wordlist lookup !  AVariable lookup        forth-wordlist lookup !
 \ !! last is user and lookup?! jaw  \ !! last is user and lookup?! jaw
 AVariable current ( -- addr ) \ gforth  AVariable current ( -- addr ) \ gforth
   \G @code{Variable} -- holds the @i{wid} of the compilation word list.
 AVariable voclink       forth-wordlist wordlist-link voclink !  AVariable voclink       forth-wordlist wordlist-link voclink !
 lookup AValue context  \ lookup AValue context ( -- addr ) \ gforth
   Defer context ( -- addr ) \ gforth
   \G @code{context} @code{@@} is the @i{wid} of the word list at the
   \G top of the search order.
   
   ' lookup is context
 forth-wordlist current !  forth-wordlist current !
   
 \ \ header, finding, ticks                              17dec92py  \ \ header, finding, ticks                              17dec92py
   
 $80 constant alias-mask \ set when the word is not an alias!  hex
 $40 constant immediate-mask  80 constant alias-mask \ set when the word is not an alias!
 $20 constant restrict-mask  40 constant immediate-mask
   20 constant restrict-mask
   
 \ higher level parts of find  \ higher level parts of find
   
Line 210 
Line 287 
     then ;      then ;
   
 : name>string ( nt -- addr count ) \ gforth     head-to-string  : name>string ( nt -- addr count ) \ gforth     head-to-string
     \g @var{addr count} is the name of the word represented by @var{nt}.      \g @i{addr count} is the name of the word represented by @i{nt}.
     cell+ count $1F and ;      cell+ count $1F and ;
   
 : ((name>))  ( nfa -- cfa )  : ((name>))  ( nfa -- cfa )
Line 225 
Line 302 
     THEN ;      THEN ;
   
 : name>int ( nt -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth
     \G @var{xt} represents the interpretation semantics of the word      \G @i{xt} represents the interpretation semantics of the word
     \G @var{nt}. Produces @code{' compile-only-error} if      \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
     \G @var{nt} is compile-only.      \G @code{compile-only}), @i{xt} is the execution token for
       \G @code{compile-only-error}, which performs @code{-14 throw}.
     (name>x) (x>int) ;      (name>x) (x>int) ;
   
 : name?int ( nt -- xt ) \ gforth  : name?int ( nt -- xt ) \ gforth
     \G Like name>int, but throws an error if compile-only.      \G Like @code{name>int}, but perform @code{-14 throw} if @i{nt}
       \G has no interpretation semantics.
     (name>x) restrict-mask and      (name>x) restrict-mask and
     if      if
         compile-only-error \ does not return          compile-only-error \ does not return
Line 239 
Line 318 
     (cfa>int) ;      (cfa>int) ;
   
 : (name>comp) ( nt -- w +-1 ) \ gforth  : (name>comp) ( nt -- w +-1 ) \ gforth
     \G @var{w xt} is the compilation token for the word @var{nt}.      \G @i{w xt} is the compilation token for the word @i{nt}.
     (name>x) >r      (name>x) >r
 [ has? compiler [IF] ]  [ has? compiler [IF] ]
     dup interpret/compile?      dup interpret/compile?
Line 257 
Line 336 
 const Create ???  0 , 3 c, char ? c, char ? c, char ? c,  const Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 \ ??? is used by dovar:, must be created/:dovar  \ ??? is used by dovar:, must be created/:dovar
   
 : >head ( cfa -- nt ) \ gforth  to-name  [IFDEF] forthstart
  $21 cell do  \ if we have a forthstart we can define head? with it
    dup i - count $9F and + cfaligned over alias-mask + = if  \ otherwise leave out the head? check
      i - cell - unloop exit  
   : head? ( addr -- f )
       \G heuristic check whether addr is a name token; may deliver false
       \G positives; addr must be a valid address
       \ 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.
       2 0 do
           dup dup aligned <> if \ protect @ against unaligned accesses
               drop false unloop exit
           then
           dup @ dup
           if ( addr addr1 )
               dup rot forthstart within
               if \ addr1 is outside forthstart..addr, not a head
                   drop false unloop exit
               then ( addr1 )
           else \ 0 in the link field, no further checks
               2drop true unloop exit
           then
       loop
       \ in dubio pro:
       drop true ;
   
   : >head ( cfa -- nt ) \ gforth  to-head
       $21 cell do ( cfa )
           dup i - count $9F and + cfaligned over alias-mask + =
           if ( cfa )
               dup i - cell - dup head?
               if
                   nip unloop exit
               then
               drop
           then
           cell +loop
       drop ??? ( wouldn't 0 be better? ) ;
   
   [ELSE]
   
   : >head ( cfa -- nt ) \ gforth  to-head
       $21 cell do ( cfa )
           dup i - count $9F and + cfaligned over alias-mask + =
           if ( cfa ) i - cell - unloop exit
    then     then
  cell +loop   cell +loop
  drop ??? ( wouldn't 0 be better? ) ;   drop ??? ( wouldn't 0 be better? ) ;
   
   [THEN]
   
 ' >head ALIAS >name  ' >head ALIAS >name
   
 : body> 0 >body - ;  : body> 0 >body - ;
   
 : (search-wordlist)  ( addr count wid -- nt / false )  : (search-wordlist)  ( addr count wid -- nt | false )
     dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
   
 : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search  : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search
     \ xt is the interpretation semantics      \G Search the word list identified by @i{wid}
       \G for the definition named by the string at @i{c-addr count}.
       \G If the definition is not found, return 0. If the definition
       \G is found return 1 (if the definition is immediate) or -1
       \G (if the definition is not immediate) together with the @i{xt}.
       \G The @i{xt} returned represents the interpretation semantics.
     (search-wordlist) dup if      (search-wordlist) dup if
         (name>intn)          (name>intn)
     then ;      then ;
   
 : find-name ( c-addr u -- nt/0 ) \ gforth  : find-name ( c-addr u -- nt | 0 ) \ gforth
     \g Find the name @var{c-addr u} in the current search      \g Find the name @i{c-addr u} in the current search
     \g order. Return its nt, if found, otherwise 0.      \g order. Return its @i{nt}, if found, otherwise 0.
     lookup @ (search-wordlist) ;      lookup @ (search-wordlist) ;
   
 : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
Line 294 
Line 423 
         then          then
    then ;     then ;
   
 : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search  : find ( c-addr -- xt +-1 | c-addr 0 ) \ core,search
       \G Search all word lists in the current search order
       \G for the definition named by the counted string at @i{c-addr}.
       \G If the definition is not found, return 0. If the definition
       \G is found return 1 (if the definition is immediate) or -1
       \G (if the definition is not immediate) together with the @i{xt}.
     dup count sfind dup      dup count sfind dup
     if      if
         rot drop          rot drop
     then ;      then ;
   
 \ ticks  \ ticks in interpreter
   
 : (') ( "name" -- nt ) \ gforth  : (') ( "name" -- nt ) \ gforth
     name find-name dup 0=      name name-too-short?
       find-name dup 0=
     IF      IF
         drop -&13 bounce          drop -&13 throw
     THEN  ;      THEN  ;
   
 : '    ( "name" -- xt ) \ core  tick  : '    ( "name" -- xt ) \ core  tick
     \g @var{xt} represents @var{name}'s interpretation      \g @i{xt} represents @i{name}'s interpretation
     \g semantics. Performs @code{-14 throw} if the word has no      \g semantics. Perform @code{-14 throw} if the word has no
     \g interpretation semantics.      \g interpretation semantics.
     (') name?int ;      (') name?int ;
   
   has? compiler 0= [IF]   \ interpreter only version of IS and TO
   
   : IS ' >body ! ;
   ' IS Alias TO
   
   [THEN]
   
 \ \ the interpreter loop                                  mar92py  \ \ the interpreter loop                                  mar92py
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser  Defer parser ( c-addr u -- )
 Defer name ( -- c-addr count ) \ gforth  Defer name ( -- c-addr count ) \ gforth
 \ get the next word from the input buffer  \ get the next word from the input buffer
 ' (name) IS name  ' (name) IS name
Line 326 
Line 468 
 Defer interpreter-notfound ( c-addr count -- )  Defer interpreter-notfound ( c-addr count -- )
   
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 bounce ;      2drop -&13 throw ;
 ' no.extensions IS compiler-notfound  ' no.extensions IS compiler-notfound
 ' no.extensions IS interpreter-notfound  ' no.extensions IS interpreter-notfound
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
   [ has? backtrace [IF] ]
       rp@ backtrace-rp0 !
   [ [THEN] ]
     BEGIN      BEGIN
         ?stack name dup          ?stack name dup
     WHILE      WHILE
Line 361 
Line 506 
 \ \ Query Evaluate                                      07apr93py  \ \ Query Evaluate                                      07apr93py
   
 has? file 0= [IF]  has? file 0= [IF]
 : sourceline# ( -- n )  loadline @ ;  : sourceline# ( -- n )  1 ;
 [THEN]  [THEN]
   
 : refill ( -- flag ) \ core-ext,block-ext,file-ext  : 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
       \G input into the terminal input device. If successful, make the
       \G result the input buffer, set @code{>IN} to 0 and return true;
       \G otherwise return false. When the input source is a block, add 1
       \G to the value of @code{BLK} to make the next block the input
       \G source and current input buffer, and set @code{>IN} to 0;
       \G return true if the new value of @code{BLK} is a valid block
       \G number, false otherwise. When the input source is a text file,
       \G attempt to read the next line from the file. If successful,
       \G make the result the current input buffer, set @code{>IN} to 0
       \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  0 >in !  EXIT  THEN
           [ [THEN] ]
   tib /line    tib /line
 [ has? file [IF] ]  [ has? file [IF] ]
   loadfile @ ?dup    loadfile @ ?dup
Line 376 
Line 536 
       accept true        accept true
 [ has? file [IF] ]  [ has? file [IF] ]
   THEN    THEN
 [ [THEN] ]  
   1 loadline +!    1 loadline +!
           [ [THEN] ]
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : query   ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \G obsolescent      \G Make the user input device the input source. Receive input into
       \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
       \G superceeded by @code{accept}.
       [ has? file [IF] ]
     blk off loadfile off      blk off loadfile off
           [ [THEN] ]
     tib /line accept #tib ! 0 >in ! ;      tib /line accept #tib ! 0 >in ! ;
   
 \ save-mem extend-mem  \ save-mem extend-mem
Line 405 
Line 569 
   
 has? file 0= [IF]  has? file 0= [IF]
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r    tibstack @ >r  >tib @ >r  #tib @ >r
   >tib @ tibstack @ = IF  r@ tibstack +!  THEN    >tib @ tibstack @ = IF  r@ tibstack +!  THEN
   tibstack @ >tib ! >in @ >r  >r ;    tibstack @ >tib ! >in @ >r  >r ;
   
 : pop-file   ( throw-code -- throw-code )  : pop-file   ( throw-code -- throw-code )
   r>    r>
   r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;    r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
 [THEN]  [THEN]
   
 : evaluate ( c-addr len -- ) \ core,block  : 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.
   push-file  #tib ! >tib !    push-file  #tib ! >tib !
   >in off blk off loadfile off -1 loadline !      >in off
       [ has? file [IF] ]
           blk off loadfile off -1 loadline !
           [ [THEN] ]
   ['] interpret catch    ['] interpret catch
   pop-file throw ;    pop-file throw ;
   
Line 429 
Line 601 
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
   
 : (Query)  ( -- )  : (Query)  ( -- )
     loadfile off  blk off loadline off refill drop ;      [ has? file [IF] ]
           loadfile off  blk off loadline off
           [ [THEN] ]
       refill drop ;
   
 : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;  : (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
       AGAIN ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
Line 447 
Line 630 
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
 : dec. ( n -- ) \ gforth  : dec. ( n -- ) \ gforth
     \ print value in decimal representation      \G Display @i{n} as a signed decimal number, followed by a space.
       \ !! not used...
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
   : dec.r ( u -- ) \ gforth
       \G Display @i{u} as a unsigned decimal number
       base @ decimal swap 0 .r base ! ;
   
 : hex. ( u -- ) \ gforth  : hex. ( u -- ) \ gforth
     \ print value as unsigned hex number      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
     '$ emit base @ swap hex u. base ! ;      \G followed by a space.
       \ !! not used...
       [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \G Like type, but white space is printed instead of the characters.
     bounds ?do      bounds ?do
         i c@ #tab = if \ check for tab          i c@ #tab = if \ check for tab
             #tab              #tab
Line 467 
Line 657 
   
 DEFER DOERROR  DEFER DOERROR
   
 : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )  has? backtrace [IF]
   Defer dobacktrace ( -- )
   ' noop IS dobacktrace
   [THEN]
   
   : .error-string ( throw-code -- )
     dup -2 =
     IF    "error @ ?dup IF count type  THEN drop
     ELSE  .error
     THEN ;
   
   : .error-frame ( throwcode addr1 u1 n1 n2 addr2 u2 -- throwcode )
   \ addr2 u2:     filename of included file
   \ n2:           line number
   \ n1:           error position in input line
   \ addr1 u1:     input line
   
   cr error-stack @    cr error-stack @
   IF    IF
      ." in file included from "       ." in file included from "
      type ." :" dec.  drop 2drop       type ." :" dec.r  drop 2drop
   ELSE    ELSE
      type ." :" dec.       type ." :" dec.r ." : " 3 pick .error-string cr
      cr dup 2over type cr drop       dup 2over type cr drop
      nip -trailing 1- ( line-start index2 )       nip -trailing 1- ( line-start index2 )
      0 >r  BEGIN       0 >r  BEGIN
                   2dup + c@ bl >  WHILE                    2dup + c@ bl >  WHILE
Line 484 
Line 690 
      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0       r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                   [char] ^ emit                    [char] ^ emit
      loop       loop
   THEN    THEN ;
 ;  
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
   [ has? os [IF] ]    [ has? os [IF] ]
Line 502 
Line 707 
     cell +LOOP      cell +LOOP
     .error-frame      .error-frame
   LOOP    LOOP
   dup -2 =  
   IF  
      "error @ ?dup  
      IF  
         cr count type  
      THEN  
      drop       drop
   ELSE  [ has? backtrace [IF] ]
      .error    dobacktrace
   THEN  [ [THEN] ]
   normal-dp dpp ! ;    normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
 : quit ( ?? -- ?? ) \ core  : quit ( ?? -- ?? ) \ core
       \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 >tib @ >r
     BEGIN      BEGIN
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
Line 524 
Line 726 
         [ [THEN] ]          [ [THEN] ]
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
           <# \ reset hold area, or we may get another error
         DoError r@ >tib ! r@ tibstack !          DoError r@ >tib ! r@ tibstack !
     REPEAT      REPEAT
     drop r> >tib ! ;      drop r> >tib ! ;
Line 532 
Line 735 
   
 : (bootmessage)  : (bootmessage)
     ." GForth " version-string type      ." GForth " version-string type
     ." , Copyright (C) 1994-1998 Free Software Foundation, Inc." cr      ." , Copyright (C) 1998 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] ]  [ has? os [IF] ]
      cr ." Type `bye' to exit"       cr ." Type `bye' to exit"
Line 548 
Line 751 
 \ command-line arguments  \ command-line arguments
 ' noop IS 'cold  ' noop IS 'cold
   
 include ../chains.fs  
   
 Variable init8  Variable init8
   
Line 561 
Line 763 
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]
     process-args      process-args
       loadline off
 [ [THEN] ]  [ [THEN] ]
     bootmessage      bootmessage
     loadline off quit ;      quit ;
   
 : clear-tibstack ( -- )  : clear-tibstack ( -- )
 [ has? glocals [IF] ]  [ has? glocals [IF] ]
Line 572 
Line 775 
     [ has? os [IF] ]      [ has? os [IF] ]
     r0 @ forthstart 6 cells + @ -      r0 @ forthstart 6 cells + @ -
     [ [ELSE] ]      [ [ELSE] ]
     sp@ $40 +      sp@ $10 cells +
     [ [THEN] ]      [ [THEN] ]
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off ;      dup >tib ! tibstack ! #tib off >in off ;
Line 594 
Line 797 
 [ [THEN] ]  [ [THEN] ]
     ['] cold catch DoError cr      ['] cold catch DoError cr
 [ has? os [IF] ]  [ has? os [IF] ]
     bye      1 (bye) \ !! determin exit code from throw code?
 [ [THEN] ]  [ [THEN] ]
 ;  ;
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help