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

version 1.8, 1994/06/17 12:35:07 version 1.60, 1996/07/16 20:57:11
Line 1 Line 1
 \ KERNAL.FS    ANS figFORTH kernal                     17dec92py  \ KERNAL.FS    GForth kernal                        17dec92py
 \ $ID:  
   \ Copyright (C) 1995 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  
   
 \ Log:  ', '- usw. durch [char] ... ersetzt  \ Log:  ', '- usw. durch [char] ... ersetzt
 \       man sollte die unterschiedlichen zahlensysteme  \       man sollte die unterschiedlichen zahlensysteme
Line 31 Line 48
   
 HEX  HEX
   
 \ Bit string manipulation                              06oct92py  \ labels for some code addresses
   
 Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  : docon: ( -- addr )    \ gforth
 DOES> ( n -- )  + c@ ;      \ the code address of a @code{CONSTANT}
       ['] bl >code-address ;
   
 : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;  : docol: ( -- addr )    \ gforth
 : +bit  ( addr n -- )  >bit over c@ or swap c! ;      \ the code address of a colon definition
       ['] docon: >code-address ;
   
 : relinfo ( -- addr )  forthstart dup @ + ;  : dovar: ( -- addr )    \ gforth
 : >rel  ( addr -- n )  forthstart - ;      \ the code address of a @code{CREATE}d word
 : relon ( addr -- )  relinfo swap >rel cell / +bit ;      ['] udp >code-address ;
   
 \ here allot , c, A,                                   17dec92py  : douser: ( -- addr )   \ gforth
       \ the code address of a @code{USER} variable
       ['] s0 >code-address ;
   
 : dp    ( -- addr )  dpp @ ;  : dodefer: ( -- addr )  \ gforth
 : here  ( -- here )  dp @ ;      \ the code address of a @code{defer}ed word
 : allot ( n -- )     dp +! ;      ['] source >code-address ;
 : c,    ( c -- )     here 1 chars allot c! ;  
 : ,     ( x -- )     here cell allot  ! ;  
 : 2,    ( w1 w2 -- ) \ general  
     here 2 cells allot 2! ;  
   
 : aligned ( addr -- addr' )  : dofield: ( -- addr )  \ gforth
   [ cell 1- ] Literal + [ -1 cells ] Literal and ;      \ the code address of a @code{field}
 : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;      ['] reveal-method >code-address ;
   
 : faligned ( addr -- f-addr )  NIL AConstant NIL \ gforth
   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;  
   
 : falign ( -- )  \ Bit string manipulation                              06oct92py
   here dup faligned swap  
   ?DO  
       bl c,  
   LOOP ;  
   
   \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
   \ DOES> ( n -- )  + c@ ;
   
   \ : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
   \ : +bit  ( addr n -- )  >bit over c@ or swap c! ;
   
   \ : relinfo ( -- addr )  forthstart dup @ + !!bug!! ;
   \ : >rel  ( addr -- n )  forthstart - ;
   \ : relon ( addr -- )  relinfo swap >rel cell / +bit ;
   
   \ here allot , c, A,                                   17dec92py
   
   : dp    ( -- addr ) \ gforth
       dpp @ ;
   : here  ( -- here ) \ core
       dp @ ;
   : allot ( n -- ) \ core
       dp +! ;
   : c,    ( c -- ) \ core
       here 1 chars allot c! ;
   : ,     ( x -- ) \ core
       here cell allot  ! ;
   : 2,    ( w1 w2 -- ) \ gforth
       here 2 cells allot 2! ;
   
   \ : aligned ( addr -- addr' ) \ core
   \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   : align ( -- ) \ core
       here dup aligned swap ?DO  bl c,  LOOP ;
   
   \ : faligned ( addr -- f-addr ) \ float
   \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
   : falign ( -- ) \ float
       here dup faligned swap
       ?DO
           bl c,
       LOOP ;
   
   \ !! this is machine-dependent, but works on all but the strangest machines
   ' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth
   ' falign Alias maxalign ( -- ) \ gforth
   
   \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
   ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
   \ the code field is aligned if its body is maxaligned
   ' maxalign Alias cfalign ( -- ) \ gforth
   
   : chars ( n1 -- n2 ) \ core
   ; immediate
   
   
   \ : A!    ( addr1 addr2 -- ) \ gforth
   \    dup relon ! ;
   \ : A,    ( addr -- ) \ gforth
   \    here cell allot A! ;
   ' ! alias A! ( addr1 addr2 -- ) \ gforth
   ' , alias A, ( addr -- ) \ gforth 
   
 : A!    ( addr1 addr2 -- )  dup relon ! ;  
 : A,    ( addr -- )     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 ! ;
   
   \ 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
   
 : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;  $80 constant alias-mask \ set when the word is not an alias!
 : name>    ( nfa -- cfa )  $40 constant immediate-mask
   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;  $20 constant restrict-mask
   
 : found ( nfa -- cfa n )  cell+  : (name>)  ( nfa+cell -- cfa )
   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN      1 cells - name>string +  cfaligned ;
 \                  -1 r@ $40 and     IF  1-      THEN  : name>    ( nfa -- cfa ) \ gforth
                   -1 r> $20 and     IF  negate  THEN  ;      cell+
       dup  (name>) swap  c@ alias-mask and 0= IF  @ THEN ;
   
 \ (find)                                               17dec92py  \ (find)                                               17dec92py
   
 \ : (find) ( addr count nfa1 -- nfa2 / false )  \ : (find) ( addr count nfa1 -- nfa2 / false )
 \   BEGIN  dup  WHILE  dup >r  \   BEGIN  dup  WHILE  dup >r
 \          cell+ count $1F and dup >r 2over r> =  \          name>string dup >r 2over r> =
 \          IF  -text  0= IF  2drop r> EXIT  THEN  \          IF  -text  0= IF  2drop r> EXIT  THEN
 \          ELSE  2drop drop  THEN  r> @  \          ELSE  2drop drop  THEN  r> @
 \   REPEAT nip nip ;  \   REPEAT nip nip ;
   
 \ 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 )  >r  : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string      \ skip all characters not equal to char
   REPEAT  THEN  rdrop ;      >r
 : skip   ( addr1 n1 char -- addr2 n2 )  >r      BEGIN
   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string          dup
   REPEAT  THEN  rdrop ;      WHILE
           over c@ r@ <>
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
       \ skip all characters equal to char
       >r
       BEGIN
           dup
       WHILE
           over c@ r@  =
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 125  Defer source Line 226  Defer source
   
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : parse-word  ( char -- addr len )  : parse-word  ( char -- addr len ) \ gforth
   source 2dup >r >r >in @ /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 @ /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 -- addr )  : capitalize ( addr len -- addr len ) \ gforth
   dup count chars bounds    2dup chars chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;    ?DO  I c@ toupper I c! 1 chars +LOOP ;
 : (name)  ( -- addr )  bl word ;  : (name) ( -- c-addr count )
 : (cname) ( -- addr )  bl word capitalize ;      source 2dup >r >r >in @ /string (parse-white)
       2dup + r> - 1+ r> min >in ! ;
   \    name count ;
   
   : name-too-short? ( c-addr u -- c-addr u )
       dup 0= -&16 and throw ;
   
   : name-too-long? ( c-addr u -- c-addr u )
       dup $1F u> -&19 and throw ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
 : Literal  ( n -- )  state @ IF postpone lit  , THEN ;  : Literal  ( compilation n -- ; run-time -- n ) \ core
                                                       immediate      postpone lit  , ; immediate restrict
 : ALiteral ( n -- )  state @ IF postpone lit A, THEN ;  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
                                                       immediate      postpone lit A, ; immediate restrict
   
 : char   ( 'char' -- n )  bl word char+ c@ ;  : char   ( 'char' -- n ) \ core
 : [char] ( 'char' -- n )  char postpone Literal ; immediate      bl word char+ c@ ;
 ' [char] Alias Ascii immediate  : [char] ( compilation 'char' -- ; run-time -- n )
       char postpone Literal ; immediate restrict
 : (compile) ( -- )  r> dup cell+ >r @ A, ;  
 : postpone ( "name" -- )  : (compile) ( -- ) \ gforth
   name find dup 0= abort" Can't compile "      r> dup cell+ >r @ compile, ;
   0> IF  A,  ELSE  postpone (compile) A,  THEN ;  : postpone ( "name" -- ) \ core
                                              immediate restrict    name sfind dup 0= abort" Can't compile "
     0> IF  compile,  ELSE  postpone (compile) A,  THEN ; 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!
   
 \ 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 183  Defer source Line 297  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<
 : number?  ( string -- string 0 / n -1 )  base @ >r      IF
   dup count over c@ [char] - = 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 2drop rdrop false r> base ! EXIT  THEN      base @ >r  dpl on
   2drop rot drop rdrop r> IF dnegate THEN      over c@ '- =  dup >r
   dpl @ dup 0< IF  nip  THEN  r> base ! ;      IF
 : s>d ( n -- d ) dup 0< ;          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> )
       s>number dpl @ 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0> 0= IF
           nip
       THEN ;
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
   : 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 -- )
       swap
       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-ext
   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 258  hex Line 449  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 270  hex Line 461  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
     handler @ rp!          [ here 9 cells ! ]
     r> handler !          handler @ rp!
     r> lp!          r> handler !
     r> fp!          r> lp!
     r> swap >r sp! r>          r> fp!
   THEN ;          r> swap >r sp! r>
       THEN ;
   
 \ 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 293  hex Line 485  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
 Defer notfound  \ get the next word from the input buffer
   ' (name) IS name
 : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;  Defer compiler-notfound ( c-addr count -- )
   Defer interpreter-notfound ( c-addr count -- )
 ' no.extensions IS notfound  
   : no.extensions  ( addr u -- )
 : interpret      2drop -&13 bounce ;
   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;  ' no.extensions IS compiler-notfound
   ' no.extensions IS interpreter-notfound
   
   : compile-only ( ... -- )
       -&14 throw ;
   Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?
   ' compile-only IS interpret-special
   
   : interpret ( ?? -- ?? ) \ gforth
       \ interpret/compile the (rest of the) input buffer
       BEGIN
           ?stack name dup
       WHILE
           parser
       REPEAT
       2drop ;
   
 \ interpreter compiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : interpreter  ( name -- ) find ?dup  : interpreter  ( c-addr u -- ) \ gforth
   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN      \ interpretation semantics for the name/number c-addr u
   number? 0= IF  notfound THEN ;      2dup (sfind) dup
       IF
           1 and
           IF \ not restricted to compile state?
               nip nip execute EXIT
           THEN
           interpret-special exit
       THEN
       drop
       2dup 2>r snumber?
       IF
           2rdrop
       ELSE
           2r> interpreter-notfound
       THEN ;
   
 ' interpreter  IS  parser  ' interpreter  IS  parser
   
 : compiler     ( name -- ) find  ?dup  : compiler     ( c-addr u -- ) \ gforth
   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup      \ compilation semantics for the name/number c-addr u
   IF  0> IF  swap postpone Literal  THEN  postpone Literal      2dup (sfind) dup
   ELSE  drop notfound  THEN ;      IF
           0>
           IF
               nip nip execute EXIT
           THEN
           compile, 2drop EXIT
       THEN
       drop
       2dup snumber? dup
       IF
           0>
           IF
               swap postpone Literal
           THEN
           postpone Literal
           2drop
       ELSE
           drop compiler-notfound
       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
   
 variable locals-size \ this is the current size of the locals stack  : compile-lp+! ( n -- ) \ gforth        compile-l-p-plus-store
                      \ frame of the current word  
   
 : compile-lp+! ( n -- )  
     dup negate locals-size +!      dup negate locals-size +!
     0 over = if      0 over = if
     else -4 over = if postpone -4lp+!      else -1 cells  over = if postpone lp-
     else  8 over = if postpone  8lp+!      else  1 floats over = if postpone lp+
     else 16 over = if postpone 16lp+!      else  2 floats over = if postpone lp+2
     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+! ;
   
   
 here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs  here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
 AConstant locals-list \ acts like a variable that contains  AConstant locals-list \ acts like a variable that contains
                      \ a linear list of locals names                        \ a linear list of locals names
   
   
 variable dead-code \ true if normal code at "here" would be dead  variable dead-code \ true if normal code at "here" would be dead
   variable backedge-locals
 : unreachable ( -- )      \ contains the locals list that BEGIN will assume to be live on
 \ declares the current point of execution as unreachable      \ the back edge if the BEGIN is unreachable from above. Set by
  dead-code on ;      \ ASSUME-LIVE, reset by UNREACHABLE.
   
   : UNREACHABLE ( -- ) \ gforth
       \ declares the current point of execution as unreachable
       dead-code on
       0 backedge-locals ! ; immediate
   
   : ASSUME-LIVE ( orig -- orig ) \ gforth
       \ used immediateliy before a BEGIN that is not reachable from
       \ above.  causes the BEGIN to assume that the same locals are live
       \ as at the orig point
       dup orig?
       2 pick backedge-locals ! ; immediate
       
 \ locals list operations  \ locals list operations
   
 : common-list ( list1 list2 -- list3 )  : common-list ( list1 list2 -- list3 ) \ gforth-internal
 \ list1 and list2 are lists, where the heads are at higher addresses than  \ list1 and list2 are lists, where the heads are at higher addresses than
 \ the tail. list3 is the largest sublist of both lists.  \ the tail. list3 is the largest sublist of both lists.
  begin   begin
Line 371  variable dead-code \ true if normal code Line 623  variable dead-code \ true if normal code
  repeat   repeat
  drop ;   drop ;
   
 : sub-list? ( list1 list2 -- f )  : sub-list? ( list1 list2 -- f ) \ gforth-internal
 \ true iff list1 is a sublist of list2  \ true iff list1 is a sublist of list2
  begin   begin
    2dup u<     2dup u<
Line 380  variable dead-code \ true if normal code Line 632  variable dead-code \ true if normal code
  repeat   repeat
  = ;   = ;
   
 : list-size ( list -- u )  : list-size ( list -- u ) \ gforth-internal
 \ size of the locals frame represented by list  \ size of the locals frame represented by list
  0 ( list n )   0 ( list n )
  begin   begin
    over 0<>     over 0<>
  while   while
    over     over
    cell+ name> >body @ max     name> >body @ max
    swap @ swap ( get next )     swap @ swap ( get next )
  repeat   repeat
  faligned nip ;   faligned nip ;
Line 441  variable dead-code \ true if normal code Line 693  variable dead-code \ true if normal code
   
 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 473  variable dead-code \ true if normal code Line 725  variable dead-code \ true if normal code
 : >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 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. Besides, it's faster.
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup-?branch >mark ;       immediate restrict
 : ?DUP-NOT-IF \ general  
     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict  
   
 : THEN ( orig -- )  : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if
     dup orig?      POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
     dead-code @  
   : then-like ( orig -- addr )
       swap -rot dead-orig =
     if      if
         dead-orig =          drop
         if  
             >resolve drop  
         else  
             >resolve set-locals-size-list dead-code off  
         then  
     else      else
         dead-orig =          dead-code @
         if          if
             >resolve drop              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 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          \ set up an assumption of the locals visible here.  if the
         \ currently we just take the top cs-item          \ users want something to be visible, they have to declare
         \ it would be more intelligent to take the top orig          \ that using ASSUME-LIVE
         \   but that can be arranged by the user          backedge-locals @ set-locals-size-list
         dup defstart <> if  
             dup cs-item?  
             2 pick  
         else  
             0  
         then  
         set-locals-size-list  
     then      then
     cs-push-part dest      cs-push-part dest
     dead-code off ; immediate restrict      dead-code off ; immediate restrict
Line 546  variable dead-code \ true if normal code Line 791  variable dead-code \ true if normal code
 \ 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 -- )  
     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
     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 572  variable dead-code \ true if normal code Line 817  variable dead-code \ true if normal code
     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 590  variable dead-code \ true if normal code Line 835  variable dead-code \ true if normal code
 \ we have to store more than just the address of the branch, so the  \ we have to store more than just the address of the branch, so the
 \ traditional linked list approach is no longer viable.  \ traditional linked list approach is no longer viable.
 \ This is solved by storing the information about the leavings in a  \ This is solved by storing the information about the leavings in a
 \ special stack. The leavings of different DO-LOOPs are separated  \ special stack.
 \ by a 0 entry  
   
 \ !! remove the fixed size limit. 'Tis not hard.  \ !! remove the fixed size limit. 'Tis not hard.
 20 constant leave-stack-size  20 constant leave-stack-size
 create leave-stack 60 cells allot  create leave-stack  60 cells allot
 Avariable leave-sp  leave-stack leave-sp !  Avariable leave-sp  leave-stack 3 cells + leave-sp !
   
 : clear-leave-stack ( -- )  : clear-leave-stack ( -- )
     leave-stack leave-sp ! ;      leave-stack leave-sp ! ;
Line 617  Avariable leave-sp  leave-stack leave-sp Line 861  Avariable leave-sp  leave-stack leave-sp
 : leave> ( -- orig )  : leave> ( -- orig )
     \ pop from leave-stack      \ pop from leave-stack
     leave-sp @      leave-sp @
     dup leave-stack <= abort" leave-stack empty"      dup leave-stack <= IF
          drop 0 0 0  EXIT  THEN
     cell - dup @ swap      cell - dup @ swap
     cell - dup @ swap      cell - dup @ swap
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : done ( -- )  : DONE ( compilation orig -- ; run-time -- ) \ gforth
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
       drop >r drop
     begin      begin
         leave>          leave>
         dup          over r@ u>=
     while      while
         POSTPONE then          POSTPONE then
     repeat      repeat
     2drop drop ; immediate      >leave rdrop ; immediate restrict
   
 : LEAVE ( -- )  : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
     POSTPONE ahead      POSTPONE ahead
     >leave ; immediate      >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      >leave ; immediate restrict
   
 : DO ( -- do-sys )  : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
     POSTPONE (do)      POSTPONE (do)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     0 0 0 >leave ; immediate      ( 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      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
   
 : FOR ( -- do-sys )  : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        plus-do
       POSTPONE (+do) ?do-like ; immediate restrict
   
   : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-plus-do
       POSTPONE (u+do) ?do-like ; immediate restrict
   
   : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        minus-do
       POSTPONE (-do) ?do-like ; immediate restrict
   
   : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-minus-do
       POSTPONE (u-do) ?do-like ; immediate restrict
   
   : FOR ( compilation -- do-sys ; run-time u -- loop-sys )        \ gforth
     POSTPONE (for)      POSTPONE (for)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     0 0 0 >leave ; immediate      ( 0 0 0 >leave ) ; immediate restrict
   
 \ LOOP etc. are just like UNTIL  \ LOOP etc. are just like UNTIL
   
 : loop-like ( do-sys xt1 xt2 -- )  : loop-like ( do-sys xt1 xt2 -- )
     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   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
   : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core  plus-loop
    ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( do-sys -- )  \ !! should the compiler warn about +DO..-LOOP?
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate  : -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   ['] (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   ['] (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
     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 697  Avariable leave-sp  leave-stack leave-sp Line 961  Avariable leave-sp  leave-stack leave-sp
   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
 : S"       [char] " parse  state @ IF  postpone SLiteral  THEN ;  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
                                              immediate      BEGIN
 : ."       state @  IF    postpone (.") ,"  align          >in @ [char] ) parse nip >in @ rot - =
                     ELSE  [char] " parse type  THEN  ;  immediate      WHILE
 : (        [char] ) parse 2drop ;                       immediate          loadfile @ IF
 : \        source >in ! drop ;                          immediate              refill 0= abort" missing ')' in paren comment"
           THEN
       REPEAT ;                       immediate
   : \ ( -- ) \ core-ext backslash
       blk @
       IF
           >in @ c/l / 1+ c/l * >in !
           EXIT
       THEN
       source >in ! drop ; immediate
   
   : \G ( -- ) \ gforth backslash
       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
   
 : flag! ( 8b -- )   last @ cell+ tuck c@ xor swap c! ;  : cset ( bmask c-addr -- )
 : immediate     $20 flag! ;      tuck c@ or swap c! ; 
 \ : restrict      $40 flag! ;  : creset ( bmask c-addr -- )
 ' noop alias restrict      tuck c@ swap invert and swap c! ; 
   : ctoggle ( bmask c-addr -- )
       tuck c@ xor swap c! ; 
   
   : lastflags ( -- c-addr )
       \ the address of the flags byte in the last header
       \ aborts if the last defined word was headerless
       last @ dup 0= abort" last word was headerless" cell+ ;
   
   : immediate     immediate-mask lastflags cset ;
   : restrict      restrict-mask lastflags cset ;
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 726  Avariable leave-sp  leave-stack leave-sp Line 1018  Avariable leave-sp  leave-stack leave-sp
 \ information through global variables), but they are useful for dealing  \ information through global variables), but they are useful for dealing
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer header  defer (header)
   defer header ( -- ) \ gforth
   ' (header) IS header
   
   : string, ( c-addr u -- ) \ gforth
       \ puts down string as cstring
       dup c, here swap chars dup allot move ;
   
   : header, ( c-addr u -- ) \ gforth
       name-too-long?
       align here last !
       current @ 1 or A,   \ link field; before revealing, it contains the
                           \ tagged reveal-into wordlist
       string, cfalign
       alias-mask lastflags cset ;
   
 : name,  ( "name" -- )  
     name c@ 1+ chars allot align ;  
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent      name name-too-short? header, ;
     align here last !  -1 A,  
     name, $80 flag! ;  
   
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;  \ switches back to getting the name from the input stream ;
     ['] input-stream-header IS header ;      ['] input-stream-header IS (header) ;
   
 ' input-stream-header IS header  ' input-stream-header IS (header)
   
 \ !! make that a 2variable  \ !! make that a 2variable
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
   
 : nextname-header ( -- )  : nextname-header ( -- )
     \ !! f83-implementation-dependent      nextname-buffer count header,
     nextname-buffer count  
     align here last ! -1 A,  
     dup c,  here swap chars  dup allot  move  align  
     $80 flag!  
     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
     dup 31 u> -19 and throw ( is name too long? )      name-too-long?
     nextname-buffer c! ( c-addr )      nextname-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
     ['] nextname-header IS header ;      ['] nextname-header IS (header) ;
   
 : noname-header ( -- )  : noname-header ( -- )
     0 last !      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
       alias-mask lastflags creset
       dup A, lastcfa ! ;
   
 : name>string ( nfa -- addr count )  : name>string ( nfa -- addr count ) \ gforth    name-to-string
  cell+ count $1F and ;   cell+ count $1F and ;
   
 Create ???  ," ???"  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 + aligned over $80 + = if     dup i - count $9F and + cfaligned over alias-mask + = if
      i - cell - unloop exit       i - cell - unloop exit
    then     then
  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>  ( compilation: -- )  
     state @  
     IF  
         ;-hook postpone (;code) dodoes,  
     ELSE  
         dodoes, here !does 0 ]  
     THEN   
     :-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
 : (Constant)  Header reveal [ :docon ] Literal cfa, ;      AVariable ;
 : Constant  (Constant) , ;  
 : AConstant (Constant) A, ;  : (Constant)  Header reveal docon: cfa, ;
   : Constant ( w -- ) \ core
       (Constant) , ;
   : AConstant ( addr -- ) \ gforth
       (Constant) A, ;
   
 : 2CONSTANT  : 2Constant ( d -- ) \ double
     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
   
 : Defer  : Defer ( -- ) \ gforth
   Create ( -- )       \ !! shouldn't it be initialized with abort or something similar?
     ['] noop A,      Header Reveal dodefer: cfa,
   DOES> ( ??? )      ['] noop A, ;
     @ execute ;  \     Create ( -- ) 
   \       ['] noop A,
 : IS ( addr "name" -- )  \     DOES> ( ??? )
     ' >body  \       perform ;
     state @  
     IF    postpone ALiteral postpone !    : Defers ( "name" -- ) \ gforth
     ELSE  !      ' >body @ compile, ; immediate
     THEN ;  immediate  
 ' IS Alias TO immediate  
   
 : What's ( "name" -- addr )  ' >body  
   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;  
                                              immediate  
 : Defers ( "name" -- )  ' >body @ compile, ;  
                                              immediate restrict  
   
 \ : ;                                                  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 )  here [ :docol ] Literal cfa, 0 ] :-hook ;  : :noname ( -- xt colon-sys ) \ core-ext        colon-no-name
       0 last !
       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 )
 : (reveal) ( -- )      last @ ?dup ;
   last?  : (reveal) ( nfa wid -- )
   IF      ( wid>wordlist-id ) dup >r
       dup @ 0<      @ over ( name>link ) ! 
       IF      r> ! ;
         current @ @ over ! current @ !  
       ELSE  
         drop  
       THEN  
   THEN ;  
   
 \ 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: ( nfa wid -- ) \ used by dofield:, must be field
     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 )
 : f83casefind  ( addr len wordlist -- nfa / false )  @ (f83casefind) ;      ( wid>wordlist-id ) @ (f83find) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search       ' f83casefind A,  ' (reveal) A,  ' drop A,  Create f83search ( -- wordlist-map )
       ' f83find A,  ' (reveal) A,  ' drop A,
 : caps-name       ['] (cname) IS name  ['] f83find     f83search ! ;  
 : case-name       ['] (name)  IS name  ['] f83casefind f83search ! ;  
 : case-sensitive  ['] (name)  IS name  ['] f83find     f83search ! ;  
   
 Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,  Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
 AVariable search       G forth-wordlist search T !  AVariable 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 ( @ swap ) cell+ @ @ execute ;      dup wordlist-map @ find-method perform ;
   
   : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search
       (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
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  \ reveal words
   (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
 \ !! 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 934  Variable warnings  G -1 warnings T ! Line 1273  Variable warnings  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : find   ( addr -- cfa +-1 / string false )  dup  : reveal ( -- ) \ gforth
   count search @ search-wordlist  dup IF  rot drop  THEN ;      last?
       if \ the last word has a header
 : reveal ( -- )          dup ( name>link ) @ 1 and
  last? if          if \ it is still hidden
    name>string current @ check-shadow              dup ( name>link ) @ 1 xor           ( nfa wid )
  then              2dup >r name>string r> check-shadow ( nfa wid )
  current @ cell+ @ cell+ @ execute ;              dup wordlist-map @ reveal-method perform
           then
       then ;
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )
       dup wordlist-map @ rehash-method perform ;
   
 : '    ( "name" -- addr )  name find 0= no.extensions ;  
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell  07 constant #bell ( -- c ) \ gforth
 08 constant #bs  08 constant #bs ( -- c ) \ gforth
 7F constant #del  09 constant #tab ( -- c ) \ gforth
 0D constant #cr                \ the newline key code  7F constant #del ( -- c ) \ gforth
 0A constant #lf  0D constant #cr   ( -- c ) \ gforth
   \ the newline key code
   0C constant #ff ( -- c ) \ gforth
   0A constant #lf ( -- c ) \ gforth
   
 : bell  #bell emit ;  : bell  #bell emit ;
   : cr ( -- ) \ core
 : backspaces  0 ?DO  #bs emit  LOOP ;      \ emit a newline
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )      #lf ( sic! ) emit ;
   over 3 pick 2 pick chars /string ;  
 : type-rest ( span addr pos1 -- span addr pos1 back )  \ : backspaces  0 ?DO  #bs emit  LOOP ;
   >string tuck type ;  
 : (del)  ( max span addr pos1 -- max span addr pos2 )  : (ins) ( max span addr pos1 key -- max span addr pos2 )
   1- >string over 1+ -rot move      >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;  : (bs) ( max span addr pos1 -- max span addr pos2 flag )
 : (ins)  ( max span addr pos1 char -- max span addr pos2 )      dup IF
   >r >string over 1+ swap move 2dup chars + r> swap c!          #bs emit bl emit #bs emit 1- rot 1- -rot
   rot 1+ -rot type-rest 1- backspaces 1+ ;      THEN false ;
 : ?del ( max span addr pos1 -- max span addr pos2 0 )  : (ret)  true space ;
   dup  IF  (del)  THEN  0 ;  
 : (ret)  type-rest drop true space ;  Create ctrlkeys
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;    ] false false false false  false false false false
 : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;      (bs)  false (ret) false  false (ret) false false
   
 Create crtlkeys  
   ] false false back  false  false false forw  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 [
   
   defer insert-char
   ' (ins) IS insert-char
   defer everychar
   ' noop IS everychar
   
 : decode ( max span addr pos1 key -- max span addr pos2 flag )  : decode ( max span addr pos1 key -- max span addr pos2 flag )
     everychar
   dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
   dup bl <   IF  cells crtlkeys + @ execute  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 ;
   
 \ decode should better use a table for control key actions  
 \ 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 998  Create crtlkeys Line 1340  Create crtlkeys
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
 DEFER type      \ defer type for a output buffer or fast  : (type) ( c-addr u -- ) \ gforth
                 \ screen write      outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
   ;
   
 : (type) ( addr len -- )  Defer type ( c-addr u -- ) \ core
   bounds ?DO  I c@ emit  LOOP ;  \ defer type for a output buffer or fast
   \ screen write
   
 ' (TYPE) IS Type  ' (type) IS Type
   
 \ DEFER Emit  : (emit) ( c -- ) \ gforth
       outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
   ;
   
 \ ' (Emit) IS Emit  Defer emit ( c -- ) \ core
   ' (Emit) IS Emit
   
 \ : form  ( -- rows cols )  &24 &80 ;  Defer key ( -- c ) \ core
 \ form should be implemented using TERMCAPS or CURSES  ' (key) IS key
 \ : rows  form drop ;  
 \ : cols  form nip  ;  
   
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag ) \ core-ext,block-ext,file-ext
     blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    dup file-position throw linestart 2!    IF    read-line throw
         read-line throw    ELSE  sourceline# 0< IF 2drop false EXIT THEN
   ELSE  linestart @ IF 2drop false EXIT THEN  
         accept true          accept true
   THEN    THEN
   1 loadline +!    1 loadline +!
   swap #tib ! >in off ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- )  loadfile off refill drop ;  : Query  ( -- ) \ core-ext
       \ obsolescent
       loadfile off  blk off  refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1036  DEFER type      \ defer type for a outpu Line 1383  DEFER type      \ defer type for a outpu
 \ 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-w
 0 Constant r/o  0 Constant r/o ( -- fam ) \ file        r-o
   
 \ 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+ ;  : 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
   
 : include-file ( i*x fid -- j*x )  : push-file  ( -- )  r>
   linestart @ >r loadline @ >r loadfile @ >r    sourceline# >r  loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    blk @ >r  tibstack @ >r  >tib @ >r  #tib @ >r
     >tib @ tibstack @ = IF  r@ tibstack +!  THEN
   >tib +! loadfile !    tibstack @ >tib ! >in @ >r  >r ;
   0 loadline ! blk off  
   BEGIN  refill  WHILE  interpret  REPEAT  : pop-file   ( throw-code -- throw-code )
   loadfile @ close-file throw    dup IF
            source >in @ sourceline# sourcefilename
   r> >in !  r> #tib !  r> >tib ! r> blk !           error-stack dup @ dup 1+
   r> loadfile ! r> loadline ! r> linestart ! ;           max-errors 1- min error-stack !
            6 * cells + cell+
            5 cells bounds swap DO
                               I !
            -1 cells +LOOP
     THEN
     r>
     r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> blk !
     r> loadfile ! r> loadline !  >r ;
   
   : read-loop ( i*x -- j*x )
     BEGIN  refill  WHILE  interpret  REPEAT ;
   
   : include-file ( i*x fid -- j*x ) \ file
     push-file  loadfile !
     0 loadline ! blk off  ['] read-loop catch
     loadfile @ close-file swap 2dup or
     pop-file  drop throw throw ;
   
   create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   
   \ : check-file-prefix  ( addr len -- addr' len' flag )
   \   dup 0=                    IF  true EXIT  THEN 
   \   over c@ '/ =              IF  true EXIT  THEN 
   \   over 2 S" ./" compare 0=  IF  true EXIT  THEN 
   \   over 3 S" ../" compare 0= IF  true EXIT  THEN
   \   over 2 S" ~/" compare 0=
   \   IF     1 /string
   \          S" HOME" getenv tuck pathfilenamebuf swap move
   \          2dup + >r pathfilenamebuf + swap move
   \          pathfilenamebuf r> true
   \   ELSE   false
   \   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
       \ opens a file for reading, searching in the path for it (unless
       \ the filename contains a slash); c-addr2 u2 is the full filename
       \ (valid until the next call); if the file is not found (or in
       \ case of other errors for each try), -38 (non-existant file) is
       \ thrown. Opening for other access modes makes little sense, as
       \ the path will usually contain dirs that are only readable for
       \ the user
       \ !! use file-status to determine access mode?
       2dup absolut-path?
       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 )
           dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
           2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
           pathfilenamebuf over r> + dup >r r/o open-file 0=
           IF ( addr u file-id )
               nip nip r> rdrop 0 LEAVE
           THEN
           rdrop drop r> cell+ cell+
       LOOP
   \    ELSE   2dup open-file throw -rot  THEN 
       0<> -&38 and throw ( file-id u2 )
       pathfilenamebuf swap ;
   
   create included-files 0 , 0 , ( pointer to and count of included files )
   here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells -
   create image-included-files  1 , A, ( 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
   
   : loadfilename ( -- a-addr )
       \ a-addr 2@ produces the current file name ( c-addr u )
       included-files 2@ drop loadfilename# @ 2* cells + ;
   
   : sourcefilename ( -- c-addr u ) \ gforth
       \ the name of the source file which is currently the input
       \ source.  The result is valid only while the file is being
       \ loaded.  If the current input source is no (stream) file, the
       \ result is undefined.
       loadfilename 2@ ;
   
   : sourceline# ( -- u ) \ gforth         sourceline-number
       \ the line number of the line that is currently being interpreted
       \ from a (stream) file. The first line has the number 1. If the
       \ current input source is no (stream) file, the result is
       \ undefined.
       loadline @ ;
   
   : 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 ) \ gforth
       \ true, iff filename c-addr u is in included-files
       included-files 2@ 0
       ?do ( c-addr u addr )
           dup >r 2@ 2over compare 0=
           if
               2drop rdrop unloop
               true EXIT
           then
           r> cell+ cell+
       loop
       2drop drop false ;
   
   : add-included-file ( c-addr u -- ) \ gforth
       \ add name c-addr u to included-files
       included-files 2@ tuck 1+ 2* cells resize throw
       swap 2dup 1+ included-files 2!
       2* cells + 2! ;
   
   : save-string           ( addr1 u -- addr2 u ) \ gforth
       \ !! not a string, but a memblock word
       swap >r
       dup allocate throw
       swap 2dup r> -rot move ;
   
   : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
       \ include the file file-id with the name given by c-addr u
       loadfilename# @ >r
       save-string add-included-file ( file-id )
       included-files 2@ nip 1- loadfilename# !
       ['] include-file catch
       r> loadfilename# !
       throw ;
       
   : included ( i*x addr u -- j*x ) \ file
       open-path-file included1 ;
   
 : included ( i*x addr u -- j*x )  : required ( i*x addr u -- j*x ) \ gforth
   r/o open-file throw include-file ;      \ include the file with the name given by addr u, if it is not
       \ included already. Currently this works by comparing the name of
       \ the file (with path) against the names of earlier included
       \ files; however, it would probably be better to fstat the file,
       \ and compare the device and inode. The advantages would be: no
       \ problems with several paths to the same file (e.g., due to
       \ links) and we would catch files included with include-file and
       \ write a require-file.
       open-path-file 2dup included?
       if
           2drop close-file throw
       else
           included1
       then ;
   
 \ 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
       sp@ s0 @ swap - cell / ;
   : clearstack ( ... -- )
       s0 @ sp! ;
   
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  ( "file" -- )  : include  ( "file" -- ) \ gforth
   bl word count included ;    name included ;
   
   : require  ( "file" -- ) \ gforth
     name required ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse  last @ cell+ name> a, ; immediate restrict  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
 \ !! does not work with anonymous words; use lastxt compile,      lastxt compile, ; immediate restrict
   ' reveal alias recursive ( -- ) \ gforth
           immediate
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   
 : */mod >r m* r> sm/rem ;  \ !! I think */mod should have the same rounding behaviour as / - anton
   : */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
   linestart @ >r loadline @ >r loadfile @ >r    push-file  #tib ! >tib !
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    >in off blk off loadfile off -1 loadline !
     ['] interpret catch
   >tib +! dup #tib ! >tib @ swap move    pop-file throw ;
   >in off blk off loadfile off -1 linestart !  
   
   BEGIN  interpret  >in @ #tib @ u>= UNTIL  : abort ( ?? -- ?? ) \ core,exception-ext
       -1 throw ;
   r> >in !  r> #tib !  r> >tib ! r> blk !  
   r> loadfile ! r> loadline ! r> linestart ! ;  
   
   
 : abort -1 throw ;  
   
 \+ environment? true ENV" CORE"  \+ environment? true ENV" CORE"
 \ core wordset is now complete!  \ core wordset is now complete!
Line 1126  Defer .status Line 1637  Defer .status
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
   
   8 Constant max-errors
   Variable error-stack  0 error-stack !
   max-errors 6 * cells allot
   \ format of one cell:
   \ source ( addr u )
   \ >in
   \ line-number
   \ Loadfilename ( addr u )
   
   : dec. ( n -- ) \ gforth
       \ print value in decimal representation
       base @ decimal swap . base ! ;
   
   : typewhite ( addr u -- ) \ gforth
       \ like type, but white space is printed instead of the characters
       bounds ?do
           i c@ 9 = if \ check for tab
               9
           else
               bl
           then
           emit
       loop ;
   
 DEFER DOERROR  DEFER DOERROR
   
   : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
     cr error-stack @
     IF
        ." in file included from "
        type ." :" dec.  drop 2drop
     ELSE
        type ." :" dec.
        cr dup 2over type cr drop
        nip -trailing 1- ( line-start index2 )
        0 >r  BEGIN
                     2dup + c@ bl >  WHILE
                     r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
        ( line-start index1 )
        typewhite
        r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                     [char] ^ emit
        loop
     THEN
   ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
          LoadFile @    sourceline# IF
          IF                 source >in @ sourceline# 0 0 .error-frame
                 ." Error in line: " Loadline @ . cr    THEN
          THEN    error-stack @ 0 ?DO
          cr source type cr      -1 error-stack +!
          source drop >in @ -trailing      error-stack dup @ 6 * cells + cell+
          here c@ 1F min dup >r - 1- 0 max nip      6 cells bounds DO
          dup spaces         I @
          IF      cell +LOOP
                 ." ^"      .error-frame
          THEN    LOOP
          r> 0 ?DO    dup -2 =
                 ." -"     IF 
          LOOP       "error @ ?dup
          ." ^"       IF
          dup -2 =          cr count type 
          IF        THEN
                 "error @ ?dup       drop
                 IF    ELSE
                         cr count type        .error
                 THEN    THEN
                 drop    normal-dp dpp ! ;
          ELSE  
                 .error  
          THEN  
          normal-dp dpp ! ;  
   
 ' (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 ! r@ tibstack !
   drop r> >tib ! ;      REPEAT
       drop r> >tib ! ;
   
 \ Cold                                                 13feb93py  \ Cold                                                 13feb93py
   
 \ : .name ( name -- ) cell+ count $1F and type space ;  \ : .name ( name -- ) name>string type space ;
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;  : cstring>sstring  ( cstring -- addr n ) \ gforth       cstring-to-sstring
 : arg ( n -- addr count )  cells argv @ + @ >len ;      -1 0 scan 0 swap 1+ /string ;
   : arg ( n -- addr count ) \ gforth
       cells argv @ + @ cstring>sstring ;
 : #!       postpone \ ;  immediate  : #!       postpone \ ;  immediate
   
 Variable env  Create pathstring 2 cells allot \ string
   Create pathdirs   2 cells allot \ dir string array, pointer and count
 Variable argv  Variable argv
 Variable argc  Variable argc
   
 : get-args ( -- )  #tib off  0 Value script? ( -- flag )
   argc @ 1 ?DO  I arg 2dup source + swap move  
                 #tib +! drop  bl source + c! 1 #tib +!  LOOP  
   >in off #tib @ 0<> #tib +! ;  
   
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;  
   
 : cold ( -- )    
   argc @ 1 >  
   IF  script?  
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN  
       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN  
   ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;  
   
 : boot ( **env **argv argc -- )  
   argc ! argv ! env !  main-task up!  
   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;  
   
 : bye  cr 0 (bye) ;  : process-path ( addr1 u1 -- addr2 u2 )
       \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
       align here >r
       BEGIN
           over >r [char] : scan
           over r> tuck - ( rest-str this-str )
           dup
           IF
               2dup 1- chars + c@ [char] / <>
               IF
                   2dup chars + [char] / swap c!
                   1+
               THEN
               2,
           ELSE
               2drop
           THEN
           dup
       WHILE
           1 /string
       REPEAT
       2drop
       here r> tuck - 2 cells / ;
   
   : do-option ( addr1 len1 addr2 len2 -- n )
       2swap
       2dup s" -e"         compare  0= >r
       2dup s" --evaluate" compare  0= r> or
       IF  2drop dup >r ['] evaluate catch
           ?dup IF  dup >r DoError r> negate (bye)  THEN
           r> >tib +!  2 EXIT  THEN
       ." Unknown option: " type cr 2drop 1 ;
   
   : process-args ( -- )
       >tib @ >r
       argc @ 1
       ?DO
           I arg over c@ [char] - <>
           IF
               required 1
           ELSE
               I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
               do-option
           THEN
       +LOOP
       r> >tib ! ;
   
   Defer 'cold ' noop IS 'cold
   
   : cold ( -- ) \ gforth
       stdout TO outfile-id
       pathstring 2@ process-path pathdirs 2!
       init-included-files
       'cold
       argc @ 1 >
       IF
           true to script?
           ['] process-args catch ?dup
           IF
               dup >r DoError cr r> negate (bye)
           THEN
           cr
       THEN
       false to script?
       ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
       ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
       ." Type `bye' to exit"
       loadline off quit ;
   
   : license ( -- ) \ gforth
    cr
    ." This program is free software; you can redistribute it and/or modify" cr
    ." it under the terms of the GNU General Public License as published by" cr
    ." the Free Software Foundation; either version 2 of the License, or" cr
    ." (at your option) any later version." cr cr
   
    ." This program is distributed in the hope that it will be useful," cr
    ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
    ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
    ." GNU General Public License for more details." cr cr
   
    ." You should have received a copy of the GNU General Public License" cr
    ." along with this program; if not, write to the Free Software" cr
    ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
   : boot ( path **argv argc -- )
     argc ! argv ! cstring>sstring pathstring 2!  main-task up!
     sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off
     rp@ r0 !  fp@ f0 !  ['] cold catch DoError 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
 \ 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.8  
changed lines
  Added in v.1.60


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