Diff for /gforth/Attic/kernal.fs between versions 1.59 and 1.60

version 1.59, 1996/05/13 16:37:00 version 1.60, 1996/07/16 20:57:11
Line 74  HEX Line 74  HEX
     \ the code address of a @code{field}      \ the code address of a @code{field}
     ['] reveal-method >code-address ;      ['] reveal-method >code-address ;
   
   NIL AConstant NIL \ gforth
   
 \ Bit string manipulation                              06oct92py  \ Bit string manipulation                              06oct92py
   
 \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 143  HEX Line 145  HEX
 : off ( addr -- ) \ gforth  : off ( addr -- ) \ gforth
     false swap ! ;      false swap ! ;
   
   \ dabs roll                                           17may93jaw
   
   : dabs ( d1 -- d2 ) \ double
       dup 0< IF dnegate THEN ;
   
   : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
     dup 1+ pick >r
     cells sp@ cell+ dup cell+ rot move drop r> ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 $80 constant alias-mask \ set when the word is not an alias!  $80 constant alias-mask \ set when the word is not an alias!
Line 155  $20 constant restrict-mask Line 166  $20 constant restrict-mask
     cell+      cell+
     dup  (name>) swap  c@ alias-mask and 0= IF  @ THEN ;      dup  (name>) swap  c@ alias-mask and 0= IF  @ THEN ;
   
 : found ( nfa -- cfa n ) \ gforth  
     cell+  
     dup c@ >r  (name>) r@ alias-mask     and  0= IF  @       THEN  
                     -1 r@ restrict-mask  and     IF  1-      THEN  
                        r> immediate-mask and     IF  negate  THEN  ;  
   
 \ (find)                                               17dec92py  \ (find)                                               17dec92py
   
 \ : (find) ( addr count nfa1 -- nfa2 / false )  \ : (find) ( addr count nfa1 -- nfa2 / false )
Line 264  Defer source ( -- addr count ) \ core Line 269  Defer source ( -- addr count ) \ core
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
 : postpone ( "name" -- ) \ core  : postpone ( "name" -- ) \ core
   name sfind dup 0= abort" Can't compile "    name sfind dup 0= abort" Can't compile "
   0> IF  compile,  ELSE  postpone (compile) A,  THEN ;    0> IF  compile,  ELSE  postpone (compile) A,  THEN ; immediate restrict
                                              immediate restrict  
   : special: ( interp comp "name" -- )
       Create immediate swap A, A,
       DOES>  state @ IF  cell+  THEN  perform ;
   
 \ Use (compile) for the old behavior of compile!  \ Use (compile) for the old behavior of compile!
   
