Commit 6f57f901 authored by anton's avatar anton

make now generates both images

the image names were changed
added C-level support for deferred words (dodefer)
made 2>r 2r> 2r@ 2rdrop primitives
some tuning of the outer interpreter; eliminated many words based on
 counted strings
Replaced the hash function with one that works better for larger tables
parent ccf34ea8
......@@ -35,7 +35,7 @@ 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 kernal.fi
FORTH_GEN = primitives.i prim_labels.i prim_alias.4th kernl32l.fi kernl32b.fi
all: gforth aliases.fs
......@@ -65,12 +65,17 @@ gforth: $(OBJECTS) $(FORTH_GEN)
-cp gforth gforth.old
$(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@
kernal.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
kernl32l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
$(FORTH_GEN)
-cp kernal.32limg kernal.32limg.old
$(FORTH) main.fs
machine32l.fs $(FORTH_GEN)
-cp kernl32l.fi kernl32l.fi.old
$(FORTH) -e 's" machine32l.fs" r/o open-file throw' main.fs
kernl32b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
machine32b.fs $(FORTH_GEN)
-cp kernl32b.fi kernl32b.fi.old
$(FORTH) -e 's" machine32b.fs" r/o open-file throw' main.fs
engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
$(GCC) $(CFLAGS) -S engine.c
......@@ -93,7 +98,8 @@ aliases.fs: primitives.b prims2x.fs
# $(EMACS) -batch -load primitives2c.el -funcall make-forth
#GNU make default rules
% :: RCS/%,v
co $@
%.o : %.c $(INCLUDES)
$(CC) $(CFLAGS) -c $< -o $@
#% :: RCS/%,v
# co $@
#%.o : %.c $(INCLUDES)
# $(CC) $(CFLAGS) -c $< -o $@
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.9 1994-07-21 10:52:37 pazsan Exp $
\ $Id: cross.fs,v 1.10 1994-08-25 15:25:20 anton Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -84,7 +84,7 @@ Variable tdp
\ Parameter for target systems 06oct92py
include machine.fs
include-file
>TARGET
......@@ -104,8 +104,9 @@ include machine.fs
-3 Constant :docon
-4 Constant :dovar
-5 Constant :douser
-6 Constant :dodoes
-7 Constant :doesjump
-6 Constant :dodefer
-7 Constant :dodoes
-8 Constant :doesjump
>CROSS
......@@ -295,7 +296,13 @@ variable ResolveFlag
Ghostnames
BEGIN @ dup
WHILE dup ?resolved
REPEAT drop ResolveFlag @ 0= IF ." Nothing!" THEN cr ;
REPEAT drop ResolveFlag @
IF
1 (bye)
ELSE
." Nothing!"
THEN
cr ;
>CROSS
\ Header states 12dec92py
......@@ -574,6 +581,7 @@ Builder Value
Build: ( -- ) compile noop ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder Defer
by Defer :dodefer resolve
\ structural conditionals 17dec92py
......
/*
$Id: engine.c,v 1.11 1994-07-13 19:21:02 pazsan Exp $
$Id: engine.c,v 1.12 1994-08-25 15:25:21 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -94,6 +94,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
&&docon,
&&dovar,
&&douser,
&&dodefer,
&&dodoes,
&&dodoes, /* dummy for does handler address */
#include "prim_labels.i"
......@@ -174,6 +175,13 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
#endif
NEXT;
dodefer:
#ifdef DEBUG
printf("%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
cfa = *(Xt *)PFA1(cfa);
NEXT1;
dodoes:
/* this assumes the following structure:
defining-word:
......
......@@ -14,10 +14,6 @@ decimal
(constant) , ;
\ !! 2value
: 2>r postpone swap postpone >r postpone >r ; immediate restrict
: 2r> postpone r> postpone r> postpone swap ; immediate restrict
: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
: 2Literal swap postpone Literal postpone Literal ;
immediate restrict
......
......@@ -70,13 +70,18 @@
scratch over c@ emit '. emit 1 /string type
'E emit . ;
: fnumber ( string -- r / )
?dup IF dup count >float 0=
IF defers notfound
ELSE drop state @
IF postpone FLiteral THEN THEN THEN ;
' fnumber IS notfound
: sfnumber ( c-addr u -- r / )
2dup >float
IF
2drop state @
IF
postpone FLiteral
THEN
ELSE
defers notfound
THEN ;
' sfnumber IS notfound
1e0 fasin 2e0 f* fconstant pi
......
/*
$Id: forth.h,v 1.7 1994-07-08 15:00:39 anton Exp $
$Id: forth.h,v 1.8 1994-08-25 15:25:24 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -13,8 +13,9 @@ typedef void *Label;
#define DOCON 1
#define DOVAR 2
#define DOUSER 3
#define DODOES 4
#define DOESJUMP 5
#define DODEFER 4
#define DODOES 5
#define DOESJUMP 6
/* Some versions of some unices (Linux) have the symbol BIG_ENDIAN defined
in their standard headers. Make sure it's undefined -- Lennart */
......
......@@ -20,7 +20,7 @@
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.7 1994-08-19 17:47:20 anton Exp $
;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.8 1994-08-25 15:25:26 anton Exp $
;;-------------------------------------------------------------------
;; A Forth indentation, documentation search and interaction library
......
\ Hashed dictionaries 15jul94py
$80 Value Hashlen
7 value hashbits
1 hashbits lshift Value Hashlen
Variable insRule insRule on
......@@ -22,12 +23,15 @@ Variable HashPointer
\ compute hash key 15jul94py
: hash ( addr len -- key ) (hashkey)
\ tuck bounds ?DO I c@ toupper + LOOP
Hashlen 1- and ;
: hash ( addr len -- key )
hashbits (hashkey1) ;
\ (hashkey)
\ Hashlen 1- and ;
: hash-find ( addr len wordlist -- nfa / false ) $C + @ >r
2dup hash cells r> + @ (hashfind) ;
: hash-find ( addr len wordlist -- nfa / false )
$C + @ >r
2dup hash cells r> + @ (hashfind) ;
\ BEGIN dup WHILE
\ 2@ >r >r dup r@ cell+ c@ $1F and =
\ IF 2dup r@ cell+ char+ capscomp 0=
......@@ -51,16 +55,18 @@ Variable HashPointer
Create hashsearch ' hash-find A, ' hash-reveal A, ' drop A,
: (initvoc ( addr -- ) cell+ dup @ 0< IF drop EXIT THEN
insRule @ >r insRule off hash-alloc
3 cells - hashsearch over cell+ ! dup
BEGIN @ dup WHILE 2dup swap (reveal REPEAT
2drop r> insRule ! ;
: (initvoc ( addr -- )
cell+ dup @ 0< IF drop EXIT THEN
insRule @ >r insRule off hash-alloc
3 cells - hashsearch over cell+ ! dup
BEGIN @ dup WHILE 2dup swap (reveal REPEAT
2drop r> insRule ! ;
' (initvoc IS 'initvoc
: addall ( -- ) voclink
BEGIN @ dup @ WHILE dup (initvoc REPEAT drop ;
: addall ( -- )
voclink
BEGIN @ dup @ WHILE dup (initvoc REPEAT drop ;
\ Hash-Find 01jan93py
......@@ -74,3 +80,24 @@ addall \ Baum aufbauen
dup cell+ @ .name REPEAT drop
LOOP drop r> base ! ;
\ \ this stuff is for evaluating the hash function
\ : square dup * ;
\ : countwl ( -- sum sumsq )
\ \ gives the number of words in the current wordlist and the sum of
\ \ squares for the sublist lengths
\ 0 0
\ context @ 3 cells + @ hashlen cells over + swap DO
\ 0 i BEGIN
\ @ dup WHILE
\ swap 1+ swap
\ REPEAT
\ drop
\ swap over square +
\ >r + r>
\ 1 cells
\ +LOOP ;
\ : chisq ( -- n )
\ \ n should have about the same size as hashlen
\ countwl hashlen 2 pick */ swap - ;
......@@ -142,7 +142,10 @@ Defer source
dup count chars bounds
?DO I c@ toupper I c! 1 chars +LOOP ;
: (name) ( -- addr ) bl word ;
\ : (cname) ( -- addr ) bl word capitalize ;
: sname ( -- c-addr count )
source 2dup >r >r >in @ /string (parse-white)
2dup + r> - 1+ r> min >in ! ;
\ name count ;
\ Literal 17dec92py
......@@ -203,9 +206,20 @@ Create bases 10 , 2 , A , 100 ,
REPEAT THEN 2drop rdrop dpl off ELSE
2drop rdrop r> IF dnegate THEN
THEN r> base ! ;
: snumber? ( c-addr u -- 0 / n -1 / d 0> )
s>number dpl @ 0=
IF
2drop false EXIT
THEN
dpl @ dup 0> 0= IF
nip
THEN ;
: number? ( string -- string 0 / n -1 / d 0> )
dup count s>number dpl @ 0= IF 2drop false EXIT THEN
rot drop dpl @ dup 0> 0= IF nip THEN ;
dup >r count snumber? dup if
rdrop
else
r> swap
then ;
: s>d ( n -- d ) dup 0< ;
: number ( string -- d )
number? ?dup 0= abort" ?" 0< IF s>d THEN ;
......@@ -304,30 +318,67 @@ hex
Defer parser
Defer name ' (name) IS name
Defer notfound
Defer notfound ( c-addr count -- )
: no.extensions ( string -- ) IF -&13 bounce THEN ;
: no.extensions ( addr u -- ) 2drop -&13 bounce ;
' no.extensions IS notfound
: interpret
BEGIN ?stack name dup c@ WHILE parser REPEAT drop ;
\ interpreter compiler 30apr92py
: interpreter ( name -- ) find ?dup
IF 1 and IF execute EXIT THEN -&14 throw THEN
number? 0= IF notfound THEN ;
BEGIN
?stack sname dup
WHILE
parser
REPEAT
2drop ;
\ sinterpreter scompiler 30apr92py
: sinterpreter ( c-addr u -- )
\ interpretation semantics for the name/number c-addr u
2dup sfind dup
IF
1 and
IF \ not restricted to compile state?
nip nip execute EXIT
THEN
-&14 throw
THEN
drop
2dup 2>r snumber?
IF
2rdrop
ELSE
2r> notfound
THEN ;
' interpreter IS parser
' sinterpreter IS parser
: compiler ( name -- ) find ?dup
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup
IF 0> IF swap postpone Literal THEN postpone Literal
ELSE drop notfound THEN ;
: scompiler ( c-addr u -- )
\ compilation semantics for the name/number c-addr u
2dup sfind dup
IF
0>
IF
nip nip execute EXIT
THEN
compile, 2drop EXIT
THEN
drop
2dup snumber? dup
IF
0>
IF
swap postpone Literal
THEN
postpone Literal
2drop
ELSE
drop notfound
THEN ;
: [ ['] interpreter IS parser state off ; immediate
: ] ['] compiler IS parser state on ;
: [ ['] sinterpreter IS parser state off ; immediate
: ] ['] scompiler IS parser state on ;
\ locals stuff needed for control structures
......@@ -839,11 +890,14 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
\ IS Defer What's Defers TO 24feb93py
: Defer
Create ( -- )
['] noop A,
DOES> ( ??? )
@ execute ;
: Defer ( -- )
\ !! shouldn't it be initialized with abort or something similar?
Header Reveal [ :dodefer ] Literal cfa,
['] noop A, ;
\ Create ( -- )
\ ['] noop A,
\ DOES> ( ??? )
\ @ execute ;
: IS ( addr "name" -- )
' >body
......@@ -936,8 +990,14 @@ Variable warnings G -1 warnings T !
then
2drop 2drop ;
: find ( addr -- cfa +-1 / string false ) dup
count search @ search-wordlist dup IF rot drop THEN ;
: sfind ( c-addr u -- xt n / 0 )
search @ search-wordlist ;
: find ( addr -- cfa +-1 / string false )
\ !! not ANS conformant: returns +-2 for restricted words
dup count sfind dup if
rot drop
then ;
: reveal ( -- )
last? if
......@@ -947,7 +1007,7 @@ Variable warnings G -1 warnings T !
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ;
: ' ( "name" -- addr ) name find 0= no.extensions ;
: ' ( "name" -- addr ) name find 0= if drop -&13 bounce then ;
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
\ Input 13feb93py
......
/*
$Id: main.c,v 1.8 1994-07-13 19:21:04 pazsan Exp $
$Id: main.c,v 1.9 1994-08-25 15:25:30 anton Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -63,7 +63,9 @@ void relocate(int *image, char *bitstring, int size, Label symbols[])
case CF(DOCOL) :
case CF(DOVAR) :
case CF(DOCON) :
case CF(DOUSER) : MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DOUSER) :
case CF(DODEFER) :
MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((int)image));
break;
case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
......
......@@ -54,9 +54,9 @@ LOCK
cr cr
endian [IF]
save-cross kernal.32bimg
save-cross kernl32b.fi
[ELSE]
save-cross kernal.32limg
save-cross kernl32l.fi
[THEN] cr
bye
......@@ -488,6 +488,21 @@ rp++;
i' -- w fig i_tick
w=rp[1];
2>r w1 w2 -- core-ext two_to_r
*--rp = w1;
*--rp = w2;
2r> -- w1 w2 core-ext two_r_from
w2 = *rp++;
w1 = *rp++;
2r@ -- w1 w2 core-ext two_r_fetch
w2 = rp[0];
w1 = rp[1];
2rdrop -- new two_r_drop
rp+=2;
over w1 w2 -- w1 w2 w1 core,fig
drop w -- core,fig
......@@ -644,11 +659,26 @@ while(a_addr != NULL)
}
}
(hashkey) c_addr u1 -- u2 new paren_hashkey
(hashkey) c_addr u1 -- u2 new paren_hashkey
u2=0;
while(u1--)
u2+=(int)toupper(*c_addr++);
(hashkey1) c_addr u ubits -- ukey new paren_hashkey1
""ukey is the hash key for the string c_addr u fitting in ubits bits""
/* this hash function rotates the key at every step by rot bits within
ubits bits and xors it with the character. This function does ok in
the chi-sqare-test. Rot should be <=7 (preferably <=5) for
ASCII strings (larger if ubits is large), and should share no
divisors with ubits.
*/
unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits];
Char *cp = c_addr;
for (ukey=0; cp<c_addr+u; cp++)
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
^ toupper(*cp))
& ((1<<ubits)-1));
(parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white
/* use !isgraph instead of isspace? */
Char *endp = c_addr1+u1;
......
......@@ -89,7 +89,7 @@ variable effect-out-end ( pointer )
2variable effect-in-size
2variable effect-out-size
variable primitive-number -8 primitive-number !
variable primitive-number -9 primitive-number !
\ for several reasons stack items of a word are stored in a wordlist
\ since neither forget nor marker are implemented yet, we make a new
......
......@@ -115,4 +115,4 @@ Root definitions
Forth definitions
[IFDEF] (hashkey) include hash.fs [THEN]
include hash.fs
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