Diff for /gforth/Attic/kernal.fs between versions 1.36 and 1.42

version 1.36, 1995/04/30 23:18:23 version 1.42, 1995/10/11 19:39:34
Line 31 Line 31
   
 HEX  HEX
   
   \ labels for some code addresses
   
   : docon: ( -- addr )    \ gforth
       \ the code address of a @code{CONSTANT}
       ['] bl >code-address ;
   
   : docol: ( -- addr )    \ gforth
       \ the code address of a colon definition
       ['] docon: >code-address ;
   
   : dovar: ( -- addr )    \ gforth
       \ the code address of a @code{CREATE}d word
       ['] udp >code-address ;
   
   : douser: ( -- addr )   \ gforth
       \ the code address of a @code{USER} variable
       ['] s0 >code-address ;
   
   : dodefer: ( -- addr )  \ gforth
       \ the code address of a @code{defer}ed word
       ['] source >code-address ;
   
   : dofield: ( -- addr )  \ gforth
       \ the code address of a @code{field}
       ['] reveal-method >code-address ;
   
 \ 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 45  DOES> ( n -- )  + c@ ; Line 71  DOES> ( n -- )  + c@ ;
   
 \ here allot , c, A,                                   17dec92py  \ here allot , c, A,                                   17dec92py
   
 : dp    ( -- addr )  dpp @ ;  : dp    ( -- addr ) \ gforth
 : here  ( -- here )  dp @ ;      dpp @ ;
 : allot ( n -- )     dp +! ;  : here  ( -- here ) \ core
 : c,    ( c -- )     here 1 chars allot c! ;      dp @ ;
 : ,     ( x -- )     here cell allot  ! ;  : allot ( n -- ) \ core
 : 2,    ( w1 w2 -- ) \ general      dp +! ;
   : c,    ( c -- ) \ core
       here 1 chars allot c! ;
   : ,     ( x -- ) \ core
       here cell allot  ! ;
   : 2,    ( w1 w2 -- ) \ gforth
     here 2 cells allot 2! ;      here 2 cells allot 2! ;
   
 : aligned ( addr -- addr' )  : aligned ( addr -- addr' ) \ core
   [ cell 1- ] Literal + [ -1 cells ] Literal and ;    [ cell 1- ] Literal + [ -1 cells ] Literal and ;
 : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;  : align ( -- ) \ core
       here dup aligned swap ?DO  bl c,  LOOP ;
   
 : faligned ( addr -- f-addr )  : faligned ( addr -- f-addr ) \ float
   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;      [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 : falign ( -- )  : falign ( -- ) \ float
   here dup faligned swap      here dup faligned swap
   ?DO      ?DO
       bl c,          bl c,
   LOOP ;      LOOP ;
   
 \ !! this is machine-dependent, but works on all but the strangest machines  \ !! this is machine-dependent, but works on all but the strangest machines
 ' faligned Alias maxaligned  ' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth
 ' falign Alias maxalign  ' falign Alias maxalign ( -- ) \ gforth
   
 \ the code field is aligned if its body is maxaligned  
 \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"  \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
 ' maxaligned Alias cfaligned  ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
 ' maxalign Alias cfalign  \ the code field is aligned if its body is maxaligned
   ' maxalign Alias cfalign ( -- ) \ gforth
   
   : chars ( n1 -- n2 ) \ core
   ; immediate
   
 : chars ; immediate  
   
 : A!    ( addr1 addr2 -- )  dup relon ! ;  : A!    ( addr1 addr2 -- ) \ gforth
 : A,    ( addr -- )     here cell allot A! ;      dup relon ! ;
   : A,    ( addr -- ) \ gforth
       here cell allot A! ;
   
 \ on off                                               23feb93py  \ on off                                               23feb93py
   
 : on  ( addr -- )  true  swap ! ;  : on  ( addr -- ) \ gforth
 : off ( addr -- )  false swap ! ;      true  swap ! ;
   : off ( addr -- ) \ gforth
       false swap ! ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )  : (name>)  ( nfa -- cfa )
     count  $1F and  +  cfaligned ;      count  $1F and  +  cfaligned ;
 : name>    ( nfa -- cfa )  : name>    ( nfa -- cfa ) \ gforth
     cell+      cell+
     dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;      dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
   
 : found ( nfa -- cfa n )  cell+  : found ( nfa -- cfa n ) \ gforth
   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN      cell+
                   -1 r@ $40 and     IF  1-      THEN      dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
                      r> $20 and     IF  negate  THEN  ;                      -1 r@ $40 and     IF  1-      THEN
                          r> $20 and     IF  negate  THEN  ;
   
 \ (find)                                               17dec92py  \ (find)                                               17dec92py
   
Line 109  DOES> ( n -- )  + c@ ; Line 148  DOES> ( n -- )  + c@ ;
   
 \ place bounds                                         13feb93py  \ place bounds                                         13feb93py
   
 : place  ( addr len to -- ) over >r  rot over 1+  r> move c! ;  : place  ( addr len to -- ) \ gforth
 : bounds ( beg count -- end beg )  over + swap ;      over >r  rot over 1+  r> move c! ;
   : bounds ( beg count -- end beg ) \ gforth
       over + swap ;
   
 \ input stream primitives                              23feb93py  \ input stream primitives                              23feb93py
   
 : tib   >tib @ ;  : tib ( -- c-addr ) \ core-ext
 Defer source      \ obsolescent
 : (source) ( -- addr count ) tib #tib @ ;      >tib @ ;
   Defer source ( -- addr count ) \ core
   \ used by dodefer:, must be defer
   : (source) ( -- addr count )
       tib #tib @ ;
 ' (source) IS source  ' (source) IS source
   
 \ (word)                                               22feb93py  \ (word)                                               22feb93py
   
 : scan   ( addr1 n1 char -- addr2 n2 )  : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
     \ skip all characters not equal to char      \ skip all characters not equal to char
     >r      >r
     BEGIN      BEGIN
Line 132  Defer source Line 177  Defer source
         1 /string          1 /string
     REPEAT  THEN      REPEAT  THEN
     rdrop ;      rdrop ;
 : skip   ( addr1 n1 char -- addr2 n2 )  : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
     \ skip all characters equal to char      \ skip all characters equal to char
     >r      >r
     BEGIN      BEGIN
Line 152  Defer source Line 197  Defer source
   
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : parse-word  ( char -- addr len )  : parse-word  ( char -- addr len ) \ gforth
   source 2dup >r >r >in @ over min /string    source 2dup >r >r >in @ over min /string
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN    rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
   2dup + r> - 1+ r> min >in ! ;    2dup + r> - 1+ r> min >in ! ;
 : word   ( char -- addr )  : word   ( char -- addr ) \ core
   parse-word here place  bl here count + c!  here ;    parse-word here place  bl here count + c!  here ;
   
 : parse    ( char -- addr len )  : parse    ( char -- addr len ) \ core-ext
   >r  source  >in @ over min /string  over  swap r>  scan >r    >r  source  >in @ over min /string  over  swap r>  scan >r
   over - dup r> IF 1+ THEN  >in +! ;    over - dup r> IF 1+ THEN  >in +! ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
 : capitalize ( addr len -- addr len )  : capitalize ( addr len -- addr len ) \ gforth
   2dup chars 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) ( -- c-addr count )  : (name) ( -- c-addr count )
Line 181  Defer source Line 226  Defer source
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
 : Literal  ( n -- )  state @ IF postpone lit  , THEN ;  : Literal  ( compilation: n -- ; run-time: -- n ) \ core
                                                       immediate      state @ IF postpone lit  , THEN ; immediate
 : ALiteral ( n -- )  state @ IF postpone lit A, THEN ;  : ALiteral ( compilation: addr -- ; run-time: -- addr ) \ gforth
       state @ IF postpone lit A, THEN ;
                                                       immediate                                                        immediate
   
 : char   ( 'char' -- n )  bl word char+ c@ ;  : char   ( 'char' -- n ) \ core
 : [char] ( 'char' -- n )  char postpone Literal ; immediate      bl word char+ c@ ;
   : [char] ( compilation: 'char' -- ; run-time: -- n )
       char postpone Literal ; immediate
 ' [char] Alias Ascii immediate  ' [char] Alias Ascii immediate
   
 : (compile) ( -- )  r> dup cell+ >r @ compile, ;  : (compile) ( -- ) \ gforth
 : postpone ( "name" -- )      r> dup cell+ >r @ compile, ;
   : 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
Line 200  Defer source Line 249  Defer source
   
 \ digit?                                               17dec92py  \ digit?                                               17dec92py
   
 : digit?   ( char -- digit true/ false )  : digit?   ( char -- digit true/ false ) \ gforth
   base @ $100 =    base @ $100 =
   IF    IF
     true EXIT      true EXIT
Line 218  Defer source Line 267  Defer source
   
 : accumulate ( +d0 addr digit - +d1 addr )  : accumulate ( +d0 addr digit - +d1 addr )
   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;    swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
 : >number ( d addr count -- d addr count )  
   0 ?DO  count digit? WHILE  accumulate  LOOP 0  : >number ( d addr count -- d addr count ) \ core
   ELSE  1- I' I - UNLOOP  THEN ;      0
       ?DO
           count digit?
       WHILE
           accumulate
       LOOP
           0
       ELSE
           1- I' I -
           UNLOOP
       THEN ;
   
 \ number? number                                       23feb93py  \ number? number                                       23feb93py
   
 Create bases   10 ,   2 ,   A , 100 ,  Create bases   10 ,   2 ,   A , 100 ,
 \              16     2    10   Zeichen  \              16     2    10   Zeichen
 \ !! 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' )
   IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;      over c@ [char] $ - dup 4 u<
 : s>number ( addr len -- d )  base @ >r  dpl on      IF
   over c@ '- =  dup >r  IF  1 /string  THEN          cells bases + @ base ! 1 /string
   getbase  dpl on  0 0 2swap      ELSE
   BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE          drop
          dup dpl ! over c@ [char] . =  WHILE      THEN ;
          1 /string  : s>number ( addr len -- d )
   REPEAT  THEN  2drop rdrop dpl off  ELSE      base @ >r  dpl on
   2drop rdrop r> IF  dnegate  THEN      over c@ '- =  dup >r
   THEN r> base ! ;      IF
           1 /string
       THEN
       getbase  dpl on  0 0 2swap
       BEGIN
           dup >r >number dup
       WHILE
           dup r> -
       WHILE
           dup dpl ! over c@ [char] . =
       WHILE
           1 /string
       REPEAT  THEN
           2drop rdrop dpl off
       ELSE
           2drop rdrop r>
           IF
               dnegate
           THEN
       THEN
       r> base ! ;
   
 : snumber? ( c-addr u -- 0 / n -1 / d 0> )  : snumber? ( c-addr u -- 0 / n -1 / d 0> )
     s>number dpl @ 0=      s>number dpl @ 0=
     IF      IF
Line 252  Create bases   10 ,   2 ,   A , 100 , Line 332  Create bases   10 ,   2 ,   A , 100 ,
     else      else
         r> swap          r> swap
     then ;      then ;
 : s>d ( n -- d ) dup 0< ;  : s>d ( n -- d ) \ core         s-to-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 ;
   
 \ space spaces ud/mod                                  21mar93py  \ space spaces ud/mod                                  21mar93py
 decimal  decimal
 Create spaces  bl 80 times \ times from target compiler! 11may93jaw  Create spaces ( u -- ) \ core
 DOES>   ( u -- )  swap  bl 80 times \ times from target compiler! 11may93jaw
         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;  DOES>   ( u -- )
 Create backspaces  08 80 times \ times from target compiler! 11may93jaw      swap
 DOES>   ( u -- )  swap      0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;  Create backspaces
   08 80 times \ times from target compiler! 11may93jaw
   DOES>   ( u -- )
       swap
       0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
 hex  hex
 : space   1 spaces ;  : space ( -- ) \ core
       1 spaces ;
   
 : ud/mod ( ud1 u2 -- urem udquot )  >r 0 r@ um/mod r> swap >r  : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
                                     um/mod r> ;      >r 0 r@ um/mod r> swap >r
       um/mod r> ;
   
 : pad    ( -- addr )  : pad    ( -- addr ) \ core
   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;    here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
   
 \ hold <# #> sign # #s                                 25jan92py  \ hold <# #> sign # #s                                 25jan92py
   
 : hold    ( char -- )         pad cell - -1 chars over +! @ c! ;  : hold    ( char -- ) \ core
       pad cell - -1 chars over +! @ c! ;
   
 : <#                          pad cell - dup ! ;  : <# ( -- ) \ core      less-number-sign
       pad cell - dup ! ;
   
 : #>      ( 64b -- addr +n )  2drop pad cell - dup @ tuck - ;  : #>      ( xd -- addr u ) \ core       number-sign-greater
       2drop pad cell - dup @ tuck - ;
   
 : sign    ( n -- )            0< IF  [char] - hold  THEN ;  : sign    ( n -- ) \ core
       0< IF  [char] - hold  THEN ;
   
 : #       ( +d1 -- +d2 )    base @ 2 max ud/mod rot 9 over <  : #       ( ud1 -- ud2 ) \ core         number-sign
   IF [ char A char 9 - 1- ] Literal +  THEN  [char] 0 + hold ;      base @ 2 max ud/mod rot 9 over <
       IF
           [ char A char 9 - 1- ] Literal +
       THEN
       [char] 0 + hold ;
   
 : #s      ( +d -- 0 0 )         BEGIN  # 2dup d0=  UNTIL ;  : #s      ( +d -- 0 0 ) \ core  number-sign-s
       BEGIN
           # 2dup d0=
       UNTIL ;
   
 \ print numbers                                        07jun92py  \ print numbers                                        07jun92py
   
 : d.r      >r tuck  dabs  <# #s  rot sign #>  : d.r ( d n -- ) \ double       d-dot-r
            r> over - spaces  type ;      >r tuck  dabs  <# #s  rot sign #>
       r> over - spaces  type ;
 : ud.r     >r <# #s #> r> over - spaces type ;  
   : ud.r ( ud n -- ) \ gforth     u-d-dot-r
 : .r       >r s>d r> d.r ;      >r <# #s #> r> over - spaces type ;
 : u.r      0 swap ud.r ;  
   : .r ( n1 n2 -- ) \ core-ext    dot-r
 : d.       0 d.r space ;      >r s>d r> d.r ;
 : ud.      0 ud.r space ;  : u.r ( u n -- )  \ core-ext    u-dot-r
       0 swap ud.r ;
 : .        s>d d. ;  
 : u.       0 ud. ;  : d. ( d -- ) \ double  d-dot
       0 d.r space ;
   : ud. ( ud -- ) \ gforth        u-d-dot
       0 ud.r space ;
   
   : . ( n -- ) \ core     dot
       s>d d. ;
   : u. ( u -- ) \ core    u-dot
       0 ud. ;
   
 \ catch throw                                          23feb93py  \ catch throw                                          23feb93py
 \ bounce                                                08jun93jaw  \ bounce                                                08jun93jaw
Line 310  hex Line 419  hex
 \ !! allow the user to add rollback actions    anton  \ !! allow the user to add rollback actions    anton
 \ !! use a separate exception stack?           anton  \ !! use a separate exception stack?           anton
   
 : lp@ ( -- addr )  : lp@ ( -- addr ) \ gforth      l-p-fetch
  laddr# [ 0 , ] ;   laddr# [ 0 , ] ;
   
 : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )  : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
   >r sp@ r> swap >r       \ don't count xt! jaw    >r sp@ r> swap >r       \ don't count xt! jaw
   fp@ >r    fp@ >r
   lp@ >r    lp@ >r
Line 322  hex Line 431  hex
   execute    execute
   r> handler ! rdrop rdrop rdrop 0 ;    r> handler ! rdrop rdrop rdrop 0 ;
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
     ?DUP IF      ?DUP IF
         [ here 4 cells ! ]          [ here 4 cells ! ]
         handler @ rp!          handler @ rp!
Line 334  hex Line 443  hex
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
 \ programming without wasting time...   jaw  \ programming without wasting time...   jaw
 : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )  : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
 \ a throw without data or fp stack restauration  \ a throw without data or fp stack restauration
   ?DUP IF    ?DUP IF
     handler @ rp!      handler @ rp!
Line 346  hex Line 455  hex
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? )  sp@ s0 @ > IF  -4 throw  THEN ;  : ?stack ( ?? -- ?? ) \ gforth
       sp@ s0 @ > IF    -4 throw  THEN
       fp@ f0 @ > IF  -&45 throw  THEN  ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser  Defer parser
 Defer name      ' (name) IS name  Defer name ( -- c-addr count ) \ gforth
   \ get the next word from the input buffer
   ' (name) IS name
 Defer notfound ( c-addr count -- )  Defer notfound ( c-addr count -- )
   
 : no.extensions  ( addr u -- )  2drop -&13 bounce ;  : no.extensions  ( addr u -- )
       2drop -&13 bounce ;
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
 : interpret  : interpret ( ?? -- ?? ) \ gforth
       \ interpret/compile the (rest of the) input buffer
     BEGIN      BEGIN
         ?stack name dup          ?stack name dup
     WHILE      WHILE
Line 369  Defer notfound ( c-addr count -- ) Line 483  Defer notfound ( c-addr count -- )
   
 \ interpreter compiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : interpreter  ( c-addr u -- )   : 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
Line 389  Defer notfound ( c-addr count -- ) Line 503  Defer notfound ( c-addr count -- )
   
 ' interpreter  IS  parser  ' interpreter  IS  parser
   
 : compiler     ( c-addr u -- )  : 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
Line 412  Defer notfound ( c-addr count -- ) Line 526  Defer notfound ( c-addr count -- )
         drop notfound          drop notfound
     THEN ;      THEN ;
   
 : [     ['] interpreter  IS parser state off ; immediate  : [ ( -- ) \ core       left-bracket
 : ]     ['] compiler     IS parser state on  ;      ['] interpreter  IS parser state off ; immediate
   : ] ( -- ) \ core       right-bracket
       ['] compiler     IS parser state on  ;
   
 \ locals stuff needed for control structures  \ locals stuff needed for control structures
   
 : compile-lp+! ( n -- )  : compile-lp+! ( n -- ) \ gforth        compile-l-p-plus-store
     dup negate locals-size +!      dup negate locals-size +!
     0 over = if      0 over = if
     else -1 cells  over = if postpone lp-      else -1 cells  over = if postpone lp-
Line 426  Defer notfound ( c-addr count -- ) Line 542  Defer notfound ( c-addr count -- )
     else postpone lp+!# dup ,      else postpone lp+!# dup ,
     then then then then drop ;      then then then then drop ;
   
 : adjust-locals-size ( n -- )  : adjust-locals-size ( n -- ) \ gforth
     \ sets locals-size to n and generates an appropriate lp+!      \ sets locals-size to n and generates an appropriate lp+!
     locals-size @ swap - compile-lp+! ;      locals-size @ swap - compile-lp+! ;
   
Line 442  variable backedge-locals Line 558  variable backedge-locals
     \ the back edge if the BEGIN is unreachable from above. Set by      \ the back edge if the BEGIN is unreachable from above. Set by
     \ ASSUME-LIVE, reset by UNREACHABLE.      \ ASSUME-LIVE, reset by UNREACHABLE.
   
 : UNREACHABLE ( -- )  : UNREACHABLE ( -- ) \ gforth
     \ declares the current point of execution as unreachable      \ declares the current point of execution as unreachable
     dead-code on      dead-code on
     0 backedge-locals ! ; immediate      0 backedge-locals ! ; immediate
   
 : ASSUME-LIVE ( orig -- orig )  : ASSUME-LIVE ( orig -- orig ) \ gforth
     \ used immediateliy before a BEGIN that is not reachable from      \ used immediateliy before a BEGIN that is not reachable from
     \ above.  causes the BEGIN to assume that the same locals are live      \ above.  causes the BEGIN to assume that the same locals are live
     \ as at the orig point      \ as at the orig point
Line 540  variable backedge-locals Line 656  variable backedge-locals
   
 3 constant cs-item-size  3 constant cs-item-size
   
 : CS-PICK ( ... u -- ... destu )  : CS-PICK ( ... u -- ... destu ) \ tools-ext
  1+ cs-item-size * 1- >r   1+ cs-item-size * 1- >r
  r@ pick  r@ pick  r@ pick   r@ pick  r@ pick  r@ pick
  rdrop   rdrop
  dup non-orig? ;   dup non-orig? ;
   
 : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu )  : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext
  1+ cs-item-size * 1- >r   1+ cs-item-size * 1- >r
  r@ roll r@ roll r@ roll   r@ roll r@ roll r@ roll
  rdrop   rdrop
Line 572  variable backedge-locals Line 688  variable backedge-locals
 : >resolve    ( addr -- )        here over - swap ! ;  : >resolve    ( addr -- )        here over - swap ! ;
 : <resolve    ( addr -- )        here - , ;  : <resolve    ( addr -- )        here - , ;
   
 : BUT       1 cs-roll ;                      immediate restrict  : BUT
 : YET       0 cs-pick ;                       immediate restrict      1 cs-roll ;                      immediate restrict
   : YET
       0 cs-pick ;                       immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : AHEAD ( -- orig )  : AHEAD ( compilation: -- orig ; run-time: -- ) \ tools-ext
  POSTPONE branch >mark POSTPONE unreachable ; immediate restrict      POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict
   
 : IF ( -- orig )  : IF ( compilation: -- orig ; run-time: f -- ) \ core
  POSTPONE ?branch >mark ; immediate restrict   POSTPONE ?branch >mark ; immediate restrict
   
 : ?DUP-IF \ general  : ?DUP-IF ( compilation: -- orig ; run-time: n -- n| ) \ gforth question-dupe-if
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  \ This is the preferred alternative to the idiom "?DUP IF", since it can be
 \ better handled by tools like stack checkers  \ better handled by tools like stack checkers
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup POSTPONE if ;       immediate restrict
 : ?DUP-0=-IF \ general  : ?DUP-0=-IF ( compilation: -- orig ; run-time: n -- n| ) \ gforth      question-dupe-zero-equals-if
     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict      POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
   
 : THEN ( orig -- )  : THEN ( compilation: orig -- ; run-time: -- ) \ core
     dup orig?      dup orig?
     dead-orig =      dead-orig =
     if      if
Line 607  variable backedge-locals Line 725  variable backedge-locals
         then          then
     then ; immediate restrict      then ; immediate restrict
   
 ' THEN alias ENDIF immediate restrict \ general  ' THEN alias ENDIF ( compilation: orig -- ; run-time: -- ) \ gforth
   immediate restrict
 \ Same as "THEN". This is what you use if your program will be seen by  \ Same as "THEN". This is what you use if your program will be seen by
 \ people who have not been brought up with Forth (or who have been  \ people who have not been brought up with Forth (or who have been
 \ brought up with fig-Forth).  \ brought up with fig-Forth).
   
 : ELSE ( orig1 -- orig2 )  : ELSE ( compilation: orig1 -- orig2 ; run-time: f -- ) \ core
     POSTPONE ahead      POSTPONE ahead
     1 cs-roll      1 cs-roll
     POSTPONE then ; immediate restrict      POSTPONE then ; immediate restrict
   
   
 : BEGIN ( -- dest )  : BEGIN ( compilation: -- dest ; run-time: -- ) \ core
     dead-code @ if      dead-code @ if
         \ set up an assumption of the locals visible here.  if the          \ set up an assumption of the locals visible here.  if the
         \ users want something to be visible, they have to declare          \ users want something to be visible, they have to declare
Line 633  variable backedge-locals Line 752  variable backedge-locals
 \ 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 ( dest -- )  : AGAIN ( compilation: dest -- ; run-time: -- ) \ core-ext
     dest?      dest?
     over list-size adjust-locals-size      over list-size adjust-locals-size
     POSTPONE branch      POSTPONE branch
Line 659  variable backedge-locals Line 778  variable backedge-locals
     then ( list )      then ( list )
     check-begin ;      check-begin ;
   
 : UNTIL ( dest -- )  : UNTIL ( compilation: dest -- ; run-time: f -- ) \ core
     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict      dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
   
 : WHILE ( dest -- orig dest )  : WHILE ( compilation: dest -- orig dest ; run-time: f -- ) \ core
     POSTPONE if      POSTPONE if
     1 cs-roll ; immediate restrict      1 cs-roll ; immediate restrict
   
 : REPEAT ( orig dest -- )  : REPEAT ( compilation: orig dest -- ; run-time: -- ) \ core
     POSTPONE again      POSTPONE again
     POSTPONE then ; immediate restrict      POSTPONE then ; immediate restrict
   
Line 710  Avariable leave-sp  leave-stack 3 cells Line 829  Avariable leave-sp  leave-stack 3 cells
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : DONE ( orig -- )  : DONE ( compilation: orig -- ; run-time: -- ) \ gforth
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
     drop >r drop      drop >r drop
     begin      begin
Line 721  Avariable leave-sp  leave-stack 3 cells Line 840  Avariable leave-sp  leave-stack 3 cells
     repeat      repeat
     >leave rdrop ; immediate restrict      >leave rdrop ; immediate restrict
   
 : LEAVE ( -- )  : LEAVE ( compilation: -- ; run-time: loop-sys -- ) \ core
     POSTPONE ahead      POSTPONE ahead
     >leave ; immediate restrict      >leave ; immediate restrict
   
 : ?LEAVE ( -- )  : ?LEAVE ( compilation: -- ; run-time: f | f loop-sys -- ) \ gforth     question-leave
     POSTPONE 0= POSTPONE if      POSTPONE 0= POSTPONE if
     >leave ; immediate restrict      >leave ; immediate restrict
   
 : DO ( -- do-sys )  : DO ( compilation: -- do-sys ; run-time: w1 w2 -- loop-sys )
     POSTPONE (do)      POSTPONE (do)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
   
 : ?DO ( -- do-sys )  : ?do-like ( -- do-sys )
     ( 0 0 0 >leave )      ( 0 0 0 >leave )
     POSTPONE (?do)  
     >mark >leave      >mark >leave
     POSTPONE begin drop do-dest ; immediate restrict      POSTPONE begin drop do-dest ;
   
   : ?DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys )        \ core-ext      question-do
       POSTPONE (?do) ?do-like ; immediate restrict
   
   : +DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys )        \ gforth        plus-do
       POSTPONE (+do) ?do-like ; immediate restrict
   
   : U+DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys )       \ gforth        u-plus-do
       POSTPONE (u+do) ?do-like ; immediate restrict
   
   : -DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys )        \ gforth        minus-do
       POSTPONE (-do) ?do-like ; immediate restrict
   
 : FOR ( -- do-sys )  : U-DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys )       \ gforth        u-minus-do
       POSTPONE (u-do) ?do-like ; immediate restrict
   
   : FOR ( compilation: -- do-sys ; run-time: w -- loop-sys )      \ gforth
     POSTPONE (for)      POSTPONE (for)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
