version 1.50, 1996/01/07 17:22:12
|
version 1.58, 1996/05/09 18:13:02
|
Line 76 HEX
|
Line 76 HEX
|
|
|
\ 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, |
DOES> ( n -- ) + c@ ; |
\ DOES> ( n -- ) + c@ ; |
|
|
: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; |
\ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; |
: +bit ( addr n -- ) >bit over c@ or swap c! ; |
\ : +bit ( addr n -- ) >bit over c@ or swap c! ; |
|
|
: relinfo ( -- addr ) forthstart dup @ + ; |
\ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ; |
: >rel ( addr -- n ) forthstart - ; |
\ : >rel ( addr -- n ) forthstart - ; |
: relon ( addr -- ) relinfo swap >rel cell / +bit ; |
\ : relon ( addr -- ) relinfo swap >rel cell / +bit ; |
|
|
\ here allot , c, A, 17dec92py |
\ here allot , c, A, 17dec92py |
|
|
Line 128 DOES> ( n -- ) + c@ ;
|
Line 128 DOES> ( n -- ) + c@ ;
|
; immediate |
; immediate |
|
|
|
|
: A! ( addr1 addr2 -- ) \ gforth |
\ : A! ( addr1 addr2 -- ) \ gforth |
dup relon ! ; |
\ dup relon ! ; |
: A, ( addr -- ) \ gforth |
\ : A, ( addr -- ) \ gforth |
here cell allot A! ; |
\ here cell allot A! ; |
|
' ! alias A! ( addr1 addr2 -- ) \ gforth |
|
' , alias A, ( addr -- ) \ gforth |
|
|
|
|
\ on off 23feb93py |
\ on off 23feb93py |
|
|
Line 244 Defer source ( -- addr count ) \ core
|
Line 247 Defer source ( -- addr count ) \ core
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
: Literal ( compilation n -- ; run-time -- n ) \ core |
: Literal ( compilation n -- ; run-time -- n ) \ core |
state @ IF postpone lit , THEN ; immediate |
postpone lit , ; immediate restrict |
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth |
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth |
state @ IF postpone lit A, THEN ; |
postpone lit A, ; immediate restrict |
immediate |
|
|
|
: char ( 'char' -- n ) \ core |
: char ( 'char' -- n ) \ core |
bl word char+ c@ ; |
bl word char+ c@ ; |
: [char] ( compilation 'char' -- ; run-time -- n ) |
: [char] ( compilation 'char' -- ; run-time -- n ) |
char postpone Literal ; immediate |
char postpone Literal ; immediate restrict |
' [char] Alias Ascii immediate |
|
|
|
: (compile) ( -- ) \ gforth |
: (compile) ( -- ) \ gforth |
r> dup cell+ >r @ compile, ; |
r> dup cell+ >r @ compile, ; |
Line 450 hex
|
Line 451 hex
|
|
|
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
?DUP IF |
?DUP IF |
[ here 4 cells ! ] |
[ here 9 cells ! ] |
handler @ rp! |
handler @ rp! |
r> handler ! |
r> handler ! |
r> lp! |
r> lp! |
Line 489 Defer notfound ( c-addr count -- )
|
Line 490 Defer notfound ( c-addr count -- )
|
2drop -&13 bounce ; |
2drop -&13 bounce ; |
' no.extensions IS notfound |
' no.extensions IS notfound |
|
|
|
: compile-only ( ... -- ) |
|
-&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 |
BEGIN |
BEGIN |
Line 508 Defer notfound ( c-addr count -- )
|
Line 514 Defer notfound ( c-addr count -- )
|
IF \ not restricted to compile state? |
IF \ not restricted to compile state? |
nip nip execute EXIT |
nip nip execute EXIT |
THEN |
THEN |
-&14 throw |
interpret-special exit |
THEN |
THEN |
drop |
drop |
2dup 2>r snumber? |
2dup 2>r snumber? |
Line 720 variable backedge-locals
|
Line 726 variable backedge-locals
|
|
|
: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ better handled by tools like stack checkers |
\ better handled by tools like stack checkers. Besides, it's faster. |
POSTPONE ?dup POSTPONE if ; immediate restrict |
POSTPONE ?dup-?branch >mark ; immediate restrict |
|
|
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
POSTPONE ?dup-0=-?branch >mark ; immediate restrict |
|
|
: THEN ( compilation orig -- ; run-time -- ) \ core |
: THEN ( compilation orig -- ; run-time -- ) \ core |
dup orig? |
dup orig? |
Line 878 Avariable leave-sp leave-stack 3 cells
|
Line 885 Avariable leave-sp leave-stack 3 cells
|
: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
POSTPONE (?do) ?do-like ; immediate restrict |
POSTPONE (?do) ?do-like ; immediate restrict |
|
|
: +DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth plus-do |
: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do |
POSTPONE (+do) ?do-like ; immediate restrict |
POSTPONE (+do) ?do-like ; immediate restrict |
|
|
: U+DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-plus-do |
: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do |
POSTPONE (u+do) ?do-like ; immediate restrict |
POSTPONE (u+do) ?do-like ; immediate restrict |
|
|
: -DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth minus-do |
: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do |
POSTPONE (-do) ?do-like ; immediate restrict |
POSTPONE (-do) ?do-like ; immediate restrict |
|
|
: U-DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-minus-do |
: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do |
POSTPONE (u-do) ?do-like ; immediate restrict |
POSTPONE (u-do) ?do-like ; immediate restrict |
|
|
: FOR ( compilation -- do-sys ; run-time w -- loop-sys ) \ gforth |
: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth |
POSTPONE (for) |
POSTPONE (for) |
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
( 0 0 0 >leave ) ; immediate restrict |
( 0 0 0 >leave ) ; immediate restrict |
Line 944 Avariable leave-sp leave-stack 3 cells
|
Line 951 Avariable leave-sp leave-stack 3 cells
|
immediate restrict |
immediate restrict |
create s"-buffer /line chars allot |
create s"-buffer /line chars allot |
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote |
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote |
[char] " parse |
[char] " parse postpone SLiteral ; immediate restrict |
state @ |
|
IF |
|
postpone SLiteral |
|
ELSE |
|
/line min >r s"-buffer r@ cmove |
|
s"-buffer r> |
|
THEN ; immediate |
|
|
|
: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote |
: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote |
state @ IF postpone (.") ," align |
postpone (.") ," align ; immediate restrict |
ELSE [char] " parse type THEN ; immediate |
|
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
[char] ) parse 2drop ; immediate |
BEGIN |
|
>in @ [char] ) parse nip >in @ rot - = |
|
WHILE |
|
loadfile @ IF |
|
refill 0= abort" missing ')' in paren comment" |
|
THEN |
|
REPEAT ; immediate |
: \ ( -- ) \ core-ext backslash |
: \ ( -- ) \ core-ext backslash |
blk @ |
blk @ |
IF |
IF |
Line 983 create s"-buffer /line chars allot
|
Line 988 create s"-buffer /line chars allot
|
|
|
\ Header states 23feb93py |
\ Header states 23feb93py |
|
|
: flag! ( 8b -- ) |
: cset ( bmask c-addr -- ) |
last @ dup 0= abort" last word was headerless" |
tuck c@ or swap c! ; |
cell+ tuck c@ xor swap c! ; |
: creset ( bmask c-addr -- ) |
: immediate $20 flag! ; |
tuck c@ swap invert and swap c! ; |
: restrict $40 flag! ; |
: ctoggle ( bmask c-addr -- ) |
\ ' noop alias restrict |
tuck c@ xor swap c! ; |
|
|
|
: lastflags ( -- c-addr ) |
|
\ the address of the flags byte in the last header |
|
\ aborts if the last defined word was headerless |
|
last @ dup 0= abort" last word was headerless" cell+ ; |
|
|
|
: immediate $20 lastflags cset ; |
|
: restrict $40 lastflags cset ; |
|
|
\ Header 23feb93py |
\ Header 23feb93py |
|
|
Line 1010 defer header ( -- ) \ gforth
|
Line 1023 defer header ( -- ) \ gforth
|
: 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, |
name, $80 flag! ; |
name, $80 lastflags cset ; |
|
|
: 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 ; |
Line 1026 create nextname-buffer 32 chars allot
|
Line 1039 create nextname-buffer 32 chars allot
|
nextname-buffer count |
nextname-buffer count |
align here last ! -1 A, |
align here last ! -1 A, |
string, cfalign |
string, cfalign |
$80 flag! |
$80 lastflags cset |
input-stream ; |
input-stream ; |
|
|
\ the next name is given in the string |
\ the next name is given in the string |
Line 1049 create nextname-buffer 32 chars allot
|
Line 1062 create nextname-buffer 32 chars allot
|
lastcfa @ ; |
lastcfa @ ; |
|
|
: Alias ( cfa "name" -- ) \ gforth |
: Alias ( cfa "name" -- ) \ gforth |
Header reveal , $80 flag! ; |
Header reveal |
|
$80 lastflags creset |
|
dup A, lastcfa ! ; |
|
|
: name>string ( nfa -- addr count ) \ gforth name-to-string |
: name>string ( nfa -- addr count ) \ gforth name-to-string |
cell+ count $1F and ; |
cell+ count $1F and ; |
Line 1084 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1099 Create ??? 0 , 3 c, char ? c, char ? c,
|
\ DOES> 17mar93py |
\ DOES> 17mar93py |
|
|
: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does |
: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does |
state @ |
;-hook postpone (does>) ?struc dodoes, |
IF |
defstart :-hook ; immediate restrict |
;-hook postpone (does>) ?struc dodoes, |
|
ELSE |
|
align dodoes, here !does ] |
|
THEN |
|
defstart :-hook ; immediate |
|
|
|
\ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
|
|
Line 1127 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1137 Create ??? 0 , 3 c, char ? c, char ? c,
|
\ Create ( -- ) |
\ Create ( -- ) |
\ ['] noop A, |
\ ['] noop A, |
\ DOES> ( ??? ) |
\ DOES> ( ??? ) |
\ @ execute ; |
\ perform ; |
|
|
: IS ( addr "name" -- ) \ gforth |
: IS ( addr "name" -- ) \ gforth |
' >body |
' >body postpone ALiteral postpone ! ; immediate restrict |
state @ |
|
IF postpone ALiteral postpone ! |
|
ELSE ! |
|
THEN ; immediate |
|
' IS Alias TO ( addr "name" -- ) \ core-ext |
' IS Alias TO ( addr "name" -- ) \ core-ext |
immediate |
immediate restrict |
|
|
: What's ( "name" -- addr ) \ gforth |
: What's ( "name" -- addr ) \ gforth |
' >body |
' >body postpone ALiteral postpone @ ; immediate restrict |
state @ |
|
IF |
|
postpone ALiteral postpone @ |
|
ELSE |
|
@ |
|
THEN ; immediate |
|
: Defers ( "name" -- ) \ gforth |
: Defers ( "name" -- ) \ gforth |
' >body @ compile, ; immediate |
' >body @ compile, ; immediate |
|
|
Line 1208 AVariable lookup G forth-wordlist
|
Line 1209 AVariable lookup G forth-wordlist
|
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 wordlist-map @ find-method @ execute ; |
dup wordlist-map @ find-method perform ; |
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
(search-wordlist) dup IF found THEN ; |
(search-wordlist) dup IF found THEN ; |
Line 1230 G -1 warnings T !
|
Line 1231 G -1 warnings T !
|
then |
then |
2drop 2drop ; |
2drop 2drop ; |
|
|
|
: (sfind) ( c-addr u -- nfa | 0 ) |
|
lookup @ (search-wordlist) ; |
|
|
: sfind ( c-addr u -- xt n / 0 ) \ gforth |
: sfind ( c-addr u -- xt n / 0 ) \ gforth |
lookup @ search-wordlist ; |
lookup @ search-wordlist ; |
|
|
Line 1243 G -1 warnings T !
|
Line 1247 G -1 warnings T !
|
last? if |
last? if |
name>string current @ check-shadow |
name>string current @ check-shadow |
then |
then |
current @ wordlist-map @ reveal-method @ execute ; |
current @ wordlist-map @ reveal-method perform ; |
|
|
: rehash ( wid -- ) |
: rehash ( wid -- ) |
dup wordlist-map @ rehash-method @ execute ; |
dup wordlist-map @ rehash-method perform ; |
|
|
: ' ( "name" -- addr ) \ core tick |
: ' ( "name" -- addr ) \ core tick |
name sfind 0= if -&13 bounce then ; |
name sfind 0= if -&13 bounce then ; |
: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick |
: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick |
' postpone ALiteral ; immediate |
' postpone ALiteral ; immediate restrict |
\ Input 13feb93py |
\ Input 13feb93py |
|
|
07 constant #bell ( -- c ) \ gforth |
07 constant #bell ( -- c ) \ gforth |
Line 1269 G -1 warnings T !
|
Line 1273 G -1 warnings T !
|
#lf ( sic! ) emit ; |
#lf ( sic! ) emit ; |
|
|
\ : backspaces 0 ?DO #bs emit LOOP ; |
\ : backspaces 0 ?DO #bs emit LOOP ; |
|
|
|
Variable ^d-mode -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line |
|
|
: >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 1284 G -1 warnings T !
|
Line 1291 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 ; |
: eof ^d-mode @ IF |
|
bye |
|
ELSE 2 pick over <> |
|
IF forw drop (del) ELSE #bell emit THEN 0 |
|
THEN ; |
|
|
Create ctrlkeys |
Create ctrlkeys |
] false false back false eof false forw false |
] false false back false eof false forw false |
Line 1298 defer everychar
|
Line 1309 defer everychar
|
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
everychar |
everychar |
dup #del = IF drop #bs THEN \ del is rubout |
dup #del = IF drop #bs THEN \ del is rubout |
dup bl < IF cells ctrlkeys + @ execute EXIT THEN |
dup bl < IF cells ctrlkeys + perform EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
r> (ins) 0 ; |
r> (ins) 0 ; |
|
|
\ decode should better use a table for control key actions |
|
\ to define keyboard bindings later |
|
|
|
: accept ( addr len -- len ) \ core |
: accept ( addr len -- len ) \ core |
dup 0< IF abs over dup 1 chars - c@ tuck type |
dup 0< IF abs over dup 1 chars - c@ tuck type |
\ this allows to edit given strings |
\ this allows to edit given strings |
ELSE 0 THEN rot over |
ELSE 0 THEN rot over |
BEGIN key decode UNTIL |
BEGIN key decode dup ^d-mode ! UNTIL |
2drop nip ; |
2drop nip ; |
|
|
\ Output 13feb93py |
\ Output 13feb93py |
|
|
|
: (type) ( c-addr u -- ) \ gforth |
|
outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? |
|
; |
|
|
Defer type ( c-addr u -- ) \ core |
Defer type ( c-addr u -- ) \ core |
\ defer type for a output buffer or fast |
\ defer type for a output buffer or fast |
\ screen write |
\ screen write |
|
|
\ : (type) ( addr len -- ) |
|
\ bounds ?DO I c@ emit LOOP ; |
|
|
|
' (type) IS Type |
' (type) IS Type |
|
|
|
: (emit) ( c -- ) \ gforth |
|
outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? |
|
; |
|
|
Defer emit ( c -- ) \ core |
Defer emit ( c -- ) \ core |
' (Emit) IS Emit |
' (Emit) IS Emit |
|
|
Line 1353 Defer key ( -- c ) \ core
|
Line 1366 Defer key ( -- c ) \ core
|
\ 2 c, here char r c, char + c, 0 c, |
\ 2 c, here char r c, char + c, 0 c, |
\ 2 c, here char w c, char + c, 0 c, align |
\ 2 c, here char w c, char + c, 0 c, align |
4 Constant w/o ( -- fam ) \ file w-o |
4 Constant w/o ( -- fam ) \ file w-o |
2 Constant r/w ( -- fam ) \ file r-o |
2 Constant r/w ( -- fam ) \ file r-w |
0 Constant r/o ( -- fam ) \ file r-w |
0 Constant r/o ( -- fam ) \ file r-o |
|
|
\ BIN WRITE-LINE 11jun93jaw |
\ BIN WRITE-LINE 11jun93jaw |
|
|
Line 1746 Variable argc
|
Line 1759 Variable argc
|
Defer 'cold ' noop IS 'cold |
Defer 'cold ' noop IS 'cold |
|
|
: cold ( -- ) \ gforth |
: cold ( -- ) \ gforth |
|
stdout TO outfile-id |
pathstring 2@ process-path pathdirs 2! |
pathstring 2@ process-path pathdirs 2! |
init-included-files |
init-included-files |
'cold |
'cold |