gforth/kernal.fs - diff

Return to kernal.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/Attic/kernal.fs between versions 1.14 and 1.40

version 1.14, 1994/08/19 17:47:23	version 1.40, 1995/09/06 21:00:21
Line 1	Line 1
\ KERNAL.FS ANS figFORTH kernal 17dec92py	\ KERNAL.FS GNU FORTH kernal 17dec92py
\ $ID:	\ $ID:
\ Idea and implementation: Bernd Paysan (py)	\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group	\ Copyright 1992 by the ANSI figForth Development Group
Line 66 DOES> ( n -- ) + c@ ;	Line 66 DOES> ( n -- ) + c@ ;
bl c,	bl c,
LOOP ;	LOOP ;

	\ !! this is machine-dependent, but works on all but the strangest machines
	' faligned Alias maxaligned
	' falign Alias maxalign

	\ the code field is aligned if its body is maxaligned
	\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
	' maxaligned Alias cfaligned
	' maxalign Alias cfalign

	: chars ; immediate

: A! ( addr1 addr2 -- ) dup relon ! ;	: A! ( addr1 addr2 -- ) dup relon ! ;
: A, ( addr -- ) here cell allot A! ;	: A, ( addr -- ) here cell allot A! ;
Line 78 DOES> ( n -- ) + c@ ;	Line 87 DOES> ( n -- ) + c@ ;

\ name> found 17dec92py	\ name> found 17dec92py

: (name>) ( nfa -- cfa ) count $1F and + aligned ;	: (name>) ( nfa -- cfa )
: name> ( nfa -- cfa ) cell+	count $1F and + cfaligned ;
dup (name>) swap c@ $80 and 0= IF @ THEN ;	: name> ( nfa -- cfa )
	cell+
	dup (name>) swap c@ $80 and 0= IF @ THEN ;

: found ( nfa -- cfa n ) cell+	: found ( nfa -- cfa n ) cell+
dup c@ >r (name>) r@ $80 and 0= IF @ THEN	dup c@ >r (name>) r@ $80 and 0= IF @ THEN
Line 110 Defer source	Line 121 Defer source

\ (word) 22feb93py	\ (word) 22feb93py

: scan ( addr1 n1 char -- addr2 n2 ) >r	: scan ( addr1 n1 char -- addr2 n2 )
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 )
	\ 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 126 Defer source	Line 153 Defer source
\ word parse 23feb93py	\ word parse 23feb93py

: parse-word ( char -- addr len )	: parse-word ( char -- addr len )
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 )
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 )
>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 )
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

Line 155 Defer source	Line 190 Defer source
: [char] ( 'char' -- n ) char postpone Literal ; immediate	: [char] ( 'char' -- n ) char postpone Literal ; immediate
' [char] Alias Ascii immediate	' [char] Alias Ascii immediate

: (compile) ( -- ) r> dup cell+ >r @ A, ;	: (compile) ( -- ) r> dup cell+ >r @ compile, ;
: postpone ( "name" -- )	: postpone ( "name" -- )
name find dup 0= abort" Can't compile "	name sfind dup 0= abort" Can't compile "
0> IF A, ELSE postpone (compile) A, THEN ;	0> IF compile, ELSE postpone (compile) A, THEN ;
immediate restrict	immediate restrict

\ Use (compile) for the old behavior of compile!	\ Use (compile) for the old behavior of compile!
Line 203 Create bases 10 , 2 , A , 100 ,	Line 238 Create bases 10 , 2 , A , 100 ,
REPEAT THEN 2drop rdrop dpl off ELSE	REPEAT THEN 2drop rdrop dpl off ELSE
2drop rdrop r> IF dnegate THEN	2drop rdrop r> IF dnegate THEN
THEN r> base ! ;	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> )	: number? ( string -- string 0 / n -1 / d 0> )
dup count s>number dpl @ 0= IF 2drop false EXIT THEN	dup >r count snumber? dup if
rot drop dpl @ dup 0> 0= IF nip THEN ;	rdrop
	else
	r> swap
	then ;
