Commit 21d46145 authored by anton's avatar anton

Added automatic glossary entry transfer from primitives to the texi file.

renamed gfoprth.texi to gforth.ds.
fixed a few minor bugs.
changed the behaviour of locals scoping when encountering an unreachable BEGIN.
made UNREACHABLE immediate
parent 550f26c2
......@@ -27,7 +27,7 @@ FORTH_SRC = add.fs assert.fs blocks.fs bufio.fs cross.fs debug.fs \
test2.fs tools.fs toolsext.fs vars.fs vt100.fs wordinfo.fs
SOURCES = Makefile primitives primitives2c.el engine.c main.c io.c \
apollo68k.h decstation.h 386.h hppa.h sparc.h \
apollo68k.h decstation.h 386.h hppa.h sparc.h gforth.ds \
$(INCLUDES) $(FORTH_SRC)
RCS_FILES = $(SOURCES) INSTALL ToDo model high-level
......@@ -40,9 +40,10 @@ OBJECTS = engine.o io.o main.o
# things that need a working forth system to be generated
# this is used for antidependences,
FORTH_GEN = primitives.i prim_labels.i prim_alias.4th kernl32l.fi kernl32b.fi
FORTH_GEN = primitives.i prim_labels.i prim_alias.4th \
kernl32l.fi kernl32b.fi gforth.texi
all: gforth aliases.fs
all: gforth
#from the gcc Makefile:
#"Deletion of files made during compilation.
......@@ -56,7 +57,7 @@ all: gforth aliases.fs
# `realclean' also deletes everything that could be regenerated automatically."
clean:
-rm $(GEN)
-rm $(GEN) *.o *.s
distclean: clean
-rm machine.h machine.fs
......@@ -104,6 +105,12 @@ aliases.fs: primitives.b prims2x.fs
primitives.fs: primitives.b prims2x.fs
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-forth process-file bye" >$@
gforth.texi: gforth.ds primitives.b ds2texi.fs prims2x.fs
$(FORTH) search-order.fs struct.fs debugging.fs ds2texi.fs prims2x.fs -e "s\" primitives.b\" ' register-doc process-file s\" gforth.ds\" r/o open-file throw ds2texi bye" >$@
gforth.dvi: gforth.texi
tex gforth.texi
#primitives.4th: primitives.b primitives2c.el
# $(EMACS) -batch -load primitives2c.el -funcall make-forth
......
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.13 1994-09-12 19:00:27 pazsan Exp $
\ $Id: cross.fs,v 1.14 1994-10-24 19:15:53 anton Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -408,6 +408,8 @@ ghost '
Cond: ['] compile lit ghost gexecute ;Cond
Cond: chars ;Cond
>CROSS
\ tLiteral 12dec92py
......
\ documentation source to texi format converter
\ documentation source can contain lines in the form `doc-word' and
\ `short-word'. These are converted to appropriate full or short
\ (without the description) glossary entries for word.
\ The glossary entries are generated from data present in the wordlist
\ `documentation'. Each word resides there under its own name.
wordlist constant documentation
struct
2 cells: field doc-name
2 cells: field doc-stack-effect
2 cells: field doc-wordset
2 cells: field doc-pronounciation
2 cells: field doc-description
end-struct doc-entry
: emittexi ( c -- )
>r
s" @{}" r@ scan 0<>
if
[char] @ emit
endif
drop r> emit ;
: typetexi ( addr u -- )
0
?do
dup c@ emittexi
char+
loop
drop ;
: print-short ( doc-entry -- )
>r ." @format"
." @code{" r@ doc-name 2@ typetexi ." } "
." @i{" r@ doc-stack-effect 2@ type ." } "
r@ doc-wordset 2@ type ." ``"
r@ doc-pronounciation 2@ type ." ''@end format" cr
rdrop ;
: print-doc ( doc-entry -- )
>r
r@ print-short
r@ doc-description 2@ dup 0<>
if
type ." @*" cr
else
2drop cr
endif
rdrop ;
: do-doc ( addr1 u1 addr2 u2 xt -- f )
\ xt is the word to be executed if addr1 u1 is a string starting
\ with the prefix addr2 u2 and continuing with a word in the
\ wordlist `documentation'. f is true if xt is executed.
>r dup >r
3 pick over compare 0=
if \ addr2 u2 is a prefix of addr1 u1
r> /string documentation search-wordlist
if \ the rest of addr1 u1 is in documentation
execute r> execute true
else
rdrop false
endif
else
2drop 2rdrop false
endif ;
: process-line ( addr u -- )
2dup s" doc-" ['] print-doc do-doc 0=
if
2dup s" short-" ['] print-short do-doc 0=
if
type cr EXIT
endif
endif
2drop ;
1024 constant doclinelength
create docline doclinelength chars allot
: ds2texi ( file-id -- )
>r
begin
docline doclinelength r@ read-line throw
while
dup doclinelength = abort" docline too long"
docline swap process-line
repeat
drop rdrop ;
......@@ -181,7 +181,8 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
#ifdef DEBUG
fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
ip,sp,rp,fp,lp,up);
(unsigned)ip,(unsigned)sp,(unsigned)rp,
(unsigned)fp,(unsigned)lp,(unsigned)up);
#endif
if (ip == NULL)
......
This diff is collapsed.
......@@ -509,5 +509,9 @@ forth definitions
endif ; immediate
: locals|
BEGIN name 2dup s" |" compare 0= WHILE
(local) REPEAT drop 0 (local) ; immediate restrict
BEGIN
name 2dup s" |" compare 0<>
WHILE
(local)
REPEAT
drop 0 (local) ; immediate restrict
......@@ -66,7 +66,7 @@ DOES> ( n -- ) + c@ ;
bl c,
LOOP ;
: chars ; immediate
: A! ( addr1 addr2 -- ) dup relon ! ;
: A, ( addr -- ) here cell allot A! ;
......@@ -173,10 +173,10 @@ Defer source
: [char] ( 'char' -- n ) char postpone Literal ; immediate
' [char] Alias Ascii immediate
: (compile) ( -- ) r> dup cell+ >r @ A, ;
: (compile) ( -- ) r> dup cell+ >r @ compile, ;
: postpone ( "name" -- )
name sfind dup 0= abort" Can't compile "
0> IF A, ELSE postpone (compile) A, THEN ;
0> IF compile, ELSE postpone (compile) A, THEN ;
immediate restrict
\ Use (compile) for the old behavior of compile!
......@@ -417,11 +417,23 @@ AConstant locals-list \ acts like a variable that contains
variable dead-code \ true if normal code at "here" would be dead
: unreachable ( -- )
\ declares the current point of execution as unreachable
dead-code on ;
variable backedge-locals
\ contains the locals list that BEGIN will assume to be live on
\ the back edge if the BEGIN is unreachable from above. Set by
\ ASSUME-LIVE, reset by UNREACHABLE.
: UNREACHABLE ( -- )
\ declares the current point of execution as unreachable
dead-code on
0 backedge-locals ! ; immediate
: ASSUME-LIVE ( orig -- orig )
\ used immediateliy before a BEGIN that is not reachable from
\ above. causes the BEGIN to assume that the same locals are live
\ as at the orig point
dup orig?
2 pick backedge-locals ! ; immediate
\ locals list operations
: common-list ( list1 list2 -- list3 )
......@@ -546,7 +558,7 @@ variable dead-code \ true if normal code at "here" would be dead
\ Structural Conditionals 12dec92py
: AHEAD ( -- orig )
POSTPONE branch >mark unreachable ; immediate restrict
POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
: IF ( -- orig )
POSTPONE ?branch >mark ; immediate restrict
......@@ -588,17 +600,10 @@ variable dead-code \ true if normal code at "here" would be dead
: BEGIN ( -- dest )
dead-code @ if
\ set up an assumption of the locals visible here
\ currently we just take the top cs-item
\ it would be more intelligent to take the top orig
\ but that can be arranged by the user
dup defstart <> if
dup cs-item?
2 pick
else
0
then
set-locals-size-list
\ set up an assumption of the locals visible here. if the
\ users want something to be visible, they have to declare
\ that using ASSUME-LIVE
backedge-locals @ set-locals-size-list
then
cs-push-part dest
dead-code off ; immediate restrict
......@@ -614,7 +619,7 @@ variable dead-code \ true if normal code at "here" would be dead
POSTPONE branch
<resolve
check-begin
unreachable ; immediate restrict
POSTPONE unreachable ; immediate restrict
\ UNTIL (the current control flow may join an earlier one or continue):
\ Similar to AGAIN. The new locals-list and locals-size are the current
......@@ -746,7 +751,7 @@ Avariable leave-sp leave-stack 3 cells + leave-sp !
: EXIT ( -- )
0 adjust-locals-size
POSTPONE ;s
unreachable ; immediate restrict
POSTPONE unreachable ; immediate restrict
: ?EXIT ( -- )
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
......
......@@ -94,9 +94,12 @@ until
: xxx5
{ a }
a drop
ahead
assume-live
begin
[ ." after begin" localsinfo ]
a drop
[ 1 cs-roll ]
then
[ ." after then" localsinfo ]
......@@ -278,5 +281,10 @@ s" " s" " strcmp1 . cr
;
teststrcmp1
." testing the abominable locals-ext wordset" cr
: puke locals| this read you can |
you read this can ;
1 2 3 4 puke . . . . cr
bye
/*
$Id: main.c,v 1.14 1994-09-28 17:02:48 anton Exp $
$Id: main.c,v 1.15 1994-10-24 19:16:02 anton Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -135,30 +135,30 @@ Cell *loader(FILE *imagefile)
int go_forth(Cell *image, int stack, Cell *entries)
{
Cell *sp=(Cell*)((void *)image+dictsize+dsize);
Address lp=(Address)((void *)sp+lsize);
Float *fp=(Float *)((void *)lp+fsize);
Cell *rp=(Cell*)((void *)fp+rsize);
Xt *ip=(Xt *)(image[3]);
int throw_code;
for(;stack>0;stack--)
*--sp=entries[stack-1];
install_signal_handlers(); /* right place? */
if ((throw_code=setjmp(throw_jmp_buf))) {
static Cell signal_data_stack[8];
static Cell signal_return_stack[8];
static Float signal_fp_stack[1];
signal_data_stack[7]=throw_code;
return((int)engine((Xt *)image[4],signal_data_stack+7,
signal_return_stack+8,signal_fp_stack,0));
}
return((int)engine(ip,sp,rp,fp,lp));
Cell *sp=(Cell*)((void *)image+dictsize+dsize);
Address lp=(Address)((void *)sp+lsize);
Float *fp=(Float *)((void *)lp+fsize);
Cell *rp=(Cell*)((void *)fp+rsize);
Xt *ip=(Xt *)(image[3]);
int throw_code;
for(;stack>0;stack--)
*--sp=entries[stack-1];
install_signal_handlers(); /* right place? */
if ((throw_code=setjmp(throw_jmp_buf))) {
static Cell signal_data_stack[8];
static Cell signal_return_stack[8];
static Float signal_fp_stack[1];
signal_data_stack[7]=throw_code;
return((int)engine((Xt *)image[4],signal_data_stack+7,
signal_return_stack+8,signal_fp_stack,0));
}
return((int)engine(ip,sp,rp,fp,lp));
}
int convsize(char *s, int elemsize)
......
......@@ -737,7 +737,7 @@ c_addr2 = c_addr1 + 1;
:
1+ ;
chars n1 -- n2 core cares
(chars) n1 -- n2 core cares
n2 = n1 * sizeof(Char);
:
;
......
......@@ -347,13 +347,13 @@ constant type-description
endif
rdrop ;
: single-type ( -- xt n1 n2 )
: single-type ( -- xt1 xt2 n1 n2 )
['] fetch-single ['] store-single 1 0 ;
: double-type ( -- xt n1 n2 )
: double-type ( -- xt1 xt2 n1 n2 )
['] fetch-double ['] store-double 2 0 ;
: float-type ( -- xt n1 n2 )
: float-type ( -- xt1 xt2 n1 n2 )
['] fetch-float ['] store-float 0 1 ;
: s, ( addr u -- )
......@@ -548,8 +548,19 @@ set-current
effect-out effect-out-end @ .stack-list ." )" cr
forth-code 2@ type cr
-1 primitive-number +!
THEN
;
THEN ;
[IFDEF] documentation
: register-doc ( -- )
get-current documentation set-current
forth-name 2@ nextname create
forth-name 2@ 2,
stack-string 2@ 2,
wordset 2@ 2,
c-name 2@ 2,
doc 2@ 2,
set-current ;
[THEN]
: process-file ( addr u xt -- )
>r r/o open-file abort" cannot open file"
......
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