Diff for /gforth/kernel/int.fs between versions 1.177 and 1.195

version 1.177, 2010/12/31 18:09:02 version 1.195, 2012/12/31 15:25:19
Line 1 Line 1
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 143  has? os 0= [IF] Line 143  has? os 0= [IF]
         WHILE \ there are characters left          WHILE \ there are characters left
                 dup r> -                  dup r> -
             WHILE \ the last >number parsed something              WHILE \ the last >number parsed something
                     dup 1- dpl ! over c@ [char] . =                      dup 1- dpl ! over c@ dp-char @ =
                 WHILE \ the current char is '.'                  WHILE \ the current char is '.'
                         1 /string                          1 /string
                 REPEAT  THEN \ there are unparseable characters left                  REPEAT  THEN \ there are unparseable characters left
Line 446  const Create ???  0 , 3 , char ? c, char Line 446  const Create ???  0 , 3 , char ? c, char
 \ if we have a forthstart we can define head? with it  \ if we have a forthstart we can define head? with it
 \ otherwise leave out the head? check  \ otherwise leave out the head? check
   
   : one-head? ( addr -- f )
   \G heuristic check whether addr is a name token; may deliver false
   \G positives; addr must be a valid address
       dup dup aligned <>
       if
           drop false exit \ heads are aligned
       then
       dup cell+ @ alias-mask and 0= >r
       name>string dup $20 $1 within if
           rdrop 2drop false exit \ realistically the name is short
       then
       over + cfaligned over - 2dup bounds ?do \ should be a printable string
           i c@ bl < if
               2drop unloop rdrop false exit
           then
       loop
       + r> if \ check for valid aliases
           @ dup forthstart here within
           over ['] noop ['] lit-execute 1+ within or
           over dup aligned = and
           0= if
               drop false exit
           then
       then \ check for cfa - must be code field or primitive
       dup @ tuck 2 cells - = swap
       docol:  ['] lit-execute @ 1+ within or ;
   
 : 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; returns 1 for  \G positives; addr must be a valid address; returns 1 for
Line 456  const Create ???  0 , 3 , char ? c, char Line 483  const Create ???  0 , 3 , char ? c, char
     \ some code), which is typically not in the dictionary.      \ some code), which is typically not in the dictionary.
     \ we added a third iteration for working with code and ;code words.      \ we added a third iteration for working with code and ;code words.
     3 0 do      3 0 do
         dup dup aligned <> if \ protect @ against unaligned accesses          dup one-head? 0= if
             drop false unloop exit              drop false unloop exit
         then          endif
         dup @ dup          dup @ dup 0= if
         if ( addr addr1 )              2drop 1 unloop exit
             dup rot forthstart within          else
             if \ addr1 is outside forthstart..addr, not a head              dup rot forthstart within if
                 drop false unloop exit                  drop false unloop exit
             then ( addr1 )              then
         else \ 0 in the link field, no further checks  
             2drop 1 unloop exit \ this is very unsure, so return 1  
         then          then
     loop      loop
     \ in dubio pro:  
     drop true ;      drop true ;
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
Line 626  Defer parser1 ( c-addr u -- ... xt) Line 650  Defer parser1 ( c-addr u -- ... xt)
 : parser ( c-addr u -- ... )  : parser ( c-addr u -- ... )
 \ text-interpret the word/number c-addr u, possibly producing a number  \ text-interpret the word/number c-addr u, possibly producing a number
     parser1 execute ;      parser1 execute ;
   
 has? ec [IF]  has? ec [IF]
     ' (name) Alias parse-name      ' (name) Alias parse-name
     : no.extensions  2drop -&13 throw ;      : no.extensions  2drop -&13 throw ;
Line 643  Defer parse-name ( "name" -- c-addr u ) Line 666  Defer parse-name ( "name" -- c-addr u )
 ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete  ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
 \G old name for @code{parse-name}  \G old name for @code{parse-name}
           
   : no.extensions  ( addr u -- )
       2drop -&13 throw ;
   
   has? recognizer 0= [IF]
 Defer compiler-notfound1 ( c-addr count -- ... xt )  Defer compiler-notfound1 ( c-addr count -- ... xt )
 Defer interpreter-notfound1 ( c-addr count -- ... xt )  Defer interpreter-notfound1 ( c-addr count -- ... xt )
   
 : no.extensions  ( addr u -- )  
     2drop -&13 throw ;  
 ' no.extensions IS compiler-notfound1  ' no.extensions IS compiler-notfound1
 ' no.extensions IS interpreter-notfound1  ' no.extensions IS interpreter-notfound1
   [THEN]
   
 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
   
   Defer before-line ( -- ) \ gforth
   \ called before the text interpreter parses the next line
   ' noop IS before-line
   
 [THEN]  [THEN]
   
 has? backtrace [IF]  has? backtrace [IF]
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
       [ has? EC 0= [IF] ] before-line [ [THEN] ]
     BEGIN      BEGIN
         ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup          ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
     WHILE      WHILE
