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

Diff for /gforth/Attic/kernal.fs between versions 1.8 and 1.11

version 1.8, 1994/06/17 12:35:07 version 1.11, 1994/07/13 19:21:03
Line 79  DOES> ( n -- )  + c@ ; Line 79  DOES> ( n -- )  + c@ ;
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;  : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;
 : name>    ( nfa -- cfa )  : name>    ( nfa -- cfa )    cell+
   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;    dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
   
 : found ( nfa -- cfa n )  cell+  : found ( nfa -- cfa n )  cell+
   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN    dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
 \                  -1 r@ $40 and     IF  1-      THEN                    -1 r@ $40 and     IF  1-      THEN
                   -1 r> $20 and     IF  negate  THEN  ;                       r> $20 and     IF  negate  THEN  ;
   
 \ (find)                                               17dec92py  \ (find)                                               17dec92py
   
Line 271  hex Line 271  hex
   r> handler ! rdrop rdrop rdrop 0 ;    r> handler ! rdrop rdrop rdrop 0 ;
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
   ?DUP IF      ?DUP IF
     handler @ rp!          [ here 4 cells ! ]
     r> handler !          handler @ rp!
     r> lp!          r> handler !
     r> fp!          r> lp!
     r> swap >r sp! r>          r> fp!
   THEN ;          r> swap >r sp! r>
       THEN ;
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
 \ programming without wasting time...   jaw  \ programming without wasting time...   jaw
Line 327  Defer notfound Line 328  Defer notfound
   
 \ locals stuff needed for control structures  \ locals stuff needed for control structures
   
 variable locals-size \ this is the current size of the locals stack  
                      \ frame of the current word  
   
 : compile-lp+! ( n -- )  : compile-lp+! ( n -- )
     dup negate locals-size +!      dup negate locals-size +!
     0 over = if      0 over = if
Line 346  variable locals-size \ this is the curre Line 344  variable locals-size \ this is the curre
   
 here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs  here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
 AConstant locals-list \ acts like a variable that contains  AConstant locals-list \ acts like a variable that contains
                      \ a linear list of locals names                        \ a linear list of locals names
   
   
 variable dead-code \ true if normal code at "here" would be dead  variable dead-code \ true if normal code at "here" would be dead
Line 387  variable dead-code \ true if normal code Line 385  variable dead-code \ true if normal code
    over 0<>     over 0<>
  while   while
    over     over
    cell+ name> >body @ max     name> >body @ max
    swap @ swap ( get next )     swap @ swap ( get next )
  repeat   repeat
  faligned nip ;   faligned nip ;
Line 590  variable dead-code \ true if normal code Line 588  variable dead-code \ true if normal code
 \ we have to store more than just the address of the branch, so the  \ we have to store more than just the address of the branch, so the
 \ traditional linked list approach is no longer viable.  \ traditional linked list approach is no longer viable.
 \ This is solved by storing the information about the leavings in a  \ This is solved by storing the information about the leavings in a
 \ special stack. The leavings of different DO-LOOPs are separated  \ special stack.
 \ by a 0 entry  
   
 \ !! remove the fixed size limit. 'Tis not hard.  \ !! remove the fixed size limit. 'Tis not hard.
 20 constant leave-stack-size  20 constant leave-stack-size
 create leave-stack 60 cells allot  create leave-stack  60 cells allot
 Avariable leave-sp  leave-stack leave-sp !  Avariable leave-sp  leave-stack 3 cells + leave-sp !
   
 : clear-leave-stack ( -- )  : clear-leave-stack ( -- )
     leave-stack leave-sp ! ;      leave-stack leave-sp ! ;
