\ kernel.fs    GForth kernel                        17dec92py

\ 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)

HEX

\ labels for some code addresses

doer? :docon [IF]
: docon: ( -- addr )	\ gforth
    \G the code address of a @code{CONSTANT}
    ['] bl >code-address ;
[THEN]

: docol: ( -- addr )	\ gforth
    \G the code address of a colon definition
    ['] docol: >code-address ;

doer? :dovar [IF]
: dovar: ( -- addr )	\ gforth
    \G the code address of a @code{CREATE}d word
    ['] udp >code-address ;
[THEN]

doer? :douser [IF]
: douser: ( -- addr )	\ gforth
    \G the code address of a @code{USER} variable
    ['] s0 >code-address ;
[THEN]

doer? :dodefer [IF]
: dodefer: ( -- addr )	\ gforth
    \G the code address of a @code{defer}ed word
    ['] source >code-address ;
[THEN]

doer? :dofield [IF]
: dofield: ( -- addr )	\ gforth
    \G the code address of a @code{field}
    ['] reveal-method >code-address ;
[THEN]

has-prims 0= [IF]
: dodoes: ( -- addr )	\ gforth
    \G the code address of a @code{field}
    ['] spaces >code-address ;
[THEN]

NIL AConstant NIL \ gforth

\ Aliases

' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
\ copy w from the return stack to the data stack

\ Bit string manipulation                              06oct92py

\ 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

: maxaligned ( addr -- f-addr ) \ float
    [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
: maxalign ( -- ) \ float
    here dup maxaligned swap
    ?DO
	bl c,
    LOOP ;

\ !! 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 


\ on off                                               23feb93py

: on  ( addr -- ) \ gforth
    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

$80 constant alias-mask \ set when the word is not an alias!
$40 constant immediate-mask
$20 constant restrict-mask

: ((name>))  ( nfa -- cfa )
    name>string +  cfaligned ;

: (name>x) ( nfa -- cfa b )
    \ cfa is an intermediate cfa and b is the flags byte of nfa
    dup ((name>))
    swap cell+ c@ dup alias-mask and 0=
    IF
	swap @ swap
    THEN ;

\ place bounds                                         13feb93py

: place  ( addr len to -- ) \ gforth
    over >r  rot over 1+  r> move c! ;
: bounds ( beg count -- end beg ) \ gforth
    over + swap ;

\ input stream primitives                              23feb93py

: tib ( -- c-addr ) \ core-ext
    \ obsolescent
    >tib @ ;
Defer source ( -- addr count ) \ core
\ used by dodefer:, must be defer
: (source) ( -- addr count )
    tib #tib @ ;
' (source) IS source

\ (word)                                               22feb93py

: scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
    \ skip all characters not equal to char
    >r
    BEGIN
	dup
    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 )
  dup >r skip 2dup r> scan  nip - ;

\ (word) should fold white spaces
\ this is what (parse-white) does

\ word parse                                           23feb93py

: parse-word  ( char -- addr len ) \ gforth
  source 2dup >r >r >in @ over min /string
  rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
  2dup + r> - 1+ r> min >in ! ;
: word   ( char -- addr ) \ core
  parse-word here place  bl here count + c!  here ;

: parse    ( char -- addr len ) \ core-ext
  >r  source  >in @ over min /string  over  swap r>  scan >r
  over - dup r> IF 1+ THEN  >in +! ;

\ name                                                 13feb93py

: capitalize ( addr len -- addr len ) \ gforth
  2dup chars chars bounds
  ?DO  I c@ toupper I c! 1 chars +LOOP ;
: (name) ( -- c-addr count )
    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  ( compilation n -- ; run-time -- n ) \ core
    postpone lit  , ; immediate restrict
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
    postpone lit A, ; immediate restrict

: char   ( 'char' -- n ) \ core
    bl word char+ c@ ;
: [char] ( compilation 'char' -- ; run-time -- n )
    char postpone Literal ; immediate restrict

: (compile) ( -- ) \ gforth
    r> dup cell+ >r @ compile, ;

: postpone, ( w xt -- ) \ gforth postpone-comma
    \g Compiles the compilation semantics represented by @var{w xt}.
    dup ['] execute =
    if
	drop compile,
    else
	dup ['] compile, =
	if
	    drop POSTPONE (compile) compile,
	else
	    swap POSTPONE aliteral compile,
	then
    then ;

: POSTPONE ( "name" -- ) \ core
    \g Compiles the compilation semantics of @var{name}.
    COMP' postpone, ; immediate restrict

: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
    Create immediate swap A, A,
DOES>
    abort" executed primary cfa of an interpret/compile: word" ;
\    state @ IF  cell+  THEN  perform ;

\ Use (compile) for the old behavior of compile!

\ digit?                                               17dec92py

: digit?   ( char -- digit true/ false ) \ gforth
  base @ $100 =
  IF
    true EXIT
  THEN
  toupper [char] 0 - dup 9 u> IF
    [ 'A '9 1 + -  ] literal -
    dup 9 u<= IF
      drop false EXIT
    THEN
  THEN
  dup base @ u>= IF
    drop false EXIT
  THEN
  true ;

: accumulate ( +d0 addr digit - +d1 addr )
  swap >r swap  base @  um* drop rot  base @  um* d+ r> ;

: >number ( d addr count -- d addr count ) \ core
    0
    ?DO
	count digit?
    WHILE
	accumulate
    LOOP
        0
    ELSE
	1- I' I -
	UNLOOP
    THEN ;

\ number? number                                       23feb93py

Create bases   10 ,   2 ,   A , 100 ,
\              16     2    10   character
\ !! this saving and restoring base is an abomination! - anton
: getbase ( addr u -- addr' u' )
    over c@ [char] $ - dup 4 u<
    IF
	cells bases + @ base ! 1 /string
    ELSE
	drop
    THEN ;
: s>number ( addr len -- d )
    base @ >r  dpl on
    over c@ '- =  dup >r
    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> )
    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? ?dup 0= abort" ?"  0<
    IF
	s>d
    THEN ;

\ space spaces ud/mod                                  21mar93py
decimal
Create spaces ( u -- ) \ core
bl 80 times \ times from target compiler! 11may93jaw
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
: space ( -- ) \ core
    1 spaces ;

: ud/mod ( ud1 u2 -- urem udquot ) \ gforth
    >r 0 r@ um/mod r> swap >r
    um/mod r> ;

: pad    ( -- addr ) \ core-ext
  here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;

\ hold <# #> sign # #s                                 25jan92py

: hold    ( char -- ) \ core
    pad cell - -1 chars over +! @ c! ;

: <# ( -- ) \ core	less-number-sign
    pad cell - dup ! ;

: #>      ( xd -- addr u ) \ core	number-sign-greater
    2drop pad cell - dup @ tuck - ;

: sign    ( n -- ) \ core
    0< IF  [char] - hold  THEN ;

: #       ( ud1 -- ud2 ) \ core		number-sign
    base @ 2 max ud/mod rot 9 over <
    IF
	[ char A char 9 - 1- ] Literal +
    THEN
    [char] 0 + hold ;

: #s      ( +d -- 0 0 ) \ core	number-sign-s
    BEGIN
	# 2dup or 0=
    UNTIL ;

\ print numbers                                        07jun92py

: d.r ( d n -- ) \ double	d-dot-r
    >r tuck  dabs  <# #s  rot sign #>
    r> over - spaces  type ;

: ud.r ( ud n -- ) \ gforth	u-d-dot-r
    >r <# #s #> r> over - spaces type ;

: .r ( n1 n2 -- ) \ core-ext	dot-r
    >r s>d r> d.r ;
: u.r ( u n -- )  \ core-ext	u-dot-r
    0 swap ud.r ;

: 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
\ bounce                                                08jun93jaw

\ !! allow the user to add rollback actions    anton
\ !! use a separate exception stack?           anton

has-locals [IF]
: lp@ ( -- addr ) \ gforth	l-p-fetch
 laddr# [ 0 , ] ;
[THEN]

Defer 'catch
Defer 'throw

' noop IS 'catch
' noop IS 'throw

: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
    'catch
    sp@ >r
[ has-floats [IF] ]
    fp@ >r
[ [THEN] ]
[ has-locals [IF] ]
    lp@ >r
[ [THEN] ]
    handler @ >r
    rp@ handler !
    execute
    r> handler ! rdrop rdrop rdrop 0 ;

: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
    ?DUP IF
	[ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
	handler @ dup 0= IF
[ has-os [IF] ]
	    2 (bye)
[ [ELSE] ]
	    quit
[ [THEN] ]
	THEN
	rp!
	r> handler !
[ has-locals [IF] ]
        r> lp!
[ [THEN] ]
[ has-floats [IF] ]
	r> fp!
[ [THEN] ]
	r> swap >r sp! drop r>
	'throw
    THEN ;

\ Bouncing is very fine,
\ programming without wasting time...   jaw
: bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
\ a throw without data or fp stack restauration
  ?DUP IF
      handler @ rp!
      r> handler !
[ has-locals [IF] ]
      r> lp!
[ [THEN] ]
[ has-floats [IF] ]
      rdrop
[ [THEN] ]
      rdrop
      'throw
  THEN ;

\ ?stack                                               23feb93py

: ?stack ( ?? -- ?? ) \ gforth
    sp@ s0 @ u> IF    -4 throw  THEN
[ has-floats [IF] ]
    fp@ f0 @ u> IF  -&45 throw  THEN
[ [THEN] ]
;
\ ?stack should be code -- it touches an empty stack!

\ interpret                                            10mar92py

Defer parser
Defer name ( -- c-addr count ) \ gforth
\ get the next word from the input buffer
' (name) IS name
Defer compiler-notfound ( c-addr count -- )
Defer interpreter-notfound ( c-addr count -- )

: no.extensions  ( addr u -- )
    2drop -&13 bounce ;
' no.extensions IS compiler-notfound
' no.extensions IS interpreter-notfound

: compile-only-error ( ... -- )
    -&14 throw ;

: interpret ( ?? -- ?? ) \ gforth
    \ interpret/compile the (rest of the) input buffer
    BEGIN
	?stack name dup
    WHILE
	parser
    REPEAT
    2drop ;

\ interpreter compiler                                 30apr92py

\ not the most efficient implementations of interpreter and compiler
: interpreter ( c-addr u -- ) 
    2dup find-name dup
    if
	nip nip name>int execute
    else
	drop
	2dup 2>r snumber?
	IF
	    2rdrop
	ELSE
	    2r> interpreter-notfound
	THEN
    then ;

: compiler ( c-addr u -- )
    2dup find-name dup
    if ( c-addr u nt )
	nip nip name>comp execute
    else
	drop
	2dup snumber? dup
	IF
	    0>
	    IF
		swap postpone Literal
	    THEN
	    postpone Literal
	    2drop
	ELSE
	    drop compiler-notfound
	THEN
    then ;

' interpreter  IS  parser

: [ ( -- ) \ core	left-bracket
    ['] interpreter  IS parser state off ; immediate
: ] ( -- ) \ core	right-bracket
    ['] compiler     IS parser state on  ;

\ Strings                                              22feb93py

: ," ( "string"<"> -- ) [char] " parse
  here over char+ allot  place align ;
: "lit ( -- addr )
  r> r> dup count + aligned >r swap >r ;
: (.")     "lit count type ;
: (S")     "lit count ;
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
    postpone (S") here over char+ allot  place align ;
                                             immediate restrict
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file	paren
    [char] ) parse 2drop ; 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
\ 'abort thrown out!                                   11may93jaw

: (abort")
    "lit >r
    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

: cset ( bmask c-addr -- )
    tuck c@ or swap c! ; 
: creset ( bmask c-addr -- )
    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 ( -- ) \ core
    immediate-mask lastflags cset ;
: restrict ( -- ) \ gforth
    restrict-mask lastflags cset ;
' restrict alias compile-only ( -- ) \ gforth

\ Header                                               23feb93py

\ input-stream, nextname and noname are quite ugly (passing
\ information through global variables), but they are useful for dealing
\ with existing/independent defining words

defer (header)
defer header ( -- ) \ gforth
' (header) IS header

: string, ( c-addr u -- ) \ gforth
    \G 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 ;

: input-stream-header ( "name" -- )
    name name-too-short? header, ;
: input-stream ( -- )  \ general
    \G switches back to getting the name from the input stream ;
    ['] input-stream-header IS (header) ;

' input-stream-header IS (header)

\ !! make that a 2variable
create nextname-buffer 32 chars allot

: nextname-header ( -- )
    nextname-buffer count header,
    input-stream ;

\ the next name is given in the string
: nextname ( c-addr u -- ) \ gforth
    name-too-long?
    nextname-buffer c! ( c-addr )
    nextname-buffer count move
    ['] nextname-header IS (header) ;

: noname-header ( -- )
    0 last ! cfalign
    input-stream ;

: noname ( -- ) \ gforth
\ the next defined word remains anonymous. The xt of that word is given by lastxt
    ['] noname-header IS (header) ;

: 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
    lastcfa @ ;

: Alias    ( cfa "name" -- ) \ gforth
    Header reveal
    alias-mask lastflags creset
    dup A, lastcfa ! ;

: name>string ( nt -- addr count ) \ gforth	name-to-string
    \g @var{addr count} is the name of the word represented by @var{nt}.
    cell+ count $1F and ;

Create ???  0 , 3 c, char ? c, char ? c, char ? c,
: >name ( cfa -- nt ) \ gforth	to-name
 $21 cell do
   dup i - count $9F and + cfaligned over alias-mask + = if
     i - cell - unloop exit
   then
 cell +loop
 drop ??? ( wouldn't 0 be better? ) ;

\ threading                                   17mar93py

: cfa,     ( code-address -- )  \ gforth	cfa-comma
    here
    dup lastcfa !
    0 A, 0 ,  code-address! ;
: compile, ( xt -- )	\ core-ext	compile-comma
    A, ;
: !does    ( addr -- ) \ gforth	store-does
    lastxt does-code! ;
: (does>)  ( R: addr -- )
    r> cfaligned /does-handler + !does ;
: dodoes,  ( -- )
  cfalign here /does-handler allot does-handler! ;

doer? :dovar [IF]
: Create ( "name" -- ) \ core
    Header reveal dovar: cfa, ;
[ELSE]
: Create ( "name" -- ) \ core
    Header reveal here lastcfa ! 0 A, 0 , DOES> ;
[THEN]

\ Create Variable User Constant                        17mar93py

: Variable ( "name" -- ) \ core
    Create 0 , ;
: AVariable ( "name" -- ) \ gforth
    Create 0 A, ;
: 2Variable ( "name" -- ) \ double
    create 0 , 0 , ;

: uallot ( n -- )  udp @ swap udp +! ;

doer? :douser [IF]
: User ( "name" -- ) \ gforth
    Header reveal douser: cfa, cell uallot , ;
: AUser ( "name" -- ) \ gforth
    User ;
[ELSE]
: User Create uallot , DOES> @ up @ + ;
: AUser User ;
[THEN]

doer? :docon [IF]
    : (Constant)  Header reveal docon: cfa, ;
[ELSE]
    : (Constant)  Create DOES> @ ;
[THEN]
: Constant ( w "name" -- ) \ core
    \G Defines constant @var{name}
    \G  
    \G @var{name} execution: @var{-- w}
    (Constant) , ;
: AConstant ( addr "name" -- ) \ gforth
    (Constant) A, ;
: Value ( w "name" -- ) \ core-ext
    (Constant) , ;

: 2Constant ( w1 w2 "name" -- ) \ double
    Create ( w1 w2 "name" -- )
        2,
    DOES> ( -- w1 w2 )
        2@ ;
    
doer? :dofield [IF]
    : (Field)  Header reveal dofield: cfa, ;
[ELSE]
    : (Field)  Create DOES> @ + ;
[THEN]
\ IS Defer What's Defers TO                            24feb93py

doer? :dodefer [IF]
: Defer ( "name" -- ) \ gforth
    \ !! shouldn't it be initialized with abort or something similar?
    Header Reveal dodefer: cfa,
    ['] noop A, ;
[ELSE]
: Defer ( "name" -- ) \ gforth
    Create ['] noop A,
DOES> @ execute ;
[THEN]

: Defers ( "name" -- ) \ gforth
    ' >body @ compile, ; immediate

\ : ;                                                  24feb93py

defer :-hook ( sys1 -- sys2 )
defer ;-hook ( sys2 -- sys1 )

: : ( "name" -- colon-sys ) \ core	colon
    Header docol: cfa, defstart ] :-hook ;
: ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
    ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict

: :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
    0 last !
    cfalign here docol: cfa, 0 ] :-hook ;

\ Search list handling                                 23feb93py

AVariable current ( -- addr ) \ gforth

: last?   ( -- false / nfa nfa )
    last @ ?dup ;
: (reveal) ( nt wid -- )
    ( wid>wordlist-id ) dup >r
    @ over ( name>link ) ! 
    r> ! ;

\ object oriented search list                          17mar93py

\ word list structure:

struct
  1 cells: field find-method   \ xt: ( c_addr u wid -- nt )
  1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
  1 cells: field rehash-method \ xt: ( wid -- )
\   \ !! what else
end-struct wordlist-map-struct

struct
  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-link \ link field to other wordlists
  1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
end-struct wordlist-struct

: f83find      ( addr len wordlist -- nt / false )
    ( wid>wordlist-id ) @ (f83find) ;

\ Search list table: find reveal
Create f83search ( -- wordlist-map )
    ' f83find A,  ' (reveal) A,  ' drop A,

Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
AVariable lookup       G forth-wordlist lookup T !
G forth-wordlist current T !

\ higher level parts of find

( struct )
0 >body cell
  1 cells: field interpret/compile-int
  1 cells: field interpret/compile-comp
end-struct interpret/compile-struct

: interpret/compile? ( xt -- flag )
    >does-code ['] S" >does-code = ;

: (cfa>int) ( cfa -- xt )
    dup interpret/compile?
    if
	interpret/compile-int @
    then ;

: (x>int) ( cfa b -- xt )
    \ get interpretation semantics of name
    restrict-mask and
    if
	drop ['] compile-only-error
    else
	(cfa>int)
    then ;

: name>int ( nt -- xt ) \ gforth
    \G @var{xt} represents the interpretation semantics of the word
    \G @var{nt}. Produces @code{' compile-only-error} if
    \G @var{nt} is compile-only.
    (name>x) (x>int) ;

: name?int ( nt -- xt ) \ gforth
    \G Like name>int, but throws an error if compile-only.
    (name>x) restrict-mask and
    if
	compile-only-error \ does not return
    then
    (cfa>int) ;

: name>comp ( nt -- w xt ) \ gforth
    \G @var{w xt} is the compilation token for the word @var{nt}.
    (name>x) >r dup interpret/compile?
    if
	interpret/compile-comp @
    then
    r> immediate-mask and if
	['] execute
    else
	['] compile,
    then ;

: (search-wordlist)  ( addr count wid -- nt / false )
    dup wordlist-map @ find-method perform ;

: flag-sign ( f -- 1|-1 )
    \ true becomes 1, false -1
    0= 2* 1+ ;

: (name>intn) ( nfa -- xt +-1 )
    (name>x) tuck (x>int) ( b xt )
    swap immediate-mask and flag-sign ;

: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
    \ xt is the interpretation semantics
    (search-wordlist) dup if
	(name>intn)
    then ;

: find-name ( c-addr u -- nt/0 ) \ gforth
    \g Find the name @var{c-addr u} in the current search
    \g order. Return its nt, if found, otherwise 0.
    lookup @ (search-wordlist) ;

: sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
    find-name dup
    if ( nt )
	state @
	if
	    name>comp ['] execute = flag-sign
	else
	    (name>intn)
	then
    then ;

: find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
    dup count sfind dup
    if
	rot drop
    then ;

: (') ( "name" -- nt ) \ gforth
    name find-name dup 0=
    IF
	drop -&13 bounce
    THEN  ;

: [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth	bracket-paren-tick
    (') postpone ALiteral ; immediate restrict

: '    ( "name" -- xt ) \ core	tick
    \g @var{xt} represents @var{name}'s interpretation
    \g semantics. Performs @code{-14 throw} if the word has no
    \g interpretation semantics.
    (') name?int ;
: [']  ( compilation. "name" -- ; run-time. -- xt ) \ core	bracket-tick
    \g @var{xt} represents @var{name}'s interpretation
    \g semantics. Performs @code{-14 throw} if the word has no
    \g interpretation semantics.
    ' postpone ALiteral ; immediate restrict

: COMP'    ( "name" -- w xt ) \ gforth	c-tick
    \g @var{w xt} represents @var{name}'s compilation semantics.
    (') name>comp ;
: [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth	bracket-comp-tick
    \g @var{w xt} represents @var{name}'s compilation semantics.
    COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict

\ reveal words

Variable warnings ( -- addr ) \ gforth
G -1 warnings T !

: check-shadow  ( addr count wid -- )
\G prints a warning if the string is already present in the wordlist
 >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
   ." redefined " name>string 2dup type
   compare 0<> if
     ."  with " type
   else
     2drop
   then
   space space EXIT
 then
 2drop 2drop ;

: reveal ( -- ) \ gforth
    last?
    if \ the last word has a header
	dup ( name>link ) @ 1 and
	if \ it is still hidden
	    dup ( name>link ) @ 1 xor		( nt wid )
	    2dup >r name>string r> check-shadow ( nt wid )
	    dup wordlist-map @ reveal-method perform
	then
    then ;

: rehash  ( wid -- )
    dup wordlist-map @ rehash-method perform ;

\ Input                                                13feb93py

07 constant #bell ( -- c ) \ gforth
08 constant #bs ( -- c ) \ gforth
09 constant #tab ( -- c ) \ gforth
7F constant #del ( -- c ) \ gforth
0D constant #cr   ( -- c ) \ gforth
\ the newline key code
0C constant #ff ( -- c ) \ gforth
0A constant #lf ( -- c ) \ gforth

: bell ( -- ) \ gforth
    \g makes a beep and flushes the output buffer
    #bell emit
    outfile-id flush-file drop ;
: cr ( -- ) \ core
    \ emit a newline
    #lf ( sic! ) emit ;

\ : backspaces  0 ?DO  #bs emit  LOOP ;

: (ins) ( max span addr pos1 key -- max span addr pos2 )
    >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
: (bs) ( max span addr pos1 -- max span addr pos2 flag )
    dup IF
	#bs emit bl emit #bs emit 1- rot 1- -rot
    THEN false ;
: (ret)  true bl emit ;

Create ctrlkeys
  ] false false false false  false false false false
    (bs)  false (ret) false  false (ret) false false
    false false false false  false false false false
    false false false false  false false false false [

defer insert-char
' (ins) IS insert-char
defer everychar
' noop IS everychar

: decode ( max span addr pos1 key -- max span addr pos2 flag )
  everychar
  dup #del = IF  drop #bs  THEN  \ del is rubout
  dup bl <   IF  cells ctrlkeys + perform  EXIT  THEN
  >r 2over = IF  rdrop bell 0 EXIT  THEN
  r> insert-char 0 ;

: accept   ( addr len -- len ) \ core
  dup 0< IF    abs over dup 1 chars - c@ tuck type 
\ this allows to edit given strings
  ELSE  0  THEN rot over
  BEGIN  key decode  UNTIL
  2drop nip ;

\ Output                                               13feb93py

has-os [IF]
0 Value outfile-id ( -- file-id ) \ gforth

: (type) ( c-addr u -- ) \ gforth
    outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
;

: (emit) ( c -- ) \ gforth
    outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
;
[THEN]

Defer type ( c-addr u -- ) \ core
' (type) IS Type

Defer emit ( c -- ) \ core
' (Emit) IS Emit

Defer key ( -- c ) \ core
' (key) IS key

\ Query                                                07apr93py

has-files 0= [IF]
: sourceline# ( -- n )  loadline @ ;
[THEN]

: refill ( -- flag ) \ core-ext,block-ext,file-ext
  blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
  tib /line
[ has-files [IF] ]
  loadfile @ ?dup
  IF    read-line throw
  ELSE
[ [THEN] ]
      sourceline# 0< IF 2drop false EXIT THEN
      accept true
[ has-files [IF] ]
  THEN
[ [THEN] ]
  1 loadline +!
  swap #tib ! 0 >in ! ;

: query   ( -- ) \ core-ext
    \G obsolescent
    blk off loadfile off
    tib /line accept #tib ! 0 >in ! ;

\ save-mem extend-mem

has-os [IF]
: save-mem	( addr1 u -- addr2 u ) \ gforth
    \g copy a memory block into a newly allocated region in the heap
    swap >r
    dup allocate throw
    swap 2dup r> -rot move ;

: extend-mem	( addr1 u1 u -- addr addr2 u2 )
    \ extend memory block allocated from the heap by u aus
    \ the (possibly reallocated piece is addr2 u2, the extension is at addr
    over >r + dup >r resize throw
    r> over r> + -rot ;
[THEN]

\ HEX DECIMAL                                           2may93jaw

: decimal ( -- ) \ core
    a base ! ;
: hex ( -- ) \ core-ext
    10 base ! ;

\ DEPTH                                                 9may93jaw

: depth ( -- +n ) \ core
    sp@ s0 @ swap - cell / ;
: clearstack ( ... -- )
    s0 @ sp! ;

\ RECURSE                                               17may93jaw

: recurse ( compilation -- ; run-time ?? -- ?? ) \ core
    lastxt compile, ; immediate restrict
' reveal alias recursive ( -- ) \ gforth
	immediate

\ */MOD */                                              17may93jaw

\ !! 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 ;

: */ ( n1 n2 n3 -- n4 ) \ core	star-slash
    */mod nip ;

\ EVALUATE                                              17may93jaw

has-files 0= [IF]
: push-file  ( -- )  r>
  sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
  >tib @ tibstack @ = IF  r@ tibstack +!  THEN
  tibstack @ >tib ! >in @ >r  >r ;

: pop-file   ( throw-code -- throw-code )
  r>
  r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;
[THEN]

: evaluate ( c-addr len -- ) \ core,block
  push-file  #tib ! >tib !
  >in off blk off loadfile off -1 loadline !
  ['] interpret catch
  pop-file throw ;

: abort ( ?? -- ?? ) \ core,exception-ext
    -1 throw ;

\+ environment? true ENV" CORE"
\ core wordset is now complete!

\ Quit                                                 13feb93py

Defer 'quit
Defer .status
: prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
: (Query)  ( -- )
    loadfile off  blk off  refill drop ;
: (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
' (quit) IS 'quit

\ 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 ! ;

: hex. ( u -- ) \ gforth
    \ print value as unsigned hex number
    '$ emit base @ swap hex u. base ! ;

: typewhite ( addr u -- ) \ gforth
    \ like type, but white space is printed instead of the characters
    bounds ?do
	i c@ #tab = if \ check for tab
	    #tab
	else
	    bl
	then
	emit
    loop ;

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 -- )
  [ has-os [IF] ]
      outfile-id dup flush-file drop >r
      stderr to outfile-id
  [ [THEN] ] 
  sourceline# IF
               source >in @ sourceline# 0 0 .error-frame
  THEN
  error-stack @ 0 ?DO
    -1 error-stack +!
    error-stack dup @ 6 * cells + cell+
    6 cells bounds DO
      I @
    cell +LOOP
    .error-frame
  LOOP
  dup -2 =
  IF 
     "error @ ?dup
     IF
        cr count type 
     THEN
     drop
  ELSE
     .error
  THEN
  normal-dp dpp !
  [ has-os [IF] ] r> to outfile-id [ [THEN] ] 
;

' (DoError) IS DoError

: quit ( ?? -- ?? ) \ core
    r0 @ rp! handler off >tib @ >r
    BEGIN
	postpone [
	['] 'quit CATCH dup
    WHILE
	DoError r@ >tib ! r@ tibstack !
    REPEAT
    drop r> >tib ! ;

\ Cold                                                 13feb93py

\ : .name ( name -- ) name>string type space ;
\ : words  listwords @
\          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
Defer 'cold ( -- ) \ gforth tick-cold
\ hook (deferred word) for things to do right before interpreting the
\ command-line arguments
' noop IS 'cold

: cold ( -- ) \ gforth
[ has-files [IF] ]
    pathstring 2@ process-path pathdirs 2!
    init-included-files
[ [THEN] ]
    'cold
[ has-files [IF] ]
    ['] process-args catch ?dup
    IF
	dup >r DoError cr r> negate (bye)
    THEN
    argc @ 1 >
    IF \ there may be some unfinished line, so let's finish it
	cr
    THEN
[ [THEN] ]
    ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
    ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
[ has-os [IF] ]
     cr ." Type `bye' to exit"
[ [THEN] ]
    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 -- )
    main-task up!
[ has-os [IF] ]
    stdout TO outfile-id
[ [THEN] ]
[ has-files [IF] ]
    argc ! argv ! pathstring 2!
[ [THEN] ]
    sp@ s0 !
[ has-locals [IF] ]
    lp@ forthstart 7 cells + @ - 
[ [ELSE] ]
    [ has-os [IF] ]
    sp@ $1040 +
    [ [ELSE] ]
    sp@ $40 +
    [ [THEN] ]
[ [THEN] ]
    dup >tib ! tibstack ! #tib off >in off
    rp@ r0 !
[ has-floats [IF] ]
    fp@ f0 !
[ [THEN] ]
    ['] cold catch DoError
[ has-os [IF] ]
    bye
[ [THEN] ]
;

has-os [IF]
: bye ( -- ) \ tools-ext
[ has-files [IF] ]
    script? 0= IF  cr  THEN
[ [ELSE] ]
    cr
[ [THEN] ]
    0 (bye) ;
[THEN]

\ **argv may be scanned by the C starter to get some important
\ information, as -display and -geometry for an X client FORTH
\ or space and stackspace overrides

\ 0 arg contains, however, the name of the program.