Commit 3ea76352 authored by anton's avatar anton

Added documentation for structures and object.fs

Changed representation of structures from "size align" to "align size",
   and renamed 1 cells: to cell% etc.
added %size and %alignment
fixed search bug
added command-line option --die-on-signal
parent 8b00512d
......@@ -16,12 +16,15 @@ siev bubble matrix fib machine and configuration
39.50 45.91 36.73 44.90 i486 50MHz 256K cache; gcc-2.7.0 -DFORCE_REG -DDIRECT_THREADED; gforth-0.1beta
42.82 46.74 38.69 48.30 i486 50MHz 256K cache; gcc-2.7.0 -DFORCE_REG; gforth-0.1beta
3.7 3.8 2.8 4.1 21164A (Alpha) 500MHz 2M cache; gcc-2.7.2.1; gforth-0.3.0
7.0 7.6 6.2 7.7 21064A (Alpha) 300MHz 2M cache; gcc-2.7.2; gforth-0.2.0
8.17 9.01 6.24 9.35 R10000 (SGI PowerChallenge XL) 195MHz 2M cache; gcc-2.7.2 -DFORCE_REG; gforth-0.3.0
17.3 19.0 14.1 18.3 R4000 (DecStation 5000/150) 100MHz 1M cache; gcc-2.4.5; gforth-0.1beta
50.9 56.8 42.4 52.0 R3000 (DecStation 5000/200) 25MHz 64K+64K cache; gcc-2.5.8 -DFORCE_REG; gforth-0.1beta
7.8 8.6 7.0 10.3 UltraSparc-II 248MHz; Solaris.5.5.1; gcc-2.7.1; gforth-0.3.0
28.5 31.1 26.3 33.3 SuperSparc (Sparcstation 10) 40MHz; Solaris.5.5.1; gcc-2.7.1; gforth-0.3.0
59.5 65.8 69.5 61.9 FJMB86903 (SPARC ELC) 33MHz; gcc-2.5.8; gforth-0.1beta
84.34 91.49 76.16 88.83 L64801 25MHz (SPARC IPC) 64K WT cache; gcc-2.4.5; gforth-0.1beta
......
......@@ -544,8 +544,8 @@ prim.TAGS: prim.b prims2x.fs
$(CP) $@- $@
$(RM) $@-
doc/doc.fd: doc/makedoc.fs $(GFORTH_FI_SRC)
$(FORTHK) -e "s\" doc/doc.fd\"" doc/makedoc.fs startup.fs code.fs -e bye
doc/doc.fd: doc/makedoc.fs $(GFORTH_FI_SRC) code.fs objects.fs
$(FORTHK) -e "s\" doc/doc.fd\"" doc/makedoc.fs startup.fs code.fs objects.fs -e bye
doc/crossdoc.fd: $(KERN_SRC) kernel/version.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach32l.fs"' kernel/main.fs -e bye
......
......@@ -51,7 +51,7 @@ variable assert-level ( -- a-addr ) \ gforth
: (endassert) ( flag -- ) \ gforth-internal
\ inline argument sourcepos
if
r> sourcepos drop + >r EXIT
r> sourcepos %size + >r EXIT
else
r> print-sourcepos ." : failed assertion"
true abort" assertion failed" \ !! or use a new throw code?
......
......@@ -32,11 +32,11 @@
require struct.fs
struct
1 cells: field buffer-block \ the block number
1 cells: field buffer-fid \ the block's fid
1 cells: field buffer-dirty \ the block dirty flag
chars/block chars: field block-buffer \ the data
0 cells: field next-buffer
cell% field buffer-block \ the block number
cell% field buffer-fid \ the block's fid
cell% field buffer-dirty \ the block dirty flag
char% chars/block * field block-buffer \ the data
cell% 0 * field next-buffer
end-struct buffer-struct
Variable block-buffers
......@@ -46,10 +46,10 @@ $20 Value buffers
User block-fid
: block-cold
: block-cold ( -- )
block-fid off last-block off
buffers buffer-struct drop * allocate throw dup block-buffers !
buffers buffer-struct drop * erase ;
buffer-struct buffers * %alloc dup block-buffers ! ( addr )
buffer-struct %size buffers * erase ;
' block-cold INIT8 chained
......@@ -114,7 +114,7 @@ Defer flush-blocks
' flush IS flush-blocks
: get-buffer ( n -- a-addr )
buffers mod buffer-struct drop * block-buffers @ + ;
buffers mod buffer-struct %size * block-buffers @ + ;
: block ( u -- a-addr )
dup 0= -35 and throw
......
......@@ -66,6 +66,12 @@ does> ( name execution: -- )
cell% 2* 2constant double%
\ memory allocation words
: %alignment ( align size -- align )
drop ;
: %size ( align size -- size )
nip ;
: %align ( align size -- )
drop here swap nalign here - allot ;
......
......@@ -840,16 +840,17 @@ Build: ;
by: :dofield T @ H + ;DO
Builder (Field)
Build: >r rot r@ nalign dup T , H ( align1 size offset )
+ swap r> nalign ;
Build: ( align1 offset1 align size "name" -- align2 offset2 )
rot dup T , H ( align1 align size offset1 )
+ >r nalign r> ;
by (Field)
Builder Field
: struct T 0 1 chars H ;
: struct T 1 chars 0 H ;
: end-struct T 2Constant H ;
: cells: ( n -- size align )
T cells 1 cells H ;
: cell% ( -- align size )
T 1 cells H dup ;
\ ' 2Constant Alias2 end-struct
\ 0 1 T Chars H 2Constant struct
......
......@@ -51,7 +51,7 @@ defer printdebugline ( addr -- ) \ gforth
: (~~) ( -- )
r@ printdebugline
r> sourcepos drop + >r ;
r> sourcepos %size + >r ;
: ~~ ( compilation -- ; run-time -- ) \ gforth tilde-tilde
POSTPONE (~~) sourcepos, ; immediate
......
......@@ -52,6 +52,11 @@ interactive mode.
.SH OPTIONS
.BI "\-\-help"
.TQ "\-h"
Lists the available options, including some not described here (see
also the manual).
.TP
.BI "\-\-image\-file " "file"
.TQ "\-i " "file"
Loads the Forth image
......
This diff is collapsed.
......@@ -38,11 +38,11 @@ script? [IF]
wordlist constant documentation
struct
2 cells: field doc-name
2 cells: field doc-stack-effect
2 cells: field doc-wordset
2 cells: field doc-pronounciation
2 cells: field doc-description
cell% 2* field doc-name
cell% 2* field doc-stack-effect
cell% 2* field doc-wordset
cell% 2* field doc-pronounciation
cell% 2* field doc-description
end-struct doc-entry
create description-buffer 4096 chars allot
......
......@@ -227,6 +227,7 @@ DCell fmdiv (DCell num, Cell denom);
int memcasecmp(const char *s1, const char *s2, long n);
extern int offset_image;
extern int die_on_signal;
/* declare all the functions that are missing */
#ifndef HAVE_ATANH
......
......@@ -977,7 +977,7 @@ void install_signal_handlers (void)
signal (sigs_to_ignore [i], SIG_IGN);
*/
for (i = 0; i < DIM (sigs_to_throw); i++)
signal (sigs_to_throw [i], signal_throw);
signal (sigs_to_throw [i], die_on_signal ? graceful_exit : signal_throw);
for (i = 0; i < DIM (sigs_to_quit); i++)
signal (sigs_to_quit [i], graceful_exit);
#ifdef SIGCONT
......
......@@ -64,6 +64,7 @@ static UCell rsize=0;
static UCell fsize=0;
static UCell lsize=0;
int offset_image=0;
int die_on_signal=0;
static int clear_dictionary=0;
static int debug=0;
static size_t pagesize=0;
......@@ -507,6 +508,7 @@ int main(int argc, char **argv, char **env)
{"offset-image", no_argument, &offset_image, 1},
{"no-offset-im", no_argument, &offset_image, 0},
{"clear-dictionary", no_argument, &clear_dictionary, 1},
{"die-on-signal", no_argument, &die_on_signal, 1},
{"debug", no_argument, &debug, 1},
{0,0,0,0}
/* no-init-file, no-rc? */
......@@ -535,11 +537,13 @@ Engine Options:\n\
-c, --clear-dictionary Initialize the dictionary with 0 bytes\n\
-d SIZE, --data-stack-size=SIZE Specify data stack size\n\
--debug Print debugging information during startup\n\
--die-on-signal exit instead of CATCHing some signals\n\
-f SIZE, --fp-stack-size=SIZE Specify floating point stack size\n\
-h, --help Print this message and exit\n\
-i FILE, --image-file=FILE Use image FILE instead of `gforth.fi'\n\
-l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
-m SIZE, --dictionary-size=SIZE Specify Forth dictionary size\n\
--no-offset-im Load image at normal position\n\
--offset-image Load image at a different position\n\
-p PATH, --path=PATH Search path for finding image and sources\n\
-r SIZE, --return-stack-size=SIZE Specify return stack size\n\
......
......@@ -94,20 +94,18 @@ decimal
\ SEARCH 02sep94py
: search ( buf buflen text textlen -- restbuf restlen flag ) \ string
2over 2 pick - 1+ 3 pick c@ >r
BEGIN
r@ scan dup
WHILE
>r >r 2dup r@ -text
0=
IF
>r drop 2drop r> r> r> rot + 1- rdrop true
EXIT
THEN
r> r> 1 /string
REPEAT
2drop 2drop rdrop false ;
: search ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) \ string
\ not very efficient; but if we want efficiency, we'll do it as primitive
2>r 2dup
begin
dup r@ >=
while
over 2r@ swap -text 0= if
2swap 2drop 2r> 2drop true exit
endif
1 /string
repeat
2drop 2r> 2drop false ;
\ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
......
......@@ -42,7 +42,7 @@ constant no-interpretation-does-code
[ 0 >body ] literal allot ; \ restrict?
: fix-does-code ( addr ret-addr -- )
lastxt [ interpret/compile-struct drop ] literal + >r
lastxt [ interpret/compile-struct %size ] literal + >r
lastxt interpret/compile?
lastxt interpret/compile-int @ r@ >body = and
lastxt interpret/compile-comp @ r> = and
......
......@@ -562,18 +562,18 @@ defer ;-hook ( sys2 -- sys1 )
\ word list structure:
struct
1 cells: field find-method \ xt: ( c_addr u wid -- nt )
1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
1 cells: field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables)
1 cells: field hash-method \ xt: ( wid -- ) \ initializes ""
cell% field find-method \ xt: ( c_addr u wid -- nt )
cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables)
cell% field hash-method \ xt: ( wid -- ) \ initializes ""
\ \ !! what else
end-struct wordlist-map-struct
struct
1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
1 cells: field wordlist-map \ pointer to a wordlist-map-struct
1 cells: field wordlist-link \ link field to other wordlists
1 cells: field wordlist-extend \ points to wordlist extensions (eg hashtables)
cell% field wordlist-id \ not the same as wid; representation depends on implementation
cell% field wordlist-map \ pointer to a wordlist-map-struct
cell% field wordlist-link \ link field to other wordlists
cell% field wordlist-extend \ points to wordlist extensions (eg hashtables)
end-struct wordlist-struct
: f83find ( addr len wordlist -- nt / false )
......@@ -599,10 +599,10 @@ forth-wordlist current !
\ higher level parts of find
( struct )
0 >body cell
1 cells: field interpret/compile-int
1 cells: field interpret/compile-comp
struct
>body
cell% field interpret/compile-int
cell% field interpret/compile-comp
end-struct interpret/compile-struct
: interpret/compile? ( xt -- flag )
......
This diff is collapsed.
......@@ -26,8 +26,8 @@
require struct.fs
struct
1 cells: field sourcepos-name#
1 cells: field sourcepos-line#
cell% field sourcepos-name#
cell% field sourcepos-line#
end-struct sourcepos
: sourcepos, ( -- )
......
......@@ -18,21 +18,9 @@
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
\ Usage example:
\
\ struct
\ 1 cells: field search-method
\ 1 cells: field reveal-method
\ end-struct wordlist-map
\
\ The structure can then be extended in the following way
\ wordlist-map
\ 1 cells: field enum-method
\ end-struct ext-wordlist-map \ with the fields search-method,...,enum-method
: nalign ( addr1 n -- addr2 )
\ addr2 is the aligned version of addr1 wrt the alignment size n
: nalign ( addr1 n -- addr2 ) \ gforth
\g @code{addr2} is the aligned version of @code{addr1} wrt the
\g alignment @code{n}.
1- tuck + swap invert and ;
: dozerofield ( -- )
......@@ -43,12 +31,19 @@
if
immediate
then
does> ( -- )
does> ( name execution: -- )
drop ;
: field ( offset1 align1 size align "name" -- offset2 align2 ) \ gforth
: field, ( align1 offset1 align size -- align2 offset2 )
rot dup , ( align1 align size offset1 )
+ >r nalign r> ;
: create-field ( align1 offset1 align size -- align2 offset2 )
create field, ;
: field ( align1 offset1 align size "name" -- align2 offset2 ) \ gforth
\G name execution: ( addr1 -- addr2 )
>r rot r@ nalign dup
2 pick
if \ field offset <> 0
[IFDEF] (Field)
(Field)
......@@ -57,50 +52,52 @@ does> ( -- )
[THEN]
else
create dozerofield
then ( align1 size offset )
dup , + swap r> nalign ;
: end-struct ( size align -- )
2constant ;
0 1 chars end-struct struct
\ : field ( offset1 align1 size align -- offset2 align2 )
\ create-field
\ does> ( addr1 -- addr2 )
\ @ + ;
\ I don't really like the "type:" syntax. Any other ideas? - anton
\ Also, this seems to be somewhat general. It probably belongs to some
\ other place
: cells: ( n -- size align )
cells cell ;
: doubles: ( n -- size align )
2* cells cell ;
: chars: ( n -- size align )
chars 1 chars ;
: floats: ( n -- size align )
floats 1 floats ;
: dfloats: ( n -- size align )
dfloats 1 dfloats ;
: sfloats: ( n -- size align )
sfloats 1 sfloats ;
: struct-align ( size align -- )
dp @ swap nalign dp !
drop ;
: struct-allot ( size align -- addr )
over swap struct-align
then
field, ;
: end-struct ( align size "name" -- ) \ gforth
\g @code{name} execution: @code{addr1 -- addr1+offset1}@*
\g create a field @code{name} with offset @code{offset1}, and the type
\g given by @code{size align}. @code{offset2} is the offset of the
\g next field, and @code{align2} is the alignment of all fields.
over nalign \ pad size to full alignment
2constant ;
1 chars 0 end-struct struct ( -- align size ) \ gforth
\g an empty structure, used to start a structure definition.
\ type descriptors
1 aligned 1 cells 2constant cell% ( -- align size ) \ gforth
1 chars 1 chars 2constant char% ( -- align size ) \ gforth
1 faligned 1 floats 2constant float% ( -- align size ) \ gforth
1 dfaligned 1 dfloats 2constant dfloat% ( -- align size ) \ gforth
1 sfaligned 1 sfloats 2constant sfloat% ( -- align size ) \ gforth
cell% 2* 2constant double% ( -- align size ) \ gforth
\ memory allocation words
' drop alias %alignment ( align size -- align ) \ gforth
\g the alignment of the structure
' nip alias %size ( align size -- size ) \ gforth
\g the size of the structure
: %align ( align size -- ) \ gforth
\G align the data space pointer to the alignment @code{align}.
drop here swap nalign here - allot ;
: %allot ( align size -- addr ) \ gforth
\g allot @code{size} address units of data space with alignment
\g @code{align}; the resulting block of data is found at
\g @code{addr}.
tuck %align
here swap allot ;
: struct-allocate ( size align -- addr ior )
drop allocate ;
: %allocate ( align size -- addr ior ) \ gforth
\g allocate @code{size} address units with alignment @code{align},
\g similar to @code{allocate}.
nip allocate ;
: struct-alloc ( size align -- addr )
struct-allocate throw ;
: %alloc ( size align -- addr ) \ gforth
\g allocate @code{size} address units with alignment @code{align},
\g giving a data block at @code{addr}; @code{throw}s an ior code
\g if not successful.
%allocate throw ;
......@@ -69,6 +69,11 @@ s" a " 2 /string -trailing throw drop
0. s" 123 " drop convert drop 23. d<> throw
\ search
name abc 2dup name xyza search throw d<> throw
name b 2dup name abc search throw d<> throw
\ comments across several lines
( fjklfjlas;d
......
This diff is collapsed.
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