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

Diff for /gforth/Attic/kernal.fs between versions 1.20 and 1.25

version 1.20, 1994/09/12 19:00:32 version 1.25, 1994/11/15 16:54:56
Line 1 Line 1
 \ KERNAL.FS    ANS figFORTH kernal                     17dec92py  \ KERNAL.FS    GNU FORTH kernal                        17dec92py
 \ $ID:  \ $ID:
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  \ Copyright 1992 by the ANSI figForth Development Group
Line 66  DOES> ( n -- )  + c@ ; Line 66  DOES> ( n -- )  + c@ ;
       bl c,        bl c,
   LOOP ;    LOOP ;
   
   : chars ; immediate
   
 : A!    ( addr1 addr2 -- )  dup relon ! ;  : A!    ( addr1 addr2 -- )  dup relon ! ;
 : A,    ( addr -- )     here cell allot A! ;  : A,    ( addr -- )     here cell allot A! ;
Line 173  Defer source Line 173  Defer source
 : [char] ( 'char' -- n )  char postpone Literal ; immediate  : [char] ( 'char' -- n )  char postpone Literal ; immediate
 ' [char] Alias Ascii immediate  ' [char] Alias Ascii immediate
   
 : (compile) ( -- )  r> dup cell+ >r @ A, ;  : (compile) ( -- )  r> dup cell+ >r @ compile, ;
 : postpone ( "name" -- )  : postpone ( "name" -- )
   name sfind dup 0= abort" Can't compile "    name sfind dup 0= abort" Can't compile "
   0> IF  A,  ELSE  postpone (compile) A,  THEN ;    0> IF  compile,  ELSE  postpone (compile) A,  THEN ;
                                              immediate restrict                                               immediate restrict
   
 \ Use (compile) for the old behavior of compile!  \ Use (compile) for the old behavior of compile!
Line 244  decimal Line 244  decimal
 Create spaces  bl 80 times \ times from target compiler! 11may93jaw  Create spaces  bl 80 times \ times from target compiler! 11may93jaw
 DOES>   ( u -- )  swap  DOES>   ( u -- )  swap
         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;          0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
   Create backspaces  08 80 times \ times from target compiler! 11may93jaw
   DOES>   ( u -- )  swap
           0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
 hex  hex
 : space   1 spaces ;  : space   1 spaces ;
   
Line 417  AConstant locals-list \ acts like a vari Line 420  AConstant locals-list \ acts like a vari
   
   
 variable dead-code \ true if normal code at "here" would be dead  variable dead-code \ true if normal code at "here" would be dead
   variable backedge-locals
 : unreachable ( -- )      \ contains the locals list that BEGIN will assume to be live on
 \ declares the current point of execution as unreachable      \ the back edge if the BEGIN is unreachable from above. Set by
  dead-code on ;      \ ASSUME-LIVE, reset by UNREACHABLE.
   
   : UNREACHABLE ( -- )
       \ declares the current point of execution as unreachable
       dead-code on
       0 backedge-locals ! ; immediate
   
   : ASSUME-LIVE ( orig -- orig )
       \ used immediateliy before a BEGIN that is not reachable from
       \ above.  causes the BEGIN to assume that the same locals are live
       \ as at the orig point
       dup orig?
       2 pick backedge-locals ! ; immediate
       
 \ locals list operations  \ locals list operations
   
 : common-list ( list1 list2 -- list3 )  : common-list ( list1 list2 -- list3 )
Line 546  variable dead-code \ true if normal code Line 561  variable dead-code \ true if normal code
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : AHEAD ( -- orig )  : AHEAD ( -- orig )
  POSTPONE branch >mark unreachable ; immediate restrict   POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
   
 : IF ( -- orig )  : IF ( -- orig )
  POSTPONE ?branch >mark ; immediate restrict   POSTPONE ?branch >mark ; immediate restrict
Line 588  variable dead-code \ true if normal code Line 603  variable dead-code \ true if normal code
   
 : BEGIN ( -- dest )  : BEGIN ( -- dest )
     dead-code @ if      dead-code @ if
         \ set up an assumption of the locals visible here          \ set up an assumption of the locals visible here.  if the
         \ currently we just take the top cs-item          \ users want something to be visible, they have to declare
         \ it would be more intelligent to take the top orig          \ that using ASSUME-LIVE
         \   but that can be arranged by the user          backedge-locals @ set-locals-size-list
         dup defstart <> if  
             dup cs-item?  
             2 pick  
         else  
             0  
         then  
         set-locals-size-list  
     then      then
     cs-push-part dest      cs-push-part dest
     dead-code off ; immediate restrict      dead-code off ; immediate restrict
Line 614  variable dead-code \ true if normal code Line 622  variable dead-code \ true if normal code
     POSTPONE branch      POSTPONE branch
     <resolve      <resolve
     check-begin      check-begin
     unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
 \ UNTIL (the current control flow may join an earlier one or continue):  \ UNTIL (the current control flow may join an earlier one or continue):
 \ Similar to AGAIN. The new locals-list and locals-size are the current  \ Similar to AGAIN. The new locals-list and locals-size are the current
Line 746  Avariable leave-sp  leave-stack 3 cells Line 754  Avariable leave-sp  leave-stack 3 cells
 : EXIT ( -- )  : EXIT ( -- )
     0 adjust-locals-size      0 adjust-locals-size
     POSTPONE ;s      POSTPONE ;s
     unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
 : ?EXIT ( -- )  : ?EXIT ( -- )
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict       POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
Line 1033  Variable warnings  G -1 warnings T ! Line 1041  Variable warnings  G -1 warnings T !
   
 : bell  #bell emit ;  : bell  #bell emit ;
   
 : backspaces  0 ?DO  #bs emit  LOOP ;  \ : backspaces  0 ?DO  #bs emit  LOOP ;
 : >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 1050  Variable warnings  G -1 warnings T ! Line 1058  Variable warnings  G -1 warnings T !
 : 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 ;
   
 Create crtlkeys  Create ctrlkeys
   ] false false back  false  false false forw  false    ] false false back  false  false false forw  false
     ?del  false (ret) false  false (ret) false false      ?del  false (ret) false  false (ret) false false
     false false false false  false false false false      false false false false  false false false false
     false false false false  false false false false [      false false false false  false false false false [
   
   defer everychar
   ' noop IS everychar
   
 : decode ( max span addr pos1 key -- max span addr pos2 flag )  : decode ( max span addr pos1 key -- max span addr pos2 flag )
     everychar
   dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
   dup bl <   IF  cells crtlkeys + @ execute  EXIT  THEN    dup bl <   IF  cells ctrlkeys + @ execute  EXIT  THEN
   >r 2over = IF  rdrop bell 0 EXIT  THEN    >r 2over = IF  rdrop bell 0 EXIT  THEN
   r> (ins) 0 ;    r> (ins) 0 ;
   
Line 1203  create pathfilenamebuf 256 chars allot \ Line 1215  create pathfilenamebuf 256 chars allot \
 \ DEPTH                                                 9may93jaw  \ DEPTH                                                 9may93jaw
   
 : depth ( -- +n )  sp@ s0 @ swap - cell / ;  : depth ( -- +n )  sp@ s0 @ swap - cell / ;
   : clearstack ( ... -- )  s0 @ sp! ;
   
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
Line 1372  Variable argc Line 1385  Variable argc
     2drop      2drop
     here r> tuck - 2 cells / ;      here r> tuck - 2 cells / ;
   
 : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;  
   
 : do-option ( addr1 len1 addr2 len2 -- n )  2swap  : do-option ( addr1 len1 addr2 len2 -- n )  2swap
   2dup s" -e"        compare  0= >r    2dup s" -e"        compare  0= >r
   2dup s" -evaluate" compare  0= r> or    2dup s" -evaluate" compare  0= r> or
   IF  2drop ">tib interpret  2 EXIT  THEN    IF  2drop dup >r ['] evaluate catch
         ?dup IF  dup >r DoError r> negate (bye)  THEN
         r> >tib +!  2 EXIT  THEN
   ." Unknown option: " type cr 2drop 1 ;    ." Unknown option: " type cr 2drop 1 ;
   
 : process-args ( -- )  : process-args ( -- )  >tib @ >r
     argc @ 1      argc @ 1
     ?DO      ?DO
         I arg over c@ [char] - <>          I arg over c@ [char] - <>
Line 1389  Variable argc Line 1402  Variable argc
         ELSE          ELSE
             I 1+ arg  do-option              I 1+ arg  do-option
         THEN          THEN
     +LOOP ;      +LOOP
       r> >tib ! ;
   
   Defer 'cold ' noop IS 'cold
   
 : cold ( -- )  : cold ( -- )
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
       'cold
     argc @ 1 >      argc @ 1 >
     IF      IF
         ['] process-args catch ?dup          ['] process-args catch ?dup
Line 1423  Variable argc Line 1440  Variable argc
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! cstring>sstring pathstring 2!  main-task up!    argc ! argv ! cstring>sstring pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;    sp@ dup s0 ! $10 + >tib ! #tib off >in off
     rp@ r0 !  fp@ f0 !  cold ;
   
 : bye  script? 0= IF  cr  THEN  0 (bye) ;  : bye  script? 0= IF  cr  THEN  0 (bye) ;
   
Removed from v.1.20  
changed lines
  Added in v.1.25

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