Line 514  Defer interpret-special ( c-addr u xt -- Line 522  Defer interpret-special ( c-addr u xt --
   
 : interpreter  ( c-addr u -- ) \ gforth  : interpreter  ( c-addr u -- ) \ gforth
     \ interpretation semantics for the name/number c-addr u      \ interpretation semantics for the name/number c-addr u
     2dup sfind dup      2dup (sfind) dup
     IF      IF
         1 and          1 and
         IF \ not restricted to compile state?          IF \ not restricted to compile state?
Line 534  Defer interpret-special ( c-addr u xt -- Line 542  Defer interpret-special ( c-addr u xt --
   
 : compiler     ( c-addr u -- ) \ gforth  : compiler     ( c-addr u -- ) \ gforth
     \ compilation semantics for the name/number c-addr u      \ compilation semantics for the name/number c-addr u
     2dup sfind dup      2dup (sfind) dup
     IF      IF
         0>          0>
         IF          IF
Line 738  variable backedge-locals Line 746  variable backedge-locals
 : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if  : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if
     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict      POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
   
 : THEN ( compilation orig -- ; run-time -- ) \ core  : then-like ( orig -- addr )
     dup orig?      swap -rot dead-orig =
     dead-orig =  
     if      if
         >resolve drop          drop
     else      else
         dead-code @          dead-code @
         if          if
             >resolve set-locals-size-list dead-code off              set-locals-size-list dead-code off
         else \ both live          else \ both live
             over list-size adjust-locals-size              dup list-size adjust-locals-size
             >resolve  
             locals-list @ common-list dup list-size adjust-locals-size              locals-list @ common-list dup list-size adjust-locals-size
             locals-list !              locals-list !
         then          then
     then ; immediate restrict      then ;
   
   : THEN ( compilation orig -- ; run-time -- ) \ core
       dup orig?  then-like  >resolve ; immediate restrict
   
 ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth  ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
 immediate restrict  immediate restrict
Line 782  immediate restrict Line 791  immediate restrict
 \ issue a warning (see below). The following code is generated:  \ issue a warning (see below). The following code is generated:
 \ lp+!# (current-local-size - dest-locals-size)  \ lp+!# (current-local-size - dest-locals-size)
 \ branch <begin>  \ branch <begin>
 : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext  
     dest?  : again-like ( dest -- addr )
     over list-size adjust-locals-size      over list-size adjust-locals-size
     POSTPONE branch      swap check-begin  POSTPONE unreachable ;
     <resolve  
     check-begin  : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
     POSTPONE unreachable ; immediate restrict      dest? again-like  POSTPONE branch  <resolve ; immediate restrict
   
 \ UNTIL (the current control flow may join an earlier one or continue):  \ UNTIL (the current control flow may join an earlier one or continue):
 \ Similar to AGAIN. The new locals-list and locals-size are the current  \ Similar to AGAIN. The new locals-list and locals-size are the current
Line 955  Avariable leave-sp  leave-stack 3 cells Line 964  Avariable leave-sp  leave-stack 3 cells
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string  : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
 create s"-buffer /line chars allot  
 : S" ( compilation 'ccc"' -- ; run-time -- c-addr u )   \ core,file     s-quote  
     [char] " parse postpone SLiteral ; immediate restrict  
   
 : ." ( compilation 'ccc"' -- ; run-time -- )  \ core    dot-quote  
     postpone (.") ,"  align ; immediate restrict  
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
     BEGIN      BEGIN
         >in @ [char] ) parse nip >in @ rot - =          >in @ [char] ) parse nip >in @ rot - =
Line 1100  Create ???  0 , 3 c, char ? c, char ? c, Line 1103  Create ???  0 , 3 c, char ? c, char ? c,
 : Create ( -- ) \ core  : Create ( -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
   
 \ DOES>                                                17mar93py  
   
 : DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does  
     ;-hook postpone (does>) ?struc dodoes,  
     defstart :-hook ; immediate restrict  
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
 : Variable ( -- ) \ core  : Variable ( -- ) \ core
Line 1143  Create ???  0 , 3 c, char ? c, char ? c, Line 1140  Create ???  0 , 3 c, char ? c, char ? c,
 \     DOES> ( ??? )  \     DOES> ( ??? )
 \       perform ;  \       perform ;
   
 : IS ( addr "name" -- ) \ gforth  
     ' >body postpone ALiteral postpone ! ; immediate restrict  
 ' IS Alias TO ( addr "name" -- ) \ core-ext  
 immediate restrict  
   
 : What's ( "name" -- addr ) \ gforth  
     ' >body postpone ALiteral postpone @ ; immediate restrict  
   
 : Defers ( "name" -- ) \ gforth  : Defers ( "name" -- ) \ gforth
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
   
Line 1208  Create forth-wordlist  NIL A, G f83searc Line 1197  Create forth-wordlist  NIL A, G f83searc
 AVariable lookup       G forth-wordlist lookup T !  AVariable lookup       G forth-wordlist lookup T !
 G forth-wordlist current T !  G forth-wordlist current T !
   
   \ higher level parts of find
   
   : special? ( xt -- flag )
       >does-code ['] S" >does-code = ;
   
   : xt>i ( xt -- xt )
       dup special?  IF  >body  @  THEN ;
   
   : xt>c ( xt -- xt )
       dup special?  IF  >body  cell+  @  THEN ;
   
   : xt>s ( xt -- xt )
       dup special?  IF  >body  state @ IF  cell+  THEN  @  THEN ;
   
   : found ( nfa -- cfa n ) \ gforth
       cell+  dup c@ >r  (name>)
       r@ alias-mask     and  0= IF  @       THEN  -1
       r@ restrict-mask  and     IF  1-      THEN
       r> immediate-mask and     IF  negate  THEN  ;
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search  : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search
     (search-wordlist) dup  IF  found  THEN ;      (search-wordlist) dup  IF  found  swap xt>s swap  THEN ;
   
   : (sfind) ( c-addr u -- xt n / 0 )
       lookup @ (search-wordlist) dup IF  found  THEN ;
   
   : sfind ( c-addr u -- xt n / 0 ) \ gforth
       lookup @ search-wordlist ;
   
   : find   ( addr -- cfa +-1 / string false ) \ core,search
       dup count sfind dup IF
           rot drop
       THEN
       dup 1 and 0=  IF  2/  THEN ;
   
   : (')    ( "name" -- xt ) \ gforth      paren-tick
       name (sfind) 0= IF  -&13 bounce THEN  ;
   : [(')]  ( compilation "name" -- ; run-time -- addr ) \ gforth  bracket-paren-tick
       (') postpone ALiteral ; immediate restrict
   
   : '    ( "name" -- xt ) \ core  tick
       (') xt>i ;
   : [']  ( compilation "name" -- ; run-time -- addr ) \ core      bracket-tick
       ' postpone ALiteral ; immediate restrict
   
   : C'    ( "name" -- xt ) \ gforth       c-tick
       (') xt>c ;
   : [C']  ( compilation "name" -- ; run-time -- addr ) \ gforth   bracket-c-tick
       C' postpone ALiteral ; immediate restrict
   
   : S'    ( "name" -- xt ) \ gforth       s-tick
       (') xt>s ;
   : [S']  ( compilation "name" -- ; run-time -- addr ) \ gforth   bracket-s-tick
       S' postpone ALiteral ; immediate restrict
   
   \ reveal words
   
 Variable warnings ( -- addr ) \ gforth  Variable warnings ( -- addr ) \ gforth
 G -1 warnings T !  G -1 warnings T !
   
 : check-shadow  ( addr count wid -- )  : check-shadow  ( addr count wid -- )
 \ prints a warning if the string is already present in the wordlist  \ prints a warning if the string is already present in the wordlist
 \ !! should be refined so the user can suppress the warnings  
  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if   >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
    ." redefined " name>string 2dup type     ." redefined " name>string 2dup type
    compare 0<> if     compare 0<> if
Line 1231  G -1 warnings T ! Line 1273  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : (sfind) ( c-addr u -- nfa | 0 )  
     lookup @ (search-wordlist) ;  
   
 : sfind ( c-addr u -- xt n / 0 ) \ gforth  
     lookup @ search-wordlist ;  
   
 : find   ( addr -- cfa +-1 / string false ) \ core,search  
     \ !! not ANS conformant: returns +-2 for restricted words  
     dup count sfind dup if  
         rot drop  
     then ;  
   
 : reveal ( -- ) \ gforth  : reveal ( -- ) \ gforth
     last?      last?
     if \ the last word has a header      if \ the last word has a header
Line 1257  G -1 warnings T ! Line 1287  G -1 warnings T !
 : rehash  ( wid -- )  : rehash  ( wid -- )
     dup wordlist-map @ rehash-method perform ;      dup wordlist-map @ rehash-method perform ;
   
 : '    ( "name" -- addr ) \ core        tick  
     name sfind 0= if -&13 bounce then ;  
 : [']  ( compilation "name" -- ; run-time --addr ) \ core       bracket-tick  
     ' postpone ALiteral ; immediate restrict  
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell ( -- c ) \ gforth  07 constant #bell ( -- c ) \ gforth
Line 1279  G -1 warnings T ! Line 1305  G -1 warnings T !
   
 \ : backspaces  0 ?DO  #bs emit  LOOP ;  \ : backspaces  0 ?DO  #bs emit  LOOP ;
   
 Variable ^d-mode  -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line  : (ins) ( max span addr pos1 key -- max span addr pos2 )
       >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )  : (bs) ( max span addr pos1 -- max span addr pos2 flag )
   over 3 pick 2 pick chars /string ;      dup IF
 : type-rest ( span addr pos1 -- span addr pos1 back )          #bs emit bl emit #bs emit 1- rot 1- -rot
   >string tuck type ;      THEN false ;
 : (del)  ( max span addr pos1 -- max span addr pos2 )  : (ret)  true space ;
   1- >string over 1+ -rot move  
   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;  
 : (ins)  ( max span addr pos1 char -- max span addr pos2 )  
   >r >string over 1+ swap move 2dup chars + r> swap c!  
   rot 1+ -rot type-rest 1- backspaces 1+ ;  
 : ?del ( max span addr pos1 -- max span addr pos2 0 )  
   dup  IF  (del)  THEN  0 ;  
 : (ret)  type-rest drop true space ;  
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  
 : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;  
 : eof  ^d-mode @  IF  
         bye  
     ELSE  2 pick over <>  
         IF  forw drop (del)  ELSE  #bell emit  THEN  0  
     THEN ;  
   
 Create ctrlkeys  Create ctrlkeys
   ] false false back  false  eof   false forw  false    ] false false false false  false false false false
     ?del  false (ret) false  false (ret) false false      (bs)  false (ret) false  false (ret) false false
     false false false false  false false false false      false false false false  false false false false
     false false false false  false false false false [      false false false false  false false false false [
   
   defer insert-char
   ' (ins) IS insert-char
 defer everychar  defer everychar
 ' noop IS everychar  ' noop IS everychar
   
Line 1316  defer everychar Line 1329  defer everychar
   dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
   dup bl <   IF  cells ctrlkeys + perform  EXIT  THEN    dup bl <   IF  cells ctrlkeys + perform  EXIT  THEN
   >r 2over = IF  rdrop bell 0 EXIT  THEN    >r 2over = IF  rdrop bell 0 EXIT  THEN
   r> (ins) 0 ;    r> insert-char 0 ;
   
 : accept   ( addr len -- len ) \ core  : accept   ( addr len -- len ) \ core
   dup 0< IF    abs over dup 1 chars - c@ tuck type     dup 0< IF    abs over dup 1 chars - c@ tuck type 
 \ this allows to edit given strings  \ this allows to edit given strings
          ELSE  0  THEN rot over           ELSE  0  THEN rot over
   BEGIN  key decode dup ^d-mode !  UNTIL    BEGIN  key decode  UNTIL
   2drop nip ;    2drop nip ;
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
Line 1439  create pathfilenamebuf 256 chars allot \ Line 1452  create pathfilenamebuf 256 chars allot \
 \   ELSE   false  \   ELSE   false
 \   THEN ;  \   THEN ;
   
   : absolut-path? ( addr u -- flag ) \ gforth
       \ a path is absolute, if it starts with a / or a ~ (~ expansion),
       \ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../
       \ Pathes simply containing a / are not absolute!
       over c@ '/ = >r
       over c@ '~ = >r
       2dup 2 min S" ./" compare 0= >r
            3 min S" ../" compare 0=
       r> r> r> or or or ;
   \   [char] / scan nip 0<> ;    
   
 : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth  : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
     \ opens a file for reading, searching in the path for it (unless      \ opens a file for reading, searching in the path for it (unless
     \ the filename contains a slash); c-addr2 u2 is the full filename      \ the filename contains a slash); c-addr2 u2 is the full filename
Line 1448  create pathfilenamebuf 256 chars allot \ Line 1472  create pathfilenamebuf 256 chars allot \
     \ the path will usually contain dirs that are only readable for      \ the path will usually contain dirs that are only readable for
     \ the user      \ the user
     \ !! use file-status to determine access mode?      \ !! use file-status to determine access mode?
     2dup [char] / scan nip ( 0<> )      2dup absolut-path?
     if \ the filename contains a slash      if \ the filename contains a slash
         2dup r/o open-file throw ( c-addr1 u1 file-id )          2dup r/o open-file throw ( c-addr1 u1 file-id )
         -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )          -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
Line 1812  Defer 'cold ' noop IS 'cold Line 1836  Defer 'cold ' noop IS 'cold
 \ or space and stackspace overrides  \ or space and stackspace overrides
   
 \ 0 arg contains, however, the name of the program.  \ 0 arg contains, however, the name of the program.
   
   

Removed from v.1.59  
changed lines
  Added in v.1.60


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