Diff for /gforth/Attic/kernal.fs between versions 1.28 and 1.34

version 1.28, 1995/02/06 18:14:34 version 1.34, 1995/04/14 18:56:55
Line 704  Avariable leave-sp  leave-stack 3 cells Line 704  Avariable leave-sp  leave-stack 3 cells
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : DONE ( orig -- )  drop >r drop  : DONE ( orig -- )
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
       drop >r drop
     begin      begin
         leave>          leave>
         over r@ u>=          over r@ u>=
Line 785  Avariable leave-sp  leave-stack 3 cells Line 786  Avariable leave-sp  leave-stack 3 cells
 : ."       state @  IF    postpone (.") ,"  align  : ."       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
 : (        [char] ) parse 2drop ;                       immediate  : (        [char] ) parse 2drop ;                       immediate
 : \        blk @ IF  >in @ c/l / 1+ c/l * >in !  EXIT  THEN  : \ ( -- ) \ core-ext backslash
            source >in ! drop ;                          immediate      blk @
       IF
           >in @ c/l / 1+ c/l * >in !
           EXIT
       THEN
       source >in ! drop ; immediate
   
   : \G ( -- ) \ new backslash
       POSTPONE \ ; immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
Line 917  Create ???  0 , 3 c, char ? c, char ? c, Line 926  Create ???  0 , 3 c, char ? c, char ? c,
 : Constant  (Constant) , ;  : Constant  (Constant) , ;
 : AConstant (Constant) A, ;  : AConstant (Constant) A, ;
   
 : 2CONSTANT  : 2Constant
     create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     does> ( -- w1 w2 )      DOES> ( -- w1 w2 )
         2@ ;          2@ ;
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
Line 980  AVariable current Line 989  AVariable current
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
 \ word list structure:  \ word list structure:
 \ struct  
 \   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )  struct
 \   1 cells: field reveal-method \ xt: ( -- )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
 \   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field reveal-method \ xt: ( -- )
     1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 \ end-struct wordlist-map-struct  end-struct wordlist-map-struct
   
 \ struct  struct
 \   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation    1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
 \   1 cells: field wordlist-map \ pointer to a wordlist-map-struct    1 cells: field wordlist-map \ pointer to a wordlist-map-struct
 \   1 cells: field wordlist-link \ link field to other wordlists    1 cells: field wordlist-link \ link field to other wordlists
 \   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 \ end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
   
Line 1004  AVariable lookup       G forth-wordlist Line 1014  AVariable lookup       G forth-wordlist
 G forth-wordlist current T !  G forth-wordlist current T !
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup cell+ @ @ execute ;    dup wordlist-map @ find-method @ execute ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  : search-wordlist  ( addr count wid -- 0 / xt +-1 )
     (search-wordlist) dup  IF  found  THEN ;      (search-wordlist) dup  IF  found  THEN ;
Line 1038  Variable warnings  G -1 warnings T ! Line 1048  Variable warnings  G -1 warnings T !
  last? if   last? if
    name>string current @ check-shadow     name>string current @ check-shadow
  then   then
  current @ cell+ @ cell+ @ execute ;   current @ wordlist-map @ reveal-method @ execute ;
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )  dup wordlist-map @ rehash-method @ execute ;
   
 : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;  : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
Line 1445  Variable argc Line 1455  Variable argc
     2drop      2drop
     here r> tuck - 2 cells / ;      here r> tuck - 2 cells / ;
   
 : do-option ( addr1 len1 addr2 len2 -- n )  2swap  : do-option ( addr1 len1 addr2 len2 -- n )
   2dup s" -e"        compare  0= >r      2swap
   2dup s" -evaluate" compare  0= r> or      2dup s" -e"         compare  0= >r
   IF  2drop dup >r ['] evaluate catch      2dup s" --evaluate" compare  0= r> or
       ?dup IF  dup >r DoError r> negate (bye)  THEN      IF  2drop dup >r ['] evaluate catch
       r> >tib +!  2 EXIT  THEN          ?dup IF  dup >r DoError r> negate (bye)  THEN
   ." Unknown option: " type cr 2drop 1 ;          r> >tib +!  2 EXIT  THEN
       ." Unknown option: " type cr 2drop 1 ;
 : process-args ( -- )  >tib @ >r  
   : process-args ( -- )
       >tib @ >r
       true to script?
     argc @ 1      argc @ 1
     ?DO      ?DO
         I arg over c@ [char] - <>          I arg over c@ [char] - <>
         IF          IF
             true to script? included  false to script? 1              included 1
         ELSE          ELSE
             I 1+ arg  do-option              I 1+ arg  do-option
         THEN          THEN
     +LOOP      +LOOP
       false to script?
     r> >tib ! ;      r> >tib ! ;
   
 Defer 'cold ' noop IS 'cold  Defer 'cold ' noop IS 'cold
   
 : cold ( -- )  : cold ( -- )
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
       0 0 included-files 2!
     'cold      'cold
     argc @ 1 >      argc @ 1 >
     IF      IF

Removed from v.1.28  
changed lines
  Added in v.1.34


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