: s>d ( n -- d ) dup 0< ;	: s>d ( n -- 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 ;
Line 215 decimal	Line 261 decimal
Create spaces bl 80 times \ times from target compiler! 11may93jaw	Create spaces bl 80 times \ times from target compiler! 11may93jaw
DOES> ( u -- ) swap	DOES> ( u -- ) swap
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;	0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
	Create backspaces 08 80 times \ times from target compiler! 11may93jaw
	DOES> ( u -- ) swap
	0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
hex	hex
: space 1 spaces ;	: space 1 spaces ;

Line 297 hex	Line 346 hex

\ ?stack 23feb93py	\ ?stack 23feb93py

: ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ;	: ?stack ( ?? -- ?? )
	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 ' (name) IS name
Defer notfound	Defer notfound ( c-addr count -- )

: no.extensions ( string -- ) IF -&13 bounce THEN ;	: no.extensions ( addr u -- ) 2drop -&13 bounce ;

' no.extensions IS notfound	' no.extensions IS notfound

: interpret	: interpret
BEGIN ?stack name dup c@ WHILE parser REPEAT drop ;	BEGIN
	?stack name dup
	WHILE
	parser
	REPEAT
	2drop ;

\ interpreter compiler 30apr92py	\ interpreter compiler 30apr92py

: interpreter ( name -- ) find ?dup	: interpreter ( c-addr u -- )
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
	-&14 throw
	THEN
	drop
	2dup 2>r snumber?
	IF
	2rdrop
	ELSE
	2r> notfound
	THEN ;

' interpreter IS parser	' interpreter IS parser

: compiler ( name -- ) find ?dup	: compiler ( c-addr u -- )
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 notfound
	THEN ;

: [ ['] interpreter IS parser state off ; immediate	: [ ['] interpreter IS parser state off ; immediate
: ] ['] compiler IS parser state on ;	: ] ['] compiler IS parser state on ;
Line 334 Defer notfound	Line 422 Defer notfound
: compile-lp+! ( n -- )	: 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 ;

Line 351 AConstant locals-list \ acts like a vari	Line 439 AConstant locals-list \ acts like a vari


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 ( -- )
	\ declares the current point of execution as unreachable
	dead-code on
	0 backedge-locals ! ; immediate

	: ASSUME-LIVE ( orig -- orig )
	\ 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 )
Line 480 variable dead-code \ true if normal code	Line 580 variable dead-code \ true if normal code
\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

: AHEAD ( -- orig )	: AHEAD ( -- orig )
POSTPONE branch >mark unreachable ; immediate restrict	POSTPONE branch >mark POSTPONE unreachable ; immediate restrict

: IF ( -- orig )	: IF ( -- orig )
POSTPONE ?branch >mark ; immediate restrict	POSTPONE ?branch >mark ; immediate restrict
Line 494 variable dead-code \ true if normal code	Line 594 variable dead-code \ true if normal code

: THEN ( orig -- )	: THEN ( orig -- )
dup orig?	dup orig?
dead-code @	dead-orig =
if	if
dead-orig =	>resolve drop
if
>resolve drop
else
>resolve set-locals-size-list dead-code off
then
else	else
dead-orig =	dead-code @
if	if
>resolve drop	>resolve set-locals-size-list dead-code off
else \ both live	else \ both live
over list-size adjust-locals-size	over list-size adjust-locals-size
>resolve	>resolve
Line 527 variable dead-code \ true if normal code	Line 622 variable dead-code \ true if normal code

: BEGIN ( -- dest )	: BEGIN ( -- dest )
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 553 variable dead-code \ true if normal code	Line 641 variable dead-code \ true if normal code
POSTPONE branch	POSTPONE branch
<resolve	<resolve
check-begin	check-begin
unreachable ; immediate restrict	POSTPONE unreachable ; 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 624 Avariable leave-sp leave-stack 3 cells	Line 712 Avariable leave-sp leave-stack 3 cells
cell - dup @ swap	cell - dup @ swap
leave-sp ! ;	leave-sp ! ;

: DONE ( orig -- ) drop >r drop	: DONE ( orig -- )
\ !! the original done had ( addr -- )	\ !! the original done had ( addr -- )
	drop >r drop
begin	begin
leave>	leave>
over r@ u>=	over r@ u>=
Line 685 Avariable leave-sp leave-stack 3 cells	Line 774 Avariable leave-sp leave-stack 3 cells
: EXIT ( -- )	: EXIT ( -- )
0 adjust-locals-size	0 adjust-locals-size
POSTPONE ;s	POSTPONE ;s
unreachable ; immediate restrict	POSTPONE unreachable ; immediate restrict

