version 1.15, 1997/02/09 21:51:39
|
version 1.24, 1997/04/10 21:32:08
|
Line 68 NIL AConstant NIL \ gforth
|
Line 68 NIL AConstant NIL \ gforth
|
|
|
\ Aliases |
\ Aliases |
|
|
' i Alias r@ |
' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch |
|
\G copy w from the return stack to the data stack |
|
|
\ Bit string manipulation 06oct92py |
\ Bit string manipulation 06oct92py |
|
|
Line 264 Defer source ( -- addr count ) \ core
|
Line 265 Defer source ( -- addr count ) \ core
|
: (compile) ( -- ) \ gforth |
: (compile) ( -- ) \ gforth |
r> dup cell+ >r @ compile, ; |
r> dup cell+ >r @ compile, ; |
|
|
: postpone, ( w xt -- ) |
: postpone, ( w xt -- ) \ gforth postpone-comma |
\g Compiles the compilation semantics represented by @var{w xt}. |
\g Compiles the compilation semantics represented by @var{w xt}. |
dup ['] execute = |
dup ['] execute = |
if |
if |
Line 489 Defer 'throw
|
Line 490 Defer 'throw
|
|
|
: 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 9 cells ! ] \ entry point for signal handler |
[ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler |
handler @ dup 0= IF |
handler @ dup 0= IF |
[ has-os [IF] ] |
[ has-os [IF] ] |
2 (bye) |
2 (bye) |
Line 747 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 748 Create ??? 0 , 3 c, char ? c, char ? c,
|
: !does ( addr -- ) \ gforth store-does |
: !does ( addr -- ) \ gforth store-does |
lastxt does-code! ; |
lastxt does-code! ; |
: (does>) ( R: addr -- ) |
: (does>) ( R: addr -- ) |
r> /does-handler + !does ; |
r> cfaligned /does-handler + !does ; |
: dodoes, ( -- ) |
: dodoes, ( -- ) |
here /does-handler allot does-handler! ; |
cfalign here /does-handler allot does-handler! ; |
|
|
doer? :dovar [IF] |
doer? :dovar [IF] |
: Create ( "name" -- ) \ core |
: Create ( "name" -- ) \ core |
Line 961 end-struct interpret/compile-struct
|
Line 962 end-struct interpret/compile-struct
|
then |
then |
then ; |
then ; |
|
|
: find ( c-addr -- xt +-1 / c-addr 0 ) \ core |
: find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search |
dup count sfind dup |
dup count sfind dup |
if |
if |
rot drop |
rot drop |
Line 1037 G -1 warnings T !
|
Line 1038 G -1 warnings T !
|
0C constant #ff ( -- c ) \ gforth |
0C constant #ff ( -- c ) \ gforth |
0A constant #lf ( -- c ) \ gforth |
0A constant #lf ( -- c ) \ gforth |
|
|
: bell #bell emit ; |
: bell ( -- ) \ gforth |
|
\g makes a beep and flushes the output buffer |
|
#bell emit |
|
outfile-id flush-file drop ; |
: cr ( -- ) \ core |
: cr ( -- ) \ core |
\ emit a newline |
\ emit a newline |
#lf ( sic! ) emit ; |
#lf ( sic! ) emit ; |
Line 1261 DEFER DOERROR
|
Line 1265 DEFER DOERROR
|
; |
; |
|
|
: (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
|
[ has-os [IF] ] |
|
outfile-id dup flush-file drop >r |
|
stderr to outfile-id |
|
[ [THEN] ] |
sourceline# IF |
sourceline# IF |
source >in @ sourceline# 0 0 .error-frame |
source >in @ sourceline# 0 0 .error-frame |
THEN |
THEN |
Line 1282 DEFER DOERROR
|
Line 1290 DEFER DOERROR
|
ELSE |
ELSE |
.error |
.error |
THEN |
THEN |
normal-dp dpp ! ; |
normal-dp dpp ! |
|
[ has-os [IF] ] r> to outfile-id [ [THEN] ] |
|
; |
|
|
' (DoError) IS DoError |
' (DoError) IS DoError |
|
|
Line 1301 DEFER DOERROR
|
Line 1311 DEFER DOERROR
|
\ : .name ( name -- ) name>string 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 ; |
Defer 'cold ' noop IS 'cold |
Defer 'cold ( -- ) \ gforth tick-cold |
|
\ hook (deferred word) for things to do right before interpreting the |
|
\ command-line arguments |
|
' noop IS 'cold |
|
|
: cold ( -- ) \ gforth |
: cold ( -- ) \ gforth |
[ has-files [IF] ] |
[ has-files [IF] ] |
Line 1310 Defer 'cold ' noop IS 'cold
|
Line 1323 Defer 'cold ' noop IS 'cold
|
[ [THEN] ] |
[ [THEN] ] |
'cold |
'cold |
[ has-files [IF] ] |
[ has-files [IF] ] |
argc @ 1 > |
['] process-args catch ?dup |
IF |
IF |
['] process-args catch ?dup |
dup >r DoError cr r> negate (bye) |
IF |
THEN |
dup >r DoError cr r> negate (bye) |
argc @ 1 > |
THEN |
IF \ there may be some unfinished line, so let's finish it |
cr |
cr |
THEN |
THEN |
[ [THEN] ] |
[ [THEN] ] |