Commit ec107478 authored by pazsan's avatar pazsan

SPECIAL: to create special "state-smart" words

parent 707c695a
......@@ -57,10 +57,15 @@
/* this is the point where the does code starts if label points to the
* jump dodoes */
#define DOES_HANDLER_SIZE 8
#define DOES_CODE(label) ((Xt *)(CODE_ADDRESS(label)+DOES_HANDLER_SIZE))
#define DOES_CODE(xt) \
({ long _xt = (long)(CODE_ADDRESS(xt)); \
(((*(unsigned char *)(xt)) == CALL) && \
((*(unsigned char *)_xt) == JMP) && \
((long)(CODE_ADDRESS(_xt)) == (long)symbols[DODOES])) ? \
_xt+DOES_HANDLER_SIZE : 0L; })
/* this is a special version of DOES_CODE for use in dodoes */
#define DOES_CODE1(label) DOES_CODE(label)
#define DOES_CODE1(label) (CODE_ADDRESS(label)+DOES_HANDLER_SIZE)
/* this stores a jump dodoes at addr */
#define MAKE_DOES_CF(addr,doesp) ({long _addr = (long)(addr); \
......
......@@ -85,6 +85,7 @@ KERN_SRC = \
kernal.fs \
main.fs \
search-order.fs \
special.fs \
tools.fs \
toolsext.fs \
vars.fs \
......@@ -103,7 +104,6 @@ GFORTH_FI_SRC = \
glocals.fs \
hash.fs \
history.fs \
interpretation.fs \
look.fs \
search-order.fs \
see.fs \
......@@ -267,7 +267,7 @@ install: gforth $(FORTH_SRC) kernal.fi gforth.fi gforth.1 gforth.info* primitive
done
$(INSTALL_DATA) kernal.fi $(libdir)/gforth/$(VERSION)
$(FORTHK) startup.fs dumpimage.fs -e "savesystem $(libdir)/gforth/$(VERSION)/gforth.fi bye" #gforth.fi contains some path names
sed s:$(srcdir)/:$(datadir)/gforth/$(VERSION): gforth.TAGS >TAGS; $(INSTALL_DATA) TAGS $(datadir)/gforth/$(VERSION)
sed s:$(srcdir)/:$(datadir)/gforth/$(VERSION)/: gforth.TAGS >TAGS; $(INSTALL_DATA) TAGS $(datadir)/gforth/$(VERSION)
if test -d $(emacssitelispdir); then \
$(INSTALL_DATA) gforth.el $(emacssitelispdir); \
else \
......@@ -304,22 +304,22 @@ gforth: $(OBJECTS)
@MAKE_EXE@
kernl16l.fi-: $(KERN_SRC) mach16l.fs $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach16l.fs"' main.fs -e "save-cross kernl16l.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . -e 's" mach16l.fs"' main.fs -e "save-cross kernl16l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi-: $(KERN_SRC) mach16b.fs $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach16b.fs"' main.fs -e "save-cross kernl16b.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . -e 's" mach16b.fs"' main.fs -e "save-cross kernl16b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32l.fi-: $(KERN_SRC) mach32l.fs $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach32l.fs"' main.fs -e "save-cross kernl32l.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . -e 's" mach32l.fs"' main.fs -e "save-cross kernl32l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32b.fi-: $(KERN_SRC) mach32b.fs $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach32b.fs"' main.fs -e "save-cross kernl32b.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . -e 's" mach32b.fs"' main.fs -e "save-cross kernl32b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64l.fi-: $(KERN_SRC) mach64l.fs $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach64l.fs"' main.fs -e "save-cross kernl64l.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . -e 's" mach64l.fs"' main.fs -e "save-cross kernl64l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64b.fi-: $(KERN_SRC) mach64b.fs $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach64b.fs"' main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
$(FORTHK) -p . -e 's" mach64b.fs"' main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi: $(KERNLS)
-$(CP) kernl16b.fi kernl16b.fi~
......@@ -394,7 +394,7 @@ doc.fd: makedoc.fs float.fs search-order.fs glocals.fs environ.fs \
$(FORTHK) -p . -e "s\" doc.fd\"" makedoc.fs startup.fs code.fs -e bye
crossdoc.fd: $(KERN_SRC) $(FORTH_GEN0)
$(FORTHK) -p . interpretation.fs -e 's" mach32l.fs"' main.fs
$(FORTHK) -p . -e 's" mach32l.fs"' main.fs -e bye
gforth.texi: gforth.ds primitives.b ds2texi.fs prims2x.fs doc.fd crossdoc.fd
$(FORTHK) -p . ds2texi.fs -e "s\" gforth.ds\" r/o open-file throw ds2texi bye" >$@
......@@ -416,6 +416,8 @@ html: gforth.texi
-mkdir html
cd html; $(TEXI2HTML) -menu -split_node ../gforth.texi
doc: gforth.ps html
# For an explanation of the following Makefile rules, see node
# `Automatic Remaking' in GNU Autoconf documentation.
${srcdir}/configure: configure.in
......
......@@ -118,7 +118,7 @@ Defer flush-file
dup 0= -35 and throw
dup get-buffer >r
dup r@ buffer-block @ <>
r@ buffer-fid @ block-fid @ <> and
r@ buffer-fid @ block-fid @ <> or
if
r@ save-buffer
dup block-position
......
......@@ -35,13 +35,14 @@ vocabulary assembler ( -- ) \ tools-ext
\ execution semantics of @code{;code}
r> lastxt code-address! ;
: ;code ( colon-sys1 -- colon-sys2 ) \ tools-ext semicolon-code
:noname ( colon-sys1 -- colon-sys2 ) \ tools-ext semicolon-code
( create the [;code] part of a low level defining word )
;-hook postpone (;code) ?struc postpone [
defstart init-asm ; immediate
interpretation: ( -- colon-sys )
defstart init-asm ;
:noname ( -- colon-sys )
align here lastxt code-address!
defstart init-asm ;
special: ;code
: end-code ( colon-sys -- ) \ gforth end_code
( end a code definition )
......
......@@ -569,6 +569,9 @@ Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
(THeader ;Resolve ! there ;Resolve cell+ !
docol, depth T ] H ;
: :noname ( -- colon-sys )
T align H there docol, depth T ] H ;
Cond: EXIT ( -- ) restrict? compile ;S ;Cond
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
......@@ -703,6 +706,10 @@ DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder Defer
by Defer :dodefer resolve
Build: ( inter comp -- ) swap T immediate A, A, H ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder special:
\ Sturctures 23feb95py
>CROSS
......
......@@ -23,18 +23,17 @@
\ and deleting. Speed is not neccassary at this point.
AVARIABLE ErrLink \ Linked list entry point
0 ErrLink !
NIL ErrLink !
: ERR" ( n -- )
ErrLink linked
,
[char] " word count
[char] " parse
string, align ;
decimal
-1 ERR" Aborted"
ErrLink @ unlock reloff lock \ make sure that the terminating 0 is not relocated
-3 ERR" Stack overflow" -4 ERR" Stack underflow"
-5 ERR" Return stack overflow" -6 ERR" Return stack undeflow"
-7 ERR" Do-loops nested too deeply" -8 ERR" Dictionary overflow"
......
......@@ -39,9 +39,6 @@ decimal
' drop alias d>s ( d -- n ) \ double d_to_s
: dabs ( d1 -- d2 ) \ double
dup 0< IF dnegate THEN ;
: m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
>r s>d >r abs -rot
s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
......@@ -125,12 +122,6 @@ decimal
REPEAT
2drop 2drop rdrop false ;
\ ROLL 17may93jaw
: roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
dup 1+ pick >r
cells sp@ cell+ dup cell+ rot move drop r> ;
\ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
: source-id ( -- 0 | -1 | fileid ) \ core-ext source-i-d
......@@ -204,6 +195,6 @@ variable span ( -- a-addr ) \ core-ext
key decode ( maxlen span c-addr pos2 flag )
>r 2over = r> or
UNTIL
type-rest drop
2drop nip span ! ;
2 pick swap /string type
nip span ! ;
#! /usr/users/bernd/bin/gforth
#! /usr/local/lib/gforth/0.2.0/kernal.fi
\ file hex dump
Create buffer $10 allot
......
......@@ -132,8 +132,8 @@ typedef Label *Xt;
/* CODE_ADDRESS is the address of the code jumped to through the code field */
#define CODE_ADDRESS(cfa) (*(Label *)(cfa))
/* DOES_CODE is the Forth code does jumps to */
#define DOES_CODE(cfa) (cfa[1])
#define DOES_CODE1(cfa) DOES_CODE(cfa)
#define DOES_CODE(cfa) ((cfa[0] == symbols[DODOES]) ? cfa[1] : NULL)
#define DOES_CODE1(cfa) (cfa[1])
/* MAKE_CF creates an appropriate code field at the cfa;
ca is the code address */
#define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca))
......
......@@ -505,7 +505,14 @@ forth definitions
code-address!
then ;
: TO ( c|w|d|r "name" -- ) \ core-ext,local
:noname
' dup >definer [ ' locals-wordlist >definer ] literal =
if
>body !
else
-&32 throw
endif ;
:noname
0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
' dup >definer
case
......@@ -520,14 +527,8 @@ forth definitions
[ ' flocal >definer ] literal
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-&32 throw
endcase ; immediate
interpretation:
' dup >definer [ ' locals-wordlist >definer ] literal =
if
>body !
else
-&32 throw
endif ;
endcase ;
special: TO ( c|w|d|r "name" -- ) \ core-ext,local
: locals|
\ don't use 'locals|'! use '{'! A portable and free '{'
......
......@@ -84,8 +84,8 @@ Variable HashIndex
: clearhash ( -- )
HashTable Hashlen cells bounds
DO I @
BEGIN dup WHILE
dup @ swap HashPointer DelFix
BEGIN dup WHILE
dup @ swap HashPointer DelFix
REPEAT I !
cell +LOOP HashIndex off ;
......@@ -110,7 +110,7 @@ Create hashsearch-map ( -- wordlist-map )
THEN ;
: (initvoc) ( addr -- )
cell+ dup @ 0< IF drop EXIT THEN
cell+ dup @ 0< IF drop EXIT THEN
insRule @ >r insRule off hash-alloc
3 cells - hashsearch-map over cell+ ! dup
BEGIN @ dup WHILE 2dup swap (reveal REPEAT
......
\ History file support 16oct94py
\ command line edit and history support 16oct94py
\ Copyright (C) 1995 Free Software Foundation, Inc.
......@@ -18,6 +18,44 @@
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
:noname
char [char] @ - ;
:noname
char [char] @ - postpone Literal ;
special: ctrl ( "<char>" -- ctrl-code )
\ command line editing 16oct94py
: >string ( span addr pos1 -- span addr pos1 addr2 len )
over 3 pick 2 pick chars /string ;
: type-rest ( span addr pos1 -- span addr pos1 back )
>string tuck type ;
: (del) ( max span addr pos1 -- max span addr pos2 )
1- >string over 1+ -rot move
rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
: (ins) ( max span addr pos1 char -- max span addr pos2 )
>r >string over 1+ swap move 2dup chars + r> swap c!
rot 1+ -rot type-rest 1- backspaces 1+ ;
: ?del ( max span addr pos1 -- max span addr pos2 0 )
dup IF (del) THEN 0 ;
: (ret) type-rest drop true space ;
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
: eof 2 pick over or 0= IF
bye
ELSE 2 pick over <>
IF forw drop (del) ELSE #bell emit THEN 0
THEN ;
' forw ctrl F cells ctrlkeys + !
' back ctrl B cells ctrlkeys + !
' ?del ctrl H cells ctrlkeys + !
' eof ctrl D cells ctrlkeys + !
' (ins) IS insert-char
\ history support 16oct94py
0 Value history
2Variable forward^
......@@ -72,11 +110,6 @@ s" ~/.gforth-history" get-history
REPEAT 2drop THEN
tuck 2dup type 0 ;
: ctrl ( compilation: "<char>" -- ) ( run-time: -- ctrl-code )
char [char] @ - postpone Literal ; immediate
interpretation: ( "<char>" -- ctrl-code )
char [char] @ - ;
Create lfpad #lf c,
: (enter) ( max span addr pos1 -- max span addr pos2 true )
......
......@@ -154,10 +154,14 @@ extern void cacheflush(void *, int, int);
/* this is the point where the does code starts if label points to the
* jump dodoes */
# define DOES_CODE(cfa) ((Xt *)(((long *)(cfa))[1]))
/* this is a special version of DOES_CODE for use in dodoes */
# define DOES_CODE1(cfa) DOES_CODE(cfa) \
# define DOES_CODE1(cfa) ((Xt *)(((long *)(cfa))[1]))
# define DOES_CODE(cfa) \
(((((*(long *)(cfa)) & 0xF7E0E002) == 0xE0000000) && \
((long)(CODE_ADDRESS(CODE_ADDRESS(cfa))) == (long)symbols[DODOES])) ? \
DOES_CODE1(cfa) : 0L)
/* ({register Xt * _ret asm("%r31"); _ret;}) */
/* HPPA uses register 2 for branch and link */
......@@ -191,7 +195,7 @@ extern void cacheflush(void *, int, int);
} \
else \
{ \
fprintf(stderr,"DOESHANDLER assignment failed, use ITC instead of DTC\n"); exit(1); \
_ca -= 4; \
_cfa[0] = ((0x08 << 26) | \
((int)_ca<0) | \
(_ca & 0x00001800)<<1 | \
......
This diff is collapsed.
......@@ -101,6 +101,8 @@ void relocate(Cell *image, char *bitstring, int size, Label symbols[])
int i=0, j, k, steps=(size/sizeof(Cell))/8;
char bits;
/* static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/
/* printf("relocating %x[%x]\n", image, size); */
for(k=0; k<=steps; k++)
for(j=0, bits=bitstring[k]; j<8; j++, i++, bits<<=1)
......@@ -118,7 +120,10 @@ void relocate(Cell *image, char *bitstring, int size, Label symbols[])
case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((Cell)image));
break;
case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
default : image[i]=(Cell)CA(CF(image[i]));
default :
/* printf("Code field generation image[%x]:=CA(%x)\n",
i, CF(image[i]));
*/ image[i]=(Cell)CA(CF(image[i]));
}
else
image[i]+=(Cell)image;
......
......@@ -25,7 +25,8 @@
\ : ; ( colon-sys -- ) ?struc postpone exit reveal postpone [ ; immediate
\ : :noname ( -- xt colon-sys ) here [ ' : @ ] ALiteral cfa, 0 ] ;
[IFUNDEF] vocabulary include search-order.fs [THEN]
include search-order.fs
\ include etags.fs
include cross.fs \ include cross-compiler
......@@ -59,14 +60,15 @@ include aliases.fs \ include primitive aliases
include vars.fs \ variables and other stuff
include add.fs \ additional things
include errore.fs
include kernal.fs \ load kernal
include version.fs
include kernal.fs \ load kernal
include extend.fs \ load core-extended
include tools.fs \ load tools ( .s dump )
include toolsext.fs
include special.fs
\ include words.fs
\ include wordinfo.fs
\ include see.fs \ load see
include toolsext.fs
\ include search-order.fs
\ Setup 13feb93py
......
......@@ -80,10 +80,10 @@
/* this is the point where the does code starts if label points to the
* jump dodoes */
# define DOES_CODE(cfa) ((Xt *)(((char *)CODE_ADDRESS(cfa))+8))
# define DOES_CODE1(cfa) ((Xt *)(((char *)CODE_ADDRESS(cfa))+8))
/* this is a special version of DOES_CODE for use in dodoes */
# define DOES_CODE1(cfa) DOES_CODE(cfa)
# define DOES_CODE(cfa) DOES_CODE1(cfa)
# define DOES_HANDLER_SIZE 8
# define MAKE_DOES_CF(cfa,does_code) \
......
......@@ -20,7 +20,7 @@
warnings off
require interpretation.fs
\ require interpretation.fs
\ include float.fs
\ include search-order.fs
include glocals.fs
......
......@@ -26,13 +26,13 @@ Variable countif
: scanIF f83find dup 0= IF drop ['] dummy >name THEN ;
Create [struct]-search ' scanIF A, ' (reveal) A, ' drop A,
Create [struct]-voc NIL A, G [struct]-search T A,
Create [struct]-voc NIL A, [struct]-search A,
NIL A, NIL A,
: ?if countif @ 0<
IF [ [struct]-voc 3 cells + ] ALiteral @ lookup ! THEN ;
UNLOCK Tlast @ NIL Tlast ! LOCK
UNLOCK Tlast @ NIL Tlast ! LOCK
: [IF] 1 countif +! ?if ; immediate
: [THEN] -1 countif +! ?if ; immediate
......@@ -55,7 +55,7 @@ UNLOCK Tlast @ NIL Tlast ! LOCK
' \ Alias \ immediate
UNLOCK Tlast @ swap Tlast ! LOCK
1 cells - G [struct]-voc T !
1 cells - [struct]-voc !
\ Interpretative Structuren 30apr92py
......@@ -83,7 +83,7 @@ User (i)
: [LOOP] ( -- ) 1 rdrop rdrop ; immediate
: [FOR] ( n -- ) 0 swap postpone [DO] ; immediate
: [NEXT] ( n -- ) -1 rdrop rdrop ; immediate
: [I] ( -- index ) (I) @ postpone Literal ; immediate restrict
: [I] ( -- index ) (I) @ postpone Literal ; immediate
: [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ;
immediate
' [+LOOP] Alias [UNTIL] immediate
......
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