Line 751  Avariable leave-sp  leave-stack 3 cells Line 884  Avariable leave-sp  leave-stack 3 cells
     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?      >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
     until-like  POSTPONE done  POSTPONE unloop ;      until-like  POSTPONE done  POSTPONE unloop ;
   
 : LOOP ( do-sys -- )  : LOOP ( compilation: do-sys -- ; run-time: loop-sys1 -- | loop-sys2 )  \ core
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( do-sys -- )  : +LOOP ( compilation: do-sys -- ; run-time: loop-sys1 n -- | loop-sys2 )       \ core  plus-loop
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict   ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
   \ !! should the compiler warn about +DO..-LOOP?
   : -LOOP ( compilation: do-sys -- ; run-time: loop-sys1 u -- | loop-sys2 )       \ gforth        minus-loop
    ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
   
 \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"  \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
 \ will iterate as often as "high low ?DO inc S+LOOP". For positive  \ will iterate as often as "high low ?DO inc S+LOOP". For positive
 \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for  \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
 \ negative increments.  \ negative increments.
 : S+LOOP ( do-sys -- )  : S+LOOP ( compilation: do-sys -- ; run-time: loop-sys1 n -- | loop-sys2 )      \ gforth        s-plus-loop
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict   ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : NEXT ( do-sys -- )  : NEXT ( compilation: do-sys -- ; run-time: loop-sys1 -- | loop-sys2 ) \ gforth
  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict   ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : EXIT ( -- )  : EXIT ( compilation: -- ; run-time: nest-sys -- ) \ core
     0 adjust-locals-size      0 adjust-locals-size
     POSTPONE ;s      POSTPONE ;s
     POSTPONE unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
 : ?EXIT ( -- )  : ?EXIT ( -- ) ( compilation: -- ; run-time: nest-sys f -- | nest-sys ) \ gforth
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict       POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
   
 \ Strings                                              22feb93py  \ Strings                                              22feb93py
