Diff for /gforth/Attic/kernal.fs between versions 1.1 and 1.29

<
version 1.1, 1994/02/11 16:30:46 version 1.29, 1995/02/09 17:49:57
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 45  DOES> ( n -- )  + c@ ; Line 45  DOES> ( n -- )  + c@ ;
   
 \ here allot , c, A,                                   17dec92py  \ here allot , c, A,                                   17dec92py
   
   : dp    ( -- addr )  dpp @ ;
 : here  ( -- here )  dp @ ;  : here  ( -- here )  dp @ ;
 : allot ( n -- )     dp +! ;  : allot ( n -- )     dp +! ;
 : c,    ( c -- )     here 1 chars allot c! ;  : c,    ( c -- )     here 1 chars allot c! ;
Line 56  DOES> ( n -- )  + c@ ; Line 57  DOES> ( n -- )  + c@ ;
   [ cell 1- ] Literal + [ -1 cells ] Literal and ;    [ cell 1- ] Literal + [ -1 cells ] Literal and ;
 : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;  : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;
   
   : faligned ( addr -- f-addr )
     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
   : falign ( -- )
     here dup faligned swap
     ?DO
         bl c,
     LOOP ;
   
   \ !! this is machine-dependent, but works on all but the strangest machines
   ' faligned Alias maxaligned
   ' falign Alias maxalign
   
   \ the code field is aligned if its body is maxaligned
   \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
   ' maxaligned Alias cfaligned
   ' maxalign Alias cfalign
   
   : 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 66  DOES> ( n -- )  + c@ ; Line 87  DOES> ( n -- )  + c@ ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;  : (name>)  ( nfa -- cfa )
       count  $1F and  +  cfaligned ;
 : name>    ( nfa -- cfa )  : name>    ( nfa -- cfa )
   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;      cell+
       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 98  Defer source Line 121  Defer source
   
 \ (word)                                               22feb93py  \ (word)                                               22feb93py
   
 : scan   ( addr1 n1 char -- addr2 n2 )  >r  : scan   ( addr1 n1 char -- addr2 n2 )
   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string      \ skip all characters not equal to char
   REPEAT  THEN  rdrop ;      >r
 : skip   ( addr1 n1 char -- addr2 n2 )  >r      BEGIN
   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string          dup
   REPEAT  THEN  rdrop ;      WHILE
           over c@ r@ <>
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   : skip   ( addr1 n1 char -- addr2 n2 )
       \ skip all characters equal to char
       >r
       BEGIN
           dup
       WHILE
           over c@ r@  =
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 126  Defer source Line 165  Defer source
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
 : capitalize ( addr -- addr )  : capitalize ( addr len -- addr len )
   dup count chars bounds    2dup chars 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) ( -- c-addr count )
       source 2dup >r >r >in @ /string (parse-white)
       2dup + r> - 1+ r> min >in ! ;
   \    name count ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
 : Literal  ( n -- )  state @ 0= ?EXIT  postpone lit  , ;  : Literal  ( n -- )  state @ IF postpone lit  , THEN ;
                                                       immediate                                                        immediate
 : ALiteral ( n -- )  state @ 0= ?EXIT  postpone lit A, ;  : ALiteral ( n -- )  state @ IF postpone lit A, THEN ;
                                                       immediate                                                        immediate
   
 : char   ( 'char' -- n )  bl word char+ c@ ;  : char   ( 'char' -- n )  bl word char+ c@ ;
 : [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 find 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 153  Defer source Line 195  Defer source
 \ digit?                                               17dec92py  \ digit?                                               17dec92py
   
 : digit?   ( char -- digit true/ false )  : digit?   ( char -- digit true/ false )
   base @ $100 = ?dup ?EXIT    base @ $100 =
     IF
       true EXIT
     THEN
   toupper [char] 0 - dup 9 u> IF    toupper [char] 0 - dup 9 u> IF
     [ 'A '9 1 + -  ] literal -      [ 'A '9 1 + -  ] literal -
     dup 9 u<= IF      dup 9 u<= IF
Line 178  Create bases   10 ,   2 ,   A , 100 , Line 223  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> )