Line 617  Avariable leave-sp  leave-stack leave-sp Line 614  Avariable leave-sp  leave-stack leave-sp
 : leave> ( -- orig )  : leave> ( -- orig )
     \ pop from leave-stack      \ pop from leave-stack
     leave-sp @      leave-sp @
     dup leave-stack <= abort" leave-stack empty"      dup leave-stack <= IF
          drop 0 0 0  EXIT  THEN
     cell - dup @ swap      cell - dup @ swap
     cell - dup @ swap      cell - dup @ swap
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : done ( -- )  : DONE ( orig -- )  drop >r drop
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
     begin      begin
         leave>          leave>
         dup          over r@ u>=
     while      while
         POSTPONE then          POSTPONE then
     repeat      repeat
     2drop drop ; immediate      >leave rdrop ; immediate restrict
   
 : LEAVE ( -- )  : LEAVE ( -- )
     POSTPONE ahead      POSTPONE ahead
     >leave ; immediate      >leave ; immediate restrict
   
 : ?LEAVE ( -- )  : ?LEAVE ( -- )
     POSTPONE 0= POSTPONE if      POSTPONE 0= POSTPONE if
     >leave ; immediate      >leave ; immediate restrict
   
 : DO ( -- do-sys )  : DO ( -- do-sys )
     POSTPONE (do)      POSTPONE (do)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     0 0 0 >leave ; immediate      ( 0 0 0 >leave ) ; immediate restrict
   
 : ?DO ( -- do-sys )  : ?DO ( -- do-sys )
     0 0 0 >leave      ( 0 0 0 >leave )
     POSTPONE (?do)      POSTPONE (?do)
     >mark >leave      >mark >leave
     POSTPONE begin drop do-dest ; immediate      POSTPONE begin drop do-dest ; immediate restrict
   
 : FOR ( -- do-sys )  : FOR ( -- do-sys )
     POSTPONE (for)      POSTPONE (for)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     0 0 0 >leave ; immediate      ( 0 0 0 >leave ) ; immediate restrict
   
 \ LOOP etc. are just like UNTIL  \ LOOP etc. are just like UNTIL
   
 : loop-like ( do-sys xt1 xt2 -- )  : loop-like ( do-sys xt1 xt2 -- )
     rot do-dest?      >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
     until-like  POSTPONE done  POSTPONE unloop ;      until-like  POSTPONE done  POSTPONE unloop ;
   
 : LOOP ( do-sys -- )  : LOOP ( do-sys -- )
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( do-sys -- )  : +LOOP ( do-sys -- )
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate   ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
 \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"  \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
 \ will iterate as often as "high low ?DO inc S+LOOP". For positive  \ will iterate as often as "high low ?DO inc S+LOOP". For positive
 \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for  \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
 \ negative increments.  \ negative increments.
 : S+LOOP ( do-sys -- )  : S+LOOP ( do-sys -- )
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate   ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : NEXT ( do-sys -- )  : NEXT ( do-sys -- )
  ['] (next) ['] (next)-lp+!# loop-like ; immediate   ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
Line 715  Avariable leave-sp  leave-stack leave-sp Line 713  Avariable leave-sp  leave-stack leave-sp
   
 \ Header states                                        23feb93py  \ Header states                                        23feb93py
   
 : flag! ( 8b -- )   last @ cell+ tuck c@ xor swap c! ;  : flag! ( 8b -- )
       last @ dup 0= abort" last word was headerless"
       cell+ tuck c@ xor swap c! ;
 : immediate     $20 flag! ;  : immediate     $20 flag! ;
 \ : restrict      $40 flag! ;  : restrict      $40 flag! ;
 ' noop alias restrict  \ ' noop alias restrict
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 729  Avariable leave-sp  leave-stack leave-sp Line 729  Avariable leave-sp  leave-stack leave-sp
 defer header  defer header
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name c@ 1+ chars allot align ;      name c@
       dup $1F u> &-19 and throw ( is name too long? )
       1+ chars allot align ;
 : 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,
Line 754  create nextname-buffer 32 chars allot Line 756  create nextname-buffer 32 chars allot
   
 \ 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
     dup 31 u> -19 and throw ( is name too long? )      dup $1F u> &-19 and throw ( is name too long? )
     nextname-buffer c! ( c-addr )      nextname-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
     ['] nextname-header IS header ;      ['] nextname-header IS header ;
Line 777  create nextname-buffer 32 chars allot Line 779  create nextname-buffer 32 chars allot
 : name>string ( nfa -- addr count )  : name>string ( nfa -- addr count )
  cell+ count $1F and ;   cell+ count $1F and ;
   
 Create ???  ," ???"  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa )  : >name ( cfa -- nfa )
  $21 cell do   $21 cell do
    dup i - count $9F and + aligned over $80 + = if     dup i - count $9F and + aligned over $80 + = if
