Commit 0f194b67 authored by anton's avatar anton

gforth-ditc is now installed with "make install"

bugfix in print-backtrace
rewrote number output: now uses a fixed buffer HOLDBUF; added <<# and
	#>> to deal with nested number output (e.g., AT-XY), and fixed
	ud.r and d.r (and thus all the "." words) and DUMP to use
	them.  Other words using <# still have to be fixed.
removed COMPACT// and its use; it did not work, and anyway, it's a bad
	idea for Cygwin, Domain/OS (Apollo's OS), and possibly other OSs.
parent abc0df93
......@@ -436,12 +436,13 @@ binonlydist: Makedist FORCE
install: gforth$(EXE) $(FORTH_SRC) $(kernel_fi) gforth.fi gforthmi doc/gforth.1 prim install.TAGS installdirs
touch $(siteforthdir)/siteinit.fs
-$(RM) $(bindir)/gforth$(EXE) $(bindir)/gforth-$(VERSION)$(EXE) $(bindir)/gforthmi
-$(RM) $(bindir)/gforth-fast$(EXE) $(bindir)/gforth-fast-$(VERSION)$(EXE) $(bindir)/gforthmi
-$(RM) $(bindir)/gforth-fast$(EXE) $(bindir)/gforth-fast-$(VERSION)$(EXE)
$(INSTALL_PROGRAM) -s gforth$(EXE) $(bindir)/gforth-$(VERSION)$(EXE)
$(LN_S) $(bindir)/gforth-$(VERSION)$(EXE) $(bindir)/gforth$(EXE)
$(INSTALL_PROGRAM) -s gforth-fast$(EXE) $(bindir)/gforth-fast-$(VERSION)$(EXE)
$(LN_S) $(bindir)/gforth-fast-$(VERSION)$(EXE) $(bindir)/gforth-fast$(EXE)
$(INSTALL_PROGRAM) gforthmi $(bindir)/gforthmi-$(VERSION)
$(INSTALL_PROGRAM) gforth-ditc $(libdir)/gforth/$(VERSION)
$(LN_S) $(bindir)/gforthmi-$(VERSION) $(bindir)/gforthmi
-$(INSTALL_DATA) $(srcdir)/doc/gforth.1 $(man1dir)
-for i in $(srcdir)/doc/gforth.info*; do $(INSTALL_DATA) $$i $(infodir); done
......
......@@ -83,8 +83,14 @@ IS store-backtrace
swap u+do
cr
i @ dup hex. ( return-addr? )
cell - dup in-dictionary? if
@ look drop .name
cell - dup in-dictionary? over dup aligned = and
if
@ look
if
.name
else
drop
then
else
drop
then
......
......@@ -622,6 +622,7 @@ Defer dobacktrace ( -- )
[ [THEN] ]
['] 'quit CATCH dup
WHILE
<# \ reset hold area, or we may get another error
DoError r@ >tib ! r@ tibstack !
REPEAT
drop r> >tib ! ;
......
......@@ -26,18 +26,38 @@
: hold ( char -- ) \ core
\G Used within @code{<#} and @code{#>}. Append the character char
\G to the pictured numeric output string.
pad cell - -1 chars over +! @ c! ;
-1 chars holdptr +!
holdptr @ dup holdbuf u< -&17 and throw
c! ;
: <# ( -- ) \ core less-number-sign
\G Initialise/clear the pictured numeric output string.
pad cell - dup ! ;
holdbuf-end holdptr ! ;
: #> ( xd -- addr u ) \ core number-sign-greater
\G Complete the pictured numeric output string by
\G discarding xd and returning addr u; the address and length
\G of the formatted string. A Standard program may modify characters
\G within the string.
2drop pad cell - dup @ tuck - ;
2drop holdptr @ holdbuf-end over - ;
: <<# ( -- addr ) \ gforth less-less-number-sign
\G starts a hold area that ends with @code{#>>}. Can be nested in
\G each other and in @code{<#}. Note: if you do not match up the
\G @code{<<#}s with @code{#>>}s, you will eventually run out of
\G hold area; you can reset the hold area to empty with @code{<#}.
holdptr @ ;
: #>> ( xd addr1 -- addr u ) \ gforth number-sign-greater-greater
\G Completes a numeric output string started with
\G @code{<<#}. @var{xd} is discarded, @var{addr1} is the value
\G produced by @code{<<#}, @var{addr u} represents the output
\G string.
\ this stack effect has been chosen to make it conventient to
\ replace @code{<# ... #>} with @code{<<# >r ... r> #>>}
>r 2drop
holdptr @ r@ over -
r> holdptr ! ;
: sign ( n -- ) \ core
\G Used within @code{<#} and @code{#>}. If n (a @var{single} number)
......@@ -75,13 +95,13 @@
\G Display d right-aligned in a field n characters wide. If more than
\G n characters are needed to display the number, all digits are displayed.
\G If appropriate, n must include a character for a leading "-".
>r tuck dabs <# #s rot sign #>
>r tuck dabs <<# >r #s rot sign r> #>>
r> over - spaces type ;
: ud.r ( ud n -- ) \ gforth u-d-dot-r
\G Display ud right-aligned in a field n characters wide. If more than
\G n characters are needed to display the number, all digits are displayed.
>r <# #s #> r> over - spaces type ;
>r <<# >r #s r> #>> r> over - spaces type ;
: .r ( n1 n2 -- ) \ core-ext dot-r
\G Display n1 right-aligned in a field n2 characters wide. If more than
......
......@@ -156,19 +156,6 @@ Create tfile 0 c, 255 chars allot
tfile count over c@ pathsep? IF 1 /string THEN
ofile +place
THEN ;
: compact// ( adr len -- adr2 len2 )
\ deletes phrases like "//" out of our directory name 2dec97jaw
over >r
BEGIN dup WHILE
over c@ pathsep? over 1- 0<> and
IF over 1+ c@ pathsep?
IF 1- over 1+ swap move
THEN
THEN
1 /string
REPEAT
drop r> tuck - ;
: compact.. ( adr len -- adr2 len2 )
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw
......@@ -195,7 +182,7 @@ Create tfile 0 c, 255 chars allot
: reworkdir ( -- )
remove~+
ofile count compact// compact..
ofile count compact..
nip ofile c! ;
: open-ofile ( -- fid ior )
......
......@@ -45,7 +45,7 @@ Variable /dump
: .4 ( addr -- addr' )
3 FOR -1 /dump +! /dump @ 0<
IF ." " ELSE dup c@ 0 <# # # #> type space THEN
IF ." " ELSE dup c@ 0 <<# >r # # r> #>> type space THEN
char+ NEXT ;
: .chars ( addr -- )
/dump @ bounds
......
......@@ -46,8 +46,13 @@ FF Constant /line
400 Constant chars/block
$20 8 2* cells + 2 + cell+ constant word-pno-size ( -- u )
create holdbuf word-pno-size chars allot
holdbuf word-pno-size chars + aconstant holdbuf-end
avariable holdptr holdbuf-end holdptr a!
84 constant pad-minsize ( -- u )
\ that's enough so long
\ User variables 13feb93py
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment