version 1.60, 1996/07/16 20:57:11
|
version 1.62, 1996/08/26 10:07:20
|
Line 160 $80 constant alias-mask \ set when the w
|
Line 160 $80 constant alias-mask \ set when the w
|
$40 constant immediate-mask |
$40 constant immediate-mask |
$20 constant restrict-mask |
$20 constant restrict-mask |
|
|
: (name>) ( nfa+cell -- cfa ) |
: ((name>)) ( nfa -- cfa ) |
1 cells - name>string + cfaligned ; |
name>string + cfaligned ; |
: name> ( nfa -- cfa ) \ gforth |
|
cell+ |
: (name>x) ( nfa -- cfa b ) |
dup (name>) swap c@ alias-mask and 0= IF @ THEN ; |
\ cfa is an intermediate cfa and b is the flags byte of nfa |
|
dup ((name>)) |
\ (find) 17dec92py |
swap cell+ c@ dup alias-mask and 0= |
|
IF |
\ : (find) ( addr count nfa1 -- nfa2 / false ) |
swap @ swap |
\ BEGIN dup WHILE dup >r |
THEN ; |
\ name>string dup >r 2over r> = |
|
\ IF -text 0= IF 2drop r> EXIT THEN |
|
\ ELSE 2drop drop THEN r> @ |
|
\ REPEAT nip nip ; |
|
|
|
\ place bounds 13feb93py |
\ place bounds 13feb93py |
|
|
Line 182 $20 constant restrict-mask
|
Line 178 $20 constant restrict-mask
|
: bounds ( beg count -- end beg ) \ gforth |
: bounds ( beg count -- end beg ) \ gforth |
over + swap ; |
over + swap ; |
|
|
|
: save-mem ( addr1 u -- addr2 u ) \ gforth |
|
\ copy a memory block into a newly allocated region in the heap |
|
swap >r |
|
dup allocate throw |
|
swap 2dup r> -rot move ; |
|
|
|
: extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
|
\ extend memory block allocated from the heap by u aus |
|
\ the (possibly reallocated piece is addr2 u2, the extension is at addr |
|
over >r + dup >r resize throw |
|
r> over r> + -rot ; |
|
|
\ input stream primitives 23feb93py |
\ input stream primitives 23feb93py |
|
|
: tib ( -- c-addr ) \ core-ext |
: tib ( -- c-addr ) \ core-ext |
Line 267 Defer source ( -- addr count ) \ core
|
Line 275 Defer source ( -- addr count ) \ core
|
|
|
: (compile) ( -- ) \ gforth |
: (compile) ( -- ) \ gforth |
r> dup cell+ >r @ compile, ; |
r> dup cell+ >r @ compile, ; |
: postpone ( "name" -- ) \ core |
|
name sfind dup 0= abort" Can't compile " |
|
0> IF compile, ELSE postpone (compile) A, THEN ; immediate restrict |
|
|
|
: special: ( interp comp "name" -- ) |
\ not the most efficient implementation of POSTPONE, but simple |
|
: POSTPONE ( -- ) \ core |
|
COMP' swap POSTPONE aliteral compile, ; immediate restrict |
|
|
|
: interpret/compile: ( interp-xt comp-xt "name" -- ) |
Create immediate swap A, A, |
Create immediate swap A, A, |
DOES> state @ IF cell+ THEN perform ; |
DOES> |
|
abort" executed primary cfa of an interpret/compile: word" ; |
|
\ state @ IF cell+ THEN perform ; |
|
|
\ Use (compile) for the old behavior of compile! |
\ Use (compile) for the old behavior of compile! |
|
|
Line 504 Defer interpreter-notfound ( c-addr coun
|
Line 515 Defer interpreter-notfound ( c-addr coun
|
' no.extensions IS compiler-notfound |
' no.extensions IS compiler-notfound |
' no.extensions IS interpreter-notfound |
' no.extensions IS interpreter-notfound |
|
|
: compile-only ( ... -- ) |
: compile-only-error ( ... -- ) |
-&14 throw ; |
-&14 throw ; |
Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt? |
|
' compile-only IS interpret-special |
|
|
|
: interpret ( ?? -- ?? ) \ gforth |
: interpret ( ?? -- ?? ) \ gforth |
\ interpret/compile the (rest of the) input buffer |
\ interpret/compile the (rest of the) input buffer |
Line 520 Defer interpret-special ( c-addr u xt --
|
Line 529 Defer interpret-special ( c-addr u xt --
|
|
|
\ interpreter compiler 30apr92py |
\ interpreter compiler 30apr92py |
|
|
: interpreter ( c-addr u -- ) \ gforth |
\ not the most efficient implementations of interpreter and compiler |
\ interpretation semantics for the name/number c-addr u |
: interpreter ( c-addr u -- ) |
2dup (sfind) dup |
2dup find-name dup |
IF |
if |
1 and |
nip nip name>int execute |
IF \ not restricted to compile state? |
else |
nip nip execute EXIT |
drop |
THEN |
2dup 2>r snumber? |
interpret-special exit |
|
THEN |
|
drop |
|
2dup 2>r snumber? |
|
IF |
|
2rdrop |
|
ELSE |
|
2r> interpreter-notfound |
|
THEN ; |
|
|
|
' interpreter IS parser |
|
|
|
: compiler ( c-addr u -- ) \ gforth |
|
\ compilation semantics for the name/number c-addr u |
|
2dup (sfind) dup |
|
IF |
|
0> |
|
IF |
IF |
nip nip execute EXIT |
2rdrop |
|
ELSE |
|
2r> interpreter-notfound |
THEN |
THEN |
compile, 2drop EXIT |
then ; |
THEN |
|
drop |
: compiler ( c-addr u -- ) |
2dup snumber? dup |
2dup find-name dup |
IF |
if ( c-addr u nfa ) |
0> |
nip nip name>comp execute |
|
else |
|
drop |
|
2dup snumber? dup |
IF |
IF |
swap postpone Literal |
0> |
|
IF |
|
swap postpone Literal |
|
THEN |
|
postpone Literal |
|
2drop |
|
ELSE |
|
drop compiler-notfound |
THEN |
THEN |
postpone Literal |
then ; |
2drop |
|
ELSE |
' interpreter IS parser |
drop compiler-notfound |
|
THEN ; |
|
|
|
: [ ( -- ) \ core left-bracket |
: [ ( -- ) \ core left-bracket |
['] interpreter IS parser state off ; immediate |
['] interpreter IS parser state off ; immediate |
Line 601 variable backedge-locals
|
Line 603 variable backedge-locals
|
0 backedge-locals ! ; immediate |
0 backedge-locals ! ; immediate |
|
|
: ASSUME-LIVE ( orig -- orig ) \ gforth |
: ASSUME-LIVE ( orig -- orig ) \ gforth |
\ used immediateliy before a BEGIN that is not reachable from |
\ used immediatly before a BEGIN that is not reachable from |
\ above. causes the BEGIN to assume that the same locals are live |
\ above. causes the BEGIN to assume that the same locals are live |
\ as at the orig point |
\ as at the orig point |
dup orig? |
dup orig? |
Line 639 variable backedge-locals
|
Line 641 variable backedge-locals
|
over 0<> |
over 0<> |
while |
while |
over |
over |
name> >body @ max |
((name>)) >body @ max |
swap @ swap ( get next ) |
swap @ swap ( get next ) |
repeat |
repeat |
faligned nip ; |
faligned nip ; |
Line 958 Avariable leave-sp leave-stack 3 cells
|
Line 960 Avariable leave-sp leave-stack 3 cells
|
: ," ( "string"<"> -- ) [char] " parse |
: ," ( "string"<"> -- ) [char] " parse |
here over char+ allot place align ; |
here over char+ allot place align ; |
: "lit ( -- addr ) |
: "lit ( -- addr ) |
r> r> dup count + aligned >r swap >r ; restrict |
r> r> dup count + aligned >r swap >r ; |
: (.") "lit count type ; restrict |
: (.") "lit count type ; |
: (S") "lit count ; restrict |
: (S") "lit count ; |
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
postpone (S") here over char+ allot place align ; |
postpone (S") here over char+ allot place align ; |
immediate restrict |
immediate restrict |
Line 1199 G forth-wordlist current T !
|
Line 1201 G forth-wordlist current T !
|
|
|
\ higher level parts of find |
\ higher level parts of find |
|
|
: special? ( xt -- flag ) |
( struct ) |
|
0 >body cell |
|
1 cells: field interpret/compile-int |
|
1 cells: field interpret/compile-comp |
|
end-struct interpret/compile-struct |
|
|
|
: interpret/compile? ( xt -- flag ) |
>does-code ['] S" >does-code = ; |
>does-code ['] S" >does-code = ; |
|
|
: xt>i ( xt -- xt ) |
: (cfa>int) ( cfa -- xt ) |
dup special? IF >body @ THEN ; |
dup interpret/compile? |
|
if |
|
interpret/compile-int @ |
|
then ; |
|
|
: xt>c ( xt -- xt ) |
: (x>int) ( cfa b -- xt ) |
dup special? IF >body cell+ @ THEN ; |
\ get interpretation semantics of name |
|
restrict-mask and |
|
if |
|
drop ['] compile-only-error |
|
else |
|
(cfa>int) |
|
then ; |
|
|
|
: name>int ( nfa -- xt ) \ gforth |
|
(name>x) (x>int) ; |
|
|
: xt>s ( xt -- xt ) |
: name?int ( nfa -- xt ) \ gforth |
dup special? IF >body state @ IF cell+ THEN @ THEN ; |
\ like name>int, but throws an error if compile-only |
|
(name>x) restrict-mask and |
|
if |
|
compile-only-error \ does not return |
|
then |
|
(cfa>int) ; |
|
|
: found ( nfa -- cfa n ) \ gforth |
: name>comp ( nfa -- w xt ) \ gforth |
cell+ dup c@ >r (name>) |
\ get compilation semantics of name |
r@ alias-mask and 0= IF @ THEN -1 |
(name>x) >r dup interpret/compile? |
r@ restrict-mask and IF 1- THEN |
if |
r> immediate-mask and IF negate THEN ; |
interpret/compile-comp @ |
|
then |
|
r> immediate-mask and if |
|
['] execute |
|
else |
|
['] compile, |
|
then ; |
|
|
: (search-wordlist) ( addr count wid -- nfa / false ) |
: (search-wordlist) ( addr count wid -- nfa / false ) |
dup wordlist-map @ find-method perform ; |
dup wordlist-map @ find-method perform ; |
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
: flag-sign ( f -- 1|-1 ) |
(search-wordlist) dup IF found swap xt>s swap THEN ; |
\ true becomes 1, false -1 |
|
0= 2* 1+ ; |
|
|
|
: (name>intn) ( nfa -- xt +-1 ) |
|
(name>x) tuck (x>int) ( b xt ) |
|
swap immediate-mask and flag-sign ; |
|
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
|
\ xt is the interpretation semantics |
|
(search-wordlist) dup if |
|
(name>intn) |
|
then ; |
|
|
: (sfind) ( c-addr u -- xt n / 0 ) |
: find-name ( c-addr u -- nfa/0 ) |
lookup @ (search-wordlist) dup IF found THEN ; |
lookup @ (search-wordlist) ; |
|
|
: sfind ( c-addr u -- xt n / 0 ) \ gforth |
: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete |
lookup @ search-wordlist ; |
find-name dup |
|
if ( nfa ) |
|
state @ |
|
if |
|
name>comp ['] execute = flag-sign |
|
else |
|
(name>intn) |
|
then |
|
then ; |
|
|
: find ( addr -- cfa +-1 / string false ) \ core,search |
: find ( c-addr -- xt +-1 / c-addr 0 ) \ core |
dup count sfind dup IF |
dup count sfind dup |
|
if |
rot drop |
rot drop |
THEN |
then ; |
dup 1 and 0= IF 2/ THEN ; |
|
|
|
: (') ( "name" -- xt ) \ gforth paren-tick |
: (') ( "name" -- nfa ) \ gforth |
name (sfind) 0= IF -&13 bounce THEN ; |
name find-name dup 0= |
: [(')] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-paren-tick |
IF |
|
drop -&13 bounce |
|
THEN ; |
|
|
|
: [(')] ( compilation "name" -- ; run-time -- nfa ) \ gforth bracket-paren-tick |
(') postpone ALiteral ; immediate restrict |
(') postpone ALiteral ; immediate restrict |
|
|
: ' ( "name" -- xt ) \ core tick |
: ' ( "name" -- xt ) \ core tick |
(') xt>i ; |
(') name?int ; |
: ['] ( compilation "name" -- ; run-time -- addr ) \ core bracket-tick |
: ['] ( compilation "name" -- ; run-time -- xt ) \ core bracket-tick |
' postpone ALiteral ; immediate restrict |
' postpone ALiteral ; immediate restrict |
|
|
: C' ( "name" -- xt ) \ gforth c-tick |
: COMP' ( "name" -- w xt ) \ gforth c-tick |
(') xt>c ; |
(') name>comp ; |
: [C'] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-c-tick |
: [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick |
C' postpone ALiteral ; immediate restrict |
COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict |
|
|
: S' ( "name" -- xt ) \ gforth s-tick |
|
(') xt>s ; |
|
: [S'] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-s-tick |
|
S' postpone ALiteral ; immediate restrict |
|
|
|
\ reveal words |
\ reveal words |
|
|
Line 1519 create image-included-files 1 , A, ( po
|
Line 1568 create image-included-files 1 , A, ( po
|
loadline @ ; |
loadline @ ; |
|
|
: init-included-files ( -- ) |
: init-included-files ( -- ) |
image-included-files 2@ 2* cells save-string drop ( addr ) |
image-included-files 2@ 2* cells save-mem drop ( addr ) |
image-included-files 2@ nip included-files 2! ; |
image-included-files 2@ nip included-files 2! ; |
|
|
: included? ( c-addr u -- f ) \ gforth |
: included? ( c-addr u -- f ) \ gforth |
Line 1537 create image-included-files 1 , A, ( po
|
Line 1586 create image-included-files 1 , A, ( po
|
|
|
: add-included-file ( c-addr u -- ) \ gforth |
: add-included-file ( c-addr u -- ) \ gforth |
\ add name c-addr u to included-files |
\ add name c-addr u to included-files |
included-files 2@ tuck 1+ 2* cells resize throw |
included-files 2@ 2* cells 2 cells extend-mem |
swap 2dup 1+ included-files 2! |
2/ cell / included-files 2! |
2* cells + 2! ; |
2! ; |
|
\ included-files 2@ tuck 1+ 2* cells resize throw |
: save-string ( addr1 u -- addr2 u ) \ gforth |
\ swap 2dup 1+ included-files 2! |
\ !! not a string, but a memblock word |
\ 2* cells + 2! ; |
swap >r |
|
dup allocate throw |
|
swap 2dup r> -rot move ; |
|
|
|
: included1 ( i*x file-id c-addr u -- j*x ) \ gforth |
: included1 ( i*x file-id c-addr u -- j*x ) \ gforth |
\ include the file file-id with the name given by c-addr u |
\ include the file file-id with the name given by c-addr u |
loadfilename# @ >r |
loadfilename# @ >r |
save-string add-included-file ( file-id ) |
save-mem add-included-file ( file-id ) |
included-files 2@ nip 1- loadfilename# ! |
included-files 2@ nip 1- loadfilename# ! |
['] include-file catch |
['] include-file catch |
r> loadfilename# ! |
r> loadfilename# ! |
Line 1650 max-errors 6 * cells allot
|
Line 1696 max-errors 6 * cells allot
|
\ print value in decimal representation |
\ print value in decimal representation |
base @ decimal swap . base ! ; |
base @ decimal swap . base ! ; |
|
|
|
: hex. ( u -- ) \ gforth |
|
\ print value as unsigned hex number |
|
'$ emit base @ swap hex u. base ! ; |
|
|
: typewhite ( addr u -- ) \ gforth |
: typewhite ( addr u -- ) \ gforth |
\ like type, but white space is printed instead of the characters |
\ like type, but white space is printed instead of the characters |
bounds ?do |
bounds ?do |