[gforth] / gforth / Attic / kernal.fs  

gforth: gforth/Attic/kernal.fs

Diff for /gforth/Attic/kernal.fs between version 1.4 and 1.5

version 1.4, Thu May 5 15:46:46 1994 UTC version 1.5, Sat May 7 14:55:58 1994 UTC
Line 45 
Line 45 
   
 \ here allot , c, A,                                   17dec92py  \ here allot , c, A,                                   17dec92py
   
   : dp    ( -- addr )  dpp @ ;
 : here  ( -- here )  dp @ ;  : here  ( -- here )  dp @ ;
 : allot ( n -- )     dp +! ;  : allot ( n -- )     dp +! ;
 : c,    ( c -- )     here 1 chars allot c! ;  : c,    ( c -- )     here 1 chars allot c! ;
Line 243 
Line 244 
 \ !! 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
   
   : lp@ ( -- addr )
    laddr# [ 0 , ] ;
   
 : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )  : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
   >r sp@ r> swap        \ don't count xt! jaw    >r sp@ r> swap >r       \ don't count xt! jaw
   >r handler @ >r rp@ handler ! execute    fp@ >r
   r> handler ! rdrop 0 ;    lp@ >r
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn )    handler @ >r
   dup 0= IF  drop EXIT  THEN    rp@ handler !
   handler @ rp!  r> handler ! r> swap >r sp! r> ;    execute
     r> handler ! rdrop rdrop 0 ;
   : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
     ?DUP IF
       handler @ rp!
       r> handler !
       r> lp!
       r> fp!
       r> swap >r sp! r>
     THEN ;
 \ Bouncing is very fine,  \ Bouncing is very fine,
 \ programming without wasting time...   jaw  \ programming without wasting time...   jaw
 : bounce ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn )  : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
 \ a throw without data stack restauration? anton !! stack diagram bad  \ a throw without data or fp stack restauration
   dup 0= IF  drop EXIT  THEN    ?DUP IF
   handler @ rp!  r> handler ! r> drop ;      handler @ rp!
       r> handler !
       r> lp!
       rdrop
       rdrop
     THEN ;
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
Line 330 
Line 348 
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
   variable locals-size \ this is the current size of the locals stack
                        \ frame of the current word
   
   : compile-lp+!# ( n -- )
       ?DUP IF
           dup negate locals-size +!
           postpone lp+!#  ,
       THEN ;
   
   \ : EXIT ( -- )
   \     locals-size @ compile-lp+!# POSTPONE ;s ; immediate restrict
   \ : ?EXIT ( -- )
   \     postpone IF postpone EXIT postpone THEN ; immediate restrict
   
 Variable leavings  Variable leavings
   
 : (leave)   here  leavings @ ,  leavings ! ;  : (leave)   here  leavings @ ,  leavings ! ;
 : LEAVE     postpone branch  (leave) ;  immediate restrict  : LEAVE     postpone branch  (leave) ;  immediate restrict
 : ?LEAVE    postpone 0= postpone ?branch  (leave) ;  : ?LEAVE    postpone 0= postpone ?branch  (leave) ;
                                              immediate restrict                                               immediate restrict
   : DONE   ( addr -- )
 : DONE   ( addr -- )  leavings @    leavings @
   BEGIN  2dup u<=  WHILE  dup @ swap >resolve  REPEAT    BEGIN
       2dup u<=
     WHILE
       dup @ swap >resolve
     REPEAT
   leavings ! drop ;                          immediate restrict    leavings ! drop ;                          immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
Line 411 
Line 447 
 ' input-stream-header IS header  ' input-stream-header IS header
   
 \ !! make that a 2variable  \ !! make that a 2variable
 create nextname-string 2 cells allot \ should we use a buffer that keeps the name?  create nextname-buffer 32 chars allot
   
 : nextname-header ( -- )  : nextname-header ( -- )
     \ !! f83-implementation-dependent      \ !! f83-implementation-dependent
     nextname-string 2@      nextname-buffer count
     align here last ! -1 A,      align here last ! -1 A,
     dup c,  here swap chars  dup allot  move  align      dup c,  here swap chars  dup allot  move  align
     $80 flag!      $80 flag!
Line 423 
Line 459 
   
 \ the next name is given in the string  \ the next name is given in the string
 : nextname ( c-addr u -- ) \ general  : nextname ( c-addr u -- ) \ general
     nextname-string 2!      dup 31 u> -19 and throw ( is name too long? )
       nextname-buffer c! ( c-addr )
       nextname-buffer count move
     ['] nextname-header IS header ;      ['] nextname-header IS header ;
   
 : noname-header ( -- )  : noname-header ( -- )
