[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.89 and 1.131

version 1.89, Sun Jan 19 23:35:35 2003 UTC version 1.131, Sun Feb 5 21:22:05 2006 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995-2003 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004,2005 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 55 
Line 55 
   
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : sword  ( char -- addr len ) \ gforth s-word  : sword  ( char -- addr len ) \ gforth-obsolete 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}.      \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).
   source 2dup >r >r >in @ over min /string    source 2dup >r >r >in @ over min /string
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN      rot dup bl = IF
           drop (parse-white)
       ELSE
           (word)
       THEN
       over start-lexeme
   2dup + r> - 1+ r> min >in ! ;    2dup + r> - 1+ r> min >in ! ;
   
 : word   ( char "<chars>ccc<char>-- c-addr ) \ core  : word   ( char "<chars>ccc<char>-- c-addr ) \ core
Line 80 
Line 85 
 \G Parse @i{ccc}, delimited by @i{char}, in the parse  \G Parse @i{ccc}, delimited by @i{char}, in the parse
 \G area. @i{c-addr u} specifies the parsed string within the  \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.  \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 ( addr u )
       over start-lexeme
       over  swap r>  scan >r
     over - dup r> IF 1+ THEN  >in +! ;      over - dup r> IF 1+ THEN  >in +! ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
Line 89 
Line 96 
   
 : (name) ( -- c-addr count ) \ gforth  : (name) ( -- c-addr count ) \ gforth
     source 2dup >r >r >in @ /string (parse-white)      source 2dup >r >r >in @ /string (parse-white)
       over start-lexeme
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
 [THEN]  [THEN]
Line 104 
Line 112 
 \ number? number                                       23feb93py  \ number? number                                       23feb93py
   
 hex  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  \ !! protect BASE saving wrapper against exceptions
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     over c@ [char] $ - dup 4 u<      2dup s" 0x" string-prefix? >r
       2dup s" 0X" string-prefix? r> or
       base @ &34 < and if
           hex 2 /string
       endif
       over c@ [char] # - dup 4 u<
     IF      IF
         cells bases + @ base ! 1 /string          cells bases + @ base ! 1 /string
     ELSE      ELSE
         drop          drop
     THEN ;      THEN ;
   
 : sign? ( addr u -- addr u flag )  : sign? ( addr u -- addr1 u1 flag )
     over c@ [char] - =  dup >r      over c@ [char] - =  dup >r
     IF      IF
         1 /string          1 /string
     THEN      THEN
     r> ;      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
           1 /string s'>unumber? exit
       endif
       base @ >r  getbase
     0. 2swap      0. 2swap
     BEGIN ( d addr len )      BEGIN ( d addr len )
         dup >r >number dup          dup >r >number dup
Line 142 
Line 167 
     r> base ! ;      r> base ! ;
   
 \ ouch, this is complicated; there must be a simpler way - anton  \ 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      sign? >r
     s>unumber?      s>unumber?
     0= IF      0= IF
Line 229 
Line 254 
   cell% field wordlist-extend \ wordlist extensions (eg bucket offset)    cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
 end-struct wordlist-struct  end-struct wordlist-struct
   
   has? f83headerstring [IF]
   : f83find      ( addr len wordlist -- nt / false )
       wordlist-id @ (f83find) ;
   [ELSE]
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
     wordlist-id @ (listlfind) ;      wordlist-id @ (listlfind) ;
   [THEN]
   
 : initvoc               ( wid -- )  : initvoc               ( wid -- )
   dup wordlist-map @ hash-method perform ;    dup wordlist-map @ hash-method perform ;
Line 260 
Line 290 
 \ The constants are defined as 32 bits, but then erased  \ The constants are defined as 32 bits, but then erased
 \ and overwritten by the right ones  \ and overwritten by the right ones
   
   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  $80000000 constant alias-mask
 1 bits/char 1 - lshift  1 bits/char 1 - lshift
 -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times  -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
Line 276 
Line 313 
 1 bits/char 3 - lshift 1 -  1 bits/char 3 - lshift 1 -
 -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times  -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                           [ELSE] -1 1 cells 1- times c, [THEN]                            [ELSE] -1 1 cells 1- times c, [THEN]
   [THEN]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 286 
