67 lines
1.3 KiB
Plaintext
67 lines
1.3 KiB
Plaintext
|
require util.4th
|
||
|
|
require logger.4th
|
||
|
|
|
||
|
|
\ The standard output will only be redirected in application code,
|
||
|
|
\ not globally in gforth.
|
||
|
|
|
||
|
|
\ We always log to a file but we have an optional hook.
|
||
|
|
|
||
|
|
true variable! (stdout)
|
||
|
|
true variable! (stdout-logger)
|
||
|
|
true variable! (stdout-hook)
|
||
|
|
|
||
|
|
: oldtype type ;
|
||
|
|
: oldemit emit ;
|
||
|
|
|
||
|
|
defer (emit)
|
||
|
|
defer (type)
|
||
|
|
|
||
|
|
: type ( str -- )
|
||
|
|
(stdout) @ IF 2dup oldtype THEN
|
||
|
|
(stdout-logger) @ IF 2dup logger.log THEN
|
||
|
|
(stdout-hook) @ IF 2dup (type) THEN
|
||
|
|
2drop ;
|
||
|
|
|
||
|
|
create (emit-buffer) 1 chars allot
|
||
|
|
: emit ( c -- )
|
||
|
|
(emit-buffer) c! (emit-buffer) 1 chars type ;
|
||
|
|
|
||
|
|
: ." ( "str" -- )
|
||
|
|
[char] " parse
|
||
|
|
state @ IF
|
||
|
|
]] sliteral type [[
|
||
|
|
ELSE
|
||
|
|
type
|
||
|
|
THEN ; immediate
|
||
|
|
: space ( -- ) bl emit ;
|
||
|
|
: cr ( -- ) 10 emit ;
|
||
|
|
: . ( n -- )
|
||
|
|
to-string type bl emit ;
|
||
|
|
: .s ( -- )
|
||
|
|
." < " depth . ." > "
|
||
|
|
depth 0> IF
|
||
|
|
depth 0
|
||
|
|
BEGIN 2dup > WHILE 1+ rot >r REPEAT
|
||
|
|
drop 0
|
||
|
|
BEGIN 2dup > WHILE 1+ r> dup . -rot REPEAT
|
||
|
|
2drop
|
||
|
|
THEN ;
|
||
|
|
|
||
|
|
: stdout ( flag -- ) (stdout) ! ;
|
||
|
|
: stdout-logger ( flag -- ) (stdout-logger) ! ;
|
||
|
|
: stdout-hook ( flag -- ) (stdout-hook) ! ;
|
||
|
|
|
||
|
|
: stdout-hook-reset ( -- )
|
||
|
|
['] drop IS (emit)
|
||
|
|
['] 2drop is (type) ;
|
||
|
|
|
||
|
|
: stdout-hook-emit ( xt -- )
|
||
|
|
\ xt ( c -- )
|
||
|
|
is (emit) ;
|
||
|
|
|
||
|
|
: stdout-hook-type ( xt -- )
|
||
|
|
\ xt ( str -- )
|
||
|
|
is (type) ;
|
||
|
|
|
||
|
|
stdout-hook-reset
|