Line 785  Avariable leave-sp  leave-stack 3 cells Line 922  Avariable leave-sp  leave-stack 3 cells
   r> r> dup count + aligned >r swap >r ;               restrict    r> r> dup count + aligned >r swap >r ;               restrict
 : (.")     "lit count type ;                           restrict  : (.")     "lit count type ;                           restrict
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;                                restrict
 : SLiteral postpone (S") here over char+ allot  place align ;  : SLiteral ( Compilation: c-addr1 u ; run-time: -- c-addr2 u ) \ string
       postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
 create s"-buffer /line chars allot  create s"-buffer /line chars allot
 : S" ( run-time: -- c-addr u )  : S" ( compilation: 'ccc"' -- ; run-time: -- c-addr u ) \ core,file     s-quote
     [char] " parse      [char] " parse
     state @      state @
     IF      IF
Line 796  create s"-buffer /line chars allot Line 934  create s"-buffer /line chars allot
     ELSE      ELSE
         /line min >r s"-buffer r@ cmove          /line min >r s"-buffer r@ cmove
         s"-buffer r>          s"-buffer r>
     THEN ;      THEN ; immediate
                                              immediate  
 : ."       state @  IF    postpone (.") ,"  align  : ." ( compilation: 'ccc"' -- ; run-time: -- )  \ core  dot-quote
       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
 : (        [char] ) parse 2drop ;                       immediate  : ( ( compilation: 'ccc<close-paren>' -- ; run-time: -- ) \ core,file   paren
       [char] ) parse 2drop ;                       immediate
 : \ ( -- ) \ core-ext backslash  : \ ( -- ) \ core-ext backslash
     blk @      blk @
     IF      IF
Line 809  create s"-buffer /line chars allot Line 949  create s"-buffer /line chars allot
     THEN      THEN
     source >in ! drop ; immediate      source >in ! drop ; immediate
   
 : \G ( -- ) \ new backslash  : \G ( -- ) \ gforth backslash
     POSTPONE \ ; immediate      POSTPONE \ ; immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
   
 : (abort")      "lit >r IF  r> "error ! -2 throw  THEN  : (abort")
                 rdrop ;      "lit >r
 : abort"        postpone (abort") ," ;        immediate restrict      IF
           r> "error ! -2 throw
       THEN
       rdrop ;
   : abort" ( compilation: 'ccc"' -- ; run-time: f -- ) \ core,exception-ext       abort-quote
       postpone (abort") ," ;        immediate restrict
   
 \ Header states                                        23feb93py  \ Header states                                        23feb93py
   
Line 835  create s"-buffer /line chars allot Line 980  create s"-buffer /line chars allot
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer (header)  defer (header)
 defer header     ' (header) IS header  defer header ( -- ) \ gforth
   ' (header) IS header
   
 : string, ( c-addr u -- )  : string, ( c-addr u -- ) \ gforth
     \ puts down string as cstring      \ puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : name,  ( "name" -- )  : name,  ( "name" -- ) \ gforth
     name name-too-short? name-too-long?      name name-too-short? name-too-long?
     string, cfalign ;      string, cfalign ;
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
Line 867  create nextname-buffer 32 chars allot Line 1013  create nextname-buffer 32 chars allot
     input-stream ;      input-stream ;
   
 \ 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 -- ) \ gforth
     name-too-long?      name-too-long?
     nextname-buffer c! ( c-addr )      nextname-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
Line 877  create nextname-buffer 32 chars allot Line 1023  create nextname-buffer 32 chars allot
     0 last ! cfalign      0 last ! cfalign
     input-stream ;      input-stream ;
   
 : noname ( -- ) \ general  : noname ( -- ) \ gforth
 \ the next defined word remains anonymous. The xt of that word is given by lastxt  \ the next defined word remains anonymous. The xt of that word is given by lastxt
     ['] noname-header IS (header) ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ general  : lastxt ( -- xt ) \ gforth
 \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname  \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
     lastcfa @ ;      lastcfa @ ;
   
 : Alias    ( cfa "name" -- )  : Alias    ( cfa "name" -- ) \ gforth
   Header reveal , $80 flag! ;    Header reveal , $80 flag! ;
   
 : name>string ( nfa -- addr count )  : name>string ( nfa -- addr count ) \ gforth    name-to-string
  cell+ count $1F and ;   cell+ count $1F and ;
   
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa )  : >name ( cfa -- nfa ) \ gforth to-name
  $21 cell do   $21 cell do
    dup i - count $9F and + cfaligned over $80 + = if     dup i - count $9F and + cfaligned over $80 + = if
      i - cell - unloop exit       i - cell - unloop exit
Line 900  Create ???  0 , 3 c, char ? c, char ? c, Line 1046  Create ???  0 , 3 c, char ? c, char ? c,
  cell +loop   cell +loop
  drop ??? ( wouldn't 0 be better? ) ;   drop ??? ( wouldn't 0 be better? ) ;
   
 \ indirect threading                                   17mar93py  \ threading                                   17mar93py
   
 : cfa,     ( code-address -- )  : cfa,     ( code-address -- )  \ gforth        cfa-comma
     here lastcfa !      here
     here  0 A, 0 ,  code-address! ;      dup lastcfa !
 : compile, ( xt -- )            A, ;      0 A, 0 ,  code-address! ;
 : !does    ( addr -- )          lastcfa @ does-code! ;  : compile, ( xt -- )    \ core-ext      compile-comma
 : (;code)  ( R: addr -- )       r> /does-handler + !does ;      A, ;
   : !does    ( addr -- ) \ gforth store-does
       lastxt does-code! ;
   : (does>)  ( R: addr -- )
       r> /does-handler + !does ;
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    here /does-handler allot does-handler! ;
   
 \ direct threading is implementation dependent  : Create ( -- ) \ core
       Header reveal dovar: cfa, ;
 : Create    Header reveal [ :dovar ] Literal cfa, ;  
   
 \ DOES>                                                17mar93py  \ DOES>                                                17mar93py
   
 : DOES>  ( compilation: -- )  : DOES>  ( compilation: colon-sys1 -- colon-sys2 ; run-time: nest-sys -- ) \ core       does
     state @      state @
     IF      IF
         ;-hook postpone (;code) dodoes,          ;-hook postpone (does>) ?struc dodoes,
     ELSE      ELSE
         dodoes, here !does 0 ]          align dodoes, here !does ]
     THEN       THEN 
     :-hook ; immediate      defstart :-hook ; immediate
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
 : Variable  Create 0 , ;  : Variable ( -- ) \ core
 : AVariable Create 0 A, ;      Create 0 , ;
   : AVariable ( -- ) \ gforth
       Create 0 A, ;
 : 2VARIABLE ( "name" -- ) \ double  : 2VARIABLE ( "name" -- ) \ double
     create 0 , 0 , ;      create 0 , 0 , ;
           
 : User      Variable ;  : User
 : AUser     AVariable ;      Variable ;
   : AUser
       AVariable ;
   
   : (Constant)  Header reveal docon: cfa, ;
   : Constant ( w -- ) \ core
       (Constant) , ;
   : AConstant ( addr -- ) \ gforth
       (Constant) A, ;
   
 : (Constant)  Header reveal [ :docon ] Literal cfa, ;  : 2Constant ( d -- ) \ double
 : Constant  (Constant) , ;  
 : AConstant (Constant) A, ;  
   
 : 2Constant  
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
Line 948  Create ???  0 , 3 c, char ? c, char ? c, Line 1103  Create ???  0 , 3 c, char ? c, char ? c,
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer ( -- )  : Defer ( -- ) \ gforth
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal [ :dodefer ] Literal cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
 \     Create ( -- )   \     Create ( -- ) 
 \       ['] noop A,  \       ['] noop A,
 \     DOES> ( ??? )  \     DOES> ( ??? )
 \       @ execute ;  \       @ execute ;
   
 : IS ( addr "name" -- )  : IS ( addr "name" -- ) \ gforth
     ' >body      ' >body
     state @      state @
     IF    postpone ALiteral postpone !        IF    postpone ALiteral postpone !  
     ELSE  !      ELSE  !
     THEN ;  immediate      THEN ;  immediate
 ' IS Alias TO immediate  ' IS Alias TO ( addr "name" -- ) \ core-ext
   immediate
   
 : What's ( "name" -- addr )  ' >body  : What's ( "name" -- addr ) \ gforth
   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;      ' >body
                                              immediate      state @
 : Defers ( "name" -- )  ' >body @ compile, ;      IF
                                              immediate          postpone ALiteral postpone @
       ELSE
           @
       THEN ; immediate
   : Defers ( "name" -- ) \ gforth
       ' >body @ compile, ; immediate
   
 \ : ;                                                  24feb93py  \ : ;                                                  24feb93py
   
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys )  Header [ :docol ] Literal cfa, defstart ] :-hook ;  : : ( -- colon-sys ) \ core     colon
 : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;      Header docol: cfa, defstart ] :-hook ;
   immediate restrict  : ; ( compilation: colon-sys -- ; run-time: nest-sys ) \ core   semicolon
       ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
   
 : :noname ( -- xt colon-sys )  : :noname ( -- xt colon-sys ) \ core-ext        colon-no-name
     0 last !      0 last !
     here [ :docol ] Literal cfa, 0 ] :-hook ;      here docol: cfa, 0 ] :-hook ;
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
 AVariable current  AVariable current ( -- addr ) \ gforth
   
 : last?   ( -- false / nfa nfa )    last @ ?dup ;  : last?   ( -- false / nfa nfa )
       last @ ?dup ;
 : (reveal) ( -- )  : (reveal) ( -- )
   last?      last?
   IF      IF
       dup @ 0<          dup @ 0<
       IF          IF
         current @ @ over ! current @ !              current @ @ over ! current @ !
       ELSE          ELSE
         drop              drop
       THEN          THEN
   THEN ;      THEN ;
   
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
Line 1006  AVariable current Line 1169  AVariable current
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
   1 cells: field reveal-method \ xt: ( -- )    1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
