gforth/kernel/int.fs - diff

Return to int.fs CVS log

Up to [gforth] / gforth / kernel

Diff for /gforth/kernel/int.fs between versions 1.130 and 1.195

version 1.130, 2006/02/05 17:54:40	version 1.195, 2012/12/31 15:25:19
Line 1	Line 1
\ definitions needed for interpreter only	\ definitions needed for interpreter only

\ Copyright (C) 1995-2000,2004,2005 Free Software Foundation, Inc.	\ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc.

\ This file is part of Gforth.	\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or	\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License	\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2	\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.	\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,	\ This program is distributed in the hope that it will be useful,
Line 15	Line 15
\ GNU General Public License for more details.	\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License	\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software	\ along with this program. If not, see http://www.gnu.org/licenses/.
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.

\ \ Revision-Log	\ \ Revision-Log

Line 28 require ./basics.fs \ bounds decimal he	Line 27 require ./basics.fs \ bounds decimal he
require ./io.fs \ type ...	require ./io.fs \ type ...
require ./nio.fs \ . <# ...	require ./nio.fs \ . <# ...
require ./errore.fs \ .error ...	require ./errore.fs \ .error ...
require kernel/version.fs \ version-string	require kernel/version.fs \ version-string
require ./../chains.fs

has? new-input 0= [IF]	has? new-input 0= [IF]
: tib ( -- c-addr ) \ core-ext t-i-b	: tib ( -- c-addr ) \ core-ext t-i-b
Line 53 Defer source ( -- c-addr u ) \ core	Line 51 Defer source ( -- c-addr u ) \ core
\ (word) should fold white spaces	\ (word) should fold white spaces
\ this is what (parse-white) does	\ this is what (parse-white) does

\ word parse 23feb93py	\ parse 23feb93py

: sword ( char -- addr len ) \ gforth-obsolete s-word
\G Parses like @code{word}, but the output is like @code{parse} output.
\G @xref{core-idef}.
\ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
\ dpANS6 A.6.2.2008 have a word with that name that behaves
\ differently (like NAME).
source 2dup >r >r >in @ over min /string
rot dup bl = IF
drop (parse-white)
ELSE
(word)
THEN
over start-lexeme
2dup + r> - 1+ r> min >in ! ;

