[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.110 and 1.142

version 1.110, Wed Dec 8 18:39:01 2004 UTC version 1.142, Sun Mar 5 14:10:52 2006 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995-2000 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
   [ has? new-input [IF] ]
       2dup input-lexeme!
   [ [THEN] ]
   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 87 
 \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 ( 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] ]
       2dup input-lexeme!
   [ [THEN] ] ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
Line 89 
Line 100 
   
 : (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)
   [ has? new-input [IF] ]
       2dup input-lexeme!
   [ [THEN] ]
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
 [THEN]  [THEN]
Line 111 
Line 125 
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     2dup s" 0x" string-prefix? >r      2dup s" 0x" string-prefix? >r
     2dup s" 0X" string-prefix? r> or      2dup s" 0X" string-prefix? r> or
     base @ #34 < and if      base @ &34 < and if
         hex 2 /string          hex 2 /string
     endif      endif
     over c@ [char] # - dup 4 u<      over c@ [char] # - dup 4 u<
Line 121 
Line 135 
         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
Line 133 
Line 147 
     dup 0= if      dup 0= if
         false exit          false exit
     endif      endif
     over c@ >r      x@+/string 0 s" '" 2rot string-prefix? ;
     1 /string s" '" 2swap string-prefix?  
     r> 0 rot ;  
   
 : s>unumber? ( addr u -- ud flag )  : s>unumber? ( addr u -- ud flag ) \ gforth
       \G converts string addr u into ud, flag indicates success
       dpl on
     over c@ '' = if      over c@ '' = if
         1 /string s'>unumber? exit          1 /string s'>unumber? exit
     endif      endif
     base @ >r  dpl on  getbase      base @ >r  getbase
     0. 2swap      0. 2swap
     BEGIN ( d addr len )      BEGIN ( d addr len )
         dup >r >number dup          dup >r >number dup
Line 159 
Line 173 
     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 227 
Line 241 
     \G comments into documentation.      \G comments into documentation.
     POSTPONE \ ; immediate      POSTPONE \ ; immediate
   
   has? ec [IF]
       AVariable forth-wordlist
       AVariable current  forth-wordlist current !
       ' current alias context
       | ' (f83find) alias (search-wordlist) ( addr len wid -- nt / false )
       : 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.
           context @ (search-wordlist) ;
   [ELSE]
 \ \ object oriented search list                         17mar93py  \ \ object oriented search list                         17mar93py
   
 \ word list structure:  \ word list structure:
Line 277 
Line 301 
 ' lookup is context  ' lookup is context
 forth-wordlist current !  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  \ \ header, finding, ticks                              17dec92py
   
 \ The constants are defined as 32 bits, but then erased  \ The constants are defined as 32 bits, but then erased
Line 329 
Line 374 
   
 : (x>int) ( cfa w -- xt )  : (x>int) ( cfa w -- xt )
     \ get interpretation semantics of name      \ get interpretation semantics of name
     restrict-mask and      restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
     if      if
         drop ['] compile-only-error          drop ['] compile-only-error
     else      else