Line 1030  G forth-wordlist current T ! Line 1193  G forth-wordlist current T !
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup wordlist-map @ find-method @ execute ;    dup wordlist-map @ find-method @ execute ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search
     (search-wordlist) dup  IF  found  THEN ;      (search-wordlist) dup  IF  found  THEN ;
   
 Variable warnings  G -1 warnings T !  Variable warnings ( -- addr ) \ gforth
   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
Line 1049  Variable warnings  G -1 warnings T ! Line 1213  Variable warnings  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : sfind ( c-addr u -- xt n / 0 )  : sfind ( c-addr u -- xt n / 0 ) \ gforth
     lookup @ search-wordlist ;      lookup @ search-wordlist ;
   
 : find   ( addr -- cfa +-1 / string false )  : find   ( addr -- cfa +-1 / string false ) \ core,search
     \ !! not ANS conformant: returns +-2 for restricted words      \ !! not ANS conformant: returns +-2 for restricted words
     dup count sfind dup if      dup count sfind dup if
         rot drop          rot drop
     then ;      then ;
   
 : reveal ( -- )  : reveal ( -- ) \ gforth
  last? if   last? if
    name>string current @ check-shadow     name>string current @ check-shadow
  then   then
  current @ wordlist-map @ reveal-method @ execute ;   current @ wordlist-map @ reveal-method @ execute ;
   
 : rehash  ( wid -- )  dup wordlist-map @ rehash-method @ execute ;  : rehash  ( wid -- )
       dup wordlist-map @ rehash-method @ execute ;
   
 : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;  : '    ( "name" -- addr ) \ core        tick
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate      name sfind 0= if -&13 bounce then ;
   : [']  ( compilation: "name" -- ; run-time: --addr ) \ core     bracket-tick
       ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell  07 constant #bell ( -- c ) \ gforth
 08 constant #bs  08 constant #bs ( -- c ) \ gforth
 09 constant #tab  09 constant #tab ( -- c ) \ gforth
 7F constant #del  7F constant #del ( -- c ) \ gforth
 0D constant #cr                \ the newline key code  0D constant #cr   ( -- c ) \ gforth
 0C constant #ff  \ the newline key code
 0A constant #lf  0C constant #ff ( -- c ) \ gforth
   0A constant #lf ( -- c ) \ gforth
   
 : bell  #bell emit ;  : bell  #bell emit ;
   
Line 1096  Variable warnings  G -1 warnings T ! Line 1264  Variable warnings  G -1 warnings T !
 : (ret)  type-rest drop true space ;  : (ret)  type-rest drop true space ;
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  : 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 ;  : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
   : eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;
   
 Create ctrlkeys  Create ctrlkeys
   ] false false back  false  false false forw  false    ] false false back  false  eof   false forw  false
     ?del  false (ret) false  false (ret) false false      ?del  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 [
Line 1116  defer everychar Line 1285  defer everychar
 \ decode should better use a table for control key actions  \ decode should better use a table for control key actions
 \ to define keyboard bindings later  \ to define keyboard bindings later
   
 : accept   ( addr len -- len )  : 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
Line 1125  defer everychar Line 1294  defer everychar
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
 Defer type      \ defer type for a output buffer or fast  Defer type ( c-addr u -- ) \ core
                 \ screen write  \ defer type for a output buffer or fast
   \ screen write
   
 \ : (type) ( addr len -- )  \ : (type) ( addr len -- )
 \   bounds ?DO  I c@ emit  LOOP ;  \   bounds ?DO  I c@ emit  LOOP ;
   
 ' (type) IS Type  ' (type) IS Type
   
 Defer emit  Defer emit ( c -- ) \ core
   
 ' (Emit) IS Emit  ' (Emit) IS Emit
   
 Defer key  Defer key ( -- c ) \ core
 ' (key) IS key  ' (key) IS key
   
 \ : form  ( -- rows cols )  &24 &80 ;  \ : form  ( -- rows cols )  &24 &80 ;
Line 1147  Defer key Line 1316  Defer key
   
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag ) \ core-ext,block-ext,file-ext
   blk @  IF  1 blk +!  true  EXIT  THEN    blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    read-line throw    IF    read-line throw
