gforth: gforth/kernel/int.fs

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

-version 1.131, Sun Feb  5 21:22:05 2006 UTC
+version 1.152, Fri May 26 21:18:45 2006 UTC
  Line 29
  Line 29
  Line 29
  require ./nio.fs        \ . <# ...
  require ./errore.fs     \ .error ...
  require kernel/version.fs       \ version-string
- require ./../chains.fs
  has? new-input 0= [IF]
  : tib ( -- c-addr ) \ core-ext t-i-b
- Line 67
+ Line 66
  Line 67
  Line 66
      ELSE
          (word)
      THEN
-     over start-lexeme
+ [ has? new-input [IF] ]
+dup input-lexeme!
+ [ [THEN] ]
 dup + r> - 1+ r> min >in ! ;
  : word   ( char "<chars>ccc<char>-- c-addr ) \ core
- Line 85
+ Line 86
  Line 85
  Line 86
  \G Parse @i{ccc}, delimited by @i{char}, in the parse
  \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.
-     >r  source  >in @ over min /string ( addr u )
+     >r  source  >in @ over min /string ( c-addr1 u1 )
-     over start-lexeme
      over  swap r>  scan >r
-     over - dup r> IF 1+ THEN  >in +! ;
+     over - dup r> IF 1+ THEN  >in +!
+ [ has? new-input [IF] ]
+dup input-lexeme!
+ [ [THEN] ] ;
  \ name                                                 13feb93py
- Line 96
+ Line 99
  Line 96
  Line 99
  : (name) ( -- c-addr count ) \ gforth
      source 2dup >r >r >in @ /string (parse-white)
-     over start-lexeme
+ [ has? new-input [IF] ]
+dup input-lexeme!
+ [ [THEN] ]
 dup + r> - 1+ r> min >in ! ;
  \    name count ;
  [THEN]
- Line 235
+ Line 240
  Line 235
  Line 240
      \G comments into documentation.
      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
  \ word list structure:
- Line 285
+ Line 297
  Line 285
  Line 297
  ' lookup is context
  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
  \ The constants are defined as 32 bits, but then erased
- Line 337
+ Line 370
  Line 337
  Line 370
  : (x>int) ( cfa w -- xt )
      \ get interpretation semantics of name
-     restrict-mask and
+     restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
      if
          drop ['] compile-only-error
      else
- Line 386
+ Line 419
  Line 386
  Line 419
  : name?int ( nt -- xt ) \ gforth
      \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
      \G has no interpretation semantics.
-     (name>x) restrict-mask and
+     (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
      if
          ticking-compile-only-error \ does not return
      then
- Line 401
+ Line 434
  Line 401
  Line 434
          interpret/compile-comp @
      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>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,
  \ ??? is used by dovar:, must be created/:dovar
- Line 500
+ Line 533
  Line 500
  Line 533
          drop 0
      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}.
  : 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+ ! ;
+     [ has? flash [IF] ]
+     dodoes: over flash! cell+ flash!
+     [ [ELSE] ]
+     dodoes: over ! cell+ !
+     [ [THEN] ] ;
  ' drop alias does-handler! ( a_addr -- ) \ gforth
  \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
- Line 517
+ Line 555
  Line 517
  Line 555
  [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
      find-name dup
      if ( nt )
- Line 573
+ Line 591
  Line 573
  Line 591
  \ ticks in interpreter
  : (') ( "name" -- nt ) \ gforth
-     name name-too-short?
+     parse-name name-too-short?
      find-name dup 0=
      IF
          drop -&13 throw
- Line 603
+ Line 621
  Line 603
  Line 621
  \ 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
  ' (name) IS parse-name
- Line 624
+ Line 648
  Line 624
  Line 648
  Defer before-word ( -- ) \ gforth
  \ called before the text interpreter parses the next word
  ' noop IS before-word
+ [THEN]
+ has? backtrace [IF]
  : interpret1 ( ... -- ... )
- [ has? backtrace [IF] ]
      rp@ backtrace-rp0 !
- [ [THEN] ]
      BEGIN
-         ?stack before-word name dup
+         ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
      WHILE
          parser1 execute
      REPEAT
- Line 638
+ Line 662
  Line 638
  Line 662
  : interpret ( ?? -- ?? ) \ gforth
      \ interpret/compile the (rest of the) input buffer
- [ has? backtrace [IF] ]
      backtrace-rp0 @ >r
- [ [THEN] ]
      ['] interpret1 catch
- [ has? backtrace [IF] ]
      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
+drop ;
+ [THEN]
  \ interpreter                                   30apr92py
- Line 679
+ Line 708
  Line 679
  Line 708
  has? new-input 0= [IF]
  : input-start-line ( -- ) >in off ;
- : start-lexeme ( addr -- ) drop ;
  : refill ( -- flag ) \ core-ext,block-ext,file-ext
      \G Attempt to fill the input buffer from the input source.  When
      \G the input source is the user input device, attempt to receive
- Line 695
+ Line 723
  Line 695
  Line 723
      \G and return true; otherwise, return false.  A successful result
      \G includes receipt of a line containing 0 characters.
      [ has? file [IF] ]
-         blk @  IF  1 blk +!  true  input-start-line  EXIT  THEN
+         blk @  IF  1 blk +!  true  EXIT  THEN
          [ [THEN] ]
      tib /line
      [ has? file [IF] ]
- Line 704
+ Line 732
  Line 704
  Line 732
          ELSE
              [ [THEN] ]
          sourceline# 0< IF 2drop false EXIT THEN
-         accept true
+         accept eof @ 0=
          [ has? file [IF] ]
          THEN
 loadline +!
          [ [THEN] ]
-     swap #tib ! input-start-line ;
+     swap #tib !
+     input-start-line ;
  : query   ( -- ) \ core-ext
      \G Make the user input device the input source. Receive input into
- Line 788
+ Line 817
  Line 788
  Line 817
  Defer 'quit
+ has? ec 0= [IF]
  Defer .status
+ [THEN]
  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
  : (quit) ( -- )
      \ exits only through THROW etc.
      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
 (bye)
-         endif
+         endif [ [THEN] ]
          refill WHILE
              interpret prompt
      REPEAT
- Line 816
+ Line 848
  Line 816
  Line 848
  Variable error-stack  0 error-stack !
  max-errors /error * cells allot
  \ format of one cell:
- \ source ( addr u )
+ \ source ( c-addr u )
- \ input-start-parse
+ \ last parsed lexeme ( c-addr u )
- \ >in
  \ line-number
  \ Loadfilename ( addr u )
- : error> ( -- addr u start-parse >in line# [addr u] )
+ : error> ( --  c-addr1 u1 c-addr2 u2 line# [addr u] )
      -1 error-stack +!
      error-stack dup @
      /error * cells + cell+
- Line 830
+ Line 861
  Line 830
  Line 861
          I @
      cell +LOOP ;
- : >error ( addr u start-parse >in line# [addr u] -- )
+ : >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- )
      error-stack dup @ dup 1+
      max-errors 1- min error-stack !
      /error * cells + cell+
- Line 838
+ Line 869
  Line 838
  Line 869
          I !
      -1 cells +LOOP ;
- : error->in ( -- u )
+ : input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )
-     \ >in corrected to eliminate one trailing white space character
-     >in @ dup if \ non-zero?
-         source 2 pick u< if \ beyond end of source?
-drop exit
-         then
-         over 1- chars + c@ bl u<= if
--
-         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#
+     source input-lexeme 2@ sourceline#
      [ has? file [IF] ] sourcefilename [ [THEN] ] ;
  : dec. ( n -- ) \ gforth
- Line 907
+ Line 927
  Line 907
  Line 927
  : part-type ( addr1 u1 u -- addr2 u2 )
      \ print first u characters of addr1 u1, addr2 u2 is the rest
-pick over type /string ;
+     over umin 2 pick over type /string ;
- : .error-line ( addr2 u2 u0 u1 -- )
+ : .error-line ( c-addr1 u1 c-addr2 u2 -- )
-     \ print error between char n0 and char n1 in line addr1 u1
+     \ print error in line c-addr1 u1, where the error-causing lexeme
-     \ should work with UTF-8 (whitespace check looks ok)
+     \ is c-addr2 u2
-pick umin    \ protect against wrong n1
+     >r 2 pick - part-type ( c-addr3 u3 R: u2 )
-     tuck umin swap \ protect against wrong n0
+     mark-start r> part-type mark-end ( c-addr4 u4 )
-     over - >r ( addr2 u2 u0 R: u1-u0 )
+     type ;
-     part-type mark-start r> part-type mark-end type ;
- : .error-frame ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] -- throwcode )
+ : .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode )
-     \ addr2 u2: filename of included file - optional
+     \ addr3 u3: filename of included file - optional
      \ n2:       line number
-     \ n1:       end of error position in input line
+     \ addr2 u2: parsed lexeme (should be marked as causing the error)
-     \ n0:       start of error position in input line
      \ addr1 u1: input line
      error-stack @
      IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
- Line 965
+ Line 983
  Line 965
  Line 983
  [ELSE]
      : 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]
  : quit ( ?? -- ?? ) \ core
- Line 1003
+ Line 1024
  Line 1003
  Line 1024
       cr ." Type `bye' to exit"
  [ [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]
  defer process-args
+ [THEN]
  ' (bootmessage) IS bootmessage
+ has? ec 0= [IF]
  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
+ [THEN]
- AVariable init8 NIL init8 !
  : cold ( -- ) \ gforth
  [ has? backtrace [IF] ]
- Line 1025
+ Line 1052
  Line 1025
  Line 1052
  [ [THEN] ]
  [ has? ec 0= [IF] ]
      set-encoding-fixed-width
- [ [THEN] ]
      'cold
-     init8 chainperform
+ [ [THEN] ]
  [ has? file [IF] ]
      process-args
      loadline off
- Line 1043
+ Line 1069
  Line 1043
  Line 1069
      [ has? os [IF] ]
      r0 @ forthstart 6 cells + @ -
      [ [ELSE] ]
-     sp@ $10 cells +
+     sp@ cell+
      [ [THEN] ]
  [ [THEN] ]
-     dup >tib ! tibstack ! #tib off input-start-line ;
+     dup >tib ! tibstack ! #tib off
+     input-start-line ;
  [THEN]
  : boot ( path n **argv argc -- )
+ [ has? no-userspace 0= [IF] ]
      main-task up!
+ [ [THEN] ]
  [ has? os [IF] ]
      os-boot
  [ [THEN] ]
+ [ has? rom [IF] ]
+     ram-shadow dup @ dup -1 <> >r u> r> and IF
+         ram-shadow 2@  ELSE
+         ram-mirror ram-size  THEN  ram-start swap move
+ [ [THEN] ]
      sp@ sp0 !
  [ has? peephole [IF] ]
      \ only needed for greedy static superinstruction selection
- Line 1068
+ Line 1102
  Line 1068
  Line 1102
  [ has? floating [IF] ]
      fp@ fp0 !
  [ [THEN] ]
+ [ has? ec 0= [IF] ]
      handler off
      ['] cold catch dup -&2049 <> if \ broken pipe?
          DoError cr
      endif
+ [ [ELSE] ]
+     cold
+ [ [THEN] ]
  [ has? os [IF] ]
 (bye) \ !! determin exit code from throw code?
  [ [THEN] ]

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.131
 


changed lines


 
Added in v.1.152
 Legend:



Removed from v.1.131
 


changed lines


 
Added in v.1.152
-Removed from v.1.131
+Added in v.1.152

CVS Admin

gforth: gforth/kernel/int.fs

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

ViewCVS and CVS Help