[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.68 and 1.112

version 1.68, Sun Jan 28 18:49:11 2001 UTC version 1.112, Tue Dec 28 21:09:47 2004 UTC
Line 104 
Line 104 
 \ 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
Line 123 
Line 128 
     THEN      THEN
     r> ;      r> ;
   
   : s'>unumber? ( addr u -- ud flag )
       \ convert string "C" or "C'" to character code
       dup 0= if
           false exit
       endif
       over c@ >r
       1 /string s" '" 2swap string-prefix?
       r> 0 rot ;
   
 : s>unumber? ( addr u -- ud flag )  : s>unumber? ( addr u -- ud flag )
       over c@ '' = if
           1 /string s'>unumber? exit
       endif
     base @ >r  dpl on  getbase      base @ >r  dpl on  getbase
     0. 2swap      0. 2swap
     BEGIN ( d addr len )      BEGIN ( d addr len )
Line 229 
Line 246 
   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 257 
Line 279 
   
 \ \ header, finding, ticks                              17dec92py  \ \ header, finding, ticks                              17dec92py
   
   \ The constants are defined as 32 bits, but then erased
   \ and overwritten by the right ones
   
 \ !! these should be done using the target's operations and cell size  has? f83headerstring [IF]
 \ 0 invert 1 rshift invert ( u ) \ top bit set      \ to save space, Gforth EC limits words to 31 characters
 \ constant alias-mask \ set when the word is not an alias!      $80 constant alias-mask
 \ alias-mask 1 rshift constant immediate-mask      $40 constant immediate-mask
 \ alias-mask 2 rshift constant restrict-mask      $20 constant restrict-mask
 \ 0 invert 3 rshift   constant lcount-mask      $1f constant lcount-mask
   [ELSE]
 \ as an intermediate step, I define them correctly for 32-bit machines:  
   
 $80000000 constant alias-mask  $80000000 constant alias-mask
   1 bits/char 1 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
 $40000000 constant immediate-mask  $40000000 constant immediate-mask
   1 bits/char 2 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
 $20000000 constant restrict-mask  $20000000 constant restrict-mask
   1 bits/char 3 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
 $1fffffff constant lcount-mask  $1fffffff constant lcount-mask
   1 bits/char 3 - lshift 1 -
   -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                             [ELSE] -1 1 cells 1- times c, [THEN]
   [THEN]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 278 
Line 313 
     \ true becomes 1, false -1      \ true becomes 1, false -1
     0= 2* 1+ ;      0= 2* 1+ ;
   
   : ticking-compile-only-error ( ... -- )
       -&2048 throw ;
   
 : compile-only-error ( ... -- )  : compile-only-error ( ... -- )
     -&14 throw ;      -&14 throw ;
   
Line 298 
Line 336 
         (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 312 
Line 366 
     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
     \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is      \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
     \G @code{compile-only}), @i{xt} is the execution token for      \G @code{compile-only}), @i{xt} is the execution token for
     \G @code{compile-only-error}, which performs @code{-14 throw}.      \G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
     (name>x) (x>int) ;      (name>x) (x>int) ;
   
 : name?int ( nt -- xt ) \ gforth  : name?int ( nt -- xt ) \ gforth
     \G Like @code{name>int}, but perform @code{-14 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
     if      if
         compile-only-error \ does not return          ticking-compile-only-error \ does not return
     then      then
     (cfa>int) ;      (cfa>int) ;
   
Line 345 
Line 400 
     (name>x) tuck (x>int) ( w xt )      (name>x) tuck (x>int) ( w xt )
     swap immediate-mask and flag-sign ;      swap immediate-mask and flag-sign ;
   
 const Create ???  0 , 3 c, 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
   
 [IFDEF] forthstart  [IFDEF] forthstart
Line 354 
Line 409 
   
 : head? ( addr -- f )  : head? ( addr -- f )
     \G heuristic check whether addr is a name token; may deliver false      \G heuristic check whether addr is a name token; may deliver false
     \G positives; addr must be a valid address  \G positives; addr must be a valid address; returns 1 for
   \G particularly unsafe positives
     \ we follow the link fields and check for plausibility; two      \ we follow the link fields and check for plausibility; two
     \ iterations should catch most false addresses: on the first      \ iterations should catch most false addresses: on the first
     \ iteration, we may get an xt, on the second a code address (or      \ iteration, we may get an xt, on the second a code address (or
     \ some code), which is typically not in the dictionary.      \ some code), which is typically not in the dictionary.
     2 0 do      \ we added a third iteration for working with code and ;code words.
       3 0 do
         dup dup aligned <> if \ protect @ against unaligned accesses          dup dup aligned <> if \ protect @ against unaligned accesses
             drop false unloop exit              drop false unloop exit
         then          then
Line 370 
Line 427 
                 drop false unloop exit                  drop false unloop exit
             then ( addr1 )              then ( addr1 )
         else \ 0 in the link field, no further checks          else \ 0 in the link field, no further checks
             2drop true unloop exit              2drop 1 unloop exit \ this is very unsure, so return 1
         then          then
     loop      loop
     \ in dubio pro:      \ in dubio pro:
     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 and ( cfa len|alias )          dup i - dup @ [ alias-mask lcount-mask or ] literal
           [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
           -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
           [ELSE] -1 1 cells 1- times c, [THEN] ]
           and ( cfa len|alias )
         swap + cell + cfaligned over alias-mask + =          swap + cell + cfaligned over alias-mask + =
         if ( cfa )          if ( cfa )
             dup i - cell - dup head?              dup i - cell - dup head?
Line 395 
Line 456 
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     $25 cell do ( cfa )      $25 cell do ( cfa )
         dup i - dup @ [ alias-mask lcount-mask or ] literal and ( cfa len|alias )          dup i - dup @ [ alias-mask lcount-mask or ] literal
           [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
           -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
           [ELSE] -1 1 cells 1- times c, [THEN] ]
           and ( cfa len|alias )
         swap + cell + cfaligned over alias-mask + =          swap + cell + cfaligned over alias-mask + =
         if ( cfa ) i - cell - unloop exit          if ( cfa ) i - cell - unloop exit
         then          then
Line 404 
Line 469 
   
 [THEN]  [THEN]
   
 : body> 0 >body - ;  cell% 2* 0 0 field >body ( xt -- a_addr ) \ core
   \G Get the address of the body of the word represented by @i{xt} (the
   \G address of the word's data field).
   drop drop
   
   cell% -2 * 0 0 field body> ( xt -- a_addr )
       drop drop
   
   has? standardthreading has? compiler and [IF]
   
   ' @ alias >code-address ( xt -- c_addr ) \ gforth
   \G @i{c-addr} is the code address of the word @i{xt}.
   
   : >does-code ( xt -- a_addr ) \ gforth
   \G If @i{xt} is the execution token of a child of a @code{DOES>} word,
   \G @i{a-addr} is the start of the Forth code after the @code{DOES>};
   \G Otherwise @i{a-addr} is 0.
       dup @ dodoes: = if
           cell+ @
       else
           drop 0
       endif ;
   
   ' ! alias code-address! ( c_addr xt -- ) \ gforth
   \G Create a code field with code address @i{c-addr} at @i{xt}.
   
   : does-code! ( a_addr xt -- ) \ gforth
   \G Create a code field at @i{xt} for a child of a @code{DOES>}-word;
   \G @i{a-addr} is the start of the Forth code after @code{DOES>}.
       dodoes: over ! cell+ ! ;
   
   ' drop alias does-handler! ( a_addr -- ) \ gforth
   \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
   \G @i{a-addr} points just behind a @code{DOES>}.
   
   2 cells constant /does-handler ( -- n ) \ gforth
   \G The size of a @code{DOES>}-handler (includes possible padding).
   
   [THEN]
   
 : (search-wordlist)  ( addr count wid -- nt | false )  : (search-wordlist)  ( addr count wid -- nt | false )
     dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
Line 486 
Line 589 
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser ( c-addr u -- )  Defer parser ( c-addr u -- )
 Defer name ( -- c-addr count ) \ gforth  Defer parse-word ( "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 name  ' (name) IS parse-word
   
   ' parse-word alias name ( -- c-addr u ) \ gforth-obsolete
   \G old name for @code{parse-word}
   
 Defer compiler-notfound ( c-addr count -- )  Defer compiler-notfound ( c-addr count -- )
 Defer interpreter-notfound ( c-addr count -- )  Defer interpreter-notfound ( c-addr count -- )
   
Line 497 
Line 604 
 ' no.extensions IS compiler-notfound  ' no.extensions IS compiler-notfound
 ' no.extensions IS interpreter-notfound  ' no.extensions IS interpreter-notfound
   
   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          parser
     REPEAT      REPEAT
Line 613 
Line 724 
   
 : 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 639 
Line 750 
     \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      >in off
Line 650 
Line 760 
     ['] 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 665 
Line 775 
   
 : (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
           ['] 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
           query interpret prompt
     AGAIN ;      AGAIN ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
Line 678 
Line 790 
 \ \ DOERROR (DOERROR)                                   13jun93jaw  \ \ DOERROR (DOERROR)                                   13jun93jaw
   
 8 Constant max-errors  8 Constant max-errors
   4 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 )
 \ >in  \ >in
Line 689 
Line 802 
 : error> ( -- addr u >in line# [addr u] )  : error> ( -- addr u >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 >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 ;
   
Line 706 
Line 819 
     \ !! 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 716 
Line 830 
     \ !! not used...      \ !! not used...
     [char] $ emit base @ swap hex u. base ! ;      [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr n -- ) \ gforth
     \G 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 u+do
       0 max bounds ?do
         i c@ #tab = if \ check for tab          i c@ #tab = if \ check for tab
             #tab              #tab
         else          else
Line 727 
Line 842 
         emit          emit
     loop ;      loop ;
   
   : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
   \G Adjust the string specified by @i{c-addr, u1} to remove all
   \G trailing spaces. @i{u2} is the length of the modified string.
       BEGIN
           dup
       WHILE
           1- 2dup + c@ bl <>
       UNTIL  1+  THEN ;
   
 DEFER DOERROR  DEFER DOERROR
   
 has? backtrace [IF]  has? backtrace [IF]
Line 740 
Line 864 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
   : umin ( u1 u2 -- u )
       2dup u>
       if
           swap
       then
       drop ;
   
   Defer mark-start
   Defer mark-end
   
   :noname ." >>>" ; IS mark-start
   :noname ." <<<" ; IS mark-end
   
   : .error-line ( addr1 u1 n1 -- )
       \ print error ending at char n1 in line addr1 u1
       \ should work with UTF-8 (whitespace check looks ok)
       over umin \ protect against wrong n1
       swap >r ( addr1 n1 R: u1 )
       -trailing 1- \ last non-space
       0 >r  BEGIN \ search for the first non-space
           2dup + c@ bl >  WHILE
           r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
       ( addr1 n2 r: u1 namelen )
       2dup type mark-start
       r> -rot r> swap /string ( namelen addr2 u2 )
       >r swap 2dup type mark-end ( addr2 namelen r: u2 )
       r> swap /string type ;
   
 : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )  : .error-frame ( throwcode addr1 u1 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:           error position in input line
 \ addr1 u1:     input line  \ addr1 u1:     input line
   cr error-stack @    cr error-stack @
   IF    IF ( throwcode addr1 u1 n1 n2 [addr2 u2] )
 [ has? file [IF] ]  [ has? file [IF] ] \ !! unbalanced stack effect
     ." in file included from "      ." in file included from "
     type ." :"      type ." :"
 [ [THEN] ]  [ [THEN] ] ( throwcode addr1 u1 n1 n2 )
     dec.r  drop 2drop      0 dec.r  drop 2drop
   ELSE    ELSE ( throwcode addr1 u1 n1 n2 [addr2 u2] )
 [ has? file [IF] ]  [ has? file [IF] ]
       type ." :"        type ." :"
 [ [THEN] ]  [ [THEN] ] ( throwcode addr1 u1 n1 n2 )
       dup >r dec.r ." : " 3 pick .error-string        dup 0 dec.r ." : " 4 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 drop
       THEN        THEN
Line 777 
Line 920 
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]    [ [THEN] ]
   source >in @ sourceline# [ has? file [IF] ]    source >in @ sourceline# [ has? file [IF] ] \ !! unbalanced stack effect
       sourcefilename        sourcefilename
   [ [THEN] ] .error-frame    [ [THEN] ] .error-frame
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
Line 800 
Line 943 
     [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]      [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]
     BEGIN      BEGIN
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         postpone [              [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 817 
Line 963 
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : (bootmessage)
     ." GForth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2000 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2003 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 835 
Line 981 
 ' noop IS 'cold  ' noop IS 'cold
   
   
 Variable init8  AVariable init8 NIL init8 !
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
 [ has? backtrace [IF] ]  [ has? backtrace [IF] ]
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     pathstring 2@ fpath only-path      os-cold
     init-included-files  
 [ [THEN] ]  [ [THEN] ]
     'cold      'cold
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]
     loadfilename# off      s" *the terminal*" loadfilename 2!
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
Line 872 
Line 1017 
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
     main-task up!      main-task up!
 [ has? os [IF] ]  [ has? os [IF] ]
     stdout TO outfile-id      os-boot
     stdin  TO infile-id  
 \ !! [ [THEN] ]  
 \ !! [ has? file [IF] ]  
     argc ! argv ! pathstring 2!  
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
   [ has? peephole [IF] ]
       \ only needed for greedy static superinstruction selection
       \ primtable prepare-peephole-table TO peeptable
   [ [THEN] ]
 [ has? new-input [IF] ]  [ has? new-input [IF] ]
     current-input off      current-input off
 [ [THEN] ]  [ [THEN] ]
Line 888 
Line 1033 
     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.68  
changed lines
  Added in v.1.112
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help