Line 1158  Defer key Line 1327  Defer key
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- )  loadfile off  blk off  refill drop ;  : Query  ( -- ) \ core-ext
       \ obsolescent
       loadfile off  blk off  refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1166  Defer key Line 1337  Defer key
 \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,  \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,
 \ 2 c, here char r c, char + c, 0 c,  \ 2 c, here char r c, char + c, 0 c,
 \ 2 c, here char w c, char + c, 0 c, align  \ 2 c, here char w c, char + c, 0 c, align
 4 Constant w/o  4 Constant w/o ( -- fam ) \ file        w-o
 2 Constant r/w  2 Constant r/w ( -- fam ) \ file        r-o
 0 Constant r/o  0 Constant r/o ( -- fam ) \ file        r-w
   
 \ BIN WRITE-LINE                                        11jun93jaw  \ BIN WRITE-LINE                                        11jun93jaw
   
 \ : bin           dup 1 chars - c@  \ : bin           dup 1 chars - c@
 \                 r/o 4 chars + over - dup >r swap move r> ;  \                 r/o 4 chars + over - dup >r swap move r> ;
   
 : bin  1 or ;  : bin ( fam1 -- fam2 ) \ file
       1 or ;
   
 create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos  create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
                            \ or not unix environments if                             \ or not unix environments if
                            \ bin is not selected                             \ bin is not selected
   
 : write-line    dup >r write-file ?dup IF r> drop EXIT THEN  : write-line ( c-addr u fileid -- ior ) \ file
                 nl$ count r> write-file ;      dup >r write-file
       ?dup IF
           r> drop EXIT
       THEN
       nl$ count r> write-file ;
   
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
Line 1207  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1383  create nl$ 1 c, A c, 0 c, \ gnu includes
 : read-loop ( i*x -- j*x )  : read-loop ( i*x -- j*x )
   BEGIN  refill  WHILE  interpret  REPEAT ;    BEGIN  refill  WHILE  interpret  REPEAT ;
   
 : include-file ( i*x fid -- j*x )  : include-file ( i*x fid -- j*x ) \ file
   push-file  loadfile !    push-file  loadfile !
   0 loadline ! blk off  ['] read-loop catch    0 loadline ! blk off  ['] read-loop catch
   loadfile @ close-file swap 2dup or    loadfile @ close-file swap 2dup or