Line 693  has? backtrace [IF] Line 725  has? backtrace [IF]
     then ;      then ;
 [THEN]  [THEN]
   
   has? recognizer 0= [IF]
 \ not the most efficient implementations of interpreter and compiler  \ not the most efficient implementations of interpreter and compiler
 : interpreter1 ( c-addr u -- ... xt )   : interpreter1 ( c-addr u -- ... xt ) 
     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup      2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
Line 709  has? backtrace [IF] Line 742  has? backtrace [IF]
     then ;      then ;
   
 ' interpreter1  IS  parser1  ' interpreter1  IS  parser1
   [THEN]
   
 \ \ Query Evaluate                                      07apr93py  \ \ Query Evaluate                                      07apr93py
   
Line 853  has? os [IF] Line 887  has? os [IF]
             [ has? OS [IF] ] >stderr [ [THEN] ]              [ has? OS [IF] ] >stderr [ [THEN] ]
             cr ." Can't print to stdout, leaving" cr              cr ." Can't print to stdout, leaving" cr
             \ 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 [ [THEN] ]          endif [ [THEN] ]
         refill  WHILE          refill  WHILE
             interpret prompt              interpret prompt
Line 893  max-errors /error * cells allot Line 927  max-errors /error * cells allot
   
 : input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )  : 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      \ error data for the current input, to be used by >error or .error-frame
     source input-lexeme 2@ sourceline#      source over >r save-mem over r> -
       input-lexeme 2@ >r + r> sourceline#
     [ has? file [IF] ] sourcefilename [ [THEN] ] ;      [ has? file [IF] ] sourcefilename [ [THEN] ] ;
   
 : dec. ( n -- ) \ gforth  : dec. ( n -- ) \ gforth
Line 934  Defer dobacktrace ( -- ) Line 969  Defer dobacktrace ( -- )
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
   [IFUNDEF] umin
 : umin ( u1 u2 -- u )  : umin ( u1 u2 -- u )
     2dup u>      2dup u>
     if      if
         swap          swap
     then      then
     drop ;      drop ;
   [THEN]
   
 Defer mark-start  Defer mark-start
 Defer mark-end  Defer mark-end
Line 1036  Defer mark-end Line 1073  Defer mark-end
     [ [ELSE] ] r> >tib !      [ [ELSE] ] r> >tib !
     [ [THEN] ] ;      [ [THEN] ] ;
   
   : do-execute ( xt -- ) \ Gforth
       \G C calling us
       catch dup IF  DoError cr  THEN  (bye) ;
   
   : do-find ( addr u -- )
       find-name dup IF  name>int  THEN  (bye) ;
   
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage) ( -- )  : gforth ( -- )
     ." Gforth " version-string type       ." Gforth " version-string type 
     ." , Copyright (C) 1995-2009,2010 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2012 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 1055  has? file [IF] Line 1099  has? file [IF]
 defer process-args  defer process-args
 [THEN]  [THEN]
   
 ' (bootmessage) IS bootmessage  ' gforth IS bootmessage
   
 has? os [IF]  has? os [IF]
 Defer 'cold ( -- ) \ gforth  tick-cold  Defer 'cold ( -- ) \ gforth  tick-cold
Line 1080  Defer 'cold ( -- ) \ gforth  tick-cold Line 1124  Defer 'cold ( -- ) \ gforth  tick-cold
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
     bootmessage      1 (bye) ;
     quit ;  
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
 : clear-tibstack ( -- )  : clear-tibstack ( -- )
Line 1100  has? new-input 0= [IF] Line 1143  has? new-input 0= [IF]
   
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
 [ has? no-userspace 0= [IF] ]  [ has? no-userspace 0= [IF] ]
     main-task up!      next-task 0= IF  main-task up!
       ELSE
           next-task @ 0= IF
               throw-entry main-task udp @ throw-entry next-task -
               /string >r swap r> move
               next-task dup next-task 2!  normal-dp dpp !
           THEN
       THEN
 [ [THEN] ]  [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     os-boot      os-boot
Line 1133  has? new-input 0= [IF] Line 1183  has? new-input 0= [IF]
     cold      cold
 [ [THEN] ]  [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     1 (bye) \ !! determin exit code from throw code?      -1 (bye) \ !! determin exit code from throw code?
 [ [THEN] ]  [ [THEN] ]
 ;  ;
   

Removed from v.1.177  
changed lines
  Added in v.1.195


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>