Line 378 
Line 423 
 : name?int ( nt -- xt ) \ gforth  : name?int ( nt -- xt ) \ gforth
     \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}      \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
     \G has no interpretation semantics.      \G has no interpretation semantics.
     (name>x) restrict-mask and      (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
     if      if
         ticking-compile-only-error \ does not return          ticking-compile-only-error \ does not return
     then      then
Line 393 
Line 438 
         interpret/compile-comp @          interpret/compile-comp @
     then      then
 [ [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>intn) ( nfa -- xt +-1 )
     (name>x) tuck (x>int) ( w xt )      (name>x) tuck (x>int) ( w xt )
     swap immediate-mask and flag-sign ;      swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ;
   
 const Create ???  0 , 3 , char ? c, char ? c, char ? c,  const Create ???  0 , 3 , char ? c, char ? c, char ? c,
 \ ??? is used by dovar:, must be created/:dovar  \ ??? is used by dovar:, must be created/:dovar
Line 492 
Line 537 
         drop 0          drop 0
     endif ;      endif ;
   
 ' ! alias code-address! ( c_addr xt -- ) \ gforth  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}.  \G Create a code field with code address @i{c-addr} at @i{xt}.
   
 : does-code! ( a_addr xt -- ) \ gforth  : does-code! ( a_addr xt -- ) \ gforth
 \G Create a code field at @i{xt} for a child of a @code{DOES>}-word;  \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>}.  \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!
       [ [ELSE] ]
       dodoes: over ! cell+ !
       [ [THEN] ] ;
   
 ' drop alias does-handler! ( a_addr -- ) \ gforth  ' drop alias does-handler! ( a_addr -- ) \ gforth
 \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
Line 509 
Line 559 
   
 [THEN]  [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  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     find-name dup      find-name dup
     if ( nt )      if ( nt )
Line 565 
Line 595 
 \ ticks in interpreter  \ ticks in interpreter
   
 : (') ( "name" -- nt ) \ gforth  : (') ( "name" -- nt ) \ gforth
     name name-too-short?      parse-name name-too-short?
     find-name dup 0=      find-name dup 0=
     IF      IF
         drop -&13 throw          drop -&13 throw
Line 588 
Line 618 
   
 \ interpret                                            10mar92py  \ 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  \G Get the next word from the input buffer
 ' (name) IS parse-word  ' (name) IS parse-name
   
   ' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete
   \G old name for @code{parse-name}
   
 ' parse-word alias name ( -- c-addr u ) \ gforth-obsolete  ' parse-name alias name ( -- 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 -- )  Defer compiler-notfound1 ( c-addr count -- ... xt )
 Defer interpreter-notfound ( c-addr count -- )  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  Defer before-word ( -- ) \ gforth
 \ called before the text interpreter parses the next word  \ called before the text interpreter parses the next word
 ' noop IS before-word  ' noop IS before-word
   [THEN]
   
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
 [ has? backtrace [IF] ]  [ has? backtrace [IF] ]
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  [ [THEN] ]
     BEGIN      BEGIN
         ?stack before-word name dup          ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
     WHILE      WHILE
         parser          parser1 execute
     REPEAT      REPEAT
     2drop ;      2drop ;
   
Line 633 
Line 679 
 \ 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 661 
Line 707 
 [THEN]  [THEN]
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
   : input-start-line ( -- )  >in off ;
 : 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 676 
Line 723 
     \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  EXIT  THEN
         [ [THEN] ]          [ [THEN] ]
     tib /line      tib /line
     [ has? file [IF] ]      [ has? file [IF] ]
Line 690 
Line 737 
         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 753 
Line 801 
     s" *evaluated string*" loadfilename>r      s" *evaluated string*" loadfilename>r
 [ [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] ]
Line 782 
Line 830 
             \ if stderr does not work either, already DoError causes a hang              \ if stderr does not work either, already DoError causes a hang
             2 (bye)              2 (bye)
         endif          endif
         query interpret prompt          refill  WHILE
     AGAIN ;              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 ( c-addr u )
 \ >in  \ last parsed lexeme ( c-addr u )
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
 : error> ( -- addr u >in line# [addr u] )  : error> ( --  c-addr1 u1 c-addr2 u2 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 ( c-addr1 u1 c-addr2 u2 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 ;
   
   : 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 input-lexeme 2@ 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 828 
Line 887 
     \ !! not used...      \ !! not used...
     [char] $ emit base @ swap hex u. base ! ;      [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  
     0 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  : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
 \G Adjust the string specified by @i{c-addr, u1} to remove all  \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.  \G trailing spaces. @i{u2} is the length of the modified string.
Line 862 
Line 909 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
 : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )  : umin ( u1 u2 -- u )
 \ addr2 u2:     filename of included file - optional      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
       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  \ n2:           line number
 \ n1:           error position in input line      \ addr2 u2: parsed lexeme (should be marked as causing the error)
 \ 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 899 
Line 965 
   [ 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 914 
Line 978 
   
 ' (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 943 
Line 1012 
   
 : (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] ] ;
   
 defer bootmessage  defer bootmessage
   has? file [IF]
 defer process-args  defer process-args
   [THEN]
   
 ' (bootmessage) IS bootmessage  ' (bootmessage) IS bootmessage
   
   has? ec 0= [IF]
 Defer 'cold ( -- ) \ gforth  tick-cold  Defer 'cold ( -- ) \ gforth  tick-cold
 \ hook (deferred word) for things to do right before interpreting the  \ hook (deferred word) for things to do right before interpreting the
 \ command-line arguments  \ command-line arguments
 ' noop IS 'cold  ' noop IS 'cold
   [THEN]
   
 AVariable init8 NIL init8 !  AVariable init8 NIL init8 !
   
Line 969 
Line 1041 
 [ has? file [IF] ]  [ has? file [IF] ]
     os-cold      os-cold
 [ [THEN] ]  [ [THEN] ]
   [ has? ec 0= [IF] ]
       set-encoding-fixed-width
     'cold      'cold
   [ [THEN] ]
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]
     s" *the terminal*" loadfilename 2!  
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
Line 987 
Line 1061 
     [ has? os [IF] ]      [ has? os [IF] ]
     r0 @ forthstart 6 cells + @ -      r0 @ forthstart 6 cells + @ -
     [ [ELSE] ]      [ [ELSE] ]
     sp@ $10 cells +      sp@ cell+
     [ [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 -- )
   [ has? no-userspace 0= [IF] ]
     main-task up!      main-task up!
   [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     os-boot      os-boot
 [ [THEN] ]  [ [THEN] ]
   [ has? rom [IF] ]
       ram-mirror ram-start ram-size cmove
   [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
 [ has? peephole [IF] ]  [ has? peephole [IF] ]
     \ only needed for greedy static superinstruction selection      \ only needed for greedy static superinstruction selection
Line 1007 
Line 1087 
     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 !

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help