Line 1215  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1391  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 create pathfilenamebuf 256 chars allot \ !! make this grow on demand  create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   
 : check-file-prefix  ( addr len -- addr' len' flag )  \ : check-file-prefix  ( addr len -- addr' len' flag )
   dup 0=                    IF  true EXIT  THEN   \   dup 0=                    IF  true EXIT  THEN 
   over c@ '/ =              IF  true EXIT  THEN   \   over c@ '/ =              IF  true EXIT  THEN 
   over 2 S" ./" compare 0=  IF  true EXIT  THEN   \   over 2 S" ./" compare 0=  IF  true EXIT  THEN 
   over 3 S" ../" compare 0= IF  true EXIT  THEN  \   over 3 S" ../" compare 0= IF  true EXIT  THEN
   over 2 S" ~/" compare 0=  \   over 2 S" ~/" compare 0=
   IF     1 /string  \   IF     1 /string
          S" HOME" getenv tuck pathfilenamebuf swap move  \          S" HOME" getenv tuck pathfilenamebuf swap move
          2dup + >r pathfilenamebuf + swap move  \          2dup + >r pathfilenamebuf + swap move
          pathfilenamebuf r> true  \          pathfilenamebuf r> true
   ELSE   false  \   ELSE   false
   THEN ;  \   THEN ;
   
 : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )  : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
     \ opens a file for reading, searching in the path for it; c-addr2      \ opens a file for reading, searching in the path for it (unless
     \ u2 is the full filename (valid until the next call); if the file      \ the filename contains a slash); c-addr2 u2 is the full filename
     \ is not found (or in case of other errors for each try), -38      \ (valid until the next call); if the file is not found (or in
     \ (non-existant file) is thrown. Opening for other access modes      \ case of other errors for each try), -38 (non-existant file) is
     \ makes little sense, as the path will usually contain dirs that      \ thrown. Opening for other access modes makes little sense, as
     \ are only readable for the user      \ the path will usually contain dirs that are only readable for
     \ !! check for "/", "./", "../" in original filename; check for "~/"?      \ the user
     check-file-prefix 0=       \ !! use file-status to determine access mode?
     IF  pathdirs 2@ 0      2dup [char] / scan nip ( 0<> )
       if \ the filename contains a slash
           2dup r/o open-file throw ( c-addr1 u1 file-id )
           -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
           pathfilenamebuf r> EXIT
       then
       pathdirs 2@ 0
   \    check-file-prefix 0= 
   \    IF  pathdirs 2@ 0
     ?DO ( c-addr1 u1 dirnamep )      ?DO ( c-addr1 u1 dirnamep )
         dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )          dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
         2dup pathfilenamebuf r@ chars + swap cmove ( addr u )          2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
         pathfilenamebuf over r> + dup >r r/o open-file 0=          pathfilenamebuf over r> + dup >r r/o open-file 0=
         IF ( addr u file-id )          IF ( addr u file-id )
             nip nip r> rdrop 0 leave              nip nip r> rdrop 0 LEAVE
         THEN          THEN
         rdrop drop r> cell+ cell+          rdrop drop r> cell+ cell+
     LOOP      LOOP
     ELSE   2dup open-file throw -rot  THEN   \    ELSE   2dup open-file throw -rot  THEN 
     0<> -&38 and throw ( file-id u2 )      0<> -&38 and throw ( file-id u2 )
     pathfilenamebuf swap ;      pathfilenamebuf swap ;
   
 create included-files 0 , 0 , ( pointer to and count of included files )  create included-files 0 , 0 , ( pointer to and count of included files )
   create image-included-files 0 , 0 , ( pointer to and count of included files )
   \ included-files points to ALLOCATEd space, while image-included-files
   \ points to ALLOTed objects, so it survives a save-system
   
   : init-included-files ( -- )
       image-included-files 2@ 2* cells save-string drop ( addr )
       image-included-files 2@ nip included-files 2! ;
   
 : included? ( c-addr u -- f )  : included? ( c-addr u -- f ) \ gforth
     \ true, iff filename c-addr u is in included-files      \ true, iff filename c-addr u is in included-files
     included-files 2@ 0      included-files 2@ 0
     ?do ( c-addr u addr )      ?do ( c-addr u addr )