Line 324 
 : ticking-compile-only-error ( ... -- )  : ticking-compile-only-error ( ... -- )
     -&2048 throw ;      -&2048 throw ;
   
   : compile-only-error ( ... -- )
       -&14 throw ;
   
 : (cfa>int) ( cfa -- xt )  : (cfa>int) ( cfa -- xt )
 [ has? compiler [IF] ]  [ has? compiler [IF] ]
     dup interpret/compile?      dup interpret/compile?
Line 298 
Line 339 
     \ get interpretation semantics of name      \ get interpretation semantics of name
     restrict-mask and      restrict-mask and
     if      if
         drop ['] ticking-compile-only-error          drop ['] compile-only-error
     else      else
         (cfa>int)          (cfa>int)
     then ;      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 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+ c@ dup alias-mask and 0=
       IF
           swap @ swap
       THEN ;
   [ELSE]
 : name>string ( nt -- addr count ) \ gforth     head-to-string  : name>string ( nt -- addr count ) \ gforth     head-to-string
     \g @i{addr count} is the name of the word represented by @i{nt}.      \g @i{addr count} is the name of the word represented by @i{nt}.
     cell+ dup cell+ swap @ lcount-mask and ;      cell+ dup cell+ swap @ lcount-mask and ;
Line 317 
Line 374 
     IF      IF
         swap @ swap          swap @ swap
     THEN ;      THEN ;
   [THEN]
   
 : name>int ( nt -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth
     \G @i{xt} represents the interpretation semantics of the word      \G @i{xt} represents the interpretation semantics of the word
Line 384 
Line 442 
     drop true ;      drop true ;
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     \ also heuristic; finds only names with up to 32 chars      \ also heuristic
     $25 cell do ( cfa )      dup forthstart - max-name-length @ float+ cell+ min cell max cell ?do ( cfa )
         dup i - dup @ [ alias-mask lcount-mask or ] literal          dup i - dup @ [ alias-mask lcount-mask or ] literal
         [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or          [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
         -1 cells allot bigendian [IF]   c, -1 1 cells 1- times          -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
Line 538 
Line 596 
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser ( c-addr u -- )  Defer parser1 ( c-addr u -- ... xt)
 Defer parse-word ( -- c-addr count ) \ 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 ;
   
   Defer parse-name ( "name" -- c-addr u ) \ gforth
 \G Get the next word from the input buffer  \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}
   
   Defer compiler-notfound1 ( c-addr count -- ... xt )
   Defer interpreter-notfound1 ( c-addr count -- ... xt )
   
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 throw ;      2drop -&13 throw ;
 ' no.extensions IS compiler-notfound  ' no.extensions IS compiler-notfound1
 ' no.extensions IS interpreter-notfound  ' no.extensions IS interpreter-notfound1
   
   Defer before-word ( -- ) \ gforth
   \ called before the text interpreter parses the next word
   ' noop IS before-word
   
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
 [ has? backtrace [IF] ]  [ has? backtrace [IF] ]
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  [ [THEN] ]
     BEGIN      BEGIN
         ?stack name dup          ?stack before-word name dup
     WHILE      WHILE
         parser          parser1 execute
     REPEAT      REPEAT
     2drop ;      2drop ;
   
Line 579 
Line 650 
 \ 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 -- )  : interpreter1 ( c-addr u -- ... xt )
     2dup find-name dup      2dup find-name dup
     if      if
         nip nip name>int execute          nip nip name>int
     else      else
         drop          drop
         2dup 2>r snumber?          2dup 2>r snumber?
         IF          IF
             2rdrop              2rdrop ['] noop
         ELSE          ELSE
             2r> interpreter-notfound              2r> interpreter-notfound1
         THEN          THEN
     then ;      then ;
   
 ' interpreter  IS  parser  ' interpreter1  IS  parser1
   
 \ \ Query Evaluate                                      07apr93py  \ \ Query Evaluate                                      07apr93py
   
Line 607 
Line 678 
 [THEN]  [THEN]
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
   : input-start-line ( -- ) >in off ;
   : start-lexeme ( addr -- ) drop ;
 : 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 Attempt to fill the input buffer from the input source.  When
     \G the input source is the user input device, attempt to receive      \G the input source is the user input device, attempt to receive
Line 622 
Line 695 
     \G and return true; otherwise, return false.  A successful result      \G and return true; otherwise, return false.  A successful result
     \G includes receipt of a line containing 0 characters.      \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  input-start-line  EXIT  THEN
         [ [THEN] ]          [ [THEN] ]
     tib /line      tib /line
     [ has? file [IF] ]      [ has? file [IF] ]
Line 636 
Line 709 
         THEN          THEN
         1 loadline +!          1 loadline +!
         [ [THEN] ]          [ [THEN] ]
     swap #tib ! 0 >in ! ;      swap #tib ! input-start-line ;
   
 : query   ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \G Make the user input device the input source. Receive input into      \G Make the user input device the input source. Receive input into
Line 670 
Line 743 
   
 : extend-mem    ( addr1 u1 u -- addr addr2 u2 )  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
     \ extend memory block allocated from the heap by u aus      \ 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      over >r + dup >r resize throw
     r> over r> + -rot ;      r> over r> + -rot ;
 [THEN]  [THEN]
Line 696 
Line 769 
     \G and input buffer. Interpret. When the parse area is empty,      \G and input buffer. Interpret. When the parse area is empty,
     \G restore the input source specification.      \G restore the input source specification.
 [ has? file [IF] ]  [ has? file [IF] ]
     loadfilename# @ >r      s" *evaluated string*" loadfilename>r
     1 loadfilename# ! \ "*evaluated string*"  
 [ [THEN] ]  [ [THEN] ]
     push-file #tib ! >tib !      push-file #tib ! >tib !
     >in off      input-start-line
     [ has? file [IF] ]      [ has? file [IF] ]
         blk off loadfile off -1 loadline !          blk off loadfile off -1 loadline !
         [ [THEN] ]          [ [THEN] ]
     ['] interpret catch      ['] interpret catch
     pop-file      pop-file
 [ has? file [IF] ]  [ has? file [IF] ]
     r> loadfilename# !      r>loadfilename
 [ [THEN] ]  [ [THEN] ]
     throw ;      throw ;
 [THEN]  [THEN]
Line 722 
Line 794 
   
 : (quit) ( -- )  : (quit) ( -- )
     \ exits only through THROW etc.      \ 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      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
               2 (bye)
           endif
           refill WHILE
               interpret prompt
       REPEAT
       bye ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ \ DOERROR (DOERROR)                                   13jun93jaw  \ \ DOERROR (DOERROR)                                   13jun93jaw
   
   has? ec 0= [IF]
 8 Constant max-errors  8 Constant max-errors
   5 has? file 2 and + Constant /error
 Variable error-stack  0 error-stack !  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:  \ format of one cell:
 \ source ( addr u )  \ source ( addr u )
   \ input-start-parse
 \ >in  \ >in
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
 : error> ( -- addr u >in line# [addr u] )  : error> ( -- addr u start-parse >in line# [addr u] )
     -1 error-stack +!      -1 error-stack +!
     error-stack dup @      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 @          I @
         cell +LOOP ;          cell +LOOP ;
 : >error ( addr u >in line# [addr u] -- )  
   : >error ( addr u start-parse >in line# [addr u] -- )
     error-stack dup @ dup 1+      error-stack dup @ dup 1+
     max-errors 1- min error-stack !      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 !          I !
         -1 cells +LOOP ;          -1 cells +LOOP ;
   
   : error->in ( -- u )
       \ >in corrected to eliminate one trailing white space character
       >in @ dup if \ non-zero?
           source 2 pick u< if \ beyond end of source?
               2drop exit
           then
           over 1- chars + c@ bl u<= if
               1-
           then
       then ;
   
   : input-error-data ( -- addr u start-parse >in line# [addr u] )
       \ error data for the current input, to be used by >error or .error-frame
       source input-start-parse @ error->in sourceline#
       [ has? file [IF] ] sourcefilename [ [THEN] ] ;
   
 : dec. ( n -- ) \ gforth  : dec. ( n -- ) \ gforth
     \G Display @i{n} as a signed decimal number, followed by a space.      \G Display @i{n} as a signed decimal number, followed by a space.
     \ !! not used...      \ !! not used...
     base @ decimal swap . base ! ;      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  : hex. ( u -- ) \ gforth
     \G Display @i{u} as an unsigned hex number, prefixed with a "$" and      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
Line 773 
Line 870 
     \ !! not used...      \ !! not used...
     [char] $ emit base @ swap hex u. base ! ;      [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          1- 2dup + c@ bl <>
         then      UNTIL  1+  THEN ;
         emit  
     loop ;  
   
 DEFER DOERROR  DEFER DOERROR
   
Line 797 
Line 892 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
 : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )  : umin ( u1 u2 -- u )
       2dup u>
       if
           swap
       then
       drop ;
   
   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
       2 pick over type /string ;
   
   : .error-line ( addr2 u2 u0 u1 -- )
       \ print error between char n0 and char n1 in line addr1 u1
       \ should work with UTF-8 (whitespace check looks ok)
       2 pick umin    \ protect against wrong n1
       tuck umin swap \ protect against wrong n0
       over - >r ( addr2 u2 u0 R: u1-u0 )
       part-type mark-start r> part-type mark-end type ;
   
   : .error-frame ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] -- throwcode )
 \ addr2 u2:     filename of included file - optional  \ addr2 u2:     filename of included file - optional
 \ n2:           line number  \ n2:           line number
 \ n1:           error position in input line      \ n1:       end of error position in input line
       \ n0:       start of error position in input line
 \ addr1 u1:     input line  \ 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 ." :"      type ." :"
 [ [THEN] ]                0 dec.r  2drop 2drop
     dec.r  drop 2drop  
   ELSE    ELSE
                 2drop 2drop 2drop drop
             THEN
             [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
       ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
 [ has? file [IF] ]  [ 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 )  
           0 >r  BEGIN  
               2dup + 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        ELSE
           2drop drop              2drop 2drop
       THEN        THEN
   THEN ;    THEN ;
   
Line 834 
Line 950 
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]    [ [THEN] ]
   source >in @ sourceline# [ has? file [IF] ]    input-error-data .error-frame
       sourcefilename  
   [ [THEN] ] .error-frame  
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
     error>      error>
     .error-frame      .error-frame
Line 849 
Line 963 
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
   [ELSE]
       : dec.  base @ >r decimal . r> base ! ;
       : DoError ( throw-code -- ) ." Error# " dec. cr ;
   [THEN]
   
 : quit ( ?? -- ?? ) \ core  : quit ( ?? -- ?? ) \ core
     \G Empty the return stack, make the user input device      \G Empty the return stack, make the user input device
     \G the input source, enter interpret state and start      \G the input source, enter interpret state and start
Line 859 
Line 978 
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         [compile] [          [compile] [
         [ [THEN] ]          [ [THEN] ]
           \ stack depths may be arbitrary here
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
         <# \ reset hold area, or we may get another error          <# \ reset hold area, or we may get another error
         DoError          DoError
               \ stack depths may be arbitrary still (or again), so clear them
               clearstacks
         [ has? new-input [IF] ] clear-tibstack          [ has? new-input [IF] ] clear-tibstack
         [ [ELSE] ] r@ >tib ! r@ tibstack !          [ [ELSE] ] r@ >tib ! r@ tibstack !
         [ [THEN] ]          [ [THEN] ]
Line 874 
Line 996 
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : (bootmessage)
     ." GForth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2003 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2006 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"
 [ [THEN] ] ;  [ [THEN] ] ;
Line 901 
Line 1023 
 [ has? file [IF] ]  [ has? file [IF] ]
     os-cold      os-cold
 [ [THEN] ]  [ [THEN] ]
   [ has? ec 0= [IF] ]
       set-encoding-fixed-width
   [ [THEN] ]
     'cold      'cold
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]
     loadfilename# off  
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
Line 922 
Line 1046 
     sp@ $10 cells +      sp@ $10 cells +
     [ [THEN] ]      [ [THEN] ]
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off ;      dup >tib ! tibstack ! #tib off input-start-line ;
 [THEN]  [THEN]
   
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
Line 939 
Line 1063 
     current-input off      current-input off
 [ [THEN] ]  [ [THEN] ]
     clear-tibstack      clear-tibstack
       0 0 includefilename 2!
     rp@ rp0 !      rp@ rp0 !
 [ has? floating [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
     handler off      handler off
     ['] cold catch DoError cr      ['] cold catch dup -&2049 <> if \ broken pipe?
           DoError cr
       endif
 [ has? os [IF] ]  [ has? os [IF] ]
     1 (bye) \ !! determin exit code from throw code?      1 (bye) \ !! determin exit code from throw code?
 [ [THEN] ]  [ [THEN] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help