: ?EXIT ( -- )	: ?EXIT ( -- )
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict	POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
Line 700 Avariable leave-sp leave-stack 3 cells	Line 789 Avariable leave-sp leave-stack 3 cells
: (S") "lit count ; restrict	: (S") "lit count ; restrict
: SLiteral postpone (S") here over char+ allot place align ;	: SLiteral postpone (S") here over char+ allot place align ;
immediate restrict	immediate restrict
: S" [char] " parse state @ IF postpone SLiteral THEN ;	create s"-buffer /line chars allot
	: S" ( run-time: -- c-addr u )
	[char] " parse
	state @
	IF
	postpone SLiteral
	ELSE
	/line min >r s"-buffer r@ cmove
	s"-buffer r>
	THEN ;
immediate	immediate
: ." state @ IF postpone (.") ," align	: ." state @ IF postpone (.") ," align
ELSE [char] " parse type THEN ; immediate	ELSE [char] " parse type THEN ; immediate
: ( [char] ) parse 2drop ; immediate	: ( [char] ) parse 2drop ; immediate
: \ source >in ! drop ; immediate	: \ ( -- ) \ core-ext backslash
	blk @
	IF
	>in @ c/l / 1+ c/l * >in !
	EXIT
	THEN
	source >in ! drop ; immediate

	: \G ( -- ) \ new backslash
	POSTPONE \ ; immediate

\ error handling 22feb93py	\ error handling 22feb93py
\ 'abort thrown out! 11may93jaw	\ 'abort thrown out! 11may93jaw
Line 729 Avariable leave-sp leave-stack 3 cells	Line 836 Avariable leave-sp leave-stack 3 cells
\ 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 ' (header) IS header

	: string, ( c-addr u -- )
	\ puts down string as cstring
	dup c, here swap chars dup allot move ;

: name, ( "name" -- )	: name, ( "name" -- )
name c@	name name-too-short? name-too-long?
dup $1F u> -&19 and throw ( is name too long? )	string, cfalign ;
1+ chars allot align ;
: input-stream-header ( "name" -- )	: input-stream-header ( "name" -- )
\ !! this is f83-implementation-dependent	\ !! this is f83-implementation-dependent
align here last ! -1 A,	align here last ! -1 A,
Line 742 defer header	Line 853 defer header

: 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
Line 753 create nextname-buffer 32 chars allot	Line 864 create nextname-buffer 32 chars allot
\ !! f83-implementation-dependent	\ !! f83-implementation-dependent
nextname-buffer count	nextname-buffer count
align here last ! -1 A,	align here last ! -1 A,
dup c, here swap chars dup allot move align	string, cfalign
$80 flag!	$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 -- ) \ general
dup $1F 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 ( -- ) \ general
\ 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 ) \ general
\ 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
Line 785 create nextname-buffer 32 chars allot	Line 896 create nextname-buffer 32 chars allot
Create ??? 0 , 3 c, char ? c, char ? c, char ? c,	Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
: >name ( cfa -- nfa )	: >name ( cfa -- nfa )
$21 cell do	$21 cell do
dup i - count $9F and + aligned over $80 + = if	dup i - count $9F and + cfaligned over $80 + = if
i - cell - unloop exit	i - cell - unloop exit
then	then
cell +loop	cell +loop
Line 831 Create ??? 0 , 3 c, char ? c, char ? c,	Line 942 Create ??? 0 , 3 c, char ? c, char ? c,
: Constant (Constant) , ;	: Constant (Constant) , ;
: AConstant (Constant) A, ;	: AConstant (Constant) A, ;

