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

Diff for /gforth/Attic/kernal.fs between versions 1.9 and 1.15

version 1.9, 1994/07/07 14:59:23 version 1.15, 1994/08/25 15:25:28
Line 142  Defer source Line 142  Defer source
   dup count chars bounds    dup count chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;    ?DO  I c@ toupper I c! 1 chars +LOOP ;
 : (name)  ( -- addr )  bl word ;  : (name)  ( -- addr )  bl word ;
 : (cname) ( -- addr )  bl word capitalize ;  : sname ( -- c-addr count )
       source 2dup >r >r >in @ /string (parse-white)
       2dup + r> - 1+ r> min >in ! ;
   \    name count ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
Line 194  Create bases   10 ,   2 ,   A , 100 , Line 197  Create bases   10 ,   2 ,   A , 100 ,
 \ !! this saving and restoring base is an abomination! - anton  \ !! this saving and restoring base is an abomination! - anton
 : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<  : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<
   IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;    IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;
 : number?  ( string -- string 0 / n -1 )  base @ >r  : s>number ( addr len -- d )  base @ >r  dpl on
   dup count over c@ [char] - = dup >r  IF 1 /string  THEN    over c@ '- =  dup >r  IF  1 /string  THEN
   getbase  dpl on  0 0 2swap    getbase  dpl on  0 0 2swap
   BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE    BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE
          dup dpl ! over c@ [char] . =  WHILE           dup dpl ! over c@ [char] . =  WHILE
          1 /string           1 /string
   REPEAT  THEN  2drop 2drop rdrop false r> base ! EXIT  THEN    REPEAT  THEN  2drop rdrop dpl off  ELSE
   2drop rot drop rdrop r> IF dnegate THEN    2drop rdrop r> IF  dnegate  THEN
   dpl @ dup 0< IF  nip  THEN  r> base ! ;    THEN r> base ! ;
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number dpl @ 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0> 0= IF
           nip
       THEN ;
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
 : s>d ( n -- d ) dup 0< ;  : s>d ( n -- d ) dup 0< ;
 : number ( string -- d )  : number ( string -- d )
   number? ?dup 0= abort" ?"  0< IF s>d THEN ;    number? ?dup 0= abort" ?"  0< IF s>d THEN ;
Line 271  hex Line 288  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 300  hex Line 318  hex
   
 Defer parser  Defer parser
 Defer name      ' (name) IS name  Defer name      ' (name) IS name
 Defer notfound  Defer notfound ( c-addr count -- )
   
 : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;  : no.extensions  ( addr u -- )  2drop -&13 bounce ;
   
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
 : interpret  : interpret
   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;      BEGIN
           ?stack sname dup
 \ interpreter compiler                                 30apr92py      WHILE
           parser
 : interpreter  ( name -- ) find ?dup      REPEAT
   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN      2drop ;
   number? 0= IF  notfound THEN ;  
   \ sinterpreter scompiler                                 30apr92py
   
   : sinterpreter  ( c-addr u -- ) 
       \ interpretation semantics for the name/number c-addr u
       2dup sfind dup
       IF
           1 and
           IF \ not restricted to compile state?
               nip nip execute  EXIT
           THEN
           -&14 throw
       THEN
       drop
       2dup 2>r snumber?
       IF
           2rdrop
       ELSE
           2r> notfound
       THEN ;
   
 ' interpreter  IS  parser  ' sinterpreter  IS  parser
   
 : compiler     ( name -- ) find  ?dup  : scompiler     ( c-addr u -- )
   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup      \ compilation semantics for the name/number c-addr u
   IF  0> IF  swap postpone Literal  THEN  postpone Literal      2dup sfind dup
   ELSE  drop notfound  THEN ;      IF
           0>
           IF
               nip nip execute EXIT
           THEN
           compile, 2drop EXIT
       THEN
       drop
       2dup snumber? dup
       IF
           0>
           IF
               swap postpone Literal
           THEN
           postpone Literal
           2drop
       ELSE
           drop notfound
       THEN ;
   
 : [     ['] interpreter  IS parser state off ; immediate  : [     ['] sinterpreter  IS parser state off ; immediate
 : ]     ['] compiler     IS parser state on  ;  : ]     ['] scompiler     IS parser state on  ;
   
 \ 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 398  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 439  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 488  variable dead-code \ true if normal code Line 540  variable dead-code \ true if normal code
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  \ This is the preferred alternative to the idiom "?DUP IF", since it can be
 \ better handled by tools like stack checkers  \ better handled by tools like stack checkers
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup POSTPONE if ;       immediate restrict
 : ?DUP-NOT-IF \ general  : ?DUP-0=-IF \ general
     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict      POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
   
 : THEN ( orig -- )  : THEN ( orig -- )
