[BACK]Return to int.fs CVS log [TXT] [DIR] Up to [gforth] / gforth / kernel

Diff for /gforth/kernel/int.fs between versions 1.129 and 1.130

version 1.129, 2006/02/04 22:09:12 version 1.130, 2006/02/05 17:54:40
Line 55  Defer source ( -- c-addr u ) \ core Line 55  Defer source ( -- c-addr u ) \ core
   
 \ 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
   2dup + r> - 1+ r> min >in ! ;          drop (parse-white)
       ELSE
           (word)
       THEN
       over start-lexeme
       2dup + r> - 1+ r> min >in ! ;
   
 : word   ( char "<chars>ccc<char>-- c-addr ) \ core  : word   ( char "<chars>ccc<char>-- c-addr ) \ core
     \G Skip leading delimiters. Parse @i{ccc}, delimited by      \G Skip leading delimiters. Parse @i{ccc}, delimited by
Line 80  Defer source ( -- c-addr u ) \ core Line 85  Defer source ( -- c-addr u ) \ core
 \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 ( addr u )
       over start-lexeme
       over  swap r>  scan >r
     over - dup r> IF 1+ THEN  >in +! ;      over - dup r> IF 1+ THEN  >in +! ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
Line 89  Defer source ( -- c-addr u ) \ core Line 96  Defer source ( -- c-addr u ) \ core
   
 : (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)
       over start-lexeme
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
 [THEN]  [THEN]
Line 685  has? new-input 0= [IF] Line 693  has? new-input 0= [IF]
     \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  input-start-line  EXIT  THEN
         [ [THEN] ]          [ [THEN] ]
     tib /line      tib /line
     [ has? file [IF] ]      [ has? file [IF] ]
Line 699  has? new-input 0= [IF] Line 707  has? new-input 0= [IF]
         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 762  has? new-input 0= [IF] Line 770  has? new-input 0= [IF]
     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 801  Defer .status Line 809  Defer .status
 \ \ DOERROR (DOERROR)                                   13jun93jaw  \ \ DOERROR (DOERROR)                                   13jun93jaw
   
 8 Constant max-errors  8 Constant max-errors
 4 has? file 2 and + Constant /error  5 has? file 2 and + Constant /error
 Variable error-stack  0 error-stack !  Variable error-stack  0 error-stack !
 max-errors /error * cells allot  max-errors /error * cells allot
 \ format of one cell:  \ format of one cell:
 \ source ( addr u )  \ source ( addr u )
   \ input-start-parse
 \ >in  \ >in
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
 : error> ( -- addr u >in line# [addr u] )  : error> ( -- addr u start-parse >in line# [addr u] )
     -1 error-stack +!      -1 error-stack +!
     error-stack dup @      error-stack dup @
     /error * cells + cell+      /error * cells + cell+
     /error cells bounds DO      /error cells bounds DO
         I @          I @
         cell +LOOP ;      cell +LOOP ;
 : >error ( addr u >in line# [addr u] -- )  
   : >error ( addr u start-parse >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 !
     /error * cells + cell+      /error * cells + cell+
     /error 1- cells bounds swap DO      /error 1- cells bounds swap DO
         I !          I !
         -1 cells +LOOP ;      -1 cells +LOOP ;
   
   : error->in ( -- u )
       \ >in corrected to eliminate one trailing white space character
       >in @ dup if \ non-zero?
           source 2 pick u< if \ beyond end of source?
               2drop exit
           then
           over 1- chars + c@ bl u<= if
               1-
           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#
       [ 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.
Line 876  Defer mark-end Line 902  Defer mark-end
 :noname ." >>>" ; IS mark-start  :noname ." >>>" ; IS mark-start
 :noname ." <<<" ; IS mark-end  :noname ." <<<" ; IS mark-end
   
 : .error-line ( addr1 u1 n1 -- )  : part-type ( addr1 u1 u -- addr2 u2 )
     \ print error ending at char n1 in line addr1 u1      \ print first u characters of addr1 u1, addr2 u2 is the rest
       2 pick over type /string ;
   
   : .error-line ( addr2 u2 u0 u1 -- )
       \ print error between char n0 and char n1 in line addr1 u1
     \ should work with UTF-8 (whitespace check looks ok)      \ should work with UTF-8 (whitespace check looks ok)
     over umin \ protect against wrong n1      2 pick umin    \ protect against wrong n1
     swap >r ( addr1 n1 R: u1 )      tuck umin swap \ protect against wrong n0
     -trailing 1- \ last non-space      over - >r ( addr2 u2 u0 R: u1-u0 )
     0 >r  BEGIN \ search for the first non-space      part-type mark-start r> part-type mark-end type ;
         2dup + c@ bl >  WHILE  
         r> 1+ >r  1- dup 0<  UNTIL  THEN  1+  : .error-frame ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] -- throwcode )
     ( addr1 n2 r: u1 namelen )      \ addr2 u2: filename of included file - optional
     2dup type mark-start      \ n2:       line number
     r> -rot r> swap /string ( namelen addr2 u2 )      \ n1:       end of error position in input line
     >r swap 2dup type mark-end ( addr2 namelen r: u2 )      \ n0:       start of error position in input line
     r> swap /string type ;      \ addr1 u1: input line
       error-stack @
 : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )      IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
 \ addr2 u2:     filename of included file - optional          [ has? file [IF] ] \ !! unbalanced stack effect
 \ n2:           line number  
 \ n1:           error position in input line  
 \ addr1 u1:     input line  
   error-stack @  
   IF ( throwcode addr1 u1 n1 n2 [addr2 u2] )  
       [ has? file [IF] ] \ !! unbalanced stack effect  
           over IF            over IF
               cr ." in file included from "                cr ." in file included from "
               type ." :"                type ." :"
               0 dec.r  drop 2drop                0 dec.r  2drop 2drop
           ELSE            ELSE
               2drop 2drop 2drop                2drop 2drop 2drop drop
           THEN            THEN
 [ [THEN] ] ( throwcode addr1 u1 n1 n2 )            [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
   ELSE ( throwcode addr1 u1 n1 n2 [addr2 u2] )      ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
 [ has? file [IF] ]          [ has? file [IF] ]
       cr type ." :"              cr type ." :"
 [ [THEN] ] ( throwcode addr1 u1 n1 n2 )              [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
       dup 0 dec.r ." : " 4 pick .error-string          dup 0 dec.r ." : " 5 pick .error-string
       IF \ if line# non-zero, there is a line          IF \ if line# non-zero, there is a line
           cr .error-line              cr .error-line
       ELSE          ELSE
           2drop drop              2drop 2drop
       THEN          THEN
   THEN ;      THEN ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]     [ [THEN] ] 
   source >in @ sourceline# [ has? file [IF] ] \ !! unbalanced stack effect    input-error-data .error-frame
       sourcefilename  
   [ [THEN] ] .error-frame  
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
     error>      error>
     .error-frame      .error-frame
Line 967  Defer mark-end Line 989  Defer mark-end
   
 : (bootmessage)  : (bootmessage)
     ." Gforth " version-string type       ." Gforth " version-string type 
     ." , Copyright (C) 1995-2004,2005 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"
Line 1016  has? new-input 0= [IF] Line 1038  has? new-input 0= [IF]
     sp@ $10 cells +      sp@ $10 cells +
     [ [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 -- )
Removed from v.1.129  
changed lines
  Added in v.1.130

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