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

version 1.16, 1994/08/31 16:37:48 version 1.17, 1994/08/31 19:42:48
Line 756  Avariable leave-sp  leave-stack 3 cells Line 756  Avariable leave-sp  leave-stack 3 cells
 : ."       state @  IF    postpone (.") ,"  align  : ."       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
 : (        [char] ) parse 2drop ;                       immediate  : (        [char] ) parse 2drop ;                       immediate
 : \        source >in ! drop ;                          immediate  : \        blk @ IF  >in @ c/l / 1+ c/l * >in !  EXIT  THEN
              source >in ! drop ;                          immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
Line 787  defer header ' (header) IS header Line 788  defer header ' (header) IS header
     name c@      name c@
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     1+ chars allot align ;      1+ chars allot align ;
   
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent      \ !! this is f83-implementation-dependent
     align here last !  -1 A,      align here last !  -1 A,
Line 1017  Variable warnings  G -1 warnings T ! Line 1017  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
 0A constant #lf  0A constant #lf
 0C constant #ff  
   
 : bell  #bell emit ;  : bell  #bell emit ;
   
Line 1064  Create crtlkeys Line 1064  Create crtlkeys
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
 DEFER type      \ defer type for a output buffer or fast  Defer type      \ defer type for a output buffer or fast
                 \ screen write                  \ screen write
   
 \ : (type) ( addr len -- )  \ : (type) ( addr len -- )
 \   bounds ?DO  I c@ emit  LOOP ;  \   bounds ?DO  I c@ emit  LOOP ;
   
 ' (TYPE) IS Type  ' (type) IS Type
   
 DEFER Emit  Defer emit
   
 ' (Emit) IS Emit  ' (Emit) IS Emit
   
   Defer key
   ' (key) IS key
   
 \ : form  ( -- rows cols )  &24 &80 ;  \ : form  ( -- rows cols )  &24 &80 ;
 \ form should be implemented using TERMCAPS or CURSES  \ form should be implemented using TERMCAPS or CURSES
 \ : rows  form drop ;  \ : rows  form drop ;
Line 1084  DEFER Emit Line 1087  DEFER Emit
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag )
     blk @  IF  1 blk +!  true  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    \ dup file-position throw linestart 2!    IF    read-line throw
         read-line throw  
   ELSE  loadline @ 0< IF 2drop false EXIT THEN    ELSE  loadline @ 0< IF 2drop false EXIT THEN
         accept true          accept true
   THEN    THEN
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- )  0 loadfile ! refill drop ;  : Query  ( -- )  loadfile off  blk off  refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1123  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1126  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   ( linestart 2@ >r >r ) 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   ( -- )  r>
   r> >in !  r> #tib !  r> >tib ! r> blk !    r> >in !  r> #tib !  r> >tib !  r> blk !
   r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;    r> loadfile ! r> loadline !  >r ;
   
   : read-loop ( i*x -- j*x )
     BEGIN  refill  WHILE  interpret  REPEAT ;
   
 : include-file ( i*x fid -- j*x )  : include-file ( i*x fid -- j*x )
   push-file  loadfile !    push-file  loadfile !
   0 loadline ! blk off    0 loadline ! blk off  ['] read-loop catch
   BEGIN  refill  WHILE  interpret  REPEAT    loadfile @ close-file
   loadfile @ close-file throw    pop-file  throw throw ;
   pop-file ;  
   
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
Line 1180  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1185  create nl$ 1 c, A c, 0 c, \ gnu includes
   push-file  dup #tib ! >tib @ swap move    push-file  dup #tib ! >tib @ swap move
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
   
   BEGIN  interpret  >in @ #tib @ u>= UNTIL  \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
     ['] interpret catch
   pop-file ;    pop-file throw ;
   
   
 : abort -1 throw ;  : abort -1 throw ;

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


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