[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.63 and 1.64

version 1.63, Sat Sep 23 15:47:10 2000 UTC version 1.64, Sun Oct 29 20:27:03 2000 UTC
Line 31 
Line 31 
 require kernel/version.fs       \ version-string  require kernel/version.fs       \ version-string
 require ./../chains.fs  require ./../chains.fs
   
   has? new-input 0= [IF]
 : tib ( -- c-addr ) \ core-ext t-i-b  : tib ( -- c-addr ) \ core-ext t-i-b
     \G @i{c-addr} is the address of the Terminal Input Buffer.      \G @i{c-addr} is the address of the Terminal Input Buffer.
     \G OBSOLESCENT: @code{source} superceeds the function of this word.      \G OBSOLESCENT: @code{source} superceeds the function of this word.
Line 44 
Line 45 
 : (source) ( -- c-addr u )  : (source) ( -- c-addr u )
     tib #tib @ ;      tib #tib @ ;
 ' (source) IS source  ' (source) IS source
   [THEN]
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 518 
Line 520 
 has? file 0= [IF]  has? file 0= [IF]
 : sourceline# ( -- n )  1 ;  : sourceline# ( -- n )  1 ;
 [ELSE]  [ELSE]
   has? new-input 0= [IF]
 Variable #fill-bytes  Variable #fill-bytes
 \G number of bytes read via (read-line) by the last refill  \G number of bytes read via (read-line) by the last refill
 [THEN]  [THEN]
   [THEN]
   
   has? new-input 0= [IF]
 : 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 560 
Line 565 
     [ has? file [IF] ]      [ has? file [IF] ]
         blk off loadfile off          blk off loadfile off
         [ [THEN] ]          [ [THEN] ]
     tib /line accept #tib ! 0 >in ! ;      refill drop ;
   [THEN]
   
 \ save-mem extend-mem  \ save-mem extend-mem
   
Line 580 
Line 586 
   
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 has? file 0= [IF]  has? file 0= has? new-input 0= and [IF]
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   tibstack @ >r  >tib @ >r  #tib @ >r    tibstack @ >r  >tib @ >r  #tib @ >r
   >tib @ tibstack @ = IF  r@ tibstack +!  THEN    >tib @ tibstack @ = IF  r@ tibstack +!  THEN
Line 591 
Line 597 
   r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;    r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
 [THEN]  [THEN]
   
   has? new-input 0= [IF]
 : evaluate ( c-addr u -- ) \ core,block  : evaluate ( c-addr u -- ) \ core,block
     \G Save the current input source specification. Store @code{-1} in      \G Save the current input source specification. Store @code{-1} in
     \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to      \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
     \G @code{0} and make the string @i{c-addr u} the input source      \G @code{0} and make the string @i{c-addr u} the input source
     \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] ]
     loadfilename# @ >r      loadfilename# @ >r
     1 loadfilename# ! \ "*evaluated string*"      1 loadfilename# ! \ "*evaluated string*"
   [ [THEN] ]
     push-file #tib ! >tib !      push-file #tib ! >tib !
     >in off      >in off
     [ has? file [IF] ]      [ has? file [IF] ]
Line 606 
Line 615 
         [ [THEN] ]          [ [THEN] ]
     ['] interpret catch      ['] interpret catch
     pop-file      pop-file
   [ has? file [IF] ]
     r> loadfilename# !      r> loadfilename# !
   [ [THEN] ]
     throw ;      throw ;
   [THEN]
   
 \ \ Quit                                                13feb93py  \ \ Quit                                                13feb93py
   
Line 617 
Line 629 
   
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
   
 : (Query)  ( -- )  
     [ has? file [IF] ]  
         loadfile off  blk off loadline off  
         [ [THEN] ]  
     refill drop ;  
   
 : (quit) ( -- )  : (quit) ( -- )
     \ exits only through THROW etc.      \ exits only through THROW etc.
 \    sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer  \    sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer
Line 630 
Line 636 
     \ after the next THROW it catches (it may be off due to BOUNCEs or      \ after the next THROW it catches (it may be off due to BOUNCEs or
     \ because process-args left something on the stack)      \ because process-args left something on the stack)
     BEGIN      BEGIN
         .status cr (query) interpret prompt          .status cr query interpret prompt
     AGAIN ;      AGAIN ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
