Commit 82cfb4ab authored by pazsan's avatar pazsan

Made block 0 the first block and provided OFFSET for backward compatibility

(store 1 there).
Fixed bug for negative buffers.
Added a type in write-file for OS-less ports.
Some corrections to make the SHARC port compile again.
HAS_DEBUG is now a central flag which replaces perror and fprintf if not set.
parent c8aedee0
\ display block 29aug95pyVocabulary editor Variable r# Variable len 2Variable mark Create rbuf $100 allot Create ibuf $100 allot Create fbuf $100 allot : rvson $1B emit ." [7m" ; : rvsoff $1B emit ." [0m" ; : hi r# @ c/l /mod 1+ swap 3 + swap at-xy rvson scr @ block r# @ + len @ type rvsoff 0 &17 at-xy ; : l editor page list hi ; : v scr @ l ; : delete ( buffer size count -- ) over min >r r@ - ( left over ) dup 0> IF 2dup swap dup r@ + -rot swap move THEN + r> blank ; : insert ( string length buffer size -- ) rot over min >r r@ - over dup r@ + rot move r> move ; : replace ( string length buffer size -- ) rot min move ; editor definitions --> \ in screen command 29aug95py: m scr @ r# @ mark 2! ; : a mark 2@ m r# ! l ; : c r# +! 1 len ! v ; : 'rest ( -- a u ) scr @ block chars/block r# @ /string ; : 'line ( -- a u ) 'rest 1- c/l 1- and 1+ ; : 'par ( buf -- a u ) >r 0 parse dup 0= IF 2drop r> count ELSE 2dup r> place THEN ; : t c/l * r# ! c/l len ! 0 parse tuck 'line insert IF update THEN v ; : i ibuf 'par 'line insert update v ; : d 'line 2dup rbuf place len @ delete update v ; : r d i ; : y rbuf count 'line insert update v ; : f 'rest len @ c/l mod /string fbuf 'par dup len ! search 0= throw nip chars/block swap - r# ! v ; --> \ multi screen commands 29aug95py: il pad c/l 'rest insert 'rest drop c/l blank update v ; : dl 'rest c/l delete update v ; : qx ( -- ) 0 0 at-xy scr @ &60 / &60 * &60 bounds DO 3 0 DO [ FORTH ] i 1+ [ EDITOR ] j + dup 3 .r space dup scr @ = IF rvson THEN block &20 type rvsoff LOOP cr 3 +LOOP ; : nx &60 scr @ + scr ! qx ; : bx -&60 scr @ + 0 max scr ! qx ; : n scr @ 1+ l r# off ; : b scr @ 1- l r# off ; : s ( n -- / n ) >r BEGIN ['] f catch WHILE scr @ r@ = IF rdrop EXIT THEN scr @ r@ u< IF n ELSE b THEN REPEAT r> ; \\ some comments on this simple editor 29aug95pym marks current position a goes to marked position c moves cursor by n chars t goes to line n and inserts i inserts d deletes marked area r replaces marked area f search and mark il insert a line dl delete a line qx gives a quick index nx gives next index bx gives previous index n goes to next screen b goes to previous screen l goes to screen n v goes to current screen s searches until screen n y yank deleted string Syntax and implementation style a la PolyFORTH If you don't like it, write a block editor mode for Emacs!
\ No newline at end of file
\\ some comments on this simple editor 29aug95pym marks current position a goes to marked position c moves cursor by n chars t goes to line n and inserts i inserts d deletes marked area r replaces marked area f search and mark il insert a line dl delete a line qx gives a quick index nx gives next index bx gives previous index n goes to next screen b goes to previous screen l goes to screen n v goes to current screen s searches until screen n y yank deleted string Syntax and implementation style a la PolyFORTH If you don't like it, write a block editor mode for Emacs! \ display block 29aug95pyVocabulary editor Variable r# Variable len 2Variable mark Create rbuf $100 allot Create ibuf $100 allot Create fbuf $100 allot : rvson $1B emit ." [7m" ; : rvsoff $1B emit ." [0m" ; : hi r# @ c/l /mod 1+ swap 3 + swap at-xy rvson scr @ block r# @ + len @ type rvsoff 0 &17 at-xy ; : l editor page list hi ; : v scr @ l ; : delete ( buffer size count -- ) over min >r r@ - ( left over ) dup 0> IF 2dup swap dup r@ + -rot swap move THEN + r> blank ; : insert ( string length buffer size -- ) rot over min >r r@ - over dup r@ + rot move r> move ; : replace ( string length buffer size -- ) rot min move ; editor definitions --> \ in screen command 29aug95py: m scr @ r# @ mark 2! ; : a mark 2@ m r# ! l ; : c r# +! 1 len ! v ; : 'rest ( -- a u ) scr @ block chars/block r# @ /string ; : 'line ( -- a u ) 'rest 1- c/l 1- and 1+ ; : 'par ( buf -- a u ) >r 0 parse dup 0= IF 2drop r> count ELSE 2dup r> place THEN ; : t c/l * r# ! c/l len ! 0 parse tuck 'line insert IF update THEN v ; : i ibuf 'par 'line insert update v ; : d 'line 2dup rbuf place len @ delete update v ; : r d i ; : y rbuf count 'line insert update v ; : f 'rest len @ c/l mod /string fbuf 'par dup len ! search 0= throw nip chars/block swap - r# ! v ; --> \ multi screen commands 29aug95py: il pad c/l 'rest insert 'rest drop c/l blank update v ; : dl 'rest c/l delete update v ; : qx ( -- ) 0 0 at-xy scr @ &60 / &60 * &60 bounds DO 3 0 DO [ FORTH ] i 1+ [ EDITOR ] j + dup 3 .r space dup scr @ = IF rvson THEN block &20 type rvsoff LOOP cr 3 +LOOP ; : nx &60 scr @ + scr ! qx ; : bx -&60 scr @ + 0 max scr ! qx ; : n scr @ 1+ l r# off ; : b scr @ 1- l r# off ; : s ( n -- / n ) >r BEGIN ['] f catch WHILE scr @ r@ = IF rdrop EXIT THEN scr @ r@ u< IF n ELSE b THEN REPEAT r> ;
\ No newline at end of file
......@@ -45,6 +45,7 @@ Variable last-block
$20 Value buffers
User block-fid
User offset 0 offset ! \ store 1 here fore 0.4.0 compatibility
: block-cold ( -- )
block-fid off last-block off
......@@ -87,7 +88,7 @@ Defer flush-blocks ( -- ) \ gforth
: block-position ( u -- ) \ block
\G Position the block file to the start of block @i{u}.
1- chars/block chars um* get-block-fid reposition-file throw ;
offset @ - chars/block chars um* get-block-fid reposition-file throw ;
: update ( -- ) \ block
\G Mark the current block buffer as dirty.
......@@ -127,8 +128,8 @@ Defer flush-blocks ( -- ) \ gforth
' flush IS flush-blocks
: get-buffer ( n -- a-addr ) \ gforth
buffers mod buffer-struct %size * block-buffers @ + ;
: get-buffer ( u -- a-addr ) \ gforth
0 buffers um/mod drop buffer-struct %size * block-buffers @ + ;
: block ( u -- a-addr ) \ block- block
\G If a block buffer is assigned for block @i{u}, return its
......@@ -137,7 +138,7 @@ Defer flush-blocks ( -- ) \ gforth
\G @code{update}d, transfer the contents to mass storage), read
\G the block into the block buffer and return its start address,
\G @i{a-addr}.
dup 0= -35 and throw
dup offset @ u< -35 and throw
dup get-buffer >r
dup r@ buffer-block @ <>
r@ buffer-fid @ block-fid @ <> or
......
......@@ -864,7 +864,7 @@ float Constant tfloat
bits/byte Constant tbits/byte
[THEN]
H
tbits/byte bits/byte / Constant tbyte
tbits/char bits/byte / Constant tbyte
\ Variables 06oct92py
......
......@@ -78,9 +78,15 @@ char *progname;
char *progname = "gforth";
int optind = 1;
#endif
#ifdef HAS_DEBUG
static int debug=0;
#else
# define debug 0
# define perror(x...)
# define fprintf(x...)
#endif
ImageHeader *gforth_header;
#ifdef MEMCMP_AS_SUBROUTINE
......@@ -122,11 +128,10 @@ void relocate(Cell *image, const char *bitstring, int size, Label symbols[])
int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
Cell token;
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(k=0; k<=steps; k++) {
for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
/* fprintf(stderr,"relocate: image[%d]\n", i);*/
if(bits & (1U << (RELINFOBITS-1))) {
......@@ -156,6 +161,7 @@ void relocate(Cell *image, const char *bitstring, int size, Label symbols[])
image[i]+=(Cell)image;
}
}
}
((ImageHeader*)(image))->base = (Address) image;
}
......@@ -188,16 +194,12 @@ Address verbose_malloc(Cell size)
Address r;
/* leave a little room (64B) for stack underflows */
if ((r = malloc(size+64))==NULL) {
#ifdef HAS_DEBUG
perror(progname);
#endif
exit(1);
}
r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);
#endif
return r;
}
......@@ -208,10 +210,8 @@ Address my_alloc(Cell size)
Address r;
#if defined(MAP_ANON)
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);
#endif
r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
#else /* !defined(MAP_ANON) */
/* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
......@@ -228,33 +228,25 @@ Address my_alloc(Cell size)
dev_zero = open("/dev/zero", O_RDONLY);
if (dev_zero == -1) {
r = (Address)-1;
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
strerror(errno));
#endif
} else {
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);
#endif
r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
}
#endif /* !defined(MAP_ANON) */
if (r != (Address)-1) {
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr, "success, address=$%lx\n", (long) r);
#endif
if (pagesize != 1)
next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
return r;
}
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr, "failed: %s\n", strerror(errno));
#endif
#endif /* HAVE_MMAP */
/* use malloc as fallback */
return verbose_malloc(size);
......@@ -409,13 +401,11 @@ Address loader(FILE *imagefile, char* filename)
preamblesize+=8;
} while(memcmp(magic,"Gforth2",7));
magic7 = magic[7];
#ifdef HAS_DEBUG
if (debug) {
magic[7]='\0';
fprintf(stderr,"Magic found: %s ", magic);
print_sizes(magic7);
}
#endif
if (magic7 != sizebyte)
{
......@@ -437,10 +427,8 @@ Address loader(FILE *imagefile, char* filename)
#elif PAGESIZE
pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
#endif
#ifdef HAS_DEBUG
if (debug)
fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
#endif
image = dict_alloc(preamblesize+dictsize+data_offset)+data_offset;
rewind(imagefile); /* fseek(imagefile,0L,SEEK_SET); */
......@@ -502,10 +490,8 @@ FILE *openimage(char *fullfilename)
char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
image_file=fopen(expfilename,"rb");
#ifdef HAS_DEBUG
if (image_file!=NULL && debug)
fprintf(stderr, "Opened image file: %s\n", expfilename);
#endif
return image_file;
}
......
......@@ -53,7 +53,7 @@ Variable bitmap-chars
: read-header ( fd -- )
image-header 4 cells rot read-file throw drop
image-header 2 cells + @ bswap tchars @ * au @ /
dup cell / image-cells ! 1- 8 cells / 1+ bitmap-chars !
dup image-cells ! 1- 8 / tchars @ / 1+ bitmap-chars !
image-cells @ cells allocate throw to image
bitmap-chars @ allocate throw to bitmap ;
......@@ -61,7 +61,7 @@ Variable bitmap-chars
image image-cells @ cells r> read-file throw drop ;
: read-bitmap ( fd -- ) >r
bitmap bitmap-chars @ r> read-file throw drop ;
bitmap bitmap-chars @ tchars @ * r> read-file throw drop ;
: .08x ( n -- ) 0 <# tcell @ 0 ?DO # # LOOP 'x hold '0 hold #> type ;
: .02x ( n -- ) 0 <# tchars @ 0 ?DO # # LOOP 'x hold '0 hold #> type ;
......@@ -72,7 +72,7 @@ Variable bitmap-chars
4 +LOOP ;
: .reloc ( -- )
bitmap-chars @ 0 ?DO
bitmap-chars @ tchars @ * 0 ?DO
I $10 + I' min I ?DO space
0 I tchars @ bounds ?DO 8 lshift bitmap I + c@ + LOOP
.02x ." ," tchars @ +LOOP cr
......@@ -85,10 +85,10 @@ Variable bitmap-chars
r@ read-dictionary r@ read-bitmap r> close-file throw ;
: .imagesize ( -- )
image-header 3 cells + @ bswap tcell @ / tchars @ * au @ / .08x ;
image-header 3 cells + @ bswap .08x ;
: .relocsize ( -- )
bitmap-chars @ 1- tchars @ / 1+ .08x ;
bitmap-chars @ .08x ;
: fi2c ( addr u -- ) base @ >r hex
read-image
......
......@@ -42,12 +42,16 @@ has? os [IF]
[THEN]
undef-words
Defer type ( c-addr u -- ) \ core
\G If @var{u}>0, display @var{u} characters from a string starting
\G with the character stored at @var{c-addr}.
[IFDEF] write-file
: (type) 0 write-file drop ;
[ELSE]
: (type) BEGIN dup WHILE
>r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
[THEN]
[IFDEF] (type) ' (type) IS Type [THEN]
......
......@@ -1663,18 +1663,19 @@ else {
}
\+
\+file
write-file c_addr u1 wfileid -- wior file write_file
/* !! fwrite does not guarantee enough */
#ifdef HAS_FILE
{
UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
if (wior)
clearerr((FILE *)wfileid);
}
\+
#else
TYPE(c_addr, u1);
#endif
emit-file c wfileid -- wior gforth emit_file
#ifdef HAS_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