version 1.50, 1996/01/07 17:22:12
|
version 1.54, 1996/04/17 16:39:41
|
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 450 hex
|
Line 453 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 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 1314 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 |
|
|
Line 1353 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 1746 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 |