[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.12 and 1.53

version 1.12, Fri Dec 11 22:54:31 1998 UTC version 1.53, Wed Aug 16 09:26:53 2000 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.  \ Copyright (C) 1995-2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 24 
Line 24 
   
 \ \ 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 43 
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 52 
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 63 
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 82 
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 92 
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 141 
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  : \ ( 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
     [ has? file [IF] ]      [ has? file [IF] ]
     blk @      blk @
     IF      IF
Line 154 
Line 203 
     [ [THEN] ]      [ [THEN] ]
     source >in ! drop ; immediate      source >in ! drop ; immediate
   
 : \G ( -- ) \ gforth backslash  : \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      POSTPONE \ ; immediate
   
 \ \ object oriented search list                         17mar93py  \ \ object oriented search list                         17mar93py
Line 171 
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 192 
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 230 
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 245 
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 259 
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 277 
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-noprim ( cfa -- nt ) \ gforth  to-head-noprim
       $25 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-noprim ( cfa -- nt ) \ gforth  to-head-noprim
       $25 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? ) ;
   
 ' >head ALIAS >name  [THEN]
   
 : 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} 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      (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 314 
Line 422 
         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 for the
       \G definition named by the counted string at @i{c-addr}.  If the
       \G definition is not found, return 0. If the definition is found
       \G return 1 (if the definition has non-default compilation
       \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      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 346 
Line 478 
 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 362 
Line 497 
 \ interpreter                                   30apr92py  \ interpreter                                   30apr92py
   
 \ not the most efficient implementations of interpreter and compiler  \ not the most efficient implementations of interpreter and compiler
 | : interpreter ( c-addr u -- )  : interpreter ( c-addr u -- )
     2dup find-name dup      2dup find-name dup
     if      if
         nip nip name>int execute          nip nip name>int execute
Line 385 
Line 520 
 [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] ]      [ has? file [IF] ]
         blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN          blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
         [ [THEN] ]          [ [THEN] ]
Line 403 
Line 551 
     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] ]      [ has? file [IF] ]
         blk off loadfile off          blk off loadfile off
         [ [THEN] ]          [ [THEN] ]
Line 438 
Line 588 
   r> >in !  r> #tib !  r> >tib !  r> tibstack !  >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    >in off
   [ has? file [IF] ]    [ has? file [IF] ]
Line 461 
Line 616 
         [ [THEN] ]          [ [THEN] ]
     refill drop ;      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 477 
Line 640 
 \ 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 497 
Line 667 
   
 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 514 
Line 700 
      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 532 
Line 717 
     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 554 
Line 736 
         [ [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 562 
Line 745 
   
 : (bootmessage)  : (bootmessage)
     ." GForth " version-string type      ." GForth " version-string type
     ." , Copyright (C) 1998 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2000 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 578 
Line 761 
 \ command-line arguments  \ command-line arguments
 ' noop IS 'cold  ' noop IS 'cold
   
 include ../chains.fs  
   
 Variable init8  Variable init8
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
   [ has? backtrace [IF] ]
       rp@ backtrace-rp0 !
   [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     pathstring 2@ fpath only-path      pathstring 2@ fpath only-path
     init-included-files      init-included-files
Line 603 
Line 788 
     [ 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 623 
Line 808 
 [ has? floating [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
       handler off
     ['] 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.12  
changed lines
  Added in v.1.53
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help