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! \\ 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 \ No newline at end of file
...@@ -45,6 +45,7 @@ Variable last-block ...@@ -45,6 +45,7 @@ Variable last-block
$20 Value buffers $20 Value buffers
User block-fid User block-fid
User offset 0 offset ! \ store 1 here fore 0.4.0 compatibility
: block-cold ( -- ) : block-cold ( -- )
block-fid off last-block off block-fid off last-block off
...@@ -87,7 +88,7 @@ Defer flush-blocks ( -- ) \ gforth ...@@ -87,7 +88,7 @@ Defer flush-blocks ( -- ) \ gforth
: block-position ( u -- ) \ block : block-position ( u -- ) \ block
\G Position the block file to the start of block @i{u}. \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 : update ( -- ) \ block
\G Mark the current block buffer as dirty. \G Mark the current block buffer as dirty.
...@@ -127,8 +128,8 @@ Defer flush-blocks ( -- ) \ gforth ...@@ -127,8 +128,8 @@ Defer flush-blocks ( -- ) \ gforth
' flush IS flush-blocks ' flush IS flush-blocks
: get-buffer ( n -- a-addr ) \ gforth : get-buffer ( u -- a-addr ) \ gforth
buffers mod buffer-struct %size * block-buffers @ + ; 0 buffers um/mod drop buffer-struct %size * block-buffers @ + ;
: block ( u -- a-addr ) \ block- block : block ( u -- a-addr ) \ block- block
\G If a block buffer is assigned for block @i{u}, return its \G If a block buffer is assigned for block @i{u}, return its
...@@ -137,7 +138,7 @@ Defer flush-blocks ( -- ) \ gforth ...@@ -137,7 +138,7 @@ Defer flush-blocks ( -- ) \ gforth
\G @code{update}d, transfer the contents to mass storage), read \G @code{update}d, transfer the contents to mass storage), read
\G the block into the block buffer and return its start address, \G the block into the block buffer and return its start address,
\G @i{a-addr}. \G @i{a-addr}.
dup 0= -35 and throw dup offset @ u< -35 and throw
dup get-buffer >r dup get-buffer >r
dup r@ buffer-block @ <> dup r@ buffer-block @ <>
r@ buffer-fid @ block-fid @ <> or r@ buffer-fid @ block-fid @ <> or
......
...@@ -864,7 +864,7 @@ float Constant tfloat ...@@ -864,7 +864,7 @@ float Constant tfloat
bits/byte Constant tbits/byte bits/byte Constant tbits/byte
[THEN] [THEN]
H H
tbits/byte bits/byte / Constant tbyte tbits/char bits/byte / Constant tbyte
\ Variables 06oct92py \ Variables 06oct92py
......
...@@ -78,9 +78,15 @@ char *progname; ...@@ -78,9 +78,15 @@ char *progname;
char *progname = "gforth"; char *progname = "gforth";
int optind = 1; int optind = 1;
#endif #endif
#ifdef HAS_DEBUG #ifdef HAS_DEBUG
static int debug=0; static int debug=0;
#else
# define debug 0
# define perror(x...)
# define fprintf(x...)
#endif #endif
ImageHeader *gforth_header; ImageHeader *gforth_header;
#ifdef MEMCMP_AS_SUBROUTINE #ifdef MEMCMP_AS_SUBROUTINE
...@@ -122,11 +128,10 @@ void relocate(Cell *image, const char *bitstring, int size, Label symbols[]) ...@@ -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; int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
Cell token; Cell token;
char bits; char bits;
/* static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/
/* printf("relocating %x[%x]\n", image, size); */ /* 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) { for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
/* fprintf(stderr,"relocate: image[%d]\n", i);*/ /* fprintf(stderr,"relocate: image[%d]\n", i);*/
if(bits & (1U << (RELINFOBITS-1))) { if(bits & (1U << (RELINFOBITS-1))) {
...@@ -156,6 +161,7 @@ void relocate(Cell *image, const char *bitstring, int size, Label symbols[]) ...@@ -156,6 +161,7 @@ void relocate(Cell *image, const char *bitstring, int size, Label symbols[])
image[i]+=(Cell)image; image[i]+=(Cell)image;
} }
} }
}
((ImageHeader*)(image))->base = (Address) image; ((ImageHeader*)(image))->base = (Address) image;
} }
...@@ -188,16 +194,12 @@ Address verbose_malloc(Cell size) ...@@ -188,16 +194,12 @@ Address verbose_malloc(Cell size)
Address r; Address r;
/* leave a little room (64B) for stack underflows */ /* leave a little room (64B) for stack underflows */
if ((r = malloc(size+64))==NULL) { if ((r = malloc(size+64))==NULL) {
#ifdef HAS_DEBUG
perror(progname); perror(progname);
#endif
exit(1); exit(1);
} }
r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float))); r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r); fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);
#endif
return r; return r;
} }
...@@ -208,10 +210,8 @@ Address my_alloc(Cell size) ...@@ -208,10 +210,8 @@ Address my_alloc(Cell size)
Address r; Address r;
#if defined(MAP_ANON) #if defined(MAP_ANON)
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size); 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); r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
#else /* !defined(MAP_ANON) */ #else /* !defined(MAP_ANON) */
/* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
...@@ -228,33 +228,25 @@ Address my_alloc(Cell size) ...@@ -228,33 +228,25 @@ Address my_alloc(Cell size)
dev_zero = open("/dev/zero", O_RDONLY); dev_zero = open("/dev/zero", O_RDONLY);
if (dev_zero == -1) { if (dev_zero == -1) {
r = (Address)-1; r = (Address)-1;
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ", fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
strerror(errno)); strerror(errno));
#endif
} else { } else {
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size); 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); r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
} }
#endif /* !defined(MAP_ANON) */ #endif /* !defined(MAP_ANON) */
if (r != (Address)-1) { if (r != (Address)-1) {
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr, "success, address=$%lx\n", (long) r); fprintf(stderr, "success, address=$%lx\n", (long) r);
#endif
if (pagesize != 1) if (pagesize != 1)
next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */ next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
return r; return r;
} }
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr, "failed: %s\n", strerror(errno)); fprintf(stderr, "failed: %s\n", strerror(errno));
#endif
#endif /* HAVE_MMAP */ #endif /* HAVE_MMAP */
/* use malloc as fallback */ /* use malloc as fallback */
return verbose_malloc(size); return verbose_malloc(size);
...@@ -409,13 +401,11 @@ Address loader(FILE *imagefile, char* filename) ...@@ -409,13 +401,11 @@ Address loader(FILE *imagefile, char* filename)
preamblesize+=8; preamblesize+=8;
} while(memcmp(magic,"Gforth2",7)); } while(memcmp(magic,"Gforth2",7));
magic7 = magic[7]; magic7 = magic[7];
#ifdef HAS_DEBUG
if (debug) { if (debug) {
magic[7]='\0'; magic[7]='\0';
fprintf(stderr,"Magic found: %s ", magic); fprintf(stderr,"Magic found: %s ", magic);
print_sizes(magic7); print_sizes(magic7);
} }
#endif
if (magic7 != sizebyte) if (magic7 != sizebyte)
{ {
...@@ -437,10 +427,8 @@ Address loader(FILE *imagefile, char* filename) ...@@ -437,10 +427,8 @@ Address loader(FILE *imagefile, char* filename)
#elif PAGESIZE #elif PAGESIZE
pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */ pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
#endif #endif
#ifdef HAS_DEBUG
if (debug) if (debug)
fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize); fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
#endif
image = dict_alloc(preamblesize+dictsize+data_offset)+data_offset; image = dict_alloc(preamblesize+dictsize+data_offset)+data_offset;
rewind(imagefile); /* fseek(imagefile,0L,SEEK_SET); */ rewind(imagefile); /* fseek(imagefile,0L,SEEK_SET); */
...@@ -502,10 +490,8 @@ FILE *openimage(char *fullfilename) ...@@ -502,10 +490,8 @@ FILE *openimage(char *fullfilename)
char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1); char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
image_file=fopen(expfilename,"rb"); image_file=fopen(expfilename,"rb");
#ifdef HAS_DEBUG
if (image_file!=NULL && debug) if (image_file!=NULL && debug)
fprintf(stderr, "Opened image file: %s\n", expfilename); fprintf(stderr, "Opened image file: %s\n", expfilename);
#endif
return image_file; return image_file;
} }
......
...@@ -53,7 +53,7 @@ Variable bitmap-chars ...@@ -53,7 +53,7 @@ Variable bitmap-chars
: read-header ( fd -- ) : read-header ( fd -- )
image-header 4 cells rot read-file throw drop image-header 4 cells rot read-file throw drop
image-header 2 cells + @ bswap tchars @ * au @ / 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 image-cells @ cells allocate throw to image
bitmap-chars @ allocate throw to bitmap ; bitmap-chars @ allocate throw to bitmap ;
...@@ -61,7 +61,7 @@ Variable bitmap-chars ...@@ -61,7 +61,7 @@ Variable bitmap-chars
image image-cells @ cells r> read-file throw drop ; image image-cells @ cells r> read-file throw drop ;
: read-bitmap ( fd -- ) >r : 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 ; : .08x ( n -- ) 0 <# tcell @ 0 ?DO # # LOOP 'x hold '0 hold #> type ;
: .02x ( n -- ) 0 <# tchars @ 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 ...@@ -72,7 +72,7 @@ Variable bitmap-chars
4 +LOOP ; 4 +LOOP ;
: .reloc ( -- ) : .reloc ( -- )
bitmap-chars @ 0 ?DO bitmap-chars @ tchars @ * 0 ?DO
I $10 + I' min I ?DO space I $10 + I' min I ?DO space
0 I tchars @ bounds ?DO 8 lshift bitmap I + c@ + LOOP 0 I tchars @ bounds ?DO 8 lshift bitmap I + c@ + LOOP
.02x ." ," tchars @ +LOOP cr .02x ." ," tchars @ +LOOP cr
...@@ -85,10 +85,10 @@ Variable bitmap-chars ...@@ -85,10 +85,10 @@ Variable bitmap-chars
r@ read-dictionary r@ read-bitmap r> close-file throw ; r@ read-dictionary r@ read-bitmap r> close-file throw ;
: .imagesize ( -- ) : .imagesize ( -- )
image-header 3 cells + @ bswap tcell @ / tchars @ * au @ / .08x ; image-header 3 cells + @ bswap .08x ;
: .relocsize ( -- ) : .relocsize ( -- )
bitmap-chars @ 1- tchars @ / 1+ .08x ; bitmap-chars @ .08x ;
: fi2c ( addr u -- ) base @ >r hex : fi2c ( addr u -- ) base @ >r hex
read-image read-image
......
...@@ -42,12 +42,16 @@ has? os [IF] ...@@ -42,12 +42,16 @@ has? os [IF]
[THEN] [THEN]
undef-words undef-words
Defer type ( c-addr u -- ) \ core Defer type ( c-addr u -- ) \ core
\G If @var{u}>0, display @var{u} characters from a string starting \G If @var{u}>0, display @var{u} characters from a string starting
\G with the character stored at @var{c-addr}. \G with the character stored at @var{c-addr}.
[IFDEF] write-file
: (type) 0 write-file drop ;
[ELSE]
: (type) BEGIN dup WHILE : (type) BEGIN dup WHILE
>r dup c@ (emit) 1+ r> 1- REPEAT 2drop ; >r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
[THEN]
[IFDEF] (type) ' (type) IS Type [THEN] [IFDEF] (type) ' (type) IS Type [THEN]
......
...@@ -1663,18 +1663,19 @@ else { ...@@ -1663,18 +1663,19 @@ else {
} }
\+ \+
\+file
write-file c_addr u1 wfileid -- wior file write_file write-file c_addr u1 wfileid -- wior file write_file
/* !! fwrite does not guarantee enough */ /* !! fwrite does not guarantee enough */
#ifdef HAS_FILE
{ {
UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
if (wior) if (wior)
clearerr((FILE *)wfileid); clearerr((FILE *)wfileid);
} }
#else
\+ TYPE(c_addr, u1);
#endif
emit-file c wfileid -- wior gforth emit_file emit-file c wfileid -- wior gforth emit_file
#ifdef HAS_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