[gforth] / gforth / Attic / kernal.fs  

gforth: gforth/Attic/kernal.fs

Diff for /gforth/Attic/kernal.fs between version 1.11 and 1.12

version 1.11, Wed Jul 13 19:21:03 1994 UTC version 1.12, Thu Jul 21 10:52:44 1994 UTC
Line 142 
Line 142 
   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 ;  \ : (cname) ( -- addr )  bl word capitalize ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
Line 194 
Line 194 
 \ !! 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 ! ;
   : number? ( string -- string 0 / n -1 / d 0> )
     dup count s>number dpl @ 0= IF  2drop false  EXIT  THEN
     rot drop dpl @ dup 0> 0= IF  nip  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 303 
Line 306 
 Defer name      ' (name) IS name  Defer name      ' (name) IS name
 Defer notfound  Defer notfound
   
 : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;  : no.extensions  ( string -- )  IF  -&13 bounce  THEN ;
   
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
Line 730 
Line 733 
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name c@      name c@
     dup $1F u> &-19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     1+ chars allot align ;      1+ chars allot align ;
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent      \ !! this is f83-implementation-dependent
Line 756 
Line 759 
   
 \ 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 $1F 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 854 
Line 857 
   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 903 
Line 906 
 \ 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 1024 
Line 1022 
 : 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 +!
Line 1060 
Line 1058 
   
 \ 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 )
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
Line 1111 
Line 1112 
 \ 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 1205 
Line 1202 
 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          ['] process-args catch ?dup
         ELSE  
             get-args ['] interpret  
         THEN  
         catch ?dup  
         IF          IF
             dup >r DoError cr r> (bye)              dup >r DoError cr r> negate (bye)
         THEN          THEN
     THEN      THEN
     cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation"      ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" cr
     cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'"      ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
     cr quit ;      cr 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 1, or (at your option)" cr
    ." 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

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help