Diff for /gforth/Attic/kernal.fs between versions 1.56 and 1.58

version 1.56, 1996/05/06 12:39:02 version 1.58, 1996/05/09 18:13:02
Line 247  Defer source ( -- addr count ) \ core Line 247  Defer source ( -- addr count ) \ core
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
 : Literal  ( compilation n -- ; run-time -- n ) \ core  : Literal  ( compilation n -- ; run-time -- n ) \ core
     state @ IF postpone lit  , THEN ; immediate      postpone lit  , ; immediate restrict
 : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
     state @ IF postpone lit A, THEN ;      postpone lit A, ; immediate restrict
                                                       immediate  
   
 : char   ( 'char' -- n ) \ core  : char   ( 'char' -- n ) \ core
     bl word char+ c@ ;      bl word char+ c@ ;
 : [char] ( compilation 'char' -- ; run-time -- n )  : [char] ( compilation 'char' -- ; run-time -- n )
     char postpone Literal ; immediate      char postpone Literal ; immediate restrict
 ' [char] Alias Ascii immediate  
   
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
Line 953  Avariable leave-sp  leave-stack 3 cells Line 951  Avariable leave-sp  leave-stack 3 cells
                                              immediate restrict                                               immediate restrict
 create s"-buffer /line chars allot  create s"-buffer /line chars allot
 : S" ( compilation 'ccc"' -- ; run-time -- c-addr u )   \ core,file     s-quote  : S" ( compilation 'ccc"' -- ; run-time -- c-addr u )   \ core,file     s-quote
     [char] " parse      [char] " parse postpone SLiteral ; immediate restrict
     state @  
     IF  
         postpone SLiteral  
     ELSE  
         /line min >r s"-buffer r@ cmove  
         s"-buffer r>  
     THEN ; immediate  
   
 : ." ( compilation 'ccc"' -- ; run-time -- )  \ core    dot-quote  : ." ( compilation 'ccc"' -- ; run-time -- )  \ core    dot-quote
     state @  IF    postpone (.") ,"  align      postpone (.") ,"  align ; immediate restrict
                     ELSE  [char] " parse type  THEN  ;  immediate  
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
     BEGIN      BEGIN
         >in @ [char] ) parse nip >in @ rot - =          >in @ [char] ) parse nip >in @ rot - =
Line 998  create s"-buffer /line chars allot Line 988  create s"-buffer /line chars allot
   
 \ Header states                                        23feb93py  \ Header states                                        23feb93py
   
 : flag! ( 8b -- )  : cset ( bmask c-addr -- )
     last @ dup 0= abort" last word was headerless"      tuck c@ or swap c! ; 
     cell+ tuck c@ xor swap c! ;  : creset ( bmask c-addr -- )
 : immediate     $20 flag! ;      tuck c@ swap invert and swap c! ; 
 : restrict      $40 flag! ;  : ctoggle ( bmask c-addr -- )
 \ ' noop alias restrict      tuck c@ xor swap c! ; 
   
   : lastflags ( -- c-addr )
       \ the address of the flags byte in the last header
       \ aborts if the last defined word was headerless
       last @ dup 0= abort" last word was headerless" cell+ ;
   
   : immediate     $20 lastflags cset ;
   : restrict      $40 lastflags cset ;
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 1025  defer header ( -- ) \ gforth Line 1023  defer header ( -- ) \ gforth
 : 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,
     name, $80 flag! ;      name, $80 lastflags cset ;
   
 : 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 ;
Line 1041  create nextname-buffer 32 chars allot Line 1039  create nextname-buffer 32 chars allot
     nextname-buffer count      nextname-buffer count
     align here last ! -1 A,      align here last ! -1 A,
     string, cfalign      string, cfalign
     $80 flag!      $80 lastflags cset
     input-stream ;      input-stream ;
   
 \ the next name is given in the string  \ the next name is given in the string
Line 1064  create nextname-buffer 32 chars allot Line 1062  create nextname-buffer 32 chars allot
     lastcfa @ ;      lastcfa @ ;
   
 : Alias    ( cfa "name" -- ) \ gforth  : Alias    ( cfa "name" -- ) \ gforth
   Header reveal , $80 flag! ;      Header reveal
       $80 lastflags creset
       dup A, lastcfa ! ;
   
 : name>string ( nfa -- addr count ) \ gforth    name-to-string  : name>string ( nfa -- addr count ) \ gforth    name-to-string
  cell+ count $1F and ;   cell+ count $1F and ;
