version 1.38, 1995/06/07 10:05:06
|
version 1.41, 1995/10/07 17:38:16
|
Line 31
|
Line 31
|
|
|
HEX |
HEX |
|
|
|
\ labels for some code addresses |
|
|
|
: docon: ( -- addr ) \ gforth |
|
\ the code address of a @code{CONSTANT} |
|
['] bl >code-address ; |
|
|
|
: docol: ( -- addr ) \ gforth |
|
\ the code address of a colon definition |
|
['] docon: >code-address ; |
|
|
|
: dovar: ( -- addr ) \ gforth |
|
\ the code address of a @code{CREATE}d word |
|
['] udp >code-address ; |
|
|
|
: douser: ( -- addr ) \ gforth |
|
\ the code address of a @code{USER} variable |
|
['] s0 >code-address ; |
|
|
|
: dodefer: ( -- addr ) \ gforth |
|
\ the code address of a @code{defer}ed word |
|
['] source >code-address ; |
|
|
|
: dofield: ( -- addr ) \ gforth |
|
\ the code address of a @code{field} |
|
['] reveal-method >code-address ; |
|
|
\ Bit string manipulation 06oct92py |
\ Bit string manipulation 06oct92py |
|
|
Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
Line 115 DOES> ( n -- ) + c@ ;
|
Line 141 DOES> ( n -- ) + c@ ;
|
\ input stream primitives 23feb93py |
\ input stream primitives 23feb93py |
|
|
: tib >tib @ ; |
: tib >tib @ ; |
Defer source |
Defer source \ used by dodefer:, must be defer |
: (source) ( -- addr count ) tib #tib @ ; |
: (source) ( -- addr count ) tib #tib @ ; |
' (source) IS source |
' (source) IS source |
|
|
Line 346 hex
|
Line 372 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 |
Line 734 Avariable leave-sp leave-stack 3 cells
|
Line 762 Avariable leave-sp leave-stack 3 cells
|
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
( 0 0 0 >leave ) ; immediate restrict |
( 0 0 0 >leave ) ; immediate restrict |
|
|
: ?DO ( -- do-sys ) |
: ?do-like ( -- do-sys ) |
( 0 0 0 >leave ) |
( 0 0 0 >leave ) |
POSTPONE (?do) |
|
>mark >leave |
>mark >leave |
POSTPONE begin drop do-dest ; immediate restrict |
POSTPONE begin drop do-dest ; |
|
|
|
: ?DO ( -- do-sys ) \ core-ext question-do |
|
POSTPONE (?do) ?do-like ; immediate restrict |
|
|
|
: +DO ( -- do-sys ) \ gforth plus-do |
|
POSTPONE (+do) ?do-like ; immediate restrict |
|
|
|
: U+DO ( -- do-sys ) \ gforth u-plus-do |
|
POSTPONE (u+do) ?do-like ; immediate restrict |
|
|
|
: -DO ( -- do-sys ) \ gforth minus-do |
|
POSTPONE (-do) ?do-like ; immediate restrict |
|
|
|
: U-DO ( -- do-sys ) \ gforth u-minus-do |
|
POSTPONE (u-do) ?do-like ; immediate restrict |
|
|
: FOR ( -- do-sys ) |
: FOR ( -- do-sys ) |
POSTPONE (for) |
POSTPONE (for) |
Line 751 Avariable leave-sp leave-stack 3 cells
|
Line 793 Avariable leave-sp leave-stack 3 cells
|
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
until-like POSTPONE done POSTPONE unloop ; |
until-like POSTPONE done POSTPONE unloop ; |
|
|
: LOOP ( do-sys -- ) |
: LOOP ( do-sys -- ) \ core |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
|
|
: +LOOP ( do-sys -- ) |
: +LOOP ( do-sys -- ) \ core plus-loop |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
|
|
|
\ !! should the compiler warn about +DO..-LOOP? |
|
: -LOOP ( do-sys -- ) \ gforth minus-loop |
|
['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict |
|
|
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ negative increments. |
\ negative increments. |
: S+LOOP ( do-sys -- ) |
: S+LOOP ( do-sys -- ) \ gforth s-plus-loop |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
|
|
: NEXT ( do-sys -- ) |
: NEXT ( do-sys -- ) |
Line 900 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 946 Create ??? 0 , 3 c, char ? c, char ? c,
|
cell +loop |
cell +loop |
drop ??? ( wouldn't 0 be better? ) ; |
drop ??? ( wouldn't 0 be better? ) ; |
|
|
\ indirect threading 17mar93py |
\ threading 17mar93py |
|
|
: cfa, ( code-address -- ) |
: cfa, ( code-address -- ) \ gforth |
here lastcfa ! |
here |
here 0 A, 0 , code-address! ; |
dup lastcfa ! |
: compile, ( xt -- ) A, ; |
0 A, 0 , code-address! ; |
: !does ( addr -- ) lastcfa @ does-code! ; |
: compile, ( xt -- ) \ core-ext |
: (;code) ( R: addr -- ) r> /does-handler + !does ; |
A, ; |
|
: !does ( addr -- ) lastxt does-code! ; |
|
: (does>) ( R: addr -- ) r> /does-handler + !does ; |
: dodoes, ( -- ) |
: dodoes, ( -- ) |
here /does-handler allot does-handler! ; |
here /does-handler allot does-handler! ; |
|
|
\ direct threading is implementation dependent |
: Create Header reveal dovar: cfa, ; |
|
|
: Create Header reveal [ :dovar ] Literal cfa, ; |
|
|
|
\ DOES> 17mar93py |
\ DOES> 17mar93py |
|
|
: DOES> ( compilation: -- ) |
: DOES> ( compilation: -- ) \ core |
state @ |
state @ |
IF |
IF |
;-hook postpone (;code) dodoes, |
;-hook postpone (does>) ?struc dodoes, |
ELSE |
ELSE |
dodoes, here !does 0 ] |
align dodoes, here !does ] |
THEN |
THEN |
:-hook ; immediate |
defstart :-hook ; immediate |
|
|
\ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
|
|
Line 936 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 982 Create ??? 0 , 3 c, char ? c, char ? c,
|
: User Variable ; |
: User Variable ; |
: AUser AVariable ; |
: AUser AVariable ; |
|
|
: (Constant) Header reveal [ :docon ] Literal cfa, ; |
: (Constant) Header reveal docon: cfa, ; |
: Constant (Constant) , ; |
: Constant (Constant) , ; |
: AConstant (Constant) A, ; |
: AConstant (Constant) A, ; |
|
|
Line 950 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 996 Create ??? 0 , 3 c, char ? c, char ? c,
|
|
|
: Defer ( -- ) |
: Defer ( -- ) |
\ !! shouldn't it be initialized with abort or something similar? |
\ !! shouldn't it be initialized with abort or something similar? |
Header Reveal [ :dodefer ] Literal cfa, |
Header Reveal dodefer: cfa, |
['] noop A, ; |
['] noop A, ; |
\ Create ( -- ) |
\ Create ( -- ) |
\ ['] noop A, |
\ ['] noop A, |
Line 976 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1022 Create ??? 0 , 3 c, char ? c, char ? c,
|
defer :-hook ( sys1 -- sys2 ) |
defer :-hook ( sys1 -- sys2 ) |
defer ;-hook ( sys2 -- sys1 ) |
defer ;-hook ( sys2 -- sys1 ) |
|
|
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; |
: : ( -- colon-sys ) Header docol: cfa, defstart ] :-hook ; |
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
immediate restrict |
immediate restrict |
|
|
: :noname ( -- xt colon-sys ) |
: :noname ( -- xt colon-sys ) |
0 last ! |
0 last ! |
here [ :docol ] Literal cfa, 0 ] :-hook ; |
here docol: cfa, 0 ] :-hook ; |
|
|
\ Search list handling 23feb93py |
\ Search list handling 23feb93py |
|
|
Line 990 AVariable current
|
Line 1036 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 |
|
|
Line 1006 AVariable current
|
Line 1052 AVariable current
|
|
|
struct |
struct |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
1 cells: field reveal-method \ xt: ( -- ) |
1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field |
1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field rehash-method \ xt: ( wid -- ) |
\ \ !! what else |
\ \ !! what else |
end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
Line 1096 Variable warnings G -1 warnings T !
|
Line 1142 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 ctrlkeys |
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 [ |
Line 1148 Defer key
|
Line 1195 Defer key
|
\ Query 07apr93py |
\ Query 07apr93py |
|
|
: refill ( -- flag ) |
: refill ( -- flag ) |
blk @ IF 1 blk +! true EXIT THEN |
blk @ IF 1 blk +! true 0 >in ! EXIT THEN |
tib /line |
tib /line |
loadfile @ ?dup |
loadfile @ ?dup |
IF read-line throw |
IF read-line throw |
Line 1334 create included-files 0 , 0 , ( pointer
|
Line 1381 create included-files 0 , 0 , ( pointer
|
: recurse ( -- ) |
: recurse ( -- ) |
lastxt compile, ; immediate restrict |
lastxt compile, ; immediate restrict |
: recursive ( -- ) |
: recursive ( -- ) |
reveal ; immediate |
reveal last off ; immediate |
|
|
\ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
|
|
Line 1503 Variable argc
|
Line 1550 Variable argc
|
|
|
: process-args ( -- ) |
: process-args ( -- ) |
>tib @ >r |
>tib @ >r |
true to script? |
|
argc @ 1 |
argc @ 1 |
?DO |
?DO |
I arg over c@ [char] - <> |
I arg over c@ [char] - <> |
IF |
IF |
required 1 |
required 1 |
ELSE |
ELSE |
I 1+ arg do-option |
I 1+ argc @ = IF s" " ELSE I 1+ arg THEN |
|
do-option |
THEN |
THEN |
+LOOP |
+LOOP |
false to script? |
|
r> >tib ! ; |
r> >tib ! ; |
|
|
Defer 'cold ' noop IS 'cold |
Defer 'cold ' noop IS 'cold |
Line 1524 Defer 'cold ' noop IS 'cold
|
Line 1570 Defer 'cold ' noop IS 'cold
|
'cold |
'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 " version-string type ." , 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" |