version 1.58, 1998/12/08 22:02:38
|
version 1.63, 1998/12/22 21:17:14
|
Line 52 Warnings off
|
Line 52 Warnings off
|
|
|
\ words that are generaly useful |
\ words that are generaly useful |
|
|
|
: KB 400 * ; |
: >wordlist ( vocabulary-xt -- wordlist-struct ) |
: >wordlist ( vocabulary-xt -- wordlist-struct ) |
also execute get-order swap >r 1- set-order r> ; |
also execute get-order swap >r 1- set-order r> ; |
|
|
Line 302 true SetValue cross
|
Line 303 true SetValue cross
|
true SetValue standard-threading |
true SetValue standard-threading |
>TARGET previous |
>TARGET previous |
|
|
|
|
mach-file count included hex |
mach-file count included hex |
|
|
>ENVIRON |
>ENVIRON |
Line 653 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 655 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: c, ( char -- ) T here tchar allot c! H ; |
: c, ( char -- ) T here tchar allot c! H ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; |
: cfalign ( -- ) |
: cfalign ( -- ) |
T here H cfalign+ 0 ?DO bl T c, H LOOP ; |
T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; |
|
|
: A! dup relon T ! H ; |
: >address dup 0>= IF tchar / THEN ; |
: A, ( w -- ) T here H relon T , H ; |
: A! swap >address swap dup relon T ! H ; |
|
: A, ( w -- ) >address T here H relon T , H ; |
|
|
>CROSS |
>CROSS |
|
|
Line 1115 NoHeaderFlag off
|
Line 1118 NoHeaderFlag off
|
IF NoHeaderFlag off |
IF NoHeaderFlag off |
ELSE |
ELSE |
T align H view, |
T align H view, |
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! |
tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast ! |
1 headers-named +! \ Statistic |
1 headers-named +! \ Statistic |
>in @ T name, H >in ! |
>in @ T name, H >in ! |
THEN |
THEN |
Line 1223 Cond: ['] T ' H alit, ;Cond
|
Line 1226 Cond: ['] T ' H alit, ;Cond
|
\ modularized 14jun97jaw |
\ modularized 14jun97jaw |
|
|
: fillcfa ( usedcells -- ) |
: fillcfa ( usedcells -- ) |
T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ; |
T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ; |
|
|
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
|
|
Line 1631 Builder Field
|
Line 1634 Builder Field
|
: sys? ( sys -- sys ) dup 0= ?struc ; |
: sys? ( sys -- sys ) dup 0= ?struc ; |
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
|
|
: branchoffset ( src dest -- ) - ; |
: branchoffset ( src dest -- ) - tchar / ; |
|
|
: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; |
: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; |
|
|
Line 1951 previous
|
Line 1954 previous
|
\ save-cross 17mar93py |
\ save-cross 17mar93py |
|
|
>CROSS |
>CROSS |
Create magic s" Gforth10" here over allot swap move |
Create magic s" Gforth2x" here over allot swap move |
|
|
char 1 bigendian + tcell + magic 7 + c! |
bigendian 1+ \ strangely, in magic big=0, little=1 |
|
tcell 1 = 0 and or |
|
tcell 2 = 2 and or |
|
tcell 4 = 4 and or |
|
tcell 8 = 6 and or |
|
magic 7 + c! |
|
|
: save-cross ( "image-name" "binary-name" -- ) |
: save-cross ( "image-name" "binary-name" -- ) |
bl parse ." Saving to " 2dup type cr |
bl parse ." Saving to " 2dup type cr |
Line 2003 bigendian Constant bigendian
|
Line 2011 bigendian Constant bigendian
|
: tempdp> tempdp> ; |
: tempdp> tempdp> ; |
: const constflag on ; |
: const constflag on ; |
: warnings name 3 = 0= twarnings ! drop ; |
: warnings name 3 = 0= twarnings ! drop ; |
: | NoHeaderFlag on ; |
: | ; |
|
\ : | NoHeaderFlag on ; \ This is broken (damages the last word) |
|
|
: save-cross save-cross ; |
: save-cross save-cross ; |
: save-region save-region ; |
: save-region save-region ; |