Line 639 
Line 645 
   
 8 Constant max-errors  8 Constant max-errors
 Variable error-stack  0 error-stack !  Variable error-stack  0 error-stack !
 max-errors 6 * cells allot  max-errors has? file [IF] 6 [ELSE] 4 [THEN] * cells allot
 \ format of one cell:  \ format of one cell:
 \ source ( addr u )  \ source ( addr u )
 \ >in  \ >in
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
   : error> ( -- addr u >in line# [addr u] )
       -1 error-stack +!
       error-stack dup @
       [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+
       [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO
           I @
           cell +LOOP ;
   : >error ( addr u >in line# [addr u] -- )
       error-stack dup @ dup 1+
       max-errors 1- min error-stack !
       [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+
       [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO
           I !
           -1 cells +LOOP ;
   
 : 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.
     \ !! not used...      \ !! not used...
Line 685 
Line 706 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
 : .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  \ 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
   [ has? file [IF] ]
      ." in file included from "       ." in file included from "
      type ." :" dec.r  drop 2drop      type ." :"
   [ [THEN] ]
       dec.r  drop 2drop
   ELSE    ELSE
       type ." :" dup >r dec.r ." : " 3 pick .error-string  [ has? file [IF] ]
         type ." :"
   [ [THEN] ]
         dup >r dec.r ." : " 3 pick .error-string
       r> IF \ if line# non-zero, there is a line        r> IF \ if line# non-zero, there is a line
           cr dup 2over type cr drop            cr dup 2over type cr drop
           nip -trailing 1- ( line-start index2 )            nip -trailing 1- ( line-start index2 )
Line 716 
Line 743 
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]    [ [THEN] ]
   source >in @ sourceline# sourcefilename .error-frame    source >in @ sourceline# [ has? file [IF] ]
         sourcefilename
     [ [THEN] ] .error-frame
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
     -1 error-stack +!      error>
     error-stack dup @ 6 * cells + cell+  
     6 cells bounds DO  
       I @  
     cell +LOOP  
     .error-frame      .error-frame
   LOOP    LOOP
   drop    drop
Line 737 
Line 762 
     \G Empty the return stack, make the user input device      \G Empty the return stack, make the user input device
     \G the input source, enter interpret state and start      \G the input source, enter interpret state and start
     \G the text interpreter.      \G the text interpreter.
     rp0 @ rp! handler off clear-tibstack >tib @ >r      rp0 @ rp! handler off clear-tibstack
       [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]
     BEGIN      BEGIN
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         postpone [          postpone [
Line 745 
Line 771 
         ['] '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 r@ >tib ! r@ tibstack !          DoError
           [ has? new-input [IF] ] clear-tibstack
           [ [ELSE] ] r@ >tib ! r@ tibstack !
           [ [THEN] ]
     REPEAT      REPEAT
     drop r> >tib ! ;      drop [ has? new-input [IF] ] clear-tibstack
       [ [ELSE] ] r> >tib !
       [ [THEN] ] ;
   
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
Line 790 
Line 821 
     bootmessage      bootmessage
     quit ;      quit ;
   
   has? new-input 0= [IF]
 : clear-tibstack ( -- )  : clear-tibstack ( -- )
 [ has? glocals [IF] ]  [ has? glocals [IF] ]
     lp@ forthstart 7 cells + @ -      lp@ forthstart 7 cells + @ -
Line 801 
Line 833 
     [ [THEN] ]      [ [THEN] ]
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off ;      dup >tib ! tibstack ! #tib off >in off ;
   [THEN]
   
 : boot ( path **argv argc -- )  : boot ( path n **argv argc -- )
     main-task up!      main-task up!
 [ has? os [IF] ]  [ has? os [IF] ]
     stdout TO outfile-id      stdout TO outfile-id
Line 812 
Line 845 
     argc ! argv ! pathstring 2!      argc ! argv ! pathstring 2!
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
   [ has? new-input [IF] ]
       current-input off
   [ [THEN] ]
     clear-tibstack      clear-tibstack
     rp@ rp0 !      rp@ rp0 !
 [ has? floating [IF] ]  [ has? floating [IF] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help