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

version 1.56, 1996/05/06 12:39:02 version 1.59, 1996/05/13 16:37:00
Line 145  HEX Line 145  HEX
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
   $80 constant alias-mask \ set when the word is not an alias!
   $40 constant immediate-mask
   $20 constant restrict-mask
   
 : (name>)  ( nfa+cell -- cfa )  : (name>)  ( nfa+cell -- cfa )
     1 cells - name>string +  cfaligned ;      1 cells - name>string +  cfaligned ;
 : name>    ( nfa -- cfa ) \ gforth  : name>    ( nfa -- cfa ) \ gforth
     cell+      cell+
     dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;      dup  (name>) swap  c@ alias-mask and 0= IF  @ THEN ;
   
 : found ( nfa -- cfa n ) \ gforth  : found ( nfa -- cfa n ) \ gforth
     cell+      cell+
     dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN      dup c@ >r  (name>) r@ alias-mask     and  0= IF  @       THEN
                     -1 r@ $40 and     IF  1-      THEN                      -1 r@ restrict-mask  and     IF  1-      THEN
                        r> $20 and     IF  negate  THEN  ;                         r> immediate-mask and     IF  negate  THEN  ;
   
 \ (find)                                               17dec92py  \ (find)                                               17dec92py
   
Line 247  Defer source ( -- addr count ) \ core Line 251  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 486  Defer parser Line 488  Defer parser
 Defer name ( -- c-addr count ) \ gforth  Defer name ( -- c-addr count ) \ gforth
 \ get the next word from the input buffer  \ get the next word from the input buffer
 ' (name) IS name  ' (name) IS name
 Defer notfound ( c-addr count -- )  Defer compiler-notfound ( c-addr count -- )
   Defer interpreter-notfound ( c-addr count -- )
   
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 bounce ;      2drop -&13 bounce ;
 ' no.extensions IS notfound  ' no.extensions IS compiler-notfound
   ' no.extensions IS interpreter-notfound
   
 : compile-only ( ... -- )  : compile-only ( ... -- )
     -&14 throw ;      -&14 throw ;
Line 523  Defer interpret-special ( c-addr u xt -- Line 527  Defer interpret-special ( c-addr u xt --
     IF      IF
         2rdrop          2rdrop
     ELSE      ELSE
         2r> notfound          2r> interpreter-notfound
     THEN ;      THEN ;
   
 ' interpreter  IS  parser  ' interpreter  IS  parser
Line 548  Defer interpret-special ( c-addr u xt -- Line 552  Defer interpret-special ( c-addr u xt --
         postpone Literal          postpone Literal
         2drop          2drop
     ELSE      ELSE
         drop notfound          drop compiler-notfound
     THEN ;      THEN ;
   
 : [ ( -- ) \ core       left-bracket  : [ ( -- ) \ core       left-bracket
Line 953  Avariable leave-sp  leave-stack 3 cells Line 957  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 994  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     immediate-mask lastflags cset ;
   : restrict      restrict-mask lastflags cset ;
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 1019  defer header ( -- ) \ gforth Line 1023  defer header ( -- ) \ gforth
     \ puts down string as cstring      \ puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : name,  ( "name" -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
     name name-too-short? name-too-long?      name-too-long?
     string, cfalign ;      align here last !
 : input-stream-header ( "name" -- )      current @ 1 or A,   \ link field; before revealing, it contains the
     \ !! this is f83-implementation-dependent                          \ tagged reveal-into wordlist
     align here last !  -1 A,      string, cfalign
     name, $80 flag! ;      alias-mask lastflags cset ;
   
   : input-stream-header ( "name" -- )
       name name-too-short? 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) ;
Line 1037  defer header ( -- ) \ gforth Line 1043  defer header ( -- ) \ gforth
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
   
 : nextname-header ( -- )  : nextname-header ( -- )
     \ !! f83-implementation-dependent      nextname-buffer count header,
     nextname-buffer count  
     align here last ! -1 A,  
     string, cfalign  
     $80 flag!  
     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 1066  create nextname-buffer 32 chars allot
     lastcfa @ ;      lastcfa @ ;
   
 : Alias    ( cfa "name" -- ) \ gforth  : Alias    ( cfa "name" -- ) \ gforth
   Header reveal , $80 flag! ;      Header reveal
       alias-mask 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 1072  create nextname-buffer 32 chars allot Line 1076  create nextname-buffer 32 chars allot
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa ) \ gforth to-name  : >name ( cfa -- nfa ) \ gforth to-name
  $21 cell do   $21 cell do
    dup i - count $9F and + cfaligned over $80 + = if     dup i - count $9F and + cfaligned over alias-mask + = if
      i - cell - unloop exit       i - cell - unloop exit
    then     then
  cell +loop   cell +loop
Line 1099  Create ???  0 , 3 c, char ? c, char ? c, Line 1103  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 1144  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 1184  AVariable current ( -- addr ) \ gforth Line 1174  AVariable current ( -- addr ) \ gforth
   
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     last @ ?dup ;      last @ ?dup ;
 : (reveal) ( -- )  : (reveal) ( nfa wid -- )
     last?      ( wid>wordlist-id ) dup >r
     IF      @ over ( name>link ) ! 
         dup @ 0<      r> ! ;
         IF  
             current @ @ over ! current @ !  
         ELSE  
             drop  
         THEN  
     THEN ;  
   
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
Line 1201  AVariable current ( -- addr ) \ gforth Line 1185  AVariable current ( -- addr ) \ gforth
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
   1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field    1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
Line 1213  struct Line 1197  struct
   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )
       ( wid>wordlist-id ) @ (f83find) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,  Create f83search ( -- wordlist-map )
       ' 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 lookup       G forth-wordlist lookup T !  AVariable lookup       G forth-wordlist lookup T !
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 1255  G -1 warnings T ! Line 1244  G -1 warnings T !
     then ;      then ;
   
 : reveal ( -- ) \ gforth  : reveal ( -- ) \ gforth
  last? if      last?
    name>string current @ check-shadow      if \ the last word has a header
  then          dup ( name>link ) @ 1 and
  current @ wordlist-map @ reveal-method perform ;          if \ it is still hidden
               dup ( name>link ) @ 1 xor           ( nfa wid )
               2dup >r name>string r> check-shadow ( nfa wid )
               dup wordlist-map @ reveal-method perform
           then
       then ;
   
 : rehash  ( wid -- )  : rehash  ( wid -- )
     dup wordlist-map @ rehash-method perform ;      dup wordlist-map @ rehash-method perform ;
Line 1266  G -1 warnings T ! Line 1260  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 1278  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 1296  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 1318  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
Line 1579  create image-included-files  1 , A, ( po Line 1577  create image-included-files  1 , A, ( po
   
 : recurse ( compilation -- ; run-time ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
     lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
 : recursive ( -- ) \ gforth  ' reveal alias recursive ( -- ) \ gforth
     reveal last off ; immediate          immediate
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   

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


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