: word ( char "<chars>ccc<char>-- c-addr ) \ core
\G Skip leading delimiters. Parse @i{ccc}, delimited by
\G @i{char}, in the parse area. @i{c-addr} is the address of a
\G transient region containing the parsed string in
\G counted-string format. If the parse area was empty or
\G contained no characters other than delimiters, the resulting
\G string has zero length. A program may replace characters within
\G the counted string. OBSOLESCENT: the counted string has a
\G trailing space that is not included in its length.
sword here place bl here count + c! here ;

: parse ( char "ccc<char>" -- c-addr u ) \ core-ext	: parse ( char "ccc<char>" -- c-addr u ) \ core-ext
\G Parse @i{ccc}, delimited by @i{char}, in the parse	\G Parse @i{ccc}, delimited by @i{char}, in the parse
\G area. @i{c-addr u} specifies the parsed string within the	\G area. @i{c-addr u} specifies the parsed string within the
\G parse area. If the parse area was empty, @i{u} is 0.	\G parse area. If the parse area was empty, @i{u} is 0.
>r source >in @ over min /string ( addr u )	>r source >in @ over min /string ( c-addr1 u1 )
over start-lexeme
over swap r> scan >r	over swap r> scan >r
over - dup r> IF 1+ THEN >in +! ;	over - dup r> IF 1+ THEN >in +!
	[ has? new-input [IF] ]
	2dup input-lexeme!
	[ [THEN] ] ;

\ name 13feb93py	\ name 13feb93py

Line 96 Defer source ( -- c-addr u ) \ core	Line 70 Defer source ( -- c-addr u ) \ core

: (name) ( -- c-addr count ) \ gforth	: (name) ( -- c-addr count ) \ gforth
source 2dup >r >r >in @ /string (parse-white)	source 2dup >r >r >in @ /string (parse-white)
over start-lexeme	[ has? new-input [IF] ]
	2dup input-lexeme!
	[ [THEN] ]
2dup + r> - 1+ r> min >in ! ;	2dup + r> - 1+ r> min >in ! ;
\ name count ;	\ name count ;
[THEN]	[THEN]
Line 109 Defer source ( -- c-addr u ) \ core	Line 85 Defer source ( -- c-addr u ) \ core

\ \ Number parsing 23feb93py	\ \ Number parsing 23feb93py

\ number? number 23feb93py	\ (number?) number 23feb93py

hex	hex
const Create bases 0A , 10 , 2 , 0A ,	const Create bases 0A , 10 , 2 , 0A ,
Line 136 const Create bases 0A , 10 , 2 , 0	Line 112 const Create bases 0A , 10 , 2 , 0
THEN	THEN
r> ;	r> ;

	: ?dnegate ( d1 f -- d2 )
	if
	dnegate
	then ;

	has? os 0= [IF]
	: x@+/string ( addr u -- addr' u' c )
	over c@ >r 1 /string r> ;
	[THEN]

: s'>unumber? ( addr u -- ud flag )	: s'>unumber? ( addr u -- ud flag )
\ convert string "C" or "C'" to character code	\ convert string "C" or "C'" to character code
dup 0= if	dup 0= if
Line 143 const Create bases 0A , 10 , 2 , 0	Line 129 const Create bases 0A , 10 , 2 , 0
endif	endif
x@+/string 0 s" '" 2rot string-prefix? ;	x@+/string 0 s" '" 2rot string-prefix? ;

: s>unumber? ( addr u -- ud flag ) \ gforth	: s>unumber? ( c-addr u -- ud flag ) \ gforth
\G converts string addr u into ud, flag indicates success	\G converts string c-addr u into ud, flag indicates success
dpl on	dpl on
over c@ '' = if	over c@ '' = if
1 /string s'>unumber? exit	1 /string s'>unumber? exit
endif	endif
base @ >r getbase	base @ >r getbase sign?
0. 2swap	over if
BEGIN ( d addr len )	>r 0. 2swap
dup >r >number dup	BEGIN ( d addr len )
WHILE \ there are characters left	dup >r >number dup
dup r> -	WHILE \ there are characters left
WHILE \ the last >number parsed something	dup r> -
dup 1- dpl ! over c@ [char] . =	WHILE \ the last >number parsed something
WHILE \ the current char is '.'	dup 1- dpl ! over c@ dp-char @ =
1 /string	WHILE \ the current char is '.'
REPEAT THEN \ there are unparseable characters left	1 /string
2drop false	REPEAT THEN \ there are unparseable characters left
	2drop rdrop false
	ELSE
	rdrop 2drop r> ?dnegate true
	THEN
ELSE	ELSE
rdrop 2drop true	drop 2drop 0. false THEN
THEN
r> base ! ;	r> base ! ;

\ ouch, this is complicated; there must be a simpler way - anton	\ ouch, this is complicated; there must be a simpler way - anton
Line 174 const Create bases 0A , 10 , 2 , 0	Line 163 const Create bases 0A , 10 , 2 , 0
0= IF	0= IF
rdrop false	rdrop false
ELSE \ no characters left, all ok	ELSE \ no characters left, all ok
r>	r> ?dnegate
IF
dnegate
THEN
true	true
THEN ;	THEN ;

Line 196 const Create bases 0A , 10 , 2 , 0	Line 182 const Create bases 0A , 10 , 2 , 0
1+	1+
THEN ;	THEN ;

: number? ( string -- string 0 / n -1 / d 0> )	: (number?) ( string -- string 0 / n -1 / d 0> )
dup >r count snumber? dup if	dup >r count snumber? dup if
rdrop	rdrop
else	else
Line 204 const Create bases 0A , 10 , 2 , 0	Line 190 const Create bases 0A , 10 , 2 , 0
then ;	then ;

: number ( string -- d )	: number ( string -- d )
number? ?dup 0= abort" ?" 0<	(number?) ?dup 0= abort" ?" 0<
IF	IF
s>d	s>d
THEN ;	THEN ;
Line 235 const Create bases 0A , 10 , 2 , 0	Line 221 const Create bases 0A , 10 , 2 , 0
\G comments into documentation.	\G comments into documentation.
POSTPONE \ ; immediate	POSTPONE \ ; immediate

	has? ec [IF]
	AVariable forth-wordlist
	: find-name ( c-addr u -- nt \| 0 ) \ gforth
	\g Find the name @i{c-addr u} in the current search
	\g order. Return its @i{nt}, if found, otherwise 0.
	forth-wordlist (f83find) ;
	[ELSE]
\ \ object oriented search list 17mar93py	\ \ object oriented search list 17mar93py

\ word list structure:	\ word list structure:
Line 269 has? f83headerstring [IF]	Line 262 has? f83headerstring [IF]
Create f83search ( -- wordlist-map )	Create f83search ( -- wordlist-map )
' f83find A, ' drop A, ' drop A, ' drop A,	' f83find A, ' drop A, ' drop A, ' drop A,

here G f83search T A, NIL A, NIL A, NIL A,	here f83search A, NIL A, NIL A, NIL A,
AValue forth-wordlist \ variable, will be redefined by search.fs	AValue forth-wordlist \ variable, will be redefined by search.fs

AVariable lookup forth-wordlist lookup !	AVariable lookup forth-wordlist lookup !
Line 285 Defer context ( -- addr ) \ gforth	Line 278 Defer context ( -- addr ) \ gforth
' lookup is context	' lookup is context
forth-wordlist current !	forth-wordlist current !

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

	: search-wordlist ( c-addr count wid -- 0 \| xt +-1 ) \ search
	\G Search the word list identified by @i{wid} for the definition
	\G named by the string at @i{c-addr count}. If the definition is
	\G not found, return 0. If the definition is found return 1 (if
	\G the definition is immediate) or -1 (if the definition is not
	\G immediate) together with the @i{xt}. In Gforth, the @i{xt}
	\G returned represents the interpretation semantics. ANS Forth
	\G does not specify clearly what @i{xt} represents.
	(search-wordlist) dup if
	(name>intn)
	then ;

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

\ \ header, finding, ticks 17dec92py	\ \ header, finding, ticks 17dec92py

\ The constants are defined as 32 bits, but then erased	\ The constants are defined as 32 bits, but then erased
Line 292 forth-wordlist current !	Line 306 forth-wordlist current !

has? f83headerstring [IF]	has? f83headerstring [IF]
\ to save space, Gforth EC limits words to 31 characters	\ to save space, Gforth EC limits words to 31 characters
	\ also, there's no predule concept in Gforth EC
$80 constant alias-mask	$80 constant alias-mask
$40 constant immediate-mask	$40 constant immediate-mask
$20 constant restrict-mask	$20 constant restrict-mask
$1f constant lcount-mask	$1f constant lcount-mask
[ELSE]	[ELSE]
	\ 32-bit systems cannot generate large 64-bit constant in the
	\ cross-compiler, so we kludge it by generating a constant and then
	\ storing the proper value into it (and that's another kludge).
$80000000 constant alias-mask	$80000000 constant alias-mask
1 bits/char 1 - lshift	1 bits/char 1 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times	-1 cells allot bigendian [IF] c, 0 1 cells 1- times
Line 309 $20000000 constant restrict-mask	Line 327 $20000000 constant restrict-mask
1 bits/char 3 - lshift	1 bits/char 3 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times	-1 cells allot bigendian [IF] c, 0 1 cells 1- times
[ELSE] 0 1 cells 1- times c, [THEN]	[ELSE] 0 1 cells 1- times c, [THEN]
$1fffffff constant lcount-mask	$10000000 constant prelude-mask
1 bits/char 3 - lshift 1 -	1 bits/char 4 - lshift
	-1 cells allot bigendian [IF] c, 0 1 cells 1- times
	[ELSE] 0 1 cells 1- times c, [THEN]
	$0fffffff constant lcount-mask
	1 bits/char 4 - lshift 1 -
-1 cells allot bigendian [IF] c, -1 1 cells 1- times	-1 cells allot bigendian [IF] c, -1 1 cells 1- times
[ELSE] -1 1 cells 1- times c, [THEN]	[ELSE] -1 1 cells 1- times c, [THEN]
[THEN]	[THEN]
Line 337 $1fffffff constant lcount-mask	Line 359 $1fffffff constant lcount-mask

: (x>int) ( cfa w -- xt )	: (x>int) ( cfa w -- xt )
\ get interpretation semantics of name	\ get interpretation semantics of name
restrict-mask and	restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
if	if
drop ['] compile-only-error	drop ['] compile-only-error
else	else
Line 345 $1fffffff constant lcount-mask	Line 367 $1fffffff constant lcount-mask
then ;	then ;

has? f83headerstring [IF]	has? f83headerstring [IF]
: name>string ( nt -- addr count ) \ gforth head-to-string	: name>string ( nt -- addr count ) \ gforth name-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.	\g @i{addr count} is the name of the word represented by @i{nt}.
cell+ count lcount-mask and ;	cell+ count lcount-mask and ;

Line 360 has? f83headerstring [IF]	Line 382 has? f83headerstring [IF]
swap @ swap	swap @ swap
THEN ;	THEN ;
[ELSE]	[ELSE]
: name>string ( nt -- addr count ) \ gforth head-to-string	: name>string ( nt -- addr count ) \ gforth name-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.	\g @i{addr count} is the name of the word represented by @i{nt}.
cell+ dup cell+ swap @ lcount-mask and ;	cell+ dup cell+ swap @ lcount-mask and ;

Line 376 has? f83headerstring [IF]	Line 398 has? f83headerstring [IF]
THEN ;	THEN ;
[THEN]	[THEN]

: name>int ( nt -- xt ) \ gforth	: name>int ( nt -- xt ) \ gforth name-to-int
\G @i{xt} represents the interpretation semantics of the word	\G @i{xt} represents the interpretation semantics of the word
\G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is	\G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
\G @code{compile-only}), @i{xt} is the execution token for	\G @code{compile-only}), @i{xt} is the execution token for
\G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.	\G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
(name>x) (x>int) ;	(name>x) (x>int) ;