Line 715  Avariable leave-sp  leave-stack 3 cells Line 767  Avariable leave-sp  leave-stack 3 cells
   
 \ 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
Line 729  Avariable leave-sp  leave-stack 3 cells Line 783  Avariable leave-sp  leave-stack 3 cells
 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 810  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 834  Create ???  0 , 3 c, char ? c, char ? c, Line 890  Create ???  0 , 3 c, char ? c, char ? c,
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer  : Defer ( -- )
   Create ( -- )       \ !! shouldn't it be initialized with abort or something similar?
     ['] noop A,      Header Reveal [ :dodefer ] Literal cfa,
   DOES> ( ??? )      ['] noop A, ;
     @ execute ;  \     Create ( -- ) 
   \       ['] noop A,
   \     DOES> ( ??? )
   \       @ execute ;
   
 : IS ( addr "name" -- )  : IS ( addr "name" -- )
     ' >body      ' >body
Line 852  Create ???  0 , 3 c, char ? c, char ? c, Line 911  Create ???  0 , 3 c, char ? c, char ? c,
   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;    state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;
                                              immediate                                               immediate
 : Defers ( "name" -- )  ' >body @ compile, ;  : Defers ( "name" -- )  ' >body @ compile, ;
                                              immediate restrict                                               immediate
   
 \ : ;                                                  24feb93py  \ : ;                                                  24feb93py
   
Line 863  defer ;-hook ( sys2 -- sys1 ) Line 922  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 899  AVariable current Line 960  AVariable current
 \ end-struct wordlist-struct  \ end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
 : f83casefind  ( addr len wordlist -- nfa / false )  @ (f83casefind) ;  
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search       ' f83casefind A,  ' (reveal) A,  ' drop A,  Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,
   
 : caps-name       ['] (cname) IS name  ['] f83find     f83search ! ;  
 : case-name       ['] (name)  IS name  ['] f83casefind f83search ! ;  
 : case-sensitive  ['] (name)  IS name  ['] f83find     f83search ! ;  
   
 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 934  Variable warnings  G -1 warnings T ! Line 990  Variable warnings  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : find   ( addr -- cfa +-1 / string false )  dup  : sfind ( c-addr u -- xt n / 0 )
   count search @ search-wordlist  dup IF  rot drop  THEN ;      search @ search-wordlist ;
   
   : find   ( addr -- cfa +-1 / string false )
       \ !! not ANS conformant: returns +-2 for restricted words
       dup count sfind dup if
           rot drop
       then ;
   
 : reveal ( -- )  : reveal ( -- )
  last? if   last? if
Line 945  Variable warnings  G -1 warnings T ! Line 1007  Variable warnings  G -1 warnings T !
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;
   
 : '    ( "name" -- addr )  name find 0= no.extensions ;  : '    ( "name" -- addr )  name find 0= if drop -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
Line 1020  DEFER Emit Line 1082  DEFER Emit
 : refill ( -- flag )  : refill ( -- flag )
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    dup file-position throw linestart 2!    IF    \ dup file-position throw linestart 2!
         read-line throw          read-line throw
   ELSE  linestart @ IF 2drop false EXIT THEN    ELSE  loadline @ 0< IF 2drop false EXIT THEN
         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 1056  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1118  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : include-file ( i*x fid -- j*x )  : push-file  ( -- )  r>
   linestart @ >r loadline @ >r loadfile @ >r    ( linestart 2@ >r >r ) loadline @ >r loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
   
   >tib +! loadfile !  : pop-file   ( -- )  r>
     r> >in !  r> #tib !  r> >tib ! r> blk !
     r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;
   
   : include-file ( i*x fid -- j*x )
     push-file  loadfile !
   0 loadline ! blk off    0 loadline ! blk off
   BEGIN  refill  WHILE  interpret  REPEAT    BEGIN  refill  WHILE  interpret  REPEAT
   loadfile @ close-file throw    loadfile @ close-file throw
     pop-file ;
   r> >in !  r> #tib !  r> >tib ! r> blk !  
   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 1158  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
   
   \ !! I think */mod should have the same rounding behaviour as / - anton
 : */mod >r m* r> sm/rem ;  : */mod >r m* r> sm/rem ;
   
 : */ */mod nip ;  : */ */mod nip ;
Line 1099  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1173  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 : evaluate ( c-addr len -- )  : evaluate ( c-addr len -- )
   linestart @ >r loadline @ >r loadfile @ >r    push-file  dup #tib ! >tib @ swap move
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    >in off blk off loadfile off -1 loadline !
   
   >tib +! dup #tib ! >tib @ swap move  
   >in off blk off loadfile off -1 linestart !  
   
   BEGIN  interpret  >in @ #tib @ u>= UNTIL    BEGIN  interpret  >in @ #tib @ u>= UNTIL
   
   r> >in !  r> #tib !  r> >tib ! r> blk !    pop-file ;
   r> loadfile ! r> loadline ! r> linestart ! ;  
   
   
 : abort -1 throw ;  : abort -1 throw ;
Line 1126  Defer .status Line 1196  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 1181  Variable env Line 1263  Variable env
 Variable argv  Variable argv
 Variable argc  Variable argc
   
 : get-args ( -- )  #tib off  0 Value script? ( -- flag )
   argc @ 1 ?DO  I arg 2dup source + swap move  
                 #tib +! drop  bl source + c! 1 #tib +!  LOOP  : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;
   >in off #tib @ 0<> #tib +! ;  
   
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;  : do-option ( addr1 len1 addr2 len2 -- n )  2swap
     2dup s" -e"        compare  0= >r
     2dup s" -evaluate" compare  0= r> or
     IF  2drop ">tib interpret  2 EXIT  THEN
     ." Unknown option: " type cr 2drop 1 ;
   
   : process-args ( -- )  argc @ 1
     ?DO  I arg over c@ [char] - <>
          IF    true to script? included  false to script? 1
          ELSE  I 1+ arg  do-option
          THEN
     +LOOP ;
   
 : cold ( -- )    : cold ( -- )  
   argc @ 1 >      argc @ 1 >
   IF  script?      IF
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN          ['] process-args catch ?dup
       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN          IF
   ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;              dup >r DoError cr r> negate (bye)
           THEN
       THEN
       cr
       ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr
       ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
       ." Type `bye' to exit"
       quit ;
   
   : license ( -- ) cr
    ." This program is free software; you can redistribute it and/or modify" cr
    ." it under the terms of the GNU General Public License as published by" cr
    ." the Free Software Foundation; either version 2 of the License, or" cr
    ." (at your option) any later version." cr cr
   
    ." This program is distributed in the hope that it will be useful," cr
    ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
    ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
    ." GNU General Public License for more details." cr cr
   
    ." You should have received a copy of the GNU General Public License" cr
    ." along with this program; if not, write to the Free Software" cr
    ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( **env **argv argc -- )  : boot ( **env **argv argc -- )
   argc ! argv ! env !  main-task up!    argc ! argv ! env !  main-task up!
   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;    sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;
   
 : bye  cr 0 (bye) ;  : bye  script? 0= IF  cr  THEN  0 (bye) ;
   
 \ **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.9  
changed lines
  Added in v.1.15

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