Line 470 
Line 508 
   
 \ DOES>                                                17mar93py  \ DOES>                                                17mar93py
   
 : DOES>  state @ IF    postpone (;code) dodoes,  : DOES>  ( compilation: -- )
                  ELSE  dodoes, here !does 0 ] THEN ; immediate      state @
       IF
           ;-hook postpone (;code) dodoes,
       ELSE
           dodoes, here !does 0 ]
       THEN
       :-hook ; immediate
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
Line 486 
Line 530 
 : (Constant)  Header reveal [ :docon ] Literal cfa, ;  : (Constant)  Header reveal [ :docon ] Literal cfa, ;
 : Constant  (Constant) , ;  : Constant  (Constant) , ;
 : AConstant (Constant) A, ;  : AConstant (Constant) A, ;
 : 2Constant ( w1 w2 "name" -- ) \ double  
   Create 2, DOES> 2@ ;  : 2CONSTANT
       create ( w1 w2 "name" -- )
           2,
       does> ( -- w1 w2 )
           2@ ;
   
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer  Create ['] noop A,  DOES> @ execute ;  : Defer
     Create ( -- )
       ['] noop A,
     DOES> ( ??? )
       @ execute ;
   
 : IS ( addr "name" -- )  : IS ( addr "name" -- )
     ' >body      ' >body
Line 509 
Line 561 
   
 \ : ;                                                  24feb93py  \ : ;                                                  24feb93py
   
   defer :-hook ( sys1 -- sys2 )
   defer ;-hook ( sys2 -- sys1 )
   
 : EXIT  ( -- )  postpone ;s ;  immediate  : EXIT  ( -- )  postpone ;s ;  immediate
   
 : : ( -- colon-sys )  Header [ :docol ] Literal cfa, 0 ] ;  : : ( -- colon-sys )  Header [ :docol ] Literal cfa, 0 ] :-hook ;
 : ; ( colon-sys -- )  ?struc postpone exit reveal postpone [ ;  : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
   immediate restrict    immediate restrict
 : :noname ( -- xt colon-sys )  here [ :docol ] Literal cfa, 0 ] ;  
   : :noname ( -- xt colon-sys )  here [ :docol ] Literal cfa, 0 ] :-hook ;
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
 AVariable current  AVariable current
   
 : last?   ( -- false / nfa nfa )    last @ ?dup ;  : last?   ( -- false / nfa nfa )    last @ ?dup ;
 : (reveal) ( -- ) last?  : (reveal) ( -- )
   IF  dup @ 0<    last?
       IF    current @ @ over ! current @ !    IF
       ELSE  drop  THEN THEN ;        dup @ 0<
         IF
           current @ @ over ! current @ !
         ELSE
           drop
         THEN
     THEN ;
   
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
 \ Search list table: find reveal  \ word list structure:
   \ struct
   \   1 cells: field find-method \ xt: ( c_addr u w1 -- name-id ) w1 is a method-\ specific wordlist-id (not the same as wid)
   \   1 cells: field reveal-method \ xt: ( -- )
   \   \ !! what else
   \ end-struct wordlist-map-struct
   
   \ struct
   \   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
   \   1 cells: field wordlist-map \ pointer to a wordlist-map-struct
   \   1 cells: field ????
   \   1 cells: field ????
   \ end-struct wordlist-struct
   
   
   \ Search list table: find reveal
 Create f83search    ' (f83find) A,  ' (reveal) A,  Create f83search    ' (f83find) A,  ' (reveal) 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 search       G forth-wordlist search T !  AVariable search       G forth-wordlist search T !
Line 750 
Line 826 
 DEFER DOERROR  DEFER DOERROR
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
          LoadFile @ IF ." Error in line: " Loadline @ . cr THEN           LoadFile @
            IF
                   ." Error in line: " Loadline @ . cr
            THEN
          cr source type cr           cr source type cr
          source drop >in @ -trailing           source drop >in @ -trailing
          here c@ 1F min dup >r - 1- 0 max nip           here c@ 1F min dup >r - 1- 0 max nip
          dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^"           dup spaces
            IF
                   ." ^"
            THEN
            r> 0 ?DO
                   ." -"
            LOOP
            ." ^"
          dup -2 =           dup -2 =
          IF "error @ ?dup IF cr count type THEN drop           IF
          ELSE .error THEN ;                  "error @ ?dup
                   IF
                           cr count type
                   THEN
                   drop
            ELSE
                   .error
            THEN
            normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
 : quit   r0 @ rp! handler off >tib @ >r  : quit   r0 @ rp! handler off >tib @ >r
   BEGIN  postpone [  ['] 'quit catch dup  WHILE    BEGIN
       postpone [
       ['] 'quit CATCH dup
     WHILE
          DoError r@ >tib !           DoError r@ >tib !
   REPEAT  drop r> >tib ! ;    REPEAT
     drop r> >tib ! ;
   
 \ Cold                                                 13feb93py  \ Cold                                                 13feb93py
   
Line 787 
Line 885 
   
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;  : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;
   
 : cold ( -- )  argc @ 1 >  : cold ( -- )
     argc @ 1 >
   IF  script?    IF  script?
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN        IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN
       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN        catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN

Generate output suitable for use with a patch program
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help