Line 1099  Create ???  0 , 3 c, char ? c, char ? c, Line 1099  Create ???  0 , 3 c, char ? c, char ? c,
 \ DOES>                                                17mar93py  \ DOES>                                                17mar93py
   
 : DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does  : DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
     state @      ;-hook postpone (does>) ?struc dodoes,
     IF      defstart :-hook ; immediate restrict
         ;-hook postpone (does>) ?struc dodoes,  
     ELSE  
         align dodoes, here !does ]  
     THEN   
     defstart :-hook ; immediate  
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
Line 1145  Create ???  0 , 3 c, char ? c, char ? c, Line 1140  Create ???  0 , 3 c, char ? c, char ? c,
 \       perform ;  \       perform ;
   
 : IS ( addr "name" -- ) \ gforth  : IS ( addr "name" -- ) \ gforth
     ' >body      ' >body postpone ALiteral postpone ! ; immediate restrict
     state @  
     IF    postpone ALiteral postpone !    
     ELSE  !  
     THEN ;  immediate  
 ' IS Alias TO ( addr "name" -- ) \ core-ext  ' IS Alias TO ( addr "name" -- ) \ core-ext
 immediate  immediate restrict
   
 : What's ( "name" -- addr ) \ gforth  : What's ( "name" -- addr ) \ gforth
     ' >body      ' >body postpone ALiteral postpone @ ; immediate restrict
     state @  
     IF  
         postpone ALiteral postpone @  
     ELSE  
         @  
     THEN ; immediate  
 : Defers ( "name" -- ) \ gforth  : Defers ( "name" -- ) \ gforth
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
   
Line 1245  G -1 warnings T ! Line 1231  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
   : (sfind) ( c-addr u -- nfa | 0 )
       lookup @ (search-wordlist) ;
   
 : sfind ( c-addr u -- xt n / 0 ) \ gforth  : sfind ( c-addr u -- xt n / 0 ) \ gforth
     lookup @ search-wordlist ;      lookup @ search-wordlist ;
   
Line 1266  G -1 warnings T ! Line 1255  G -1 warnings T !
 : '    ( "name" -- addr ) \ core        tick  : '    ( "name" -- addr ) \ core        tick
     name sfind 0= if -&13 bounce then ;      name sfind 0= if -&13 bounce then ;
 : [']  ( compilation "name" -- ; run-time --addr ) \ core       bracket-tick  : [']  ( compilation "name" -- ; run-time --addr ) \ core       bracket-tick
     ' postpone ALiteral ; immediate      ' postpone ALiteral ; immediate restrict
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell ( -- c ) \ gforth  07 constant #bell ( -- c ) \ gforth
Line 1284  G -1 warnings T ! Line 1273  G -1 warnings T !
     #lf ( sic! ) emit ;      #lf ( sic! ) emit ;
   
 \ : backspaces  0 ?DO  #bs emit  LOOP ;  \ : backspaces  0 ?DO  #bs emit  LOOP ;
   
   Variable ^d-mode  -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line
   
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )  : >string  ( span addr pos1 -- span addr pos1 addr2 len )
   over 3 pick 2 pick chars /string ;    over 3 pick 2 pick chars /string ;
 : type-rest ( span addr pos1 -- span addr pos1 back )  : type-rest ( span addr pos1 -- span addr pos1 back )
Line 1299  G -1 warnings T ! Line 1291  G -1 warnings T !
 : (ret)  type-rest drop true space ;  : (ret)  type-rest drop true space ;
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
 : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;  : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
 : eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;  : eof  ^d-mode @  IF
           bye
       ELSE  2 pick over <>
           IF  forw drop (del)  ELSE  #bell emit  THEN  0
       THEN ;
   
 Create ctrlkeys  Create ctrlkeys
   ] false false back  false  eof   false forw  false    ] false false back  false  eof   false forw  false
Line 1317  defer everychar Line 1313  defer everychar
   >r 2over = IF  rdrop bell 0 EXIT  THEN    >r 2over = IF  rdrop bell 0 EXIT  THEN
   r> (ins) 0 ;    r> (ins) 0 ;
   
 \ decode should better use a table for control key actions  
 \ to define keyboard bindings later  
   
 : accept   ( addr len -- len ) \ core  : accept   ( addr len -- len ) \ core
   dup 0< IF    abs over dup 1 chars - c@ tuck type     dup 0< IF    abs over dup 1 chars - c@ tuck type 
 \ this allows to edit given strings  \ this allows to edit given strings
          ELSE  0  THEN rot over           ELSE  0  THEN rot over
   BEGIN  key decode  UNTIL    BEGIN  key decode dup ^d-mode !  UNTIL
   2drop nip ;    2drop nip ;
   
 \ Output                                               13feb93py  \ Output                                               13feb93py

Removed from v.1.56  
changed lines
  Added in v.1.58


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