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

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

version 1.57, 1996/05/07 16:15:22 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
Removed from v.1.57  
changed lines
  Added in v.1.58

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