version 1.82, 2002/12/26 19:16:17
|
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 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 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 |
|
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 over swap r> scan >r |
>r source >in @ over min /string ( c-addr1 u1 ) |
over - dup r> IF 1+ THEN >in +! ; |
over swap r> scan >r |
|
over - dup r> IF 1+ THEN >in +! |
|
[ has? new-input [IF] ] |
|
2dup input-lexeme! |
|
[ [THEN] ] ; |
|
|
\ name 13feb93py |
\ name 13feb93py |
|
|
Line 89 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) |
|
[ 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 101 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 10 , 2 , A , 100 , |
const Create bases 0A , 10 , 2 , 0A , |
\ 16 2 10 character |
\ 10 16 2 10 |
|
|
\ !! protect BASE saving wrapper against exceptions |
\ !! protect BASE saving wrapper against exceptions |
: getbase ( addr u -- addr' u' ) |
: getbase ( addr u -- addr' u' ) |
over c@ [char] $ - dup 4 u< |
2dup s" 0x" string-prefix? >r |
|
2dup s" 0X" string-prefix? r> or |
|
base @ &34 < and if |
|
hex 2 /string |
|
endif |
|
over c@ [char] # - dup 4 u< |
IF |
IF |
cells bases + @ base ! 1 /string |
cells bases + @ base ! 1 /string |
ELSE |
ELSE |
drop |
drop |
THEN ; |
THEN ; |
|
|
: sign? ( addr u -- addr u flag ) |
: sign? ( addr u -- addr1 u1 flag ) |
over c@ [char] - = dup >r |
over c@ [char] - = dup >r |
IF |
IF |
1 /string |
1 /string |
THEN |
THEN |
r> ; |
r> ; |
|
|
: s>unumber? ( addr u -- ud flag ) |
: ?dnegate ( d1 f -- d2 ) |
base @ >r dpl on getbase |
if |
0. 2swap |
dnegate |
BEGIN ( d addr len ) |
then ; |
dup >r >number dup |
|
WHILE \ there are characters left |
has? os 0= [IF] |
dup r> - |
: x@+/string ( addr u -- addr' u' c ) |
WHILE \ the last >number parsed something |
over c@ >r 1 /string r> ; |
dup 1- dpl ! over c@ [char] . = |
[THEN] |
WHILE \ the current char is '.' |
|
1 /string |
: s'>unumber? ( addr u -- ud flag ) |
REPEAT THEN \ there are unparseable characters left |
\ convert string "C" or "C'" to character code |
2drop false |
dup 0= if |
|
false exit |
|
endif |
|
x@+/string 0 s" '" 2rot string-prefix? ; |
|
|
|
: s>unumber? ( c-addr u -- ud flag ) \ gforth |
|
\G converts string c-addr u into ud, flag indicates success |
|
dpl on |
|
over c@ '' = if |
|
1 /string s'>unumber? exit |
|
endif |
|
base @ >r getbase sign? |
|
over if |
|
>r 0. 2swap |
|
BEGIN ( d addr len ) |
|
dup >r >number dup |
|
WHILE \ there are characters left |
|
dup r> - |
|
WHILE \ the last >number parsed something |
|
dup 1- dpl ! over c@ dp-char @ = |
|
WHILE \ the current char is '.' |
|
1 /string |
|
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 |
: s>number? ( addr len -- d f ) |
: s>number? ( addr u -- d f ) \ gforth |
\ converts string addr len into d, flag indicates success |
\G converts string addr u into d, flag indicates success |
sign? >r |
sign? >r |
s>unumber? |
s>unumber? |
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 171 const Create bases 10 , 2 , A , 10
|
Line 182 const Create bases 10 , 2 , A , 10
|
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 179 const Create bases 10 , 2 , A , 10
|
Line 190 const Create bases 10 , 2 , A , 10
|
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 210 const Create bases 10 , 2 , A , 10
|
Line 221 const Create bases 10 , 2 , A , 10
|
\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 229 struct
|
Line 247 struct
|
cell% field wordlist-extend \ wordlist extensions (eg bucket offset) |
cell% field wordlist-extend \ wordlist extensions (eg bucket offset) |
end-struct wordlist-struct |
end-struct wordlist-struct |
|
|
|
has? f83headerstring [IF] |
|
: f83find ( addr len wordlist -- nt / false ) |
|
wordlist-id @ (f83find) ; |
|
[ELSE] |
: f83find ( addr len wordlist -- nt / false ) |
: f83find ( addr len wordlist -- nt / false ) |
wordlist-id @ (listlfind) ; |
wordlist-id @ (listlfind) ; |
|
[THEN] |
|
|
: initvoc ( wid -- ) |
: initvoc ( wid -- ) |
dup wordlist-map @ hash-method perform ; |
dup wordlist-map @ hash-method perform ; |
Line 239 end-struct wordlist-struct
|
Line 262 end-struct wordlist-struct
|
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 255 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 |
\ and overwritten by the right ones |
\ and overwritten by the right ones |
|
|
|
has? f83headerstring [IF] |
|
\ to save space, Gforth EC limits words to 31 characters |
|
\ also, there's no predule concept in Gforth EC |
|
$80 constant alias-mask |
|
$40 constant immediate-mask |
|
$20 constant restrict-mask |
|
$1f constant lcount-mask |
|
[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 272 $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] |
|
|
\ higher level parts of find |
\ higher level parts of find |
|
|
Line 286 $1fffffff constant lcount-mask
|
Line 346 $1fffffff constant lcount-mask
|
: ticking-compile-only-error ( ... -- ) |
: ticking-compile-only-error ( ... -- ) |
-&2048 throw ; |
-&2048 throw ; |
|
|
|
: compile-only-error ( ... -- ) |
|
-&14 throw ; |
|
|
: (cfa>int) ( cfa -- xt ) |
: (cfa>int) ( cfa -- xt ) |
[ has? compiler [IF] ] |
[ has? compiler [IF] ] |
dup interpret/compile? |
dup interpret/compile? |
Line 296 $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 ['] ticking-compile-only-error |
drop ['] compile-only-error |
else |
else |
(cfa>int) |
(cfa>int) |
then ; |
then ; |
|
|
: name>string ( nt -- addr count ) \ gforth head-to-string |
has? f83headerstring [IF] |
|
: name>string ( nt -- addr count ) \ gforth name-to-string |
|
\g @i{addr count} is the name of the word represented by @i{nt}. |
|
cell+ count lcount-mask and ; |
|
|
|
: ((name>)) ( nfa -- cfa ) |
|
name>string + cfaligned ; |
|
|
|
: (name>x) ( nfa -- cfa w ) |
|
\ cfa is an intermediate cfa and w is the flags cell of nfa |
|
dup ((name>)) |
|
swap cell+ c@ dup alias-mask and 0= |
|
IF |
|
swap @ swap |
|
THEN ; |
|
[ELSE] |
|
: 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 317 $1fffffff constant lcount-mask
|
Line 396 $1fffffff constant lcount-mask
|
IF |
IF |
swap @ swap |
swap @ swap |
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 343 $1fffffff constant lcount-mask
|
Line 423 $1fffffff constant lcount-mask
|
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 357 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 367 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; finds only names with up to 32 chars |
\ also heuristic |
$25 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 |
[ELSE] -1 1 cells 1- times c, [THEN] ] |
[ELSE] -1 1 cells 1- times c, [THEN] ] |
and ( cfa len|alias ) |
and ( cfa len|alias ) |
swap + cell + cfaligned over alias-mask + = |
swap + cell+ cfaligned over alias-mask + = |
if ( cfa ) |
if ( cfa ) |
dup i - cell - dup head? |
dup i - cell - dup head? |
if |
if |
Line 419 const Create ??? 0 , 3 , char ? c, char
|
Line 534 const Create ??? 0 , 3 , char ? c, char
|
|
|
[THEN] |
[THEN] |
|
|
: body> 0 >body - ; |
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 address of the word's data field). |
|
drop drop |
|
|
|
cell% -2 * 0 0 field body> ( xt -- a_addr ) |
|
drop drop |
|
|
|
has? standardthreading has? compiler and [IF] |
|
|
|
' @ alias >code-address ( xt -- c_addr ) \ gforth |
|
\G @i{c-addr} is the code address of the word @i{xt}. |
|
|
|
: >does-code ( xt -- a_addr ) \ gforth |
|
\G If @i{xt} is the execution token of a child of a @code{DOES>} word, |
|
\G @i{a-addr} is the start of the Forth code after the @code{DOES>}; |
|
\G Otherwise @i{a-addr} is 0. |
|
dup @ dodoes: = if |
|
cell+ @ |
|
else |
|
drop 0 |
|
endif ; |
|
|
: (search-wordlist) ( addr count wid -- nt | false ) |
has? prims [IF] |
dup wordlist-map @ find-method perform ; |
: flash! ! ; |
|
: flashc! c! ; |
|
[THEN] |
|
|
: search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search |
has? flash [IF] ' flash! [ELSE] ' ! [THEN] |
\G Search the word list identified by @i{wid} for the definition |
alias code-address! ( c_addr xt -- ) \ gforth |
\G named by the string at @i{c-addr count}. If the definition is |
\G Create a code field with code address @i{c-addr} at @i{xt}. |
\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 |
: any-code! ( a-addr cfa code-addr -- ) |
\G immediate) together with the @i{xt}. In Gforth, the @i{xt} |
\ for implementing DOES> and ;ABI-CODE, maybe : |
\G returned represents the interpretation semantics. ANS Forth |
\ code-address is stored at cfa, a-addr at cfa+cell |
\G does not specify clearly what @i{xt} represents. |
over ! cell+ ! ; |
(search-wordlist) dup if |
|
(name>intn) |
: does-code! ( a-addr xt -- ) \ gforth |
then ; |
\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>}. |
|
[ has? flash [IF] ] |
|
dodoes: over flash! cell+ flash! |
|
[ [ELSE] ] |
|
dodoes: any-code! |
|
[ [THEN] ] ; |
|
|
: find-name ( c-addr u -- nt | 0 ) \ gforth |
2 cells constant /does-handler ( -- n ) \ gforth |
\g Find the name @i{c-addr u} in the current search |
\G The size of a @code{DOES>}-handler (includes possible padding). |
\g order. Return its @i{nt}, if found, otherwise 0. |
|
lookup @ (search-wordlist) ; |
[THEN] |
|
|
: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete |
: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete |
find-name dup |
find-name dup |
Line 477 const Create ??? 0 , 3 , char ? c, char
|
Line 621 const Create ??? 0 , 3 , char ? c, char
|
\ 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 500 has? compiler 0= [IF] \ interpreter only
|
Line 644 has? compiler 0= [IF] \ interpreter only
|
|
|
\ interpret 10mar92py |
\ interpret 10mar92py |
|
|
Defer parser ( c-addr u -- ) |
Defer parser1 ( c-addr u -- ... xt) |
Defer parse-word ( -- c-addr count ) \ gforth |
\ "... xt" is the action to be performed by the text-interpretation of c-addr u |
\G Get the next word from the input buffer |
|
' (name) IS parse-word |
|
|
|
' parse-word alias name ( -- c-addr u ) \ gforth-obsolete |
|
\G old name for @code{parse-word} |
|
|
|
Defer compiler-notfound ( c-addr count -- ) |
: parser ( c-addr u -- ... ) |
Defer interpreter-notfound ( c-addr count -- ) |
\ text-interpret the word/number c-addr u, possibly producing a number |
|
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 |
|
\G Get the next word from the input buffer |
|
' (name) IS parse-name |
|
|
|
' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete |
|
\G old name for @code{parse-name} |
|
|
|
' parse-name alias name ( -- c-addr u ) \ gforth-obsolete |
|
\G old name for @code{parse-name} |
|
|
: no.extensions ( addr u -- ) |
: no.extensions ( addr u -- ) |
2drop -&13 throw ; |
2drop -&13 throw ; |
' no.extensions IS compiler-notfound |
|
' no.extensions IS interpreter-notfound |
|
|
|
|
has? recognizer 0= [IF] |
|
Defer compiler-notfound1 ( c-addr count -- ... xt ) |
|
Defer interpreter-notfound1 ( c-addr count -- ... xt ) |
|
|
|
' no.extensions IS compiler-notfound1 |
|
' no.extensions IS interpreter-notfound1 |
|
[THEN] |
|
|
|
Defer before-word ( -- ) \ gforth |
|
\ called before the text interpreter parses the next 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 name dup |
?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup |
WHILE |
WHILE |
parser |
parser1 execute |
REPEAT |
REPEAT |
2drop ; |
2drop ; |
|
|
: 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 |
: interpreter ( c-addr u -- ) |
: 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 execute |
nip nip name>int |
else |
else |
drop |
drop |
2dup 2>r snumber? |
2dup 2>r snumber? |
IF |
IF |
2rdrop |
2rdrop ['] noop |
ELSE |
ELSE |
2r> interpreter-notfound |
2r> interpreter-notfound1 |
THEN |
THEN |
then ; |
then ; |
|
|
' interpreter IS parser |
' interpreter1 IS parser1 |
|
[THEN] |
|
|
\ \ Query Evaluate 07apr93py |
\ \ Query Evaluate 07apr93py |
|
|
Line 569 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 584 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 0 >in ! EXIT THEN |
blk @ IF 1 blk +! true EXIT THEN |
[ [THEN] ] |
[ [THEN] ] |
tib /line |
tib /line |
[ has? file [IF] ] |
[ has? file [IF] ] |
Line 593 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 ! 0 >in ! ; |
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 632 has? os [IF]
|
Line 821 has? os [IF]
|
|
|
: extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
: extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
\ extend memory block allocated from the heap by u aus |
\ extend memory block allocated from the heap by u aus |
\ the (possibly reallocated piece is addr2 u2, the extension is at addr |
\ the (possibly reallocated) piece is addr2 u2, the extension is at addr |
over >r + dup >r resize throw |
over >r + dup >r resize throw |
r> over r> + -rot ; |
r> over r> + -rot ; |
[THEN] |
[THEN] |
Line 658 has? new-input 0= [IF]
|
Line 847 has? new-input 0= [IF]
|
\G and input buffer. Interpret. When the parse area is empty, |
\G and input buffer. Interpret. When the parse area is empty, |
\G restore the input source specification. |
\G restore the input source specification. |
[ has? file [IF] ] |
[ has? file [IF] ] |
loadfilename# @ >r |
s" *evaluated string*" loadfilename>r |
1 loadfilename# ! \ "*evaluated string*" |
|
[ [THEN] ] |
[ [THEN] ] |
push-file #tib ! >tib ! |
push-file #tib ! >tib ! |
>in off |
input-start-line |
[ has? file [IF] ] |
[ has? file [IF] ] |
blk off loadfile off -1 loadline ! |
blk off loadfile off -1 loadline ! |
[ [THEN] ] |
[ [THEN] ] |
['] interpret catch |
['] interpret catch |
pop-file |
pop-file |
[ has? file [IF] ] |
[ has? file [IF] ] |
r> loadfilename# ! |
r>loadfilename |
[ [THEN] ] |
[ [THEN] ] |
throw ; |
throw ; |
[THEN] |
[THEN] |
Line 678 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. |
\ sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer |
|
\ stored in the system's CATCH frame, so the stack depth will be 0 |
|
\ after the next THROW it catches (it may be off due to BOUNCEs or |
|
\ because process-args left something on the stack) |
|
BEGIN |
BEGIN |
.status cr query interpret prompt |
[ has? ec [IF] ] cr [ [ELSE] ] |
AGAIN ; |
.status ['] cr catch if |
|
[ has? OS [IF] ] >stderr [ [THEN] ] |
|
cr ." Can't print to stdout, leaving" cr |
|
\ if stderr does not work either, already DoError causes a hang |
|
-2 (bye) |
|
endif [ [THEN] ] |
|
refill WHILE |
|
interpret prompt |
|
REPEAT |
|
bye ; |
|
|
' (quit) IS 'quit |
' (quit) IS 'quit |
|
|
\ \ DOERROR (DOERROR) 13jun93jaw |
\ \ DOERROR (DOERROR) 13jun93jaw |
|
|
|
has? os [IF] |
8 Constant max-errors |
8 Constant max-errors |
|
5 has? file 2 and + Constant /error |
Variable error-stack 0 error-stack ! |
Variable error-stack 0 error-stack ! |
max-errors has? file [IF] 6 [ELSE] 4 [THEN] * cells allot |
max-errors /error * cells allot |
\ format of one cell: |
\ format of one cell: |
\ source ( addr u ) |
\ source ( c-addr u ) |
\ >in |
\ last parsed lexeme ( c-addr u ) |
\ line-number |
\ line-number |
\ Loadfilename ( addr u ) |
\ Loadfilename ( addr u ) |
|
|
: error> ( -- addr u >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 @ |
[ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+ |
/error * cells + cell+ |
[ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO |
/error cells bounds DO |
I @ |
I @ |
cell +LOOP ; |
cell +LOOP ; |
: >error ( addr u >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 ! |
[ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+ |
/error * cells + cell+ |
[ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO |
/error 1- cells bounds swap DO |
I ! |
I ! |
-1 cells +LOOP ; |
-1 cells +LOOP ; |
|
|
|
: input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) |
|
\ error data for the current input, to be used by >error or .error-frame |
|
source over >r save-mem over r> - |
|
input-lexeme 2@ >r + r> sourceline# |
|
[ has? file [IF] ] sourcefilename [ [THEN] ] ; |
|
|
: dec. ( n -- ) \ gforth |
: dec. ( n -- ) \ gforth |
\G Display @i{n} as a signed decimal number, followed by a space. |
\G Display @i{n} as a signed decimal number, followed by a space. |
\ !! not used... |
\ !! not used... |
base @ decimal swap . base ! ; |
base @ decimal swap . base ! ; |
|
|
: dec.r ( u -- ) \ gforth |
: dec.r ( u n -- ) \ gforth |
\G Display @i{u} as a unsigned decimal number |
\G Display @i{u} as a unsigned decimal number in a field @i{n} |
base @ decimal swap 0 .r base ! ; |
\G characters wide. |
|
base @ >r decimal .r r> base ! ; |
|
|
: hex. ( u -- ) \ gforth |
: hex. ( u -- ) \ gforth |
\G Display @i{u} as an unsigned hex number, prefixed with a "$" and |
\G Display @i{u} as an unsigned hex number, prefixed with a "$" and |
Line 735 max-errors has? file [IF] 6 [ELSE] 4 [TH
|
Line 947 max-errors has? file [IF] 6 [ELSE] 4 [TH
|
\ !! not used... |
\ !! not used... |
[char] $ emit base @ swap hex u. base ! ; |
[char] $ emit base @ swap hex u. base ! ; |
|
|
: typewhite ( addr u -- ) \ gforth |
: -trailing ( c_addr u1 -- c_addr u2 ) \ string dash-trailing |
\G Like type, but white space is printed instead of the characters. |
\G Adjust the string specified by @i{c-addr, u1} to remove all |
bounds ?do |
\G trailing spaces. @i{u2} is the length of the modified string. |
i c@ #tab = if \ check for tab |
BEGIN |
#tab |
dup |
else |
WHILE |
bl |
1- 2dup + c@ bl <> |
then |
UNTIL 1+ THEN ; |
emit |
|
loop ; |
|
|
|
DEFER DOERROR |
DEFER DOERROR |
|
|
Line 759 Defer dobacktrace ( -- )
|
Line 969 Defer dobacktrace ( -- )
|
ELSE .error |
ELSE .error |
THEN ; |
THEN ; |
|
|
: .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode ) |
[IFUNDEF] umin |
\ addr2 u2: filename of included file - optional |
: umin ( u1 u2 -- u ) |
\ n2: line number |
2dup u> |
\ n1: error position in input line |
if |
\ addr1 u1: input line |
swap |
cr error-stack @ |
then |
IF |
drop ; |
[ has? file [IF] ] |
[THEN] |
." in file included from " |
|
type ." :" |
Defer mark-start |
[ [THEN] ] |
Defer mark-end |
dec.r drop 2drop |
|
ELSE |
:noname ." >>>" ; IS mark-start |
[ has? file [IF] ] |
:noname ." <<<" ; IS mark-end |
type ." :" |
|
[ [THEN] ] |
: part-type ( addr1 u1 u -- addr2 u2 ) |
dup >r dec.r ." : " 3 pick .error-string |
\ print first u characters of addr1 u1, addr2 u2 is the rest |
r> IF \ if line# non-zero, there is a line |
over umin 2 pick over type /string ; |
cr dup 2over type cr drop |
|
nip -trailing 1- ( line-start index2 ) |
: .error-line ( c-addr1 u1 c-addr2 u2 -- ) |
0 >r BEGIN |
\ print error in line c-addr1 u1, where the error-causing lexeme |
2dup + c@ bl > WHILE |
\ is c-addr2 u2 |
r> 1+ >r 1- dup 0< UNTIL THEN 1+ |
>r 2 pick - part-type ( c-addr3 u3 R: u2 ) |
( line-start index1 ) |
mark-start r> part-type mark-end ( c-addr4 u4 ) |
typewhite |
type ; |
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 |
|
[char] ^ emit |
: .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode ) |
loop |
\ addr3 u3: filename of included file - optional |
ELSE |
\ n2: line number |
2drop drop |
\ addr2 u2: parsed lexeme (should be marked as causing the error) |
THEN |
\ addr1 u1: input line |
THEN ; |
error-stack @ |
|
IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] ) |
|
[ has? file [IF] ] \ !! unbalanced stack effect |
|
over IF |
|
cr ." in file included from " |
|
type ." :" |
|
0 dec.r 2drop 2drop |
|
ELSE |
|
2drop 2drop 2drop drop |
|
THEN |
|
[ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 ) |
|
ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] ) |
|
[ has? file [IF] ] |
|
cr type ." :" |
|
[ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 ) |
|
dup 0 dec.r ." : " 5 pick .error-string |
|
IF \ if line# non-zero, there is a line |
|
cr .error-line |
|
ELSE |
|
2drop 2drop |
|
THEN |
|
THEN ; |
|
|
: (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
[ has? os [IF] ] |
[ has? os [IF] ] |
>stderr |
>stderr |
[ [THEN] ] |
[ [THEN] ] |
source >in @ sourceline# [ has? file [IF] ] |
input-error-data .error-frame |
sourcefilename |
|
[ [THEN] ] .error-frame |
|
error-stack @ 0 ?DO |
error-stack @ 0 ?DO |
error> |
error> |
.error-frame |
.error-frame |
Line 811 Defer dobacktrace ( -- )
|
Line 1040 Defer dobacktrace ( -- )
|
|
|
' (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 819 Defer dobacktrace ( -- )
|
Line 1056 Defer dobacktrace ( -- )
|
[ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ] |
[ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ] |
BEGIN |
BEGIN |
[ has? compiler [IF] ] |
[ has? compiler [IF] ] |
[compile] [ |
[compile] [ |
[ [THEN] ] |
[ [THEN] ] |
|
\ stack depths may be arbitrary here |
['] 'quit CATCH dup |
['] 'quit CATCH dup |
WHILE |
WHILE |
<# \ reset hold area, or we may get another error |
<# \ reset hold area, or we may get another error |
DoError |
DoError |
[ has? new-input [IF] ] clear-tibstack |
\ stack depths may be arbitrary still (or again), so clear them |
[ [ELSE] ] r@ >tib ! r@ tibstack ! |
clearstacks |
[ [THEN] ] |
[ has? new-input [IF] ] clear-tibstack |
|
[ [ELSE] ] r@ >tib ! r@ tibstack ! |
|
[ [THEN] ] |
REPEAT |
REPEAT |
drop [ has? new-input [IF] ] clear-tibstack |
drop [ has? new-input [IF] ] clear-tibstack |
[ [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-2000 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 863 AVariable init8 NIL init8 !
|
Line 1116 AVariable init8 NIL init8 !
|
[ has? file [IF] ] |
[ has? file [IF] ] |
os-cold |
os-cold |
[ [THEN] ] |
[ [THEN] ] |
|
[ has? os [IF] ] |
|
set-encoding-fixed-width |
'cold |
'cold |
init8 chainperform |
[ [THEN] ] |
[ has? file [IF] ] |
[ has? file [IF] ] |
loadfilename# off |
|
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 881 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 >in off ; |
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] ] |
primtable prepare-peephole-table TO peeptable |
\ only needed for greedy static superinstruction selection |
|
\ primtable prepare-peephole-table TO peeptable |
[ [THEN] ] |
[ [THEN] ] |
[ has? new-input [IF] ] |
[ has? new-input [IF] ] |
current-input off |
current-input off |
[ [THEN] ] |
[ [THEN] ] |
clear-tibstack |
clear-tibstack |
|
0 0 includefilename 2! |
rp@ rp0 ! |
rp@ rp0 ! |
[ has? floating [IF] ] |
[ has? floating [IF] ] |
fp@ fp0 ! |
fp@ fp0 ! |
[ [THEN] ] |
[ [THEN] ] |
|
[ has? os [IF] ] |
handler off |
handler off |
['] cold catch DoError cr |
['] cold catch dup -&2049 <> if \ broken pipe? |
|
DoError cr |
|
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] ] |
; |
; |
|
|