: name?int ( nt -- xt ) \ gforth	: name?int ( nt -- xt ) \ gforth name-question-int
\G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}	\G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
\G has no interpretation semantics.	\G has no interpretation semantics.
(name>x) restrict-mask and	(name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
if	if
ticking-compile-only-error \ does not return	ticking-compile-only-error \ does not return
then	then
Line 401 has? f83headerstring [IF]	Line 423 has? f83headerstring [IF]
interpret/compile-comp @	interpret/compile-comp @
then	then
[ [THEN] ]	[ [THEN] ]
r> immediate-mask and flag-sign	r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign
;	;

: (name>intn) ( nfa -- xt +-1 )	: (name>intn) ( nfa -- xt +-1 )
(name>x) tuck (x>int) ( w xt )	(name>x) tuck (x>int) ( w xt )
swap immediate-mask and flag-sign ;	swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ;

	[IFDEF] prelude-mask
	: name>prelude ( nt -- xt )
	dup cell+ @ prelude-mask and if
	[ -1 cells ] literal + @
	else
	drop ['] noop
	then ;
	[THEN]

const Create ??? 0 , 3 , char ? c, char ? c, char ? c,	const Create ??? 0 , 3 , char ? c, char ? c, char ? c,
\ ??? is used by dovar:, must be created/:dovar	\ ??? is used by dovar:, must be created/:dovar
Line 415 const Create ??? 0 , 3 , char ? c, char	Line 446 const Create ??? 0 , 3 , char ? c, char
\ if we have a forthstart we can define head? with it	\ if we have a forthstart we can define head? with it
\ otherwise leave out the head? check	\ otherwise leave out the head? check

	: one-head? ( addr -- f )
	\G heuristic check whether addr is a name token; may deliver false
	\G positives; addr must be a valid address
	dup dup aligned <>
	if
	drop false exit \ heads are aligned
	then
	dup cell+ @ alias-mask and 0= >r
	name>string dup $20 $1 within if
	rdrop 2drop false exit \ realistically the name is short
	then
	over + cfaligned over - 2dup bounds ?do \ should be a printable string
	i c@ bl < if
	2drop unloop rdrop false exit
	then
	loop
	+ r> if \ check for valid aliases
	@ dup forthstart here within
	over ['] noop ['] lit-execute 1+ within or
	over dup aligned = and
	0= if
	drop false exit
	then
	then \ check for cfa - must be code field or primitive
	dup @ tuck 2 cells - = swap
	docol: ['] lit-execute @ 1+ within or ;

: head? ( addr -- f )	: head? ( addr -- f )
\G heuristic check whether addr is a name token; may deliver false	\G heuristic check whether addr is a name token; may deliver false
\G positives; addr must be a valid address; returns 1 for	\G positives; addr must be a valid address; returns 1 for
Line 425 const Create ??? 0 , 3 , char ? c, char	Line 483 const Create ??? 0 , 3 , char ? c, char
\ some code), which is typically not in the dictionary.	\ some code), which is typically not in the dictionary.
\ we added a third iteration for working with code and ;code words.	\ we added a third iteration for working with code and ;code words.
3 0 do	3 0 do
dup dup aligned <> if \ protect @ against unaligned accesses	dup one-head? 0= if
drop false unloop exit	drop false unloop exit
then	endif
dup @ dup	dup @ dup 0= if
if ( addr addr1 )	2drop 1 unloop exit
dup rot forthstart within	else
if \ addr1 is outside forthstart..addr, not a head	dup rot forthstart within if
drop false unloop exit	drop false unloop exit
then ( addr1 )	then
else \ 0 in the link field, no further checks
2drop 1 unloop exit \ this is very unsure, so return 1
then	then
loop	loop
\ in dubio pro:
drop true ;	drop true ;

: >head-noprim ( cfa -- nt ) \ gforth to-head-noprim	: >head-noprim ( cfa -- nt ) \ gforth to-head-noprim
\ also heuristic	\ also heuristic
dup forthstart - max-name-length @ float+ cell+ min cell max cell ?do ( cfa )	dup forthstart - max-name-length @
	[ has? float [IF] ] float+ [ [ELSE] ] cell+ [ [THEN] ] cell+ min
	cell max cell ?do ( cfa )
dup i - dup @ [ alias-mask lcount-mask or ] literal	dup i - dup @ [ alias-mask lcount-mask or ] literal
[ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or	[ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
-1 cells allot bigendian [IF] c, -1 1 cells 1- times	-1 cells allot bigendian [IF] c, -1 1 cells 1- times
Line 477 const Create ??? 0 , 3 , char ? c, char	Line 534 const Create ??? 0 , 3 , char ? c, char

[THEN]	[THEN]

cell% 2* 0 0 field >body ( xt -- a_addr ) \ core	cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
\G Get the address of the body of the word represented by @i{xt} (the	\G Get the address of the body of the word represented by @i{xt} (the
\G address of the word's data field).	\G address of the word's data field).
drop drop	drop drop
Line 500 has? standardthreading has? compiler and	Line 557 has? standardthreading has? compiler and
drop 0	drop 0
endif ;	endif ;

' ! alias code-address! ( c_addr xt -- ) \ gforth	has? prims [IF]
	: flash! ! ;
	: flashc! c! ;
	[THEN]

	has? flash [IF] ' flash! [ELSE] ' ! [THEN]
	alias code-address! ( c_addr xt -- ) \ gforth
\G Create a code field with code address @i{c-addr} at @i{xt}.	\G Create a code field with code address @i{c-addr} at @i{xt}.

: does-code! ( a_addr xt -- ) \ gforth	: any-code! ( a-addr cfa code-addr -- )
	\ for implementing DOES> and ;ABI-CODE, maybe :
	\ code-address is stored at cfa, a-addr at cfa+cell
	over ! cell+ ! ;

	: does-code! ( a-addr xt -- ) \ gforth
\G Create a code field at @i{xt} for a child of a @code{DOES>}-word;	\G Create a code field at @i{xt} for a child of a @code{DOES>}-word;
\G @i{a-addr} is the start of the Forth code after @code{DOES>}.	\G @i{a-addr} is the start of the Forth code after @code{DOES>}.
dodoes: over ! cell+ ! ;	[ has? flash [IF] ]
	dodoes: over flash! cell+ flash!
' drop alias does-handler! ( a_addr -- ) \ gforth	[ [ELSE] ]
\G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,	dodoes: any-code!
\G @i{a-addr} points just behind a @code{DOES>}.	[ [THEN] ] ;

2 cells constant /does-handler ( -- n ) \ gforth	2 cells constant /does-handler ( -- n ) \ gforth
\G The size of a @code{DOES>}-handler (includes possible padding).	\G The size of a @code{DOES>}-handler (includes possible padding).

[THEN]	[THEN]

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

: search-wordlist ( c-addr count wid -- 0 \| xt +-1 ) \ search
\G Search the word list identified by @i{wid} for the definition
\G named by the string at @i{c-addr count}. If the definition is
\G not found, return 0. If the definition is found return 1 (if
\G the definition is immediate) or -1 (if the definition is not
\G immediate) together with the @i{xt}. In Gforth, the @i{xt}
\G returned represents the interpretation semantics. ANS Forth
\G does not specify clearly what @i{xt} represents.
(search-wordlist) dup if
(name>intn)
then ;

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

: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete	: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
find-name dup	find-name dup
if ( nt )	if ( nt )
Line 573 has? standardthreading has? compiler and	Line 621 has? standardthreading has? compiler and
\ ticks in interpreter	\ ticks in interpreter

: (') ( "name" -- nt ) \ gforth	: (') ( "name" -- nt ) \ gforth
name name-too-short?	parse-name name-too-short?
find-name dup 0=	find-name dup 0=
IF	IF
drop -&13 throw	drop -&13 throw
Line 602 Defer parser1 ( c-addr u -- ... xt)	Line 650 Defer parser1 ( c-addr u -- ... xt)
: parser ( c-addr u -- ... )	: parser ( c-addr u -- ... )
\ text-interpret the word/number c-addr u, possibly producing a number	\ text-interpret the word/number c-addr u, possibly producing a number
parser1 execute ;	parser1 execute ;
	has? ec [IF]
	' (name) Alias parse-name
	: no.extensions 2drop -&13 throw ;
	' no.extensions Alias compiler-notfound1
	' no.extensions Alias interpreter-notfound1
	[ELSE]
Defer parse-name ( "name" -- c-addr u ) \ gforth	Defer parse-name ( "name" -- c-addr u ) \ gforth
\G Get the next word from the input buffer	\G Get the next word from the input buffer
' (name) IS parse-name	' (name) IS parse-name
Line 613 Defer parse-name ( "name" -- c-addr u )	Line 666 Defer parse-name ( "name" -- c-addr u )
' parse-name alias name ( -- c-addr u ) \ gforth-obsolete	' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
\G old name for @code{parse-name}	\G old name for @code{parse-name}

	: no.extensions ( addr u -- )
	2drop -&13 throw ;

	has? recognizer 0= [IF]
Defer compiler-notfound1 ( c-addr count -- ... xt )	Defer compiler-notfound1 ( c-addr count -- ... xt )
Defer interpreter-notfound1 ( c-addr count -- ... xt )	Defer interpreter-notfound1 ( c-addr count -- ... xt )

: no.extensions ( addr u -- )
2drop -&13 throw ;
' no.extensions IS compiler-notfound1	' no.extensions IS compiler-notfound1
' no.extensions IS interpreter-notfound1	' no.extensions IS interpreter-notfound1
	[THEN]

Defer before-word ( -- ) \ gforth	Defer before-word ( -- ) \ gforth
\ called before the text interpreter parses the next word	\ called before the text interpreter parses the next word
' noop IS before-word	' noop IS before-word

	Defer before-line ( -- ) \ gforth
	\ called before the text interpreter parses the next line
	' noop IS before-line

	[THEN]

	has? backtrace [IF]
: interpret1 ( ... -- ... )	: interpret1 ( ... -- ... )
[ has? backtrace [IF] ]
rp@ backtrace-rp0 !	rp@ backtrace-rp0 !
[ [THEN] ]	[ has? EC 0= [IF] ] before-line [ [THEN] ]
BEGIN	BEGIN
?stack before-word name dup	?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
WHILE	WHILE
parser1 execute	parser1 execute
REPEAT	REPEAT
Line 638 Defer before-word ( -- ) \ gforth	Line 700 Defer before-word ( -- ) \ gforth

: interpret ( ?? -- ?? ) \ gforth	: interpret ( ?? -- ?? ) \ gforth
\ interpret/compile the (rest of the) input buffer	\ interpret/compile the (rest of the) input buffer
[ has? backtrace [IF] ]
backtrace-rp0 @ >r	backtrace-rp0 @ >r
[ [THEN] ]
['] interpret1 catch	['] interpret1 catch
[ has? backtrace [IF] ]
r> backtrace-rp0 !	r> backtrace-rp0 !
[ [THEN] ]
throw ;	throw ;
	[ELSE]
	: interpret ( ... -- ... )
	BEGIN
	?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
	WHILE
	parser1 execute
	REPEAT
	2drop ;
	[THEN]

\ interpreter 30apr92py	\ interpreter 30apr92py

	[IFDEF] prelude-mask
	: run-prelude ( nt\|0 -- nt\|0 )
	\ run the prelude of the name identified by nt (if present). This
	\ is used in the text interpreter and similar stuff.
	dup if
	dup name>prelude execute
	then ;
	[THEN]

	has? recognizer 0= [IF]
\ not the most efficient implementations of interpreter and compiler	\ not the most efficient implementations of interpreter and compiler
: interpreter1 ( c-addr u -- ... xt )	: interpreter1 ( c-addr u -- ... xt )
2dup find-name dup	2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
if	if
nip nip name>int	nip nip name>int
else	else
Line 665 Defer before-word ( -- ) \ gforth	Line 742 Defer before-word ( -- ) \ gforth
then ;	then ;

' interpreter1 IS parser1	' interpreter1 IS parser1
	[THEN]

\ \ Query Evaluate 07apr93py	\ \ Query Evaluate 07apr93py

Line 678 Variable #fill-bytes	Line 756 Variable #fill-bytes
[THEN]	[THEN]

has? new-input 0= [IF]	has? new-input 0= [IF]
	: input-start-line ( -- ) >in off ;
: refill ( -- flag ) \ core-ext,block-ext,file-ext	: refill ( -- flag ) \ core-ext,block-ext,file-ext
\G Attempt to fill the input buffer from the input source. When	\G Attempt to fill the input buffer from the input source. When
\G the input source is the user input device, attempt to receive	\G the input source is the user input device, attempt to receive
Line 693 has? new-input 0= [IF]	Line 772 has? new-input 0= [IF]
\G and return true; otherwise, return false. A successful result	\G and return true; otherwise, return false. A successful result
\G includes receipt of a line containing 0 characters.	\G includes receipt of a line containing 0 characters.
[ has? file [IF] ]	[ has? file [IF] ]
blk @ IF 1 blk +! true input-start-line EXIT THEN	blk @ IF 1 blk +! true EXIT THEN
[ [THEN] ]	[ [THEN] ]
tib /line	tib /line
[ has? file [IF] ]	[ has? file [IF] ]
Line 702 has? new-input 0= [IF]	Line 781 has? new-input 0= [IF]
ELSE	ELSE
[ [THEN] ]	[ [THEN] ]
sourceline# 0< IF 2drop false EXIT THEN	sourceline# 0< IF 2drop false EXIT THEN
accept true	accept eof @ 0=
[ has? file [IF] ]	[ has? file [IF] ]
THEN	THEN
1 loadline +!	1 loadline +!
[ [THEN] ]	[ [THEN] ]
swap #tib ! input-start-line ;	swap #tib !
	input-start-line ;

: query ( -- ) \ core-ext	: query ( -- ) \ core-ext
\G Make the user input device the input source. Receive input into	\G Make the user input device the input source. Receive input into
Line 786 has? new-input 0= [IF]	Line 866 has? new-input 0= [IF]

Defer 'quit	Defer 'quit

Defer .status	has? os [IF]
	Defer .status
	[ELSE]
	[IFUNDEF] bye
	: (bye) ( 0 -- ) \ back to DOS
	drop 5 emit ;

	: bye ( -- ) 0 (bye) ;
	[THEN]
	[THEN]

: prompt state @ IF ." compiled" EXIT THEN ." ok" ;	: prompt state @ IF ." compiled" EXIT THEN ." ok" ;

: (quit) ( -- )	: (quit) ( -- )
\ exits only through THROW etc.	\ exits only through THROW etc.
BEGIN	BEGIN
.status	[ has? ec [IF] ] cr [ [ELSE] ]
['] cr catch if	.status ['] cr catch if
>stderr cr ." Can't print to stdout, leaving" cr	[ has? OS [IF] ] >stderr [ [THEN] ]
	cr ." Can't print to stdout, leaving" cr
\ if stderr does not work either, already DoError causes a hang	\ if stderr does not work either, already DoError causes a hang
2 (bye)	-2 (bye)
endif	endif [ [THEN] ]
refill WHILE	refill WHILE
interpret prompt	interpret prompt
REPEAT	REPEAT
bye ;	bye ;
Line 808 Defer .status	Line 898 Defer .status

\ \ DOERROR (DOERROR) 13jun93jaw	\ \ DOERROR (DOERROR) 13jun93jaw

	has? os [IF]
8 Constant max-errors	8 Constant max-errors
5 has? file 2 and + Constant /error	5 has? file 2 and + Constant /error
Variable error-stack 0 error-stack !	Variable error-stack 0 error-stack !
max-errors /error * cells allot	max-errors /error * cells allot
\ format of one cell:	\ format of one cell:
\ source ( addr u )	\ source ( c-addr u )
\ input-start-parse	\ last parsed lexeme ( c-addr u )
\ >in
\ line-number	\ line-number
\ Loadfilename ( addr u )	\ Loadfilename ( addr u )

: error> ( -- addr u start-parse >in line# [addr u] )	: error> ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )
-1 error-stack +!	-1 error-stack +!
error-stack dup @	error-stack dup @
/error * cells + cell+	/error * cells + cell+
Line 827 max-errors /error * cells allot	Line 917 max-errors /error * cells allot
I @	I @
cell +LOOP ;	cell +LOOP ;

: >error ( addr u start-parse >in line# [addr u] -- )	: >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- )
error-stack dup @ dup 1+	error-stack dup @ dup 1+
max-errors 1- min error-stack !	max-errors 1- min error-stack !
/error * cells + cell+	/error * cells + cell+
Line 835 max-errors /error * cells allot	Line 925 max-errors /error * cells allot
I !	I !
-1 cells +LOOP ;	-1 cells +LOOP ;

: error->in ( -- u )	: input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )
\ >in corrected to eliminate one trailing white space character
>in @ dup if \ non-zero?
source 2 pick u< if \ beyond end of source?
2drop exit
then
over 1- chars + c@ bl u<= if
1-
then
then ;

: input-error-data ( -- addr u start-parse >in line# [addr u] )
\ error data for the current input, to be used by >error or .error-frame	\ error data for the current input, to be used by >error or .error-frame
source input-start-parse @ error->in sourceline#	source over >r save-mem over r> -
	input-lexeme 2@ >r + r> sourceline#
[ has? file [IF] ] sourcefilename [ [THEN] ] ;	[ has? file [IF] ] sourcefilename [ [THEN] ] ;

: dec. ( n -- ) \ gforth	: dec. ( n -- ) \ gforth
Line 889 Defer dobacktrace ( -- )	Line 969 Defer dobacktrace ( -- )
ELSE .error	ELSE .error
THEN ;	THEN ;

	[IFUNDEF] umin
: umin ( u1 u2 -- u )	: umin ( u1 u2 -- u )
2dup u>	2dup u>
if	if
swap	swap
then	then
drop ;	drop ;
	[THEN]

Defer mark-start	Defer mark-start
Defer mark-end	Defer mark-end
Line 904 Defer mark-end	Line 986 Defer mark-end

: part-type ( addr1 u1 u -- addr2 u2 )	: part-type ( addr1 u1 u -- addr2 u2 )
\ print first u characters of addr1 u1, addr2 u2 is the rest	\ print first u characters of addr1 u1, addr2 u2 is the rest
2 pick over type /string ;	over umin 2 pick over type /string ;

: .error-line ( addr2 u2 u0 u1 -- )	: .error-line ( c-addr1 u1 c-addr2 u2 -- )
\ print error between char n0 and char n1 in line addr1 u1	\ print error in line c-addr1 u1, where the error-causing lexeme
\ should work with UTF-8 (whitespace check looks ok)	\ is c-addr2 u2
2 pick umin \ protect against wrong n1	>r 2 pick - part-type ( c-addr3 u3 R: u2 )
tuck umin swap \ protect against wrong n0	mark-start r> part-type mark-end ( c-addr4 u4 )
over - >r ( addr2 u2 u0 R: u1-u0 )	type ;
part-type mark-start r> part-type mark-end type ;

: .error-frame ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] -- throwcode )	: .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode )
\ addr2 u2: filename of included file - optional	\ addr3 u3: filename of included file - optional
\ n2: line number	\ n2: line number
\ n1: end of error position in input line	\ addr2 u2: parsed lexeme (should be marked as causing the error)
\ n0: start of error position in input line
\ addr1 u1: input line	\ addr1 u1: input line
error-stack @	error-stack @
IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )	IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
Line 960 Defer mark-end	Line 1040 Defer mark-end

' (DoError) IS DoError	' (DoError) IS DoError

	[ELSE]
	: dec. base @ >r decimal . r> base ! ;
	: DoError ( throw-code -- )
	cr source drop >in @ type ." <<< "
	dup -2 = IF "error @ type drop EXIT THEN
	.error ;
	[THEN]

: quit ( ?? -- ?? ) \ core	: quit ( ?? -- ?? ) \ core
\G Empty the return stack, make the user input device	\G Empty the return stack, make the user input device
\G the input source, enter interpret state and start	\G the input source, enter interpret state and start
Line 985 Defer mark-end	Line 1073 Defer mark-end
[ [ELSE] ] r> >tib !	[ [ELSE] ] r> >tib !
[ [THEN] ] ;	[ [THEN] ] ;

	: do-execute ( xt -- ) \ Gforth
	\G C calling us
	catch dup IF DoError cr THEN (bye) ;

	: do-find ( addr u -- )
	find-name dup IF name>int THEN (bye) ;

\ \ Cold Boot 13feb93py	\ \ Cold Boot 13feb93py

: (bootmessage)	: gforth ( -- )
." Gforth " version-string type	." Gforth " version-string type
." , Copyright (C) 1995-2006 Free Software Foundation, Inc." cr	." , Copyright (C) 1995-2012 Free Software Foundation, Inc." cr
." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'"	." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
[ has? os [IF] ]	[ has? os [IF] ]
cr ." Type `bye' to exit"	cr ." Type `bye' to exit"
[ [THEN] ] ;	[ [THEN] ] ;

defer bootmessage	defer bootmessage ( -- ) \ gforth
	\G Hook (deferred word) executed right after interpreting the OS
	\G command-line arguments. Normally prints the Gforth startup
	\G message.

	has? file [IF]
defer process-args	defer process-args
	[THEN]

' (bootmessage) IS bootmessage	' gforth IS bootmessage

	has? os [IF]
Defer 'cold ( -- ) \ gforth tick-cold	Defer 'cold ( -- ) \ gforth tick-cold
\ hook (deferred word) for things to do right before interpreting the	\G Hook (deferred word) for things to do right before interpreting the
\ command-line arguments	\G OS command-line arguments. Normally does some initializations that
	\G you also want to perform.
' noop IS 'cold	' noop IS 'cold
	[THEN]

AVariable init8 NIL init8 !

: cold ( -- ) \ gforth	: cold ( -- ) \ gforth
[ has? backtrace [IF] ]	[ has? backtrace [IF] ]
Line 1015 AVariable init8 NIL init8 !	Line 1116 AVariable init8 NIL init8 !
[ has? file [IF] ]	[ has? file [IF] ]
os-cold	os-cold
[ [THEN] ]	[ [THEN] ]
[ has? ec 0= [IF] ]	[ has? os [IF] ]
set-encoding-fixed-width	set-encoding-fixed-width
[ [THEN] ]
'cold	'cold
init8 chainperform	[ [THEN] ]
[ has? file [IF] ]	[ has? file [IF] ]
process-args	process-args
loadline off	loadline off
[ [THEN] ]	[ [THEN] ]
bootmessage	1 (bye) ;
quit ;

has? new-input 0= [IF]	has? new-input 0= [IF]
: clear-tibstack ( -- )	: clear-tibstack ( -- )
Line 1035 has? new-input 0= [IF]	Line 1134 has? new-input 0= [IF]
[ has? os [IF] ]	[ has? os [IF] ]
r0 @ forthstart 6 cells + @ -	r0 @ forthstart 6 cells + @ -
[ [ELSE] ]	[ [ELSE] ]
sp@ $10 cells +	sp@ cell+
[ [THEN] ]	[ [THEN] ]
[ [THEN] ]	[ [THEN] ]
dup >tib ! tibstack ! #tib off input-start-line ;	dup >tib ! tibstack ! #tib off
	input-start-line ;
[THEN]	[THEN]

: boot ( path n **argv argc -- )	: boot ( path n **argv argc -- )
main-task up!	[ has? no-userspace 0= [IF] ]
	next-task 0= IF main-task up!
	ELSE
	next-task @ 0= IF
	throw-entry main-task udp @ throw-entry next-task -
	/string >r swap r> move
	next-task dup next-task 2! normal-dp dpp !
	THEN
	THEN
	[ [THEN] ]
[ has? os [IF] ]	[ has? os [IF] ]
os-boot	os-boot
[ [THEN] ]	[ [THEN] ]
	[ has? rom [IF] ]
	ram-shadow dup @ dup -1 <> >r u> r> and IF
	ram-shadow 2@ ELSE
	ram-mirror ram-size THEN ram-start swap move
	[ [THEN] ]
sp@ sp0 !	sp@ sp0 !
[ has? peephole [IF] ]	[ has? peephole [IF] ]
\ only needed for greedy static superinstruction selection	\ only needed for greedy static superinstruction selection
Line 1060 has? new-input 0= [IF]	Line 1174 has? new-input 0= [IF]
[ has? floating [IF] ]	[ has? floating [IF] ]
fp@ fp0 !	fp@ fp0 !
[ [THEN] ]	[ [THEN] ]
	[ has? os [IF] ]
handler off	handler off
['] cold catch dup -&2049 <> if \ broken pipe?	['] cold catch dup -&2049 <> if \ broken pipe?
DoError cr	DoError cr
endif	endif
	[ [ELSE] ]
	cold
	[ [THEN] ]
[ has? os [IF] ]	[ has? os [IF] ]
1 (bye) \ !! determin exit code from throw code?	-1 (bye) \ !! determin exit code from throw code?
[ [THEN] ]	[ [THEN] ]
;	;

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

Removed from v.1.130
changed lines
	Added in v.1.195