version 1.46, 1995/11/07 18:06:47
|
version 1.53, 1996/02/19 19:19:34
|
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 142 DOES> ( n -- ) + c@ ;
|
Line 145 DOES> ( n -- ) + c@ ;
|
|
|
\ name> found 17dec92py |
\ name> found 17dec92py |
|
|
: (name>) ( nfa -- cfa ) |
: (name>) ( nfa+cell -- cfa ) |
count $1F and + cfaligned ; |
1 cells - name>string + cfaligned ; |
: name> ( nfa -- cfa ) \ gforth |
: name> ( nfa -- cfa ) \ gforth |
cell+ |
cell+ |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
Line 158 DOES> ( n -- ) + c@ ;
|
Line 161 DOES> ( n -- ) + c@ ;
|
|
|
\ : (find) ( addr count nfa1 -- nfa2 / false ) |
\ : (find) ( addr count nfa1 -- nfa2 / false ) |
\ BEGIN dup WHILE dup >r |
\ BEGIN dup WHILE dup >r |
\ cell+ count $1F and dup >r 2over r> = |
\ name>string dup >r 2over r> = |
\ IF -text 0= IF 2drop r> EXIT THEN |
\ IF -text 0= IF 2drop r> EXIT THEN |
\ ELSE 2drop drop THEN r> @ |
\ ELSE 2drop drop THEN r> @ |
\ REPEAT nip nip ; |
\ REPEAT nip nip ; |
Line 720 variable backedge-locals
|
Line 723 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 882 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 957 create s"-buffer /line chars allot
|
Line 961 create s"-buffer /line chars allot
|
state @ IF postpone (.") ," align |
state @ IF postpone (.") ," align |
ELSE [char] " parse type THEN ; immediate |
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 1264 G -1 warnings T !
|
Line 1274 G -1 warnings T !
|
0A constant #lf ( -- c ) \ gforth |
0A constant #lf ( -- c ) \ gforth |
|
|
: bell #bell emit ; |
: bell #bell emit ; |
|
: cr ( -- ) \ core |
|
\ emit a newline |
|
#lf ( sic! ) emit ; |
|
|
\ : backspaces 0 ?DO #bs emit LOOP ; |
\ : backspaces 0 ?DO #bs emit LOOP ; |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
Line 1311 defer everychar
|
Line 1324 defer everychar
|
|
|
\ 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 |
|
|
Defer key ( -- c ) \ core |
Defer key ( -- c ) \ core |
' (key) IS key |
' (key) IS key |
|
|
\ : form ( -- rows cols ) &24 &80 ; |
|
\ form should be implemented using TERMCAPS or CURSES |
|
\ : rows form drop ; |
|
\ : cols form nip ; |
|
|
|
\ Query 07apr93py |
\ Query 07apr93py |
|
|
: refill ( -- flag ) \ core-ext,block-ext,file-ext |
: refill ( -- flag ) \ core-ext,block-ext,file-ext |
Line 1338 Defer key ( -- c ) \ core
|
Line 1351 Defer key ( -- c ) \ core
|
tib /line |
tib /line |
loadfile @ ?dup |
loadfile @ ?dup |
IF read-line throw |
IF read-line throw |
ELSE loadline @ 0< IF 2drop false EXIT THEN |
ELSE sourceline# 0< IF 2drop false EXIT THEN |
accept true |
accept true |
THEN |
THEN |
1 loadline +! |
1 loadline +! |
Line 1355 Defer key ( -- c ) \ core
|
Line 1368 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 1380 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1393 create nl$ 1 c, A c, 0 c, \ gnu includes
|
\ include-file 07apr93py |
\ include-file 07apr93py |
|
|
: push-file ( -- ) r> |
: push-file ( -- ) r> |
loadline @ >r loadfile @ >r |
sourceline# >r loadfile @ >r |
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; |
blk @ >r tibstack @ >r >tib @ >r #tib @ >r |
|
>tib @ tibstack @ = IF r@ tibstack +! THEN |
|
tibstack @ >tib ! >in @ >r >r ; |
|
|
: pop-file ( throw-code -- throw-code ) |
: pop-file ( throw-code -- throw-code ) |
dup IF |
dup IF |
source >in @ loadline @ loadfilename 2@ |
source >in @ sourceline# sourcefilename |
error-stack dup @ dup 1+ |
error-stack dup @ dup 1+ |
max-errors 1- min error-stack ! |
max-errors 1- min error-stack ! |
6 * cells + cell+ |
6 * cells + cell+ |
Line 1394 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1409 create nl$ 1 c, A c, 0 c, \ gnu includes
|
-1 cells +LOOP |
-1 cells +LOOP |
THEN |
THEN |
r> |
r> |
r> >in ! r> #tib ! r> >tib ! r> blk ! |
r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> blk ! |
r> loadfile ! r> loadline ! >r ; |
r> loadfile ! r> loadline ! >r ; |
|
|
: read-loop ( i*x -- j*x ) |
: read-loop ( i*x -- j*x ) |
Line 1453 create pathfilenamebuf 256 chars allot \
|
Line 1468 create pathfilenamebuf 256 chars allot \
|
pathfilenamebuf swap ; |
pathfilenamebuf swap ; |
|
|
create included-files 0 , 0 , ( pointer to and count of included files ) |
create included-files 0 , 0 , ( pointer to and count of included files ) |
create image-included-files 0 , 0 , ( pointer to and count of included files ) |
here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells - |
|
create image-included-files 1 , A, ( pointer to and count of included files ) |
\ included-files points to ALLOCATEd space, while image-included-files |
\ included-files points to ALLOCATEd space, while image-included-files |
\ points to ALLOTed objects, so it survives a save-system |
\ points to ALLOTed objects, so it survives a save-system |
|
|
Line 1461 create image-included-files 0 , 0 , ( po
|
Line 1477 create image-included-files 0 , 0 , ( po
|
\ a-addr 2@ produces the current file name ( c-addr u ) |
\ a-addr 2@ produces the current file name ( c-addr u ) |
included-files 2@ drop loadfilename# @ 2* cells + ; |
included-files 2@ drop loadfilename# @ 2* cells + ; |
|
|
|
: sourcefilename ( -- c-addr u ) \ gforth |
|
\ the name of the source file which is currently the input |
|
\ source. The result is valid only while the file is being |
|
\ loaded. If the current input source is no (stream) file, the |
|
\ result is undefined. |
|
loadfilename 2@ ; |
|
|
|
: sourceline# ( -- u ) \ gforth sourceline-number |
|
\ the line number of the line that is currently being interpreted |
|
\ from a (stream) file. The first line has the number 1. If the |
|
\ current input source is no (stream) file, the result is |
|
\ undefined. |
|
loadline @ ; |
|
|
: init-included-files ( -- ) |
: init-included-files ( -- ) |
image-included-files 2@ 2* cells save-string drop ( addr ) |
image-included-files 2@ 2* cells save-string drop ( addr ) |
image-included-files 2@ nip included-files 2! ; |
image-included-files 2@ nip included-files 2! ; |
Line 1559 create image-included-files 0 , 0 , ( po
|
Line 1589 create image-included-files 0 , 0 , ( po
|
\ EVALUATE 17may93jaw |
\ EVALUATE 17may93jaw |
|
|
: evaluate ( c-addr len -- ) \ core,block |
: evaluate ( c-addr len -- ) \ core,block |
push-file dup #tib ! >tib @ swap move |
push-file #tib ! >tib ! |
>in off blk off loadfile off -1 loadline ! |
>in off blk off loadfile off -1 loadline ! |
\ BEGIN interpret >in @ #tib @ u>= UNTIL |
|
['] interpret catch |
['] interpret catch |
pop-file throw ; |
pop-file throw ; |
|
|
Line 1628 DEFER DOERROR
|
Line 1657 DEFER DOERROR
|
; |
; |
|
|
: (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
loadline @ IF |
sourceline# IF |
source >in @ loadline @ 0 0 .error-frame |
source >in @ sourceline# 0 0 .error-frame |
THEN |
THEN |
error-stack @ 0 ?DO |
error-stack @ 0 ?DO |
-1 error-stack +! |
-1 error-stack +! |
Line 1659 DEFER DOERROR
|
Line 1688 DEFER DOERROR
|
postpone [ |
postpone [ |
['] 'quit CATCH dup |
['] 'quit CATCH dup |
WHILE |
WHILE |
DoError r@ >tib ! |
DoError r@ >tib ! r@ tibstack ! |
REPEAT |
REPEAT |
drop r> >tib ! ; |
drop r> >tib ! ; |
|
|
\ Cold 13feb93py |
\ Cold 13feb93py |
|
|
\ : .name ( name -- ) cell+ count $1F and type space ; |
\ : .name ( name -- ) name>string type space ; |
\ : words listwords @ |
\ : words listwords @ |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
|
|
Line 1732 Variable argc
|
Line 1761 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 |
Line 1745 Defer 'cold ' noop IS 'cold
|
Line 1775 Defer 'cold ' noop IS 'cold
|
cr |
cr |
THEN |
THEN |
false to script? |
false to script? |
." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr |
." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr |
." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." Type `bye' to exit" |
." Type `bye' to exit" |
loadline off quit ; |
loadline off quit ; |
Line 1768 Defer 'cold ' noop IS 'cold
|
Line 1798 Defer 'cold ' noop IS 'cold
|
|
|
: boot ( path **argv argc -- ) |
: boot ( path **argv argc -- ) |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
sp@ dup s0 ! $10 + >tib ! #tib off >in off |
sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off |
rp@ r0 ! fp@ f0 ! cold ; |
rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; |
|
|
: bye ( -- ) \ tools-ext |
: bye ( -- ) \ tools-ext |
script? 0= IF cr THEN 0 (bye) ; |
script? 0= IF cr THEN 0 (bye) ; |