version 1.40, 1995/09/06 21:00:21
|
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 736 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 753 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 902 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 938 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 952 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 978 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 1008 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 |