Diff for /gforth/Attic/kernel.fs between versions 1.5 and 1.10

version 1.5, 1996/10/01 16:25:59 version 1.10, 1997/01/04 16:32:30
Line 20 Line 20
   
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Log:  ', '- usw. durch [char] ... ersetzt  
 \       man sollte die unterschiedlichen zahlensysteme  
 \       mit $ und & zumindest im interpreter weglassen  
 \       schon erledigt!  
 \       11may93jaw  
 \ name>         0= nicht vorhanden              17may93jaw  
 \               nfa can be lfa or nfa!  
 \ find          splited into find and (find)  
 \               (find) for later use            17may93jaw  
 \ search        replaced by lookup because  
 \               it is a word of the string wordset  
 \                                               20may93jaw  
 \ postpone      added immediate                 21may93jaw  
 \ to            added immediate                 07jun93jaw  
 \ cfa, header   put "here lastcfa !" in  
 \               cfa, this is more logical  
 \               and noname: works wothout  
 \               extra "here lastcfa !"          08jun93jaw  
 \ (parse-white) thrown out  
 \ refill        added outer trick  
 \               to show there is something  
 \               going on                        09jun93jaw  
 \ leave ?leave  somebody forgot UNLOOP!!!       09jun93jaw  
 \ leave ?leave  unloop thrown out  
 \               unloop after loop is used       10jun93jaw  
   
 HEX  HEX
   
 \ labels for some code addresses  \ labels for some code addresses
Line 1164  end-struct interpret/compile-struct Line 1138  end-struct interpret/compile-struct
     (cfa>int) ;      (cfa>int) ;
   
 : name>comp ( nt -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth
     \G @var{w xt} is the compilation token wor the word @var{nt}.      \G @var{w xt} is the compilation token for the word @var{nt}.
     (name>x) >r dup interpret/compile?      (name>x) >r dup interpret/compile?
     if      if
         interpret/compile-comp @          interpret/compile-comp @
Line 1359  Defer key ( -- c ) \ core Line 1333  Defer key ( -- c ) \ core
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \G obsolescent      \G obsolescent
     loadfile off  blk off  refill drop ;      tib /line accept #tib ! 0 >in ! ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1381  Defer key ( -- c ) \ core Line 1355  Defer key ( -- c ) \ core
 : bin ( fam1 -- fam2 ) \ file  : bin ( fam1 -- fam2 ) \ file
     1 or ;      1 or ;
   
 create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos  
                            \ or not unix environments if  
                            \ bin is not selected  
   
 : write-line ( c-addr u fileid -- ior ) \ file  : write-line ( c-addr u fileid -- ior ) \ file
     dup >r write-file      dup >r write-file
     ?dup IF      ?dup IF
         r> drop EXIT          r> drop EXIT
     THEN      THEN
     nl$ count r> write-file ;      #lf r> emit-file ;
   
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
Line 1615  create image-included-files  1 , A, ( po Line 1585  create image-included-files  1 , A, ( po
 Defer 'quit  Defer 'quit
 Defer .status  Defer .status
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 : (quit)        BEGIN .status cr query interpret prompt AGAIN ;  : (Query)  ( -- )
       loadfile off  blk off  refill drop ;
   : (quit)        BEGIN .status cr (query) interpret prompt AGAIN ;
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
Line 1640  max-errors 6 * cells allot Line 1612  max-errors 6 * cells allot
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     bounds ?do      bounds ?do
         i c@ 9 = if \ check for tab          i c@ #tab = if \ check for tab
             9              #tab
         else          else
             bl              bl
         then          then
Line 1729  Variable argc Line 1701  Variable argc
     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings      \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
     align here >r      align here >r
     BEGIN      BEGIN
         over >r [char] : scan          over >r 0 scan
         over r> tuck - ( rest-str this-str )          over r> tuck - ( rest-str this-str )
         dup          dup
         IF          IF
Line 1811  Defer 'cold ' noop IS 'cold Line 1783  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 ! cstring>sstring save-mem pathstring 2!  main-task up!    argc ! argv ! pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off    sp@ s0 !
   rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;    lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off
     rp@ r0 !
     fp@ f0 !
     ['] cold catch DoError
     bye ;
   
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;      script? 0= IF  cr  THEN  0 (bye) ;

Removed from v.1.5  
changed lines
  Added in v.1.10


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