: 2CONSTANT	: 2Constant
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 ( -- )
Create ( -- )	\ !! shouldn't it be initialized with abort or something similar?
['] noop A,	Header Reveal [ :dodefer ] Literal cfa,
DOES> ( ??? )	['] noop A, ;
@ execute ;	\ Create ( -- )
	\ ['] noop A,
	\ DOES> ( ??? )
	\ @ execute ;

: IS ( addr "name" -- )	: IS ( addr "name" -- )
' >body	' >body
Line 878 AVariable current	Line 992 AVariable current

: last? ( -- false / nfa nfa ) last @ ?dup ;	: last? ( -- false / nfa nfa ) last @ ?dup ;
: (reveal) ( -- )	: (reveal) ( -- )
last?	last?
IF	IF
dup @ 0<	dup @ 0<
IF	IF
current @ @ over ! current @ !	current @ @ over ! current @ !
ELSE	ELSE
drop	drop
THEN	THEN
THEN ;	THEN ;

\ object oriented search list 17mar93py	\ object oriented search list 17mar93py

\ 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: ( -- )
	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 ) @ (f83find) ;

Line 911 AVariable current	Line 1026 AVariable current
Create f83search ' f83find A, ' (reveal) A, ' drop A,	Create f83search ' f83find A, ' (reveal) A, ' drop A,

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 !

: (search-wordlist) ( addr count wid -- nfa / false )	: (search-wordlist) ( addr count wid -- nfa / false )
dup ( @ swap ) cell+ @ @ execute ;	dup wordlist-map @ find-method @ execute ;

: search-wordlist ( addr count wid -- 0 / xt +-1 )	: search-wordlist ( addr count wid -- 0 / xt +-1 )
(search-wordlist) dup IF found THEN ;	(search-wordlist) dup IF found THEN ;

Variable warnings G -1 warnings T !	Variable warnings G -1 warnings T !

Line 936 Variable warnings G -1 warnings T !	Line 1051 Variable warnings G -1 warnings T !
then	then
2drop 2drop ;	2drop 2drop ;

: find ( addr -- cfa +-1 / string false ) dup	: sfind ( c-addr u -- xt n / 0 )
count search @ search-wordlist dup IF rot drop THEN ;	lookup @ search-wordlist ;

	: find ( addr -- cfa +-1 / string false )
	\ !! not ANS conformant: returns +-2 for restricted words
	dup count sfind dup if
	rot drop
	then ;

: reveal ( -- )	: reveal ( -- )
last? if	last? if
name>string current @ check-shadow	name>string current @ check-shadow
then	then
current @ cell+ @ cell+ @ execute ;	current @ wordlist-map @ reveal-method @ execute ;

: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ;	: rehash ( wid -- ) dup wordlist-map @ rehash-method @ execute ;

: ' ( "name" -- addr ) name find 0= no.extensions ;	: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ;
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate	: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
\ Input 13feb93py	\ Input 13feb93py

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

: bell #bell emit ;	: bell #bell emit ;

: backspaces 0 ?DO #bs emit LOOP ;	\ : backspaces 0 ?DO #bs emit LOOP ;
: >string ( span addr pos1 -- span addr pos1 addr2 len )	: >string ( span addr pos1 -- span addr pos1 addr2 len )
over 3 pick 2 pick chars /string ;	over 3 pick 2 pick chars /string ;
: type-rest ( span addr pos1 -- span addr pos1 back )	: type-rest ( span addr pos1 -- span addr pos1 back )
Line 975 Variable warnings G -1 warnings T !	Line 1098 Variable warnings G -1 warnings T !
: (ret) type-rest drop true space ;	: (ret) type-rest drop true space ;
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;	: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;	: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
	: eof 2 pick 0= IF bye ELSE (ret) THEN ;

Create crtlkeys	Create ctrlkeys
] false false back false false false forw false	] false false back false eof false forw false
?del false (ret) false false (ret) false false	?del false (ret) false false (ret) false false
false false false false false false false false	false false false false false false false false
false false false false false false false false [	false false false false false false false false [

	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 + @ execute EXIT THEN
>r 2over = IF rdrop bell 0 EXIT THEN	>r 2over = IF rdrop bell 0 EXIT THEN
r> (ins) 0 ;	r> (ins) 0 ;

Line 1000 Create crtlkeys	Line 1128 Create crtlkeys

\ Output 13feb93py	\ Output 13feb93py

DEFER type \ defer type for a output buffer or fast	Defer type \ defer type for a output buffer or fast
\ screen write	\ screen write

\ : (type) ( addr len -- )	\ : (type) ( addr len -- )
\ bounds ?DO I c@ emit LOOP ;	\ bounds ?DO I c@ emit LOOP ;

' (TYPE) IS Type	' (type) IS Type

DEFER Emit	Defer emit

' (Emit) IS Emit	' (Emit) IS Emit

	Defer key
	' (key) IS key

\ : form ( -- rows cols ) &24 &80 ;	\ : form ( -- rows cols ) &24 &80 ;
\ form should be implemented using TERMCAPS or CURSES	\ form should be implemented using TERMCAPS or CURSES
\ : rows form drop ;	\ : rows form drop ;
Line 1020 DEFER Emit	Line 1151 DEFER Emit
\ Query 07apr93py	\ Query 07apr93py

: refill ( -- flag )	: refill ( -- flag )
	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 loadline @ 0< IF 2drop false EXIT THEN	ELSE loadline @ 0< IF 2drop false EXIT THEN
accept true	accept true
THEN	THEN
1 loadline +!	1 loadline +!
swap #tib ! 0 >in ! ;	swap #tib ! 0 >in ! ;

: Query ( -- ) 0 loadfile ! refill drop ;	: Query ( -- ) loadfile off blk off refill drop ;

\ File specifiers 11jun93jaw	\ File specifiers 11jun93jaw

Line 1047 DEFER Emit	Line 1178 DEFER Emit
\ : 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 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
Line 1059 create nl$ 1 c, A c, 0 c, \ gnu includes	Line 1190 create nl$ 1 c, A c, 0 c, \ gnu includes
\ include-file 07apr93py	\ include-file 07apr93py

: push-file ( -- ) r>	: push-file ( -- ) r>
( linestart 2@ >r >r ) loadline @ >r loadfile @ >r	loadline @ >r loadfile @ >r
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ;	blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ;

: pop-file ( -- ) r>	: pop-file ( throw-code -- throw-code )
r> >in ! r> #tib ! r> >tib ! r> blk !	dup IF
r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;	source >in @ loadline @ loadfilename 2@
	error-stack dup @ dup 1+
	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> blk !
	r> loadfile ! r> loadline ! >r ;

	: read-loop ( ix -- jx )
	BEGIN refill WHILE interpret REPEAT ;

: include-file ( ix fid -- jx )	: include-file ( ix fid -- jx )
push-file loadfile !	push-file loadfile !
0 loadline ! blk off	0 loadline ! blk off ['] read-loop catch
BEGIN refill WHILE interpret REPEAT	loadfile @ close-file swap 2dup or
loadfile @ close-file throw	pop-file drop throw throw ;
pop-file ;
	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 ;

	: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )
	\ 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 [char] / scan nip ( 0<> )
	if \ the filename contains a slash
	2dup r/o open-file throw ( c-addr1 u1 file-id )
	-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
	pathfilenamebuf r> EXIT
	then
	pathdirs 2@ 0
	\ check-file-prefix 0=
	\ IF pathdirs 2@ 0
	?DO ( c-addr1 u1 dirnamep )
	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 )

	: included? ( c-addr u -- f )
	\ 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 ;

: included ( ix addr u -- jx )	: add-included-file ( c-addr u -- )
	\ 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 )
	swap >r
	dup allocate throw
	swap 2dup r> -rot move ;

	: included1 ( ix file-id c-addr u -- jx )
	\ include the file file-id with the name given by c-addr u
