[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.135 and 1.152

version 1.135, Sat Feb 18 22:58:05 2006 UTC version 1.152, Fri May 26 21:18:45 2006 UTC
Line 29 
Line 29 
 require ./nio.fs        \ . <# ...  require ./nio.fs        \ . <# ...
 require ./errore.fs     \ .error ...  require ./errore.fs     \ .error ...
 require kernel/version.fs       \ version-string  require kernel/version.fs       \ version-string
 require ./../chains.fs  
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
 : tib ( -- c-addr ) \ core-ext t-i-b  : tib ( -- c-addr ) \ core-ext t-i-b
Line 67 
Line 66 
     ELSE      ELSE
         (word)          (word)
     THEN      THEN
   [ has? new-input [IF] ]
     2dup input-lexeme!      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 88 
Line 89 
     >r  source  >in @ over min /string ( c-addr1 u1 )      >r  source  >in @ over min /string ( c-addr1 u1 )
     over  swap r>  scan >r      over  swap r>  scan >r
     over - dup r> IF 1+ THEN  >in +!      over - dup r> IF 1+ THEN  >in +!
     2dup input-lexeme! ;  [ has? new-input [IF] ]
       2dup input-lexeme!
   [ [THEN] ] ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
Line 96 
Line 99 
   
 : (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!      2dup input-lexeme!
   [ [THEN] ]
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
 [THEN]  [THEN]
Line 235 
Line 240 
     \G comments into documentation.      \G comments into documentation.
     POSTPONE \ ; immediate      POSTPONE \ ; immediate
   
   has? ec [IF]
       AVariable forth-wordlist
       : 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.
           forth-wordlist (f83find) ;
   [ELSE]
 \ \ object oriented search list                         17mar93py  \ \ object oriented search list                         17mar93py
   
 \ word list structure:  \ word list structure:
Line 285 
Line 297 
 ' 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 337 
Line 370 
   
 : (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 386 
Line 419 
 : 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 401 
Line 434 
         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 500 
Line 533 
         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 517 
Line 555 
   
 [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 573 
Line 591 
 \ 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 603 
Line 621 
 \ 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]
       ' (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  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-name  ' (name) IS parse-name
Line 624 
Line 648 
 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]
   
   has? backtrace [IF]
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
 [ has? backtrace [IF] ]  
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  
     BEGIN      BEGIN
         ?stack before-word name dup          ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
     WHILE      WHILE
         parser1 execute          parser1 execute
     REPEAT      REPEAT
Line 638 
Line 662 
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
 [ has? backtrace [IF] ]  
     backtrace-rp0 @ >r      backtrace-rp0 @ >r
 [ [THEN] ]  
     ['] interpret1 catch      ['] interpret1 catch
 [ has? backtrace [IF] ]  
     r> backtrace-rp0 !      r> backtrace-rp0 !
     [ [THEN] ]      throw>error ;
     throw ;  [ELSE]
   : interpret ( ... -- ... )
       BEGIN
           ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
       WHILE
           parser1 execute
       REPEAT
       2drop ;
   [THEN]
   
 \ interpreter                                   30apr92py  \ interpreter                                   30apr92py
   
Line 679 
Line 708 
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
 : input-start-line ( -- ) >in off ;  : input-start-line ( -- ) >in off ;
 : input-lexeme! ( c-addr n -- ) 2drop ;  
 : 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 695 
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  input-start-line  EXIT  THEN          blk @  IF  1 blk +!  true  EXIT  THEN
         [ [THEN] ]          [ [THEN] ]
     tib /line      tib /line
     [ has? file [IF] ]      [ has? file [IF] ]
Line 704 
Line 732 
         ELSE          ELSE
             [ [THEN] ]              [ [THEN] ]
         sourceline# 0< IF 2drop false EXIT THEN          sourceline# 0< IF 2drop false EXIT THEN
         accept true          accept eof @ 0=
         [ has? file [IF] ]          [ has? file [IF] ]
         THEN          THEN
         1 loadline +!          1 loadline +!
         [ [THEN] ]          [ [THEN] ]
     swap #tib ! input-start-line ;      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 788 
Line 817 
   
 Defer 'quit  Defer 'quit
   
   has? ec 0= [IF]
 Defer .status  Defer .status
   [THEN]
   
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
   
 : (quit) ( -- )  : (quit) ( -- )
     \ exits only through THROW etc.      \ exits only through THROW etc.
     BEGIN      BEGIN
         .status          [ has? ec [IF] ] cr [ [ELSE] ]
         ['] cr catch if          .status ['] cr catch if
             >stderr cr ." Can't print to stdout, leaving" cr              [ has? OS [IF] ] >stderr [ [THEN] ]
               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          endif [ [THEN] ]
         refill WHILE          refill WHILE
             interpret prompt              interpret prompt
     REPEAT      REPEAT
Line 951 
Line 983 
   
 [ELSE]  [ELSE]
     : dec.  base @ >r decimal . r> base ! ;      : dec.  base @ >r decimal . r> base ! ;
     : DoError ( throw-code -- ) ." Error# " dec. cr ;      : DoError ( throw-code -- )
           cr source drop >in @ type ." <<< "
           dup -2 =  IF  "error @ type  drop  EXIT  THEN
           .error ;
 [THEN]  [THEN]
   
 : quit ( ?? -- ?? ) \ core  : quit ( ?? -- ?? ) \ core
Line 989 
Line 1024 
      cr ." Type `bye' to exit"       cr ." Type `bye' to exit"
 [ [THEN] ] ;  [ [THEN] ] ;
   
 defer bootmessage  defer bootmessage \ gforth
   \G Hook (deferred word) executed right after interpreting the OS
   \G command-line arguments.  Normally prints the Gforth startup
   \G message.
   
 has? file [IF]  has? file [IF]
 defer process-args  defer process-args
 [THEN]  [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  \G Hook (deferred word) for things to do right before interpreting the
 \ command-line arguments  \G OS command-line arguments.  Normally does some initializations that
   \G you also want to perform.
 ' noop IS 'cold  ' noop IS 'cold
   [THEN]
   
 AVariable init8 NIL init8 !  
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
     [ has? backtrace [IF] ]      [ has? backtrace [IF] ]
Line 1013 
Line 1052 
 [ [THEN] ]  [ [THEN] ]
 [ has? ec 0= [IF] ]  [ has? ec 0= [IF] ]
     set-encoding-fixed-width      set-encoding-fixed-width
 [ [THEN] ]  
     'cold      'cold
     init8 chainperform  [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     process-args      process-args
     loadline off      loadline off
Line 1031 
Line 1069 
     [ 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 input-start-line ;      dup >tib ! tibstack ! #tib off
       input-start-line ;
 [THEN]  [THEN]
   
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
Line 1045 
Line 1084 
     os-boot      os-boot
 [ [THEN] ]  [ [THEN] ]
 [ has? rom [IF] ]  [ has? rom [IF] ]
     ram-mirror ram-start ram-size move      ram-shadow dup @ dup -1 <> >r u> r> and IF
           ram-shadow 2@  ELSE
           ram-mirror ram-size  THEN  ram-start swap move
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
 [ has? peephole [IF] ]  [ has? peephole [IF] ]
Line 1061 
Line 1102 
 [ has? floating [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
   [ has? ec 0= [IF] ]
     handler off      handler off
     ['] cold catch dup -&2049 <> if \ broken pipe?      ['] cold catch dup -&2049 <> if \ broken pipe?
         DoError cr          DoError cr
     endif      endif
   [ [ELSE] ]
       cold
   [ [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] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help