Line 1266  create included-files 0 , 0 , ( pointer Line 1457  create included-files 0 , 0 , ( pointer
     loop      loop
     2drop drop false ;      2drop drop false ;
   
 : add-included-file ( c-addr u -- )  : add-included-file ( c-addr u -- ) \ gforth
     \ add name c-addr u to included-files      \ add name c-addr u to included-files
     included-files 2@ tuck 1+ 2* cells resize throw      included-files 2@ tuck 1+ 2* cells resize throw
     swap 2dup 1+ included-files 2!      swap 2dup 1+ included-files 2!
     2* cells + 2! ;      2* cells + 2! ;
   
 : save-string           ( addr1 u -- addr2 u )  : save-string           ( addr1 u -- addr2 u ) \ gforth
       \ !! not a string, but a memblock word
     swap >r      swap >r
     dup allocate throw      dup allocate throw
     swap 2dup r> -rot move ;      swap 2dup r> -rot move ;
   
 : included1 ( i*x file-id c-addr u -- j*x )  : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
     \ include the file file-id with the name given by c-addr u      \ include the file file-id with the name given by c-addr u
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
     save-string 2dup loadfilename 2! add-included-file ( file-id )      save-string 2dup loadfilename 2! add-included-file ( file-id )
     ['] include-file catch      ['] include-file catch
     r> r> loadfilename 2!  throw ;      r> r> loadfilename 2!  throw ;
           
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x ) \ gforth
     open-path-file included1 ;      open-path-file included1 ;
   
 : required ( i*x addr u -- j*x )  : required ( i*x addr u -- j*x ) \ gforth
     \ include the file with the name given by addr u, if it is not      \ include the file with the name given by addr u, if it is not
     \ included already. Currently this works by comparing the name of      \ included already. Currently this works by comparing the name of
     \ the file (with path) against the names of earlier included      \ the file (with path) against the names of earlier included
Line 1305  create included-files 0 , 0 , ( pointer Line 1497  create included-files 0 , 0 , ( pointer
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
 : decimal a base ! ;  : decimal ( -- ) \ core
 : hex     10 base ! ;      a base ! ;
   : hex ( -- ) \ core-ext
       10 base ! ;
   
 \ DEPTH                                                 9may93jaw  \ DEPTH                                                 9may93jaw
   
 : depth ( -- +n )  sp@ s0 @ swap - cell / ;  : depth ( -- +n ) \ core
 : clearstack ( ... -- )  s0 @ sp! ;      sp@ s0 @ swap - cell / ;
   : clearstack ( ... -- )
       s0 @ sp! ;
   
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  ( "file" -- )  : include  ( "file" -- ) \ gforth
   name included ;    name included ;
   
 : require  ( "file" -- )  : require  ( "file" -- ) \ gforth
   name required ;    name required ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse ( -- )  : recurse ( compilation: -- ; run-time: ?? -- ?? ) \ core
     lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
 : recursive ( -- )  : recursive ( -- ) \ gforth
     reveal ; immediate      reveal last off ; immediate
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   
 \ !! I think */mod should have the same rounding behaviour as / - anton  \ !! I think */mod should have the same rounding behaviour as / - anton
 : */mod >r m* r> sm/rem ;  : */mod ( n1 n2 n3 -- n4 n5 ) \ core    star-slash-mod
       >r m* r> sm/rem ;
   
 : */ */mod nip ;  : */ ( n1 n2 n3 -- n4 ) \ core  star-slash
       */mod nip ;
   
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 : evaluate ( c-addr len -- )  : evaluate ( c-addr len -- ) \ core,block
   push-file  dup #tib ! >tib @ swap move    push-file  dup #tib ! >tib @ swap move
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
   
 \  BEGIN  interpret  >in @ #tib @ u>= UNTIL  \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
   ['] interpret catch    ['] interpret catch
   pop-file throw ;    pop-file throw ;
   
   : abort ( ?? -- ?? ) \ core,exception-ext
 : abort -1 throw ;      -1 throw ;
   
 \+ environment? true ENV" CORE"  \+ environment? true ENV" CORE"
 \ core wordset is now complete!  \ core wordset is now complete!
Line 1370  max-errors 6 * cells allot Line 1567  max-errors 6 * cells allot
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
 : dec. ( n -- )  : dec. ( n -- ) \ gforth
     \ print value in decimal representation      \ print value in decimal representation
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : typewhite ( addr u -- )  : 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@ 9 = if \ check for tab
Line 1383  max-errors 6 * cells allot Line 1580  max-errors 6 * cells allot
             bl              bl
         then          then
         emit          emit
     loop      loop ;
 ;  
   
 DEFER DOERROR  DEFER DOERROR
   
Line 1434  DEFER DOERROR Line 1630  DEFER DOERROR
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
 : quit   r0 @ rp! handler off >tib @ >r  : quit ( ?? -- ?? ) \ core
   BEGIN      r0 @ rp! handler off >tib @ >r
     postpone [      BEGIN
     ['] 'quit CATCH dup          postpone [
   WHILE          ['] 'quit CATCH dup
     DoError r@ >tib !      WHILE
   REPEAT          DoError r@ >tib !
   drop r> >tib ! ;      REPEAT
       drop r> >tib ! ;
   
 \ Cold                                                 13feb93py  \ Cold                                                 13feb93py
   
Line 1449  DEFER DOERROR Line 1646  DEFER DOERROR
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 : cstring>sstring  ( cstring -- addr n )  -1 0 scan 0 swap 1+ /string ;  : cstring>sstring  ( cstring -- addr n ) \ gforth       cstring-to-sstring
 : arg ( n -- addr count )  cells argv @ + @ cstring>sstring ;      -1 0 scan 0 swap 1+ /string ;
   : arg ( n -- addr count ) \ gforth
       cells argv @ + @ cstring>sstring ;
 : #!       postpone \ ;  immediate  : #!       postpone \ ;  immediate
   
 Create pathstring 2 cells allot \ string  Create pathstring 2 cells allot \ string
Line 1495  Variable argc Line 1694  Variable argc
   
 : process-args ( -- )  : process-args ( -- )
     >tib @ >r      >tib @ >r
     true to script?  
     argc @ 1      argc @ 1
     ?DO      ?DO
         I arg over c@ [char] - <>          I arg over c@ [char] - <>
         IF          IF
             required 1              required 1
         ELSE          ELSE
             I 1+ arg  do-option              I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
               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 ( -- ) \ gforth
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
     0 0 included-files 2!      init-included-files
     'cold      'cold
     argc @ 1 >      argc @ 1 >
     IF      IF
           true to script?
         ['] process-args catch ?dup          ['] process-args catch ?dup
         IF          IF
             dup >r DoError cr r> negate (bye)              dup >r DoError cr r> negate (bye)
         THEN          THEN
           cr
     THEN      THEN
     cr      false to script?
     ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr      ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
     ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr      ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
     ." Type `bye' to exit"      ." Type `bye' to exit"
     loadline off quit ;      loadline off quit ;
   
 : license ( -- ) cr  : license ( -- ) \ gforth
    cr
  ." This program is free software; you can redistribute it and/or modify" 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   ." it under the terms of the GNU General Public License as published by" cr
  ." the Free Software Foundation; either version 2 of the License, or" cr   ." the Free Software Foundation; either version 2 of the License, or" cr
Line 1547  Defer 'cold ' noop IS 'cold Line 1748  Defer 'cold ' noop IS 'cold
   sp@ dup s0 ! $10 + >tib ! #tib off >in off    sp@ dup s0 ! $10 + >tib ! #tib off >in off
   rp@ r0 !  fp@ f0 !  cold ;    rp@ r0 !  fp@ f0 !  cold ;
   
 : bye  script? 0= IF  cr  THEN  0 (bye) ;  : bye ( -- ) \ tools-ext
       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

Removed from v.1.36  
changed lines
  Added in v.1.42


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