loadfilename 2@ >r >r	loadfilename 2@ >r >r
dup allocate throw over loadfilename 2!	save-string 2dup loadfilename 2! add-included-file ( file-id )
over loadfilename 2@ move	['] include-file catch
r/o open-file throw include-file	r> r> loadfilename 2! throw ;
\ don't free filenames; they don't take much space
\ and are used for debugging	: included ( ix addr u -- jx )
r> r> loadfilename 2! ;	open-path-file included1 ;

	: required ( ix addr u -- jx )
	\ 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

Line 1090 create nl$ 1 c, A c, 0 c, \ gnu includes	Line 1322 create nl$ 1 c, A c, 0 c, \ gnu includes
\ DEPTH 9may93jaw	\ DEPTH 9may93jaw

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

\ INCLUDE 9may93jaw	\ INCLUDE 9may93jaw

: include ( "file" -- )	: include ( "file" -- )
bl word count included ;	name included ;

	: require ( "file" -- )
	name required ;

\ RECURSE 17may93jaw	\ RECURSE 17may93jaw

: recurse ( -- )	: recurse ( -- )
lastxt compile, ; immediate restrict	lastxt compile, ; immediate restrict
: recursive ( -- )	: recursive ( -- )
reveal ; immediate	reveal last off ; immediate

\ /MOD / 17may93jaw	\ /MOD / 17may93jaw

Line 1116 create nl$ 1 c, A c, 0 c, \ gnu includes	Line 1352 create nl$ 1 c, A c, 0 c, \ gnu includes
push-file dup #tib ! >tib @ swap move	push-file dup #tib ! >tib @ swap move
>in off blk off loadfile off -1 loadline !	>in off blk off loadfile off -1 loadline !

BEGIN interpret >in @ #tib @ u>= UNTIL	\ BEGIN interpret >in @ #tib @ u>= UNTIL
	['] interpret catch
pop-file ;	pop-file throw ;


: abort -1 throw ;	: abort -1 throw ;
Line 1136 Defer .status	Line 1372 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 -- )	: dec. ( n -- )
\ print value in decimal representation	\ print value in decimal representation
base @ decimal swap . base ! ;	base @ decimal swap . base ! ;

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

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 @	loadline @ IF
IF	source >in @ loadline @ 0 0 .error-frame
cr loadfilename 2@ type ." :" Loadline @ dec.	THEN
THEN	error-stack @ 0 ?DO
cr source type cr	-1 error-stack +!
source drop >in @ -trailing ( throw-code line-start index2 )	error-stack dup @ 6 * cells + cell+
here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )	6 cells bounds DO
typewhite	I @
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0	cell +LOOP
." ^"	.error-frame
loop	LOOP
dup -2 =	dup -2 =
IF	IF
"error @ ?dup	"error @ ?dup
IF	IF
cr count type	cr count type
THEN	THEN
drop	drop
ELSE	ELSE
.error	.error
THEN	THEN
normal-dp dpp ! ;	normal-dp dpp ! ;

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

