Diff for /gforth/Attic/kernel.fs between versions 1.13 and 1.20

version 1.13, 1997/02/06 21:23:01 version 1.20, 1997/03/21 12:21:13
Line 24  HEX Line 24  HEX
   
 \ labels for some code addresses  \ labels for some code addresses
   
   doer? :docon [IF]
 : docon: ( -- addr )    \ gforth  : docon: ( -- addr )    \ gforth
     \G the code address of a @code{CONSTANT}      \G the code address of a @code{CONSTANT}
     ['] bl >code-address ;      ['] bl >code-address ;
   [THEN]
   
 : docol: ( -- addr )    \ gforth  : docol: ( -- addr )    \ gforth
     \G the code address of a colon definition      \G the code address of a colon definition
     ['] docon: >code-address ;      ['] docol: >code-address ;
   
   doer? :dovar [IF]
 : dovar: ( -- addr )    \ gforth  : dovar: ( -- addr )    \ gforth
     \G the code address of a @code{CREATE}d word      \G the code address of a @code{CREATE}d word
     ['] udp >code-address ;      ['] udp >code-address ;
   [THEN]
   
   doer? :douser [IF]
 : douser: ( -- addr )   \ gforth  : douser: ( -- addr )   \ gforth
     \G the code address of a @code{USER} variable      \G the code address of a @code{USER} variable
     ['] s0 >code-address ;      ['] s0 >code-address ;
   [THEN]
   
   doer? :dodefer [IF]
 : dodefer: ( -- addr )  \ gforth  : dodefer: ( -- addr )  \ gforth
     \G the code address of a @code{defer}ed word      \G the code address of a @code{defer}ed word
     ['] source >code-address ;      ['] source >code-address ;
   [THEN]
   
   doer? :dofield [IF]
 : dofield: ( -- addr )  \ gforth  : dofield: ( -- addr )  \ gforth
     \G the code address of a @code{field}      \G the code address of a @code{field}
     ['] reveal-method >code-address ;      ['] reveal-method >code-address ;
   [THEN]
   
   has-prims 0= [IF]
   : dodoes: ( -- addr )   \ gforth
       \G the code address of a @code{field}
       ['] spaces >code-address ;
   [THEN]
   
 NIL AConstant NIL \ gforth  NIL AConstant NIL \ gforth
   
 \ Aliases  \ Aliases
   
 ' i Alias r@  ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
   \ copy w from the return stack to the data stack
   
 \ Bit string manipulation                              06oct92py  \ Bit string manipulation                              06oct92py
   
Line 96  NIL AConstant NIL \ gforth Line 113  NIL AConstant NIL \ gforth
     LOOP ;      LOOP ;
   
 \ !! this is machine-dependent, but works on all but the strangest machines  \ !! this is machine-dependent, but works on all but the strangest machines
 ' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth  
 ' falign Alias maxalign ( -- ) \ gforth  : maxaligned ( addr -- f-addr ) \ float
       [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
   : maxalign ( -- ) \ float
       here dup maxaligned swap
       ?DO
           bl c,
       LOOP ;
   
 \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"  \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
 ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth  ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
Line 242  Defer source ( -- addr count ) \ core Line 265  Defer source ( -- addr count ) \ core
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 : postpone, ( w xt -- )  : postpone, ( w xt -- ) \ gforth postpone-comma
     \g Compiles the compilation semantics represented by @var{w xt}.      \g Compiles the compilation semantics represented by @var{w xt}.
     dup ['] execute =      dup ['] execute =
     if      if
Line 407  hex Line 430  hex
   
 : #s      ( +d -- 0 0 ) \ core  number-sign-s  : #s      ( +d -- 0 0 ) \ core  number-sign-s
     BEGIN      BEGIN
         # 2dup d0=          # 2dup or 0=
     UNTIL ;      UNTIL ;
   
 \ print numbers                                        07jun92py  \ print numbers                                        07jun92py
Line 440  hex Line 463  hex
 \ !! allow the user to add rollback actions    anton  \ !! allow the user to add rollback actions    anton
 \ !! use a separate exception stack?           anton  \ !! use a separate exception stack?           anton
   
   has-locals [IF]
 : lp@ ( -- addr ) \ gforth      l-p-fetch  : lp@ ( -- addr ) \ gforth      l-p-fetch
  laddr# [ 0 , ] ;   laddr# [ 0 , ] ;
   [THEN]
   
 Defer 'catch  Defer 'catch
 Defer 'throw  Defer 'throw
 Defer 'bounce  
   
 ' noop IS 'catch  ' noop IS 'catch
 ' noop IS 'throw  ' noop IS 'throw
Line 453  Defer 'bounce Line 477  Defer 'bounce
 : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception  : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
     'catch      'catch
     sp@ >r      sp@ >r
   [ has-floats [IF] ]
     fp@ >r      fp@ >r
   [ [THEN] ]
   [ has-locals [IF] ]
     lp@ >r      lp@ >r
   [ [THEN] ]
     handler @ >r      handler @ >r
     rp@ handler !      rp@ handler !
     execute      execute
Line 462  Defer 'bounce Line 490  Defer 'bounce
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
     ?DUP IF      ?DUP IF
         [ here 9 cells ! ] \ entry point for signal handler          [ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
         handler @ dup 0= IF          handler @ dup 0= IF
   [ has-os [IF] ]
             2 (bye)              2 (bye)
   [ [ELSE] ]
               quit
   [ [THEN] ]
         THEN          THEN
         rp!          rp!
         r> handler !          r> handler !
         r> lp!  [ has-locals [IF] ]
           r> lp!
   [ [THEN] ]
   [ has-floats [IF] ]
         r> fp!          r> fp!
   [ [THEN] ]
         r> swap >r sp! drop r>          r> swap >r sp! drop r>
         'throw          'throw
     THEN ;      THEN ;
Line 481  Defer 'bounce Line 517  Defer 'bounce
   ?DUP IF    ?DUP IF
       handler @ rp!        handler @ rp!
       r> handler !        r> handler !
   [ has-locals [IF] ]
       r> lp!        r> lp!
   [ [THEN] ]
   [ has-floats [IF] ]
       rdrop        rdrop
   [ [THEN] ]
       rdrop        rdrop
       'throw        'throw
   THEN ;    THEN ;
Line 491  Defer 'bounce Line 531  Defer 'bounce
   
 : ?stack ( ?? -- ?? ) \ gforth  : ?stack ( ?? -- ?? ) \ gforth
     sp@ s0 @ u> IF    -4 throw  THEN      sp@ s0 @ u> IF    -4 throw  THEN
     fp@ f0 @ u> IF  -&45 throw  THEN  ;  [ has-floats [IF] ]
       fp@ f0 @ u> IF  -&45 throw  THEN
   [ [THEN] ]
   ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
Line 705  Create ???  0 , 3 c, char ? c, char ? c, Line 748  Create ???  0 , 3 c, char ? c, char ? c,
 : !does    ( addr -- ) \ gforth store-does  : !does    ( addr -- ) \ gforth store-does
     lastxt does-code! ;      lastxt does-code! ;
 : (does>)  ( R: addr -- )  : (does>)  ( R: addr -- )
     r> /does-handler + !does ;      r> cfaligned /does-handler + !does ;
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    cfalign here /does-handler allot does-handler! ;
   
   doer? :dovar [IF]
 : Create ( "name" -- ) \ core  : Create ( "name" -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
   [ELSE]
   : Create ( "name" -- ) \ core
       Header reveal here lastcfa ! 0 A, 0 , DOES> ;
   [THEN]
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
Line 718  Create ???  0 , 3 c, char ? c, char ? c, Line 766  Create ???  0 , 3 c, char ? c, char ? c,
     Create 0 , ;      Create 0 , ;
 : AVariable ( "name" -- ) \ gforth  : AVariable ( "name" -- ) \ gforth
     Create 0 A, ;      Create 0 A, ;
 : 2VARIABLE ( "name" -- ) \ double  : 2Variable ( "name" -- ) \ double
     create 0 , 0 , ;      create 0 , 0 , ;
       
   : uallot ( n -- )  udp @ swap udp +! ;
   
   doer? :douser [IF]
 : User ( "name" -- ) \ gforth  : User ( "name" -- ) \ gforth
     Variable ;      Header reveal douser: cfa, cell uallot , ;
 : AUser ( "name" -- ) \ gforth  : AUser ( "name" -- ) \ gforth
     AVariable ;      User ;
   [ELSE]
 : (Constant)  Header reveal docon: cfa, ;  : User Create uallot , DOES> @ up @ + ;
   : AUser User ;
   [THEN]
   
   doer? :docon [IF]
       : (Constant)  Header reveal docon: cfa, ;
   [ELSE]
       : (Constant)  Create DOES> @ ;
   [THEN]
 : Constant ( w "name" -- ) \ core  : Constant ( w "name" -- ) \ core
     \G Defines constant @var{name}      \G Defines constant @var{name}
     \G        \G  
Line 734  Create ???  0 , 3 c, char ? c, char ? c, Line 793  Create ???  0 , 3 c, char ? c, char ? c,
     (Constant) , ;      (Constant) , ;
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   : Value ( w "name" -- ) \ core-ext
       (Constant) , ;
   
 : 2Constant ( w1 w2 "name" -- ) \ double  : 2Constant ( w1 w2 "name" -- ) \ double
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
Line 741  Create ???  0 , 3 c, char ? c, char ? c, Line 802  Create ???  0 , 3 c, char ? c, char ? c,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
         2@ ;          2@ ;
           
   doer? :dofield [IF]
       : (Field)  Header reveal dofield: cfa, ;
   [ELSE]
       : (Field)  Create DOES> @ + ;
   [THEN]
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
   doer? :dodefer [IF]
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
 \     Create ( -- )   [ELSE]
 \       ['] noop A,  : Defer ( "name" -- ) \ gforth
 \     DOES> ( ??? )      Create ['] noop A,
 \       perform ;  DOES> @ execute ;
   [THEN]
   
 : Defers ( "name" -- ) \ gforth  : Defers ( "name" -- ) \ gforth
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
Line 894  end-struct interpret/compile-struct Line 962  end-struct interpret/compile-struct
         then          then
     then ;      then ;
   
 : find ( c-addr -- xt +-1 / c-addr 0 ) \ core  : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
     dup count sfind dup      dup count sfind dup
     if      if
         rot drop          rot drop
Line 970  G -1 warnings T ! Line 1038  G -1 warnings T !
 0C constant #ff ( -- c ) \ gforth  0C constant #ff ( -- c ) \ gforth
 0A constant #lf ( -- c ) \ gforth  0A constant #lf ( -- c ) \ gforth
   
 : bell  #bell emit ;  : bell ( -- ) \ gforth
       \g makes a beep and flushes the output buffer
       #bell emit
       outfile-id flush-file drop ;
 : cr ( -- ) \ core  : cr ( -- ) \ core
     \ emit a newline      \ emit a newline
     #lf ( sic! ) emit ;      #lf ( sic! ) emit ;
Line 983  G -1 warnings T ! Line 1054  G -1 warnings T !
     dup IF      dup IF
         #bs emit bl emit #bs emit 1- rot 1- -rot          #bs emit bl emit #bs emit 1- rot 1- -rot
     THEN false ;      THEN false ;
 : (ret)  true space ;  : (ret)  true bl emit ;
   
 Create ctrlkeys  Create ctrlkeys
   ] false false false false  false false false false    ] false false false false  false false false false
Line 1006  defer everychar Line 1077  defer everychar
 : 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  UNTIL
   2drop nip ;    2drop nip ;
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
   has-os [IF]
   0 Value outfile-id ( -- file-id ) \ gforth
   
 : (type) ( c-addr u -- ) \ gforth  : (type) ( c-addr u -- ) \ gforth
     outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?      outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
 ;  ;
   
 Defer type ( c-addr u -- ) \ core  
 \ defer type for a output buffer or fast  
 \ screen write  
   
 ' (type) IS Type  
   
 : (emit) ( c -- ) \ gforth  : (emit) ( c -- ) \ gforth
     outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?      outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
 ;  ;
   [THEN]
   
   Defer type ( c-addr u -- ) \ core
   ' (type) IS Type
   
 Defer emit ( c -- ) \ core  Defer emit ( c -- ) \ core
 ' (Emit) IS Emit  ' (Emit) IS Emit
Line 1034  Defer key ( -- c ) \ core Line 1106  Defer key ( -- c ) \ core
   
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
   has-files 0= [IF]
   : sourceline# ( -- n )  loadline @ ;
   [THEN]
   
 : refill ( -- flag ) \ core-ext,block-ext,file-ext  : refill ( -- flag ) \ core-ext,block-ext,file-ext
   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN    blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
   [ has-files [IF] ]
   loadfile @ ?dup    loadfile @ ?dup
   IF    read-line throw    IF    read-line throw
   ELSE  sourceline# 0< IF 2drop false EXIT THEN    ELSE
         accept true  [ [THEN] ]
         sourceline# 0< IF 2drop false EXIT THEN
         accept true
   [ has-files [IF] ]
   THEN    THEN
   [ [THEN] ]
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
Line 1052  Defer key ( -- c ) \ core Line 1133  Defer key ( -- c ) \ core
   
 \ save-mem extend-mem  \ save-mem extend-mem
   
   has-os [IF]
 : save-mem      ( addr1 u -- addr2 u ) \ gforth  : save-mem      ( addr1 u -- addr2 u ) \ gforth
     \g copy a memory block into a newly allocated region in the heap      \g copy a memory block into a newly allocated region in the heap
     swap >r      swap >r
Line 1063  Defer key ( -- c ) \ core Line 1145  Defer key ( -- c ) \ core
     \ the (possibly reallocated piece is addr2 u2, the extension is at addr      \ the (possibly reallocated piece is addr2 u2, the extension is at addr
     over >r + dup >r resize throw      over >r + dup >r resize throw
     r> over r> + -rot ;      r> over r> + -rot ;
   [THEN]
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 1096  Defer key ( -- c ) \ core Line 1179  Defer key ( -- c ) \ core
   
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
   has-files 0= [IF]
   : push-file  ( -- )  r>
     sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
     >tib @ tibstack @ = IF  r@ tibstack +!  THEN
     tibstack @ >tib ! >in @ >r  >r ;
   
   : pop-file   ( throw-code -- throw-code )
     r>
     r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;
   [THEN]
   
 : evaluate ( c-addr len -- ) \ core,block  : evaluate ( c-addr len -- ) \ core,block
   push-file  #tib ! >tib !    push-file  #tib ! >tib !
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
Line 1115  Defer .status Line 1209  Defer .status
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 : (Query)  ( -- )  : (Query)  ( -- )
     loadfile off  blk off  refill drop ;      loadfile off  blk off  refill drop ;
 : (quit)        BEGIN .status cr (query) interpret prompt AGAIN ;  : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
Line 1171  DEFER DOERROR Line 1265  DEFER DOERROR
 ;  ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
     [ has-os [IF] ] stderr to outfile-id [ [THEN] ] 
   sourceline# IF    sourceline# IF
                source >in @ sourceline# 0 0 .error-frame                 source >in @ sourceline# 0 0 .error-frame
   THEN    THEN
Line 1192  DEFER DOERROR Line 1287  DEFER DOERROR
   ELSE    ELSE
      .error       .error
   THEN    THEN
   normal-dp dpp ! ;    normal-dp dpp !
     [ has-os [IF] ] stdout to outfile-id [ [THEN] ] 
   ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
Line 1211  DEFER DOERROR Line 1308  DEFER DOERROR
 \ : .name ( name -- ) name>string type space ;  \ : .name ( name -- ) name>string type space ;
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
 Defer 'cold ' noop IS 'cold  Defer 'cold ( -- ) \ gforth tick-cold
   \ hook (deferred word) for things to do right before interpreting the
   \ command-line arguments
   ' noop IS 'cold
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
     stdout TO outfile-id  [ has-files [IF] ]
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
     init-included-files      init-included-files
   [ [THEN] ]
     'cold      'cold
   [ has-files [IF] ]
     argc @ 1 >      argc @ 1 >
     IF      IF
         ['] process-args catch ?dup          ['] process-args catch ?dup
Line 1226  Defer 'cold ' noop IS 'cold Line 1328  Defer 'cold ' noop IS 'cold
         THEN          THEN
         cr          cr
     THEN      THEN
   [ [THEN] ]
     ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr      ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr      ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
     ." Type `bye' to exit"  [ has-os [IF] ]
        cr ." Type `bye' to exit"
   [ [THEN] ]
     loadline off quit ;      loadline off quit ;
   
 : license ( -- ) \ gforth  : license ( -- ) \ gforth
Line 1248  Defer 'cold ' noop IS 'cold Line 1353  Defer 'cold ' noop IS 'cold
  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;   ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! pathstring 2!  main-task up!      main-task up!
   sp@ s0 !  [ has-os [IF] ]
   lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off      stdout TO outfile-id
   rp@ r0 !  [ [THEN] ]
   fp@ f0 !  [ has-files [IF] ]
   ['] cold catch DoError      argc ! argv ! pathstring 2!
   bye ;  [ [THEN] ]
       sp@ s0 !
   [ has-locals [IF] ]
       lp@ forthstart 7 cells + @ - 
   [ [ELSE] ]
       [ has-os [IF] ]
       sp@ $1040 +
       [ [ELSE] ]
       sp@ $40 +
       [ [THEN] ]
   [ [THEN] ]
       dup >tib ! tibstack ! #tib off >in off
       rp@ r0 !
   [ has-floats [IF] ]
       fp@ f0 !
   [ [THEN] ]
       ['] cold catch DoError
   [ has-os [IF] ]
       bye
   [ [THEN] ]
   ;
   
   has-os [IF]
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;  [ has-files [IF] ]
       script? 0= IF  cr  THEN
   [ [ELSE] ]
       cr
   [ [THEN] ]
       0 (bye) ;
   [THEN]
   
 \ **argv may be scanned by the C starter to get some important  \ **argv may be scanned by the C starter to get some important
 \ information, as -display and -geometry for an X client FORTH  \ information, as -display and -geometry for an X client FORTH

Removed from v.1.13  
changed lines
  Added in v.1.20


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