Diff for /gforth/Attic/kernal.fs between versions 1.17 and 1.18

version 1.17, 1994/08/31 19:42:48 version 1.18, 1994/09/02 15:23:36
Line 781  Avariable leave-sp  leave-stack 3 cells Line 781  Avariable leave-sp  leave-stack 3 cells
 \ information through global variables), but they are useful for dealing  \ information through global variables), but they are useful for dealing
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer (header)  defer header
 defer header ' (header) IS header  
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name c@      name c@
Line 795  defer header ' (header) IS header Line 794  defer header ' (header) IS header
   
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;  \ switches back to getting the name from the input stream ;
     ['] input-stream-header IS (header) ;      ['] input-stream-header IS header ;
   
 ' input-stream-header IS (header)  ' input-stream-header IS header
   
 \ !! make that a 2variable  \ !! make that a 2variable
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
Line 815  create nextname-buffer 32 chars allot Line 814  create nextname-buffer 32 chars allot
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     nextname-buffer c! ( c-addr )      nextname-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
     ['] nextname-header IS (header) ;      ['] nextname-header IS header ;
   
 : noname-header ( -- )  : noname-header ( -- )
     0 last !      0 last !
Line 823  create nextname-buffer 32 chars allot Line 822  create nextname-buffer 32 chars allot
   
 : noname ( -- ) \ general  : noname ( -- ) \ general
 \ the next defined word remains anonymous. The xt of that word is given by lastxt  \ the next defined word remains anonymous. The xt of that word is given by lastxt
     ['] noname-header IS (header) ;      ['] noname-header IS header ;
   
 : lastxt ( -- xt ) \ general  : lastxt ( -- xt ) \ general
 \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname  \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
Line 967  AVariable current Line 966  AVariable current
 Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,  Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,
   
 Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,  Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
 AVariable search       G forth-wordlist search T !  AVariable lookup       G forth-wordlist lookup T !
 G forth-wordlist current T !  G forth-wordlist current T !
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup ( @ swap ) cell+ @ @ execute ;    dup cell+ @ @ execute ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  : search-wordlist  ( addr count wid -- 0 / xt +-1 )
   (search-wordlist) dup  IF  found  THEN ;    (search-wordlist) dup  IF  found  THEN ;
Line 993  Variable warnings  G -1 warnings T ! Line 992  Variable warnings  G -1 warnings T !
  2drop 2drop ;   2drop 2drop ;
   
 : sfind ( c-addr u -- xt n / 0 )  : sfind ( c-addr u -- xt n / 0 )
     search @ search-wordlist ;      lookup @ search-wordlist ;
   
 : find   ( addr -- cfa +-1 / string false )  : find   ( addr -- cfa +-1 / string false )
     \ !! not ANS conformant: returns +-2 for restricted words      \ !! not ANS conformant: returns +-2 for restricted words
Line 1017  Variable warnings  G -1 warnings T ! Line 1016  Variable warnings  G -1 warnings T !
 08 constant #bs  08 constant #bs
 09 constant #tab  09 constant #tab
 7F constant #del  7F constant #del
 0C constant #ff  
 0D constant #cr                \ the newline key code  0D constant #cr                \ the newline key code
   0C constant #ff
 0A constant #lf  0A constant #lf
   
 : bell  #bell emit ;  : bell  #bell emit ;
Line 1129  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1128  create nl$ 1 c, A c, 0 c, \ gnu includes
   loadline @ >r loadfile @ >r    loadline @ >r loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;    blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
   
 : pop-file   ( -- )  r>  : pop-file   ( throw-code -- throw-code )
     dup IF
            source >in @ loadline @ loadfilename 2@
            error-stack dup @ dup 1+
            max-errors 1- min error-stack !
            6 * cells + cell+
            5 cells bounds swap DO
                               I !
            -1 cells +LOOP
     THEN
     r>
   r> >in !  r> #tib !  r> >tib !  r> blk !    r> >in !  r> #tib !  r> >tib !  r> blk !
   r> loadfile ! r> loadline !  >r ;    r> loadfile ! r> loadline !  >r ;
   
Line 1139  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1148  create nl$ 1 c, A c, 0 c, \ gnu includes
 : include-file ( i*x fid -- j*x )  : include-file ( i*x fid -- j*x )
   push-file  loadfile !    push-file  loadfile !
   0 loadline ! blk off  ['] read-loop catch    0 loadline ! blk off  ['] read-loop catch
   loadfile @ close-file    loadfile @ close-file swap
   pop-file  throw throw ;    pop-file  throw throw ;
   
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
Line 1205  Defer .status Line 1214  Defer .status
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
   
   8 Constant max-errors
   Variable error-stack  0 error-stack !
   max-errors 6 * cells allot
   \ format of one cell:
   \ source ( addr u )
   \ >in
   \ line-number
   \ Loadfilename ( addr u )
   
 : dec. ( n -- )  : dec. ( n -- )
     \ print value in decimal representation      \ print value in decimal representation
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : typewhite ( addr u -- )  : typewhite ( addr u -- )
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     0 ?do      bounds ?do
         dup i + c@ 9 = if \ check for tab          i c@ 9 = if \ check for tab
             9              9
         else          else
             bl              bl
         then          then
         emit          emit
     loop      loop
     drop ;  ;
   
 DEFER DOERROR  DEFER DOERROR
   
   : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
     cr error-stack @
     IF
        ." in file included from "
        type ." :" dec.  drop 2drop
     ELSE
        type ." :" dec.
        cr dup 2over type cr drop
        nip -trailing ( line-start index2 )
        0 >r  BEGIN
                     1- 2dup + c@ bl >  WHILE
                     r> 1+ >r  dup 0<  UNTIL  THEN  1+
        ( line-start index1 )
        typewhite
        r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                     [char] ^ emit
        loop
     THEN
   ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
     LoadFile @    loadline @ IF
     IF                 source >in @ loadline @ 0 0 .error-frame
         cr loadfilename 2@ type ." :" Loadline @ dec.    THEN
     THEN    error-stack @ 0 ?DO
     cr source type cr      -1 error-stack +!
     source drop >in @ -trailing ( throw-code line-start index2 )      error-stack dup @ 6 * cells + cell+
     here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )      6 cells bounds DO
     typewhite        I @
     r> 1 max 0 ?do \ we want at least one "^", even if the length is 0      cell +LOOP
         ." ^"      .error-frame
     loop    LOOP
     dup -2 =    dup -2 =
     IF     IF 
         "error @ ?dup       "error @ ?dup
         IF       IF
             cr count type           cr count type 
         THEN       THEN
         drop       drop
     ELSE    ELSE
         .error       .error
     THEN    THEN
     normal-dp dpp ! ;    normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   

Removed from v.1.17  
changed lines
  Added in v.1.18


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