Line 1195 DEFER DOERROR	Line 1460 DEFER DOERROR
\ : 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 ) -1 0 scan 0 swap 1+ /string ;
: arg ( n -- addr count ) cells argv @ + @ >len ;	: arg ( n -- addr count ) 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

0 Value script? ( -- flag )	0 Value script? ( -- flag )

: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ;	: process-path ( addr1 u1 -- addr2 u2 )
	\ addr1 u1 is a path string, addr2 u2 is an array of dir strings
	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 ! ;

: do-option ( addr1 len1 addr2 len2 -- n ) 2swap	Defer 'cold ' noop IS 'cold
2dup s" -e" compare 0= >r
2dup s" -evaluate" compare 0= r> or
IF 2drop ">tib interpret 2 EXIT THEN
." Unknown option: " type cr 2drop 1 ;

: process-args ( -- ) argc @ 1
?DO I arg over c@ [char] - <>
IF true to script? included false to script? 1
ELSE I 1+ arg do-option
THEN
+LOOP ;

: cold ( -- )	: cold ( -- )
	pathstring 2@ process-path pathdirs 2!
	0 0 included-files 2!
	'cold
argc @ 1 >	argc @ 1 >
IF	IF
	true to script?
['] process-args catch ?dup	['] process-args catch ?dup
IF	IF
dup >r DoError cr r> negate (bye)	dup >r DoError cr r> negate (bye)
THEN	THEN
	cr
THEN	THEN
cr	false to script?
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr	." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr	." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
." Type `bye' to exit"	." Type `bye' to exit"
quit ;	loadline off quit ;

: license ( -- ) cr	: license ( -- ) cr
." This program is free software; you can redistribute it and/or modify" cr	." This program is free software; you can redistribute it and/or modify" cr
Line 1249 Variable argc	Line 1554 Variable argc
." along with this program; if not, write to the Free Software" cr	." along with this program; if not, write to the Free Software" cr
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;	." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;

: boot ( env argv argc -- )	: boot ( path **argv argc -- )
argc ! argv ! env ! main-task up!	argc ! argv ! cstring>sstring pathstring 2! main-task up!
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;	sp@ dup s0 ! $10 + >tib ! #tib off >in off
	rp@ r0 ! fp@ f0 ! cold ;

: bye script? 0= IF cr THEN 0 (bye) ;	: bye script? 0= IF cr THEN 0 (bye) ;

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

Removed from v.1.14
changed lines
	Added in v.1.40