Line 863  defer ;-hook ( sys2 -- sys1 ) Line 865  defer ;-hook ( sys2 -- sys1 )
 : ; ( colon-sys -- )  ;-hook ?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 ] :-hook ;  : :noname ( -- xt colon-sys )
       0 last !
       here [ :docol ] Literal cfa, 0 ] :-hook ;
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
Line 1001  Create crtlkeys Line 1005  Create crtlkeys
 DEFER type      \ defer type for a output buffer or fast  DEFER type      \ defer type for a output buffer or fast
                 \ screen write                  \ screen write
   
 : (type) ( addr len -- )  \ : (type) ( addr len -- )
   bounds ?DO  I c@ emit  LOOP ;  \   bounds ?DO  I c@ emit  LOOP ;
   
 ' (TYPE) IS Type  ' (TYPE) IS Type
   
 \ DEFER Emit  DEFER Emit
   
 \ ' (Emit) IS Emit  ' (Emit) IS Emit
   
 \ : form  ( -- rows cols )  &24 &80 ;  \ : form  ( -- rows cols )  &24 &80 ;
 \ form should be implemented using TERMCAPS or CURSES  \ form should be implemented using TERMCAPS or CURSES
Line 1026  DEFER type      \ defer type for a outpu Line 1030  DEFER type      \ defer type for a outpu
         accept true          accept true
   THEN    THEN
   1 loadline +!    1 loadline +!
   swap #tib ! >in off ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- )  loadfile off refill drop ;  : Query  ( -- )  0 loadfile ! refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1069  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1073  create nl$ 1 c, A c, 0 c, \ gnu includes
   r> loadfile ! r> loadline ! r> linestart ! ;    r> loadfile ! r> loadline ! r> linestart ! ;
   
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
   r/o open-file throw include-file ;      loadfilename 2@ >r >r
       dup allocate throw over loadfilename 2!
       over loadfilename 2@ move
       r/o open-file throw include-file
       \ don't free filenames; they don't take much space
       \ and are used for debugging
       r> r> loadfilename 2! ;
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 1087  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1097  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse  last @ cell+ name> a, ; immediate restrict  : recurse ( -- )
 \ !! does not work with anonymous words; use lastxt compile,      lastxt compile, ; immediate restrict
   : recursive ( -- )
       reveal ; immediate
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   
Line 1126  Defer .status Line 1138  Defer .status
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
   
   : dec. ( n -- )
       \ print value in decimal representation
       base @ decimal swap . base ! ;
   
   : typewhite ( addr u -- )
       \ like type, but white space is printed instead of the characters
       0 ?do
           dup i + c@ 9 = if \ check for tab
               9
           else
               bl
           then
           emit
       loop
       drop ;
   
 DEFER DOERROR  DEFER DOERROR
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
          LoadFile @      LoadFile @
          IF      IF
                 ." Error in line: " Loadline @ . cr          cr loadfilename 2@ type ." :" Loadline @ dec.
          THEN      THEN
          cr source type cr      cr source type cr
          source drop >in @ -trailing      source drop >in @ -trailing ( throw-code line-start index2 )
          here c@ 1F min dup >r - 1- 0 max nip      here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )
          dup spaces       typewhite
          IF      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                 ." ^"          ." ^"
          THEN      loop
          r> 0 ?DO      dup -2 =
                 ." -"       IF 
          LOOP          "error @ ?dup
          ." ^"          IF
          dup -2 =              cr count type 
          IF           THEN
                 "error @ ?dup          drop
                 IF      ELSE
                         cr count type           .error
                 THEN      THEN
                 drop      normal-dp dpp ! ;
          ELSE  
                 .error  
          THEN  
          normal-dp dpp ! ;  
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
Line 1189  Variable argc Line 1213  Variable argc
 : 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 ( -- )    : cold ( -- )  
   argc @ 1 >      argc @ 1 >
   IF  script?      IF  script?
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN          IF
       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN              1 arg ['] included
   ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;          ELSE
               get-args ['] interpret
           THEN
           catch ?dup
           IF
               dup >r DoError cr r> (bye)
           THEN
       THEN
       cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation"
       cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" 
       cr quit ;
   
 : boot ( **env **argv argc -- )  : boot ( **env **argv argc -- )
   argc ! argv ! env !  main-task up!    argc ! argv ! env !  main-task up!
Removed from v.1.8  
changed lines
  Added in v.1.11

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