Commit 8fa99ebf authored by pazsan's avatar pazsan

Added dictionary hashing

Changed argument interpretation as documented
Made refill for DOS 20 times faster
Added m*/ and missing FP words.
parent 94db3dc0
......@@ -2,13 +2,14 @@
RM = echo 'Trying to remove'
GCC = gcc
FORTH = ansforth
CC = gcc
SWITCHES = -D_POSIX_VERSION -DDEFAULTBIN='"'`pwd`'"' #-DNDEBUG #turn off assertions
SWITCHES = -D_POSIX_VERSION -DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'`pwd`'"' -DDIRECT_THREADED #-DNDEBUG #turn off assertions
CFLAGS = -O4 -Wall -g $(SWITCHES)
#-Xlinker -n puts text and data into the same 256M region
#John Wavrik should use -Xlinker -N to get a writable text (executable)
LDFLAGS = -g # -Xlinker -N
LDFLAGS = -g -Xlinker -N
LDLIBS = -lm
EMACS = emacs
......@@ -34,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.32limg
FORTH_GEN = primitives.i prim_labels.i prim_alias.4th kernal.fi
all: ansforth aliases.fs
......@@ -64,11 +65,11 @@ ansforth: $(OBJECTS) $(FORTH_GEN)
-cp ansforth ansforth.old
$(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@
kernal.32limg: search-order.fs cross.fs aliases.fs vars.fs add.fs \
kernal.fi: search-order.fs cross.fs aliases.fs vars.fs add.fs \
environ.fs errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
$(FORTH_GEN)
-cp kernal.32limg kernal.32limg.old
ansforth "include main.fs"
$(FORTH) main.fs
engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
......@@ -80,16 +81,13 @@ primitives.b: primitives
m4 primitives >$@
primitives.i : primitives.b prims2x.fs
ansforth "include prims2x.fs s\" primitives.b\" ' output-c process-file bye" >$@
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-c process-file bye" >$@
prim_labels.i : primitives.b prims2x.fs
ansforth "include prims2x.fs s\" primitives.b\" ' output-label process-file bye" >$@
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-label process-file bye" >$@
prim_alias.4th: primitives.b prims2x.fs
ansforth "include prims2x.fs s\" primitives.b\" ' output-alias process-file bye" >$@
aliases.fs: prim_alias.4th
cp prim_alias.4th $@
aliases.fs: primitives.b prims2x.fs
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-alias process-file bye" >$@
#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.8 1994-07-13 19:20:59 pazsan Exp $
\ $Id: cross.fs,v 1.9 1994-07-21 10:52:37 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -21,7 +21,7 @@
\ targets 09jun93jaw
\ added: 2user and value 11jun93jaw
include other.fs \ ansforth extentions for cross
\ include other.fs \ ansforth extentions for cross
: comment? ( c-addr u -- c-addr u )
2dup s" (" compare 0=
......@@ -31,47 +31,6 @@ include other.fs \ ansforth extentions for cross
decimal
\ number? 11may93jaw
\ checks for +, -, $, & ...
: leading? ( c-addr u -- c-addr u doubleflag negflag base )
2dup 1- chars + c@ [char] . = \ process double
IF dup 1 chars = IF over 1 swap c! false ELSE 1 chars - true THEN
\ only if more than only . ( may be number output! )
\ if only . => store garbage
ELSE false THEN >r \ numbers
false -rot base @ -rot
BEGIN over c@
dup [char] - =
IF drop >r >r >r
drop true r> r> r> 0 THEN
dup [char] + =
IF drop 0 THEN
dup [char] $ =
IF drop >r >r drop 16 r> r> 0 THEN
dup [char] & =
IF drop >r >r drop 10 r> r> 0 THEN
0= IF 1 chars - swap char+ swap false ELSE true THEN
over 0= or
UNTIL
rot >r rot r> r> -rot ;
: number? ( c-addr -- n/d flag )
\ return -1 if cell 1 if double 0 if garbage
0 swap 0 swap \ create double number
count leading?
base @ >r base !
>r >r
>number IF 2drop false r> r> 2drop
r> base ! EXIT THEN
drop r> r>
IF IF dnegate 1
ELSE drop negate -1 THEN
ELSE IF 1 ELSE drop -1 THEN
THEN r> base ! ;
\ Begin CROSS COMPILER:
\ GhostNames 9may93jaw
......@@ -424,6 +383,7 @@ ghost unloop ghost ;S 2drop
ghost lit ghost (compile) ghost ! 2drop drop
ghost (;code) ghost noop 2drop
ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost '
\ compile 10may93jaw
......@@ -682,6 +642,8 @@ Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond
Cond: IS T ' >body H compile ALiteral compile ! ;Cond
: IS T ' >body ! H ;
Cond: TO T ' >body H compile ALiteral compile ! ;Cond
: TO T ' >body ! H ;
\ LINKED ERR" ENV" 2ENV" 18may93jaw
......
......@@ -14,13 +14,18 @@ decimal
(constant) , ;
\ !! 2value
: 2>r postpone >r postpone >r ; immediate restrict
: 2r> postpone r> postpone r> ; immediate restrict
: 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
: m*/ ( d1 n2 u3 -- dqout ) >r s>d >r abs -rot
s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
r> IF dnegate THEN ;
\ CASE OF ENDOF ENDCASE 17may93jaw
\ just as described in dpANS5
......@@ -49,9 +54,8 @@ decimal
\ UNUSED 17may93jaw
: unused forthstart dup @ over 2 cells + @ -
512 - \ for stack
+ here - ;
: unused s0 @ 512 - \ for stack
here - ;
\ [COMPILE] 17may93jaw
......@@ -80,20 +84,20 @@ decimal
\ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
: source-id ( -- 0 | -1 | fileid )
loadfile @ dup 0= IF drop linestart @ THEN ;
loadfile @ dup 0= IF drop loadline @ 0 min THEN ;
: save-input ( -- x1 .. xn n )
>in @
loadfile @ ?dup
IF linestart 2@ loadline @ 6
ELSE loadline @ blk @ linestart @ 5 THEN
>tib @ swap ; \ >tib for security
IF dup file-position throw loadline @ >tib @ 6
#tib @ >tib +!
ELSE loadline @ blk @ linestart @ >tib @ 5 THEN
;
: restore-input ( x1 .. xn n -- flag )
1- swap >tib @ <> IF discard true EXIT THEN
5 = IF loadline ! 2dup linestart 2! rot dup loadfile !
swap >tib !
6 = IF loadline ! rot dup loadfile !
reposition-file IF drop true EXIT THEN
refill 0= IF drop true EXIT THEN
ELSE linestart ! blk !
dup loadline @ <> IF 2drop true EXIT THEN
loadline !
......
\ High level floating point 14jan94py
1 cells 4 = [IF]
' cells Alias sfloats
' cell+ Alias sfloat+
' align Alias sfalign
' aligned Alias sfaligned
[ELSE]
: sfloats 4 * ;
: sfloat+ 4 + ;
: sfaligned ( addr -- addr' ) 3 + -4 and ;
: sfalign ( -- ) here dup sfaligned swap ?DO bl c, LOOP ;
[THEN]
1 floats 8 = [IF]
' floats Alias dfloats
' float+ Alias dfloat+
' falign Alias dfalign
' faligned Alias dfaligned
[ELSE]
: dfloats 8 * ;
: dfloat+ 8 + ;
: dfaligned ( addr -- addr' ) 7 + -8 and ;
: dfalign ( -- ) here dup dfaligned swap ?DO bl c, LOOP ;
[THEN]
: f, ( f -- ) here 1 floats allot f! ;
\ !! have create produce faligned pfas
......@@ -55,3 +79,18 @@
' fnumber IS notfound
1e0 fasin 2e0 f* fconstant pi
: f2* 2e0 f* ;
: f2/ 2e0 f/ ;
: 1/f 1e0 fswap f/ ;
: falog ( f -- 10^f ) [ 10e0 fln ] FLiteral f* fexp ;
: fsinh fexpm1 fdup fdup 1e0 f+ f/ f+ f2/ ;
: fcosh fexp fdup 1/f f+ f2/ ;
: ftanh f2* fexpm1 fdup 2e0 f+ f/ ;
: fatanh fdup f0< >r fabs 1e0 fover f- f/ f2* flnp1 f2/
r> IF fnegate THEN ;
: facosh fdup fdup f* 1e0 f- fsqrt f+ fln ;
: fasinh fdup fdup f* 1e0 f+ fsqrt f/ fatanh ;
......@@ -16,7 +16,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.3 1994-07-08 15:00:41 anton Exp $
;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.4 1994-07-21 10:52:42 pazsan Exp $
;;-------------------------------------------------------------------
;; A Forth indentation, documentation search and interaction library
......@@ -617,7 +617,7 @@ The region is sent terminated by a newline."
;; Misc
(setq auto-mode-alist (append auto-mode-alist
'(("\\.f83$" . forth-mode))))
'(("\\.fs$" . forth-mode))))
(defun forth-split ()
(interactive)
......
\ Hashed dictionaries 15jul94py
$80 Value Hashlen
Variable insRule insRule on
\ Memory handling 15jul94py
Variable HashPointer
: hash-alloc ( addr -- addr ) dup @ 0= IF
Hashlen cells allocate throw over !
dup @ Hashlen cells erase THEN ;
\ DelFix and NewFix is from bigFORTH 15jul94py
: DelFix ( addr root -- ) dup @ 2 pick ! ! ;
: NewFix ( root len # -- addr )
BEGIN 2 pick @ ?dup 0= WHILE 2dup * allocate throw
over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
\ compute hash key 15jul94py
: hash ( addr len -- key ) (hashkey)
\ tuck bounds ?DO I c@ toupper + LOOP
Hashlen 1- and ;
: 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=
\ IF 2drop r> rdrop EXIT THEN THEN
\ rdrop r>
\ REPEAT nip nip ;
\ hash vocabularies 16jul94py
: lastlink! ( addr link -- )
BEGIN dup @ dup WHILE nip REPEAT drop ! ;
: (reveal ( addr voc -- ) $C + dup @ 0< IF 2drop EXIT THEN
hash-alloc @ over cell+ count $1F and Hash cells + >r
HashPointer 8 $400 NewFix
tuck cell+ ! r> insRule @
IF dup @ 2 pick ! ! ELSE lastlink! THEN ;
: hash-reveal ( -- ) (reveal) last? IF
current @ (reveal THEN ;
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 IS 'initvoc
: addall ( -- ) voclink
BEGIN @ dup @ WHILE dup (initvoc REPEAT drop ;
\ Hash-Find 01jan93py
addall \ Baum aufbauen
\ Baumsuche ist installiert.
: .words ( -- )
base @ >r hex context @ 3 cells + HashLen 0
DO cr i 2 .r ." : " dup @ i cells +
BEGIN @ dup WHILE
dup cell+ @ .name REPEAT drop
LOOP drop r> base ! ;
......@@ -142,7 +142,7 @@ Defer source
dup count chars bounds
?DO I c@ toupper I c! 1 chars +LOOP ;
: (name) ( -- addr ) bl word ;
: (cname) ( -- addr ) bl word capitalize ;
\ : (cname) ( -- addr ) bl word capitalize ;
\ Literal 17dec92py
......@@ -194,15 +194,18 @@ Create bases 10 , 2 , A , 100 ,
\ !! this saving and restoring base is an abomination! - anton
: getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u<
IF cells bases + @ base ! 1 /string ELSE drop THEN ;
: number? ( string -- string 0 / n -1 ) base @ >r
dup count over c@ [char] - = dup >r IF 1 /string THEN
: s>number ( addr len -- d ) base @ >r dpl on
over c@ '- = dup >r IF 1 /string THEN
getbase dpl on 0 0 2swap
BEGIN dup >r >number dup WHILE dup r> - WHILE
dup dpl ! over c@ [char] . = WHILE
1 /string
REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN
2drop rot drop rdrop r> IF dnegate THEN
dpl @ dup 0< IF nip THEN r> base ! ;
REPEAT THEN 2drop rdrop dpl off ELSE
2drop rdrop r> IF dnegate THEN
THEN r> base ! ;
: 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 ;
: s>d ( n -- d ) dup 0< ;
: number ( string -- d )
number? ?dup 0= abort" ?" 0< IF s>d THEN ;
......@@ -303,7 +306,7 @@ Defer parser
Defer name ' (name) IS name
Defer notfound
: no.extensions ( string -- ) IF &-13 bounce THEN ;
: no.extensions ( string -- ) IF -&13 bounce THEN ;
' no.extensions IS notfound
......@@ -730,7 +733,7 @@ defer header
: name, ( "name" -- )
name c@
dup $1F u> &-19 and throw ( is name too long? )
dup $1F u> -&19 and throw ( is name too long? )
1+ chars allot align ;
: input-stream-header ( "name" -- )
\ !! this is f83-implementation-dependent
......@@ -756,7 +759,7 @@ create nextname-buffer 32 chars allot
\ the next name is given in the string
: nextname ( c-addr u -- ) \ general
dup $1F u> &-19 and throw ( is name too long? )
dup $1F u> -&19 and throw ( is name too long? )
nextname-buffer c! ( c-addr )
nextname-buffer count move
['] nextname-header IS header ;
......@@ -854,7 +857,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
state @ IF postpone ALiteral postpone @ ELSE @ THEN ;
immediate
: Defers ( "name" -- ) ' >body @ compile, ;
immediate restrict
immediate
\ : ; 24feb93py
......@@ -903,14 +906,9 @@ AVariable current
\ end-struct wordlist-struct
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ;
: f83casefind ( addr len wordlist -- nfa / false ) @ (f83casefind) ;
\ Search list table: find reveal
Create f83search ' f83casefind A, ' (reveal) A, ' drop A,
: caps-name ['] (cname) IS name ['] f83find f83search ! ;
: case-name ['] (name) IS name ['] f83casefind f83search ! ;
: case-sensitive ['] (name) IS name ['] f83find f83search ! ;
Create f83search ' f83find A, ' (reveal) A, ' drop A,
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
AVariable search G forth-wordlist search T !
......@@ -1024,9 +1022,9 @@ DEFER Emit
: refill ( -- flag )
tib /line
loadfile @ ?dup
IF dup file-position throw linestart 2!
IF \ dup file-position throw linestart 2!
read-line throw
ELSE linestart @ IF 2drop false EXIT THEN
ELSE loadline @ 0< IF 2drop false EXIT THEN
accept true
THEN
1 loadline +!
......@@ -1060,17 +1058,20 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
\ include-file 07apr93py
: include-file ( i*x fid -- j*x )
linestart @ >r loadline @ >r loadfile @ >r
blk @ >r >tib @ >r #tib @ dup >r >in @ >r
: push-file ( -- ) r>
( linestart 2@ >r >r ) loadline @ >r loadfile @ >r
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ;
: pop-file ( -- ) r>
r> >in ! r> #tib ! r> >tib ! r> blk !
r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;
>tib +! loadfile !
: include-file ( i*x fid -- j*x )
push-file loadfile !
0 loadline ! blk off
BEGIN refill WHILE interpret REPEAT
loadfile @ close-file throw
r> >in ! r> #tib ! r> >tib ! r> blk !
r> loadfile ! r> loadline ! r> linestart ! ;
pop-file ;
: included ( i*x addr u -- j*x )
loadfilename 2@ >r >r
......@@ -1111,16 +1112,12 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
\ EVALUATE 17may93jaw
: evaluate ( c-addr len -- )
linestart @ >r loadline @ >r loadfile @ >r
blk @ >r >tib @ >r #tib @ dup >r >in @ >r
>tib +! dup #tib ! >tib @ swap move
>in off blk off loadfile off -1 linestart !
push-file dup #tib ! >tib @ swap move
>in off blk off loadfile off -1 loadline !
BEGIN interpret >in @ #tib @ u>= UNTIL
r> >in ! r> #tib ! r> >tib ! r> blk !
r> loadfile ! r> loadline ! r> linestart ! ;
pop-file ;
: abort -1 throw ;
......@@ -1205,35 +1202,55 @@ Variable env
Variable argv
Variable argc
: get-args ( -- ) #tib off
argc @ 1 ?DO I arg 2dup source + swap move
#tib +! drop bl source + c! 1 #tib +! LOOP
>in off #tib @ 0<> #tib +! ;
0 Value script? ( -- flag )
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ;
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap
2dup s" -e" compare 0= >r
2dup s" -evaluate" compare 0= r> or
IF 2drop ">tib interpret 2 EXIT THEN
." Unknown option: " type cr 2drop 1 ;
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ;
: process-args ( -- ) argc @ 1
?DO I arg over c@ [char] - <>
IF true to script? included false to script? 1
ELSE I 1+ arg do-option
THEN
+LOOP ;
: cold ( -- )
argc @ 1 >
IF script?
IF
1 arg ['] included
ELSE
get-args ['] interpret
THEN
catch ?dup
IF
['] process-args catch ?dup
IF
dup >r DoError cr r> (bye)
dup >r DoError cr r> negate (bye)
THEN
THEN
cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation"
cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" cr
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
cr quit ;
: license ( -- ) cr
." This program is free software; you can redistribute it and/or modify" cr
." it under the terms of the GNU General Public License as published by" cr
." the Free Software Foundation; either version 1, or (at your option)" cr
." any later version." cr cr
." This program is distributed in the hope that it will be useful," cr
." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr
." GNU General Public License for more details." cr cr
." You should have received a copy of the GNU General Public License" cr
." along with this program; if not, write to the Free Software" cr
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
: boot ( **env **argv argc -- )
argc ! argv ! env ! main-task up!
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;
: bye cr 0 (bye) ;
: bye script? 0= IF cr THEN 0 (bye) ;
\ **argv may be scanned by the C starter to get some important
\ information, as -display and -geometry for an X client FORTH
......
......@@ -7,7 +7,7 @@
\ : ; ( colon-sys -- ) ?struc postpone exit reveal postpone [ ; immediate
\ : :noname ( -- xt colon-sys ) here [ ' : @ ] ALiteral cfa, 0 ] ;
include search-order.fs
[IFUNDEF] vocabulary include search-order.fs [THEN]
include cross.fs \ include cross-compiler
......
......@@ -10,7 +10,7 @@
dup count chars bounds
?DO I c@ [char] a [char] { within
IF I c@ bl - I c! THEN 1 chars +LOOP ;
: name bl word capitalize ;
: name bl word ( capitalize ) ;
: on true swap ! ;
: off false swap ! ;
: place ( adr len adr )
......
......@@ -164,7 +164,7 @@ rp += 2;
*--rp = nlimit;
*--rp = nstart;
:
swap >r >r ;
r> -rot swap >r >r >r ;
(?do) nlimit nstart -- core-ext paren_question_do
*--rp = nlimit;
......@@ -392,7 +392,7 @@ d2 = 2*d1;
d2/ d1 -- d2 double d_two_slash
/* !! is this still correct? */
d2 = d1/2;
d2 = d1>>1;
d>s d -- n double d_to_s
/* make this an alias for drop? */
......@@ -623,19 +623,32 @@ a_addr2 = realloc(a_addr1, u);
wior = a_addr2==NULL; /* !! Define a return code */
(f83find) c_addr u f83name1 -- f83name2 new paren_f83find
for (; f83name1 != NULL; f83name1 = f83name1->next)
if (F83NAME_COUNT(f83name1)==u &&
strncmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;
f83name2=f83name1;
(f83casefind) c_addr u f83name1 -- f83name2 new paren_f83casefind
for (; f83name1 != NULL; f83name1 = f83name1->next)
if (F83NAME_COUNT(f83name1)==u &&
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;
f83name2=f83name1;
(hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
F83Name *f83name1;
f83name2=NULL;
while(a_addr != NULL)
{
f83name1=(F83Name *)(a_addr[1]);
a_addr=(Cell *)(a_addr[0]);
if (F83NAME_COUNT(f83name1)==u &&
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
{
f83name2=f83name1;
break;
}
}
(hashkey) c_addr u1 -- u2 new paren_hashkey
u2=0;
while(u1--)
u2+=(int)toupper(*c_addr++);
(parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white
/* use !isgraph instead of isspace? */
Char *endp = c_addr1+u1;
......@@ -710,10 +723,25 @@ wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
/* !! who performs clearerr((FILE *)wfileid); ? */
read-line c_addr u1 wfileid -- u2 flag wior file read_line
if ((flag=FLAG(!feof((FILE *)wfileid)))) {
char *s = fgets(c_addr,u1+1,(FILE *)wfileid);
/*
Cell c;
flag=-1;
for(u2=0; u2<u1; u2++)
{
*c_addr++ = (Char)(c = getc((FILE *)wfileid));
if(c=='\n') break;
if(c==EOF)
{
flag=FLAG(u2!=0);
break;
}
}
wior=FILEIO(ferror((FILE *)wfileid));
*/
if ((flag=FLAG(!feof((FILE *)wfileid) &&
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
wior=FILEIO(ferror((FILE *)wfileid));
u2=strlen(c_addr);
u2 = strlen(c_addr);
u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
}
else {
......
......@@ -21,8 +21,8 @@
warnings off
[IFUNDEF] vocabulary include search-order.fs [THEN]
include gray.fs
include search-order.fs
100 constant max-effect \ number of things on one side of a stack effect
4096 constant batch-size \ no meaning, just make sure it's >0
......@@ -543,4 +543,5 @@ set-current
endif
warnings @ if
." ------------ CUT HERE -------------" cr endif
r> [ ] primfilter [ 0 ] ;
r> primfilter ;
......@@ -2,8 +2,8 @@
$10 constant maxvp
Variable vp
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
: get-current ( -- wid ) current @ ;
: set-current ( wid -- ) current ! ;
......@@ -11,58 +11,18 @@ Variable vp
: context ( -- addr ) vp dup @ cells + ;
: definitions ( -- ) context @ current ! ;
\ hash search 29may94py
\ uses a direct hash mapped cache --- idea from Heinz Schnitter
\ : hashkey ( addr count -- key )
\ swap c@ toupper 3 * + $3F and ; \ gives a simple hash key
\ Variable hits
\ Variable fails
\ : hash-find ( addr count wid -- nfa / false )
\ >r 2dup hashkey
\ cells r@ 3 cells + @ + \ hashed addr
\ dup @
\ IF >r r@ @ cell+ c@ over =
\ IF 2dup r@ @ cell+ char+ capscomp 0=
\ IF 2drop r> @ rdrop 1 hits +! EXIT THEN THEN
\ r>
\ THEN r> swap >r @ (f83casefind) dup
\ IF dup r@ ! THEN rdrop 1 fails +! ;
\ : hash-reveal ( -- )
\ last?
\ IF dup cell+ count hashkey cells
\ current @ 3 cells + @ + !
\ (reveal)
\ THEN ;
\ : clear-hash ( wid -- ) 3 cells + @ $40 cells erase ;
\ Create hashsearch
\ ' hash-find A, ' hash-reveal A, ' clear-hash A,
\ for testing
\ : .hash ( wid -- ) 3 cells + @ ?dup