Commit 62cd3e54 authored by pazsan's avatar pazsan

Added further options to shrink a kernel down

Cleaned up conditional primitives (works now for C-generated part, too)
Cleaned up mach files for embedded architectures
Cleaned up options in the kernel
parent bce5545d
......@@ -31,8 +31,8 @@
true Constant NIL \ relocating
: prims-include ." Include primitives" cr s" arch/4stack/prim.fs" included ;
: asm-include ." Include assembler" cr s" arch/4stack/asm.fs" included ;
: prims-include ." Include primitives" cr s" ~+/arch/4stack/prim.fs" included ;
: asm-include ." Include assembler" cr s" ~+/arch/4stack/asm.fs" included ;
: >boot
S" ' boot >body $800 ! here $804 !" evaluate ;
......@@ -61,3 +61,10 @@ false Constant header \ save a header information
false Constant ec
false Constant crlf
false Constant ITC
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
......@@ -50,3 +50,9 @@ true Constant has-crlf
true Value ec
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
......@@ -35,3 +35,10 @@ true SetValue interpreter
true SetValue crlf
true SetValue ITC
\ true SetValue has-rom
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
......@@ -30,3 +30,10 @@ true Constant crlf
true Constant ITC
true Constant ec
\ true Constant rom
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
\ misc-key.fs basic-io for misc processor 01feb97jaw
c: key? $ffff x@ 0<> ;
c: (key?) $ffff x@ 0<> ;
c: (key) BEGIN key? UNTIL $fffe x@ ;
......
......@@ -31,8 +31,8 @@
false Constant NIL \ relocating
: prims-include ." Include primitives" cr s" arch/misc/prim.fs" included ;
: asm-include ." Include assembler" cr s" arch/misc/asm.fs" included ;
: prims-include ." Include primitives" cr s" ~+/arch/misc/prim.fs" included ;
: asm-include ." Include assembler" cr s" ~+/arch/misc/asm.fs" included ;
: >boot
hex
S" $6FF0 SP ! $7FF0 RP ! $7000 2* UP ! ' boot >body IP !" evaluate
......@@ -61,3 +61,10 @@ false Constant header \ save a header information
true Constant ec
false Constant crlf
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
......@@ -50,3 +50,9 @@ true SetValue ec
true SetValue crlf
false SetValue ITC
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
......@@ -52,6 +52,7 @@ Warnings off
\ words that are generaly useful
: KB 400 * ;
: >wordlist ( vocabulary-xt -- wordlist-struct )
also execute get-order swap >r 1- set-order r> ;
......@@ -302,6 +303,7 @@ true SetValue cross
true SetValue standard-threading
>TARGET previous
mach-file count included hex
>ENVIRON
......@@ -653,10 +655,11 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
: c, ( char -- ) T here tchar allot c! H ;
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
: cfalign ( -- )
T here H cfalign+ 0 ?DO bl T c, H LOOP ;
T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ;
: A! dup relon T ! H ;
: A, ( w -- ) T here H relon T , H ;
: >address dup 0>= IF tchar / THEN ;
: A! swap >address swap dup relon T ! H ;
: A, ( w -- ) >address T here H relon T , H ;
>CROSS
......@@ -1115,7 +1118,7 @@ NoHeaderFlag off
IF NoHeaderFlag off
ELSE
T align H view,
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast !
1 headers-named +! \ Statistic
>in @ T name, H >in !
THEN
......@@ -1223,7 +1226,7 @@ Cond: ['] T ' H alit, ;Cond
\ modularized 14jun97jaw
: fillcfa ( usedcells -- )
T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;
T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ;
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H
......@@ -1631,7 +1634,7 @@ Builder Field
: sys? ( sys -- sys ) dup 0= ?struc ;
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ;
: branchoffset ( src dest -- ) - ;
: branchoffset ( src dest -- ) - tchar / ;
: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ;
......@@ -1954,6 +1957,7 @@ previous
Create magic s" Gforth10" here over allot swap move
char 1 bigendian + tcell + magic 7 + c!
char 0 tchar + magic 6 + c!
: save-cross ( "image-name" "binary-name" -- )
bl parse ." Saving to " 2dup type cr
......
......@@ -250,7 +250,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
(Label)&&dodoes,
/* the following entry is normally unused;
it's there because its index indicates a does-handler */
(Label)CPU_DEP1,
CPU_DEP1,
#include "prim_lab.i"
(Label)0
};
......@@ -270,24 +270,24 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
#define CODE_OFFSET (22*sizeof(Cell))
int i;
Cell code_offset = offset_image? CODE_OFFSET : 0;
symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
for (i=0; i<DOESJUMP+1; i++)
symbols[i] = routines[i];
symbols[i] = (Label)routines[i];
for (; routines[i]!=0; i++) {
if (i>=MAX_SYMBOLS) {
fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
exit(1);
}
symbols[i] = &routines[i];
}
#endif /* defined(DOUBLY_INDIRECT) */
return symbols;
symbols[i] = &routines[i];
}
#endif /* defined(DOUBLY_INDIRECT) */
return symbols;
}
IF_TOS(TOS = sp[0]);
IF_FTOS(FTOS = fp[0]);
/* prep_terminal(); */
/* prep_terminal(); */
NEXT_P0;
NEXT;
......
......@@ -23,10 +23,21 @@
Create magicbuf 8 allot
Variable bswap?
Variable tchars
: bswap ( n -- n' ) bswap? @ 0= ?EXIT 0
over 24 rshift $FF and or
over 8 rshift $FF00 and or
over 8 lshift $FF0000 and or
over 24 lshift $FF000000 and or nip ;
: search-magic ( fd -- ) >r
BEGIN magicbuf 8 r@ read-file throw 8 = WHILE
magicbuf s" Gforth1" tuck compare 0= UNTIL
magicbuf s" Gforth" tuck compare 0= UNTIL
ELSE true abort" No magic found" THEN
magicbuf 6 + c@ digit? drop tchars !
magicbuf 7 + c@ 1 and 0= [ pad off 1 pad ! pad c@ 1 = ] Literal = bswap? !
rdrop ;
Create image-header 4 cells allot
......@@ -35,7 +46,8 @@ Variable bitmap-chars
: read-header ( fd -- )
image-header 4 cells rot read-file throw drop
image-header 2 cells + @ dup cell / image-cells ! 1- 8 cells / 1+ bitmap-chars !
image-header 2 cells + @ bswap tchars @ *
dup cell / image-cells ! 1- 8 cells / 1+ bitmap-chars !
image-cells @ cells allocate throw to image
bitmap-chars @ allocate throw to bitmap ;
......@@ -50,7 +62,7 @@ Variable bitmap-chars
: .image ( -- )
image-cells @ 0 ?DO
I 4 + I' min I ?DO space image I cells + @ .08x ." ," LOOP cr
I 4 + I' min I ?DO space image I cells + @ bswap .08x ." ," LOOP cr
4 +LOOP ;
: .reloc ( -- )
......@@ -65,7 +77,7 @@ Variable bitmap-chars
r@ read-dictionary r@ read-bitmap r> close-file throw ;
: .imagesize ( -- )
image-header 3 cells + @ 1 cells / .08x ;
image-header 3 cells + @ bswap 1 cells / tchars @ * .08x ;
: .relocsize ( -- )
bitmap-chars @ .08x ;
......
......@@ -34,9 +34,13 @@ decimal
\ error numbers between -512 and -2047 are for OS errors and are
\ handled with strerror
has? OS [IF]
: >stderr ( -- )
r> outfile-id >r stderr to outfile-id
>exec r> to outfile-id ;
[ELSE]
: >stderr ;
[THEN]
: .error ( n -- )
>stderr
......
......@@ -145,11 +145,13 @@ const Create bases 10 , 2 , A , 100 ,
[char] ) parse 2drop ; immediate
: \ ( -- ) \ core-ext backslash
[ has? file [IF] ]
blk @
IF
>in @ c/l / 1+ c/l * >in !
EXIT
THEN
[ [THEN] ]
source >in ! drop ; immediate
: \G ( -- ) \ gforth backslash
......@@ -360,7 +362,7 @@ Defer interpreter-notfound ( c-addr count -- )
\ interpreter 30apr92py
\ not the most efficient implementations of interpreter and compiler
: interpreter ( c-addr u -- )
| : interpreter ( c-addr u -- )
2dup find-name dup
if
nip nip name>int execute
......@@ -379,28 +381,32 @@ Defer interpreter-notfound ( c-addr count -- )
\ \ Query Evaluate 07apr93py
has? file 0= [IF]
: sourceline# ( -- n ) loadline @ ;
: sourceline# ( -- n ) 1 ;
[THEN]
: refill ( -- flag ) \ core-ext,block-ext,file-ext
blk @ IF 1 blk +! true 0 >in ! EXIT THEN
tib /line
[ has? file [IF] ]
loadfile @ ?dup
IF read-line throw
ELSE
[ [THEN] ]
sourceline# 0< IF 2drop false EXIT THEN
accept true
[ has? file [IF] ]
THEN
[ [THEN] ]
1 loadline +!
swap #tib ! 0 >in ! ;
[ has? file [IF] ]
blk @ IF 1 blk +! true 0 >in ! EXIT THEN
[ [THEN] ]
tib /line
[ has? file [IF] ]
loadfile @ ?dup
IF read-line throw
ELSE
[ [THEN] ]
sourceline# 0< IF 2drop false EXIT THEN
accept true
[ has? file [IF] ]
THEN
1 loadline +!
[ [THEN] ]
swap #tib ! 0 >in ! ;
: query ( -- ) \ core-ext
\G obsolescent
blk off loadfile off
[ has? file [IF] ]
blk off loadfile off
[ [THEN] ]
tib /line accept #tib ! 0 >in ! ;
\ save-mem extend-mem
......@@ -423,18 +429,21 @@ has? os [IF]
has? file 0= [IF]
: push-file ( -- ) r>
sourceline# >r tibstack @ >r >tib @ >r #tib @ >r
tibstack @ >r >tib @ >r #tib @ >r
>tib @ tibstack @ = IF r@ tibstack +! THEN
tibstack @ >tib ! >in @ >r >r ;
: pop-file ( throw-code -- throw-code )
r>
r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> loadline ! >r ;
r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ;
[THEN]
: evaluate ( c-addr len -- ) \ core,block
push-file #tib ! >tib !
>in off blk off loadfile off -1 loadline !
>in off
[ has? file [IF] ]
blk off loadfile off -1 loadline !
[ [THEN] ]
['] interpret catch
pop-file throw ;
......@@ -447,7 +456,10 @@ Defer .status
: prompt state @ IF ." compiled" EXIT THEN ." ok" ;
: (Query) ( -- )
loadfile off blk off loadline off refill drop ;
[ has? file [IF] ]
loadfile off blk off loadline off
[ [THEN] ]
refill drop ;
: (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
......@@ -579,9 +591,10 @@ Variable init8
init8 chainperform
[ has? file [IF] ]
process-args
loadline off
[ [THEN] ]
bootmessage
loadline off quit ;
quit ;
: clear-tibstack ( -- )
[ has? glocals [IF] ]
......
......@@ -23,7 +23,7 @@
has? os [IF]
0 Value outfile-id ( -- file-id ) \ gforth
0 Value infile-id ( -- file-id ) \ gforth
: (type) ( c-addr u -- ) \ gforth
outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
;
......@@ -39,22 +39,34 @@ has? os [IF]
infile-id key?-file ;
[THEN]
[IFUNDEF] (type)
undef-words
Defer type ( c-addr u -- ) \ core
: (type) BEGIN dup WHILE
>r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
[THEN]
Defer type ( c-addr u -- ) \ core
' (type) IS Type
[IFDEF] (type) ' (type) IS Type [THEN]
Defer emit ( c -- ) \ core
' (Emit) IS Emit
: (emit) ( c -- ) \ gforth
0 emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
;
[IFDEF] (emit) ' (emit) IS emit [THEN]
Defer key ( -- c ) \ core
' (key) IS key
: (key) ( -- c ) \ gforth
0 key-file ;
[IFDEF] (key) ' (key) IS key [THEN]
Defer key? ( -- flag ) \ core
' (key?) IS key?
: (key?) ( -- flag ) \ gforth
0 key?-file ;
[IFDEF] (key?) ' (key?) IS key? [THEN]
all-words
: (.") "lit count type ;
: (S") "lit count ;
......@@ -78,7 +90,11 @@ Defer key? ( -- flag ) \ core
[ [THEN] ]
;
1 [IF]
: space bl emit ;
has? ec [IF]
: spaces 0 max 0 ?DO space LOOP ;
: backspaces 0 max 0 ?DO #bs emit LOOP ;
[ELSE]
\ space spaces 21mar93py
decimal
Create spaces ( u -- ) \ core
......@@ -92,11 +108,5 @@ DOES> ( u -- )
swap
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
hex
: space ( -- ) \ core
1 spaces ;
[ELSE]
: space bl emit ;
: spaces 0 max 0 ?DO space LOOP ;
[THEN]
......@@ -18,14 +18,14 @@
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
include ./basics.fs
include ./io.fs \ basic io functions
include basics.fs
include io.fs \ basic io functions
has? interpreter [IF]
include ./int.fs
include int.fs
has? compiler [IF]
include ./comp.fs
include comp.fs
[THEN]
[THEN]
include ./accept.fs
include ./license.fs
include ./nio.fs
include accept.fs
include license.fs
include nio.fs
......@@ -37,20 +37,20 @@ include ../cross.fs \ include cross-compiler
decimal
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB makekernel ( size )
has? kernel-size makekernel ( size )
\ create image-header
has? header [IF]
0 A, \ base address
0 , \ checksum
0 , \ image size (without tags)
, \ dict size
16 KB , \ data stack size
15 KB 512 + , \ FP stack size
15 KB , \ return stack size
14 KB 512 + , \ locals stack size
>address , \ dict size
has? stack-size , \ data stack size
has? fstack-size , \ FP stack size
has? rstack-size , \ return stack size
has? lstack-size , \ locals stack size
0 A, \ code entry point
0 A, \ throw entry point
16 KB , \ unused (possibly tib stack size)
has? stack-size , \ unused (possibly tib stack size)
0 , \ unused
0 , \ data stack base
0 , \ fp stack base
......@@ -92,12 +92,11 @@ include cond.fs \ load IF and co
[ELSE]
include cond-old.fs \ load IF and co w/o locals
[THEN]
include toolsext.fs
\ include arch/misc/tt.fs
\ include arch/misc/sokoban.fs
[THEN]
include toolsext.fs
include tools.fs \ load tools ( .s dump )
include doers.fs
include getdoers.fs
include special.fs \ special must be last!
......@@ -108,8 +107,10 @@ tudp H @ minimal udp !
decimal
has? header [IF]
here 2 cells ! \ image size
' boot >body 8 cells ! \ Entry point
\ UNLOCK
here >address 2 cells ! \ image size
' boot >body 8 cells A! \ Entry point
\ LOCK
[ELSE]
>boot
[THEN]
......
......@@ -49,7 +49,7 @@ $20 8 2* cells + 2 + cell+ constant word-pno-size ( -- u )
\ initialized by COLD
Create main-task 100 cells allot
Create main-task has? OS [IF] 100 [ELSE] 40 [THEN] cells allot
\ set user-pointer from cross-compiler right
main-task
......@@ -79,6 +79,7 @@ AUser "error 0 "error !
User #tib \ chars in terminal input buffer
User >in 0 >in ! \ char number currently processed in tib
[THEN]
has? file [IF]
User blk 0 blk !
User loadfile 0 loadfile !
......@@ -91,6 +92,7 @@ AUser "error 0 "error !
2User linestart \ starting file postition of
\ the current interpreted line (in TIB)
[THEN]
User base A base !
User dpl -1 dpl !
......@@ -104,7 +106,8 @@ AUser dpp normal-dp dpp !
AUser LastCFA
AUser Last
has? glocals [IF]
User locals-size \ this is the current size of the locals stack
\ frame of the current word
[THEN]
......@@ -42,4 +42,11 @@ true Constant xconds \ used together with glocals,
true Constant header \ save a header information
false Constant ec
false Constant crlf
\ No newline at end of file
false Constant crlf
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
......@@ -1369,15 +1369,23 @@ n=1;
:
1 ;
\+os
key-file wfileid -- n gforth paren_key_file
#ifdef HAS_FILE
fflush(stdout);
n = key((FILE*)wfileid);
#else
n = key(stdin);
#endif
key?-file wfileid -- n facility key_q_file
#ifdef HAS_FILE
fflush(stdout);
n = key_query((FILE*)wfileid);
#else
n = key_query(stdin);
#endif
\+os
stdin -- wfileid gforth
wfileid = (Cell)stdin;
......@@ -1596,12 +1604,17 @@ write-file c_addr u1 wfileid -- wior file write_file
clearerr((FILE *)wfileid);
}
\+
emit-file c wfileid -- wior gforth emit_file
#ifdef HAS_FILE
wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
if (wior)
clearerr((FILE *)wfileid);
#else
putc(c, stdout);
#endif
\+
\+file
flush-file wfileid -- wior file-ext flush_file
......@@ -2073,4 +2086,3 @@ UP=up=(char *)a_addr;
:
up ! ;
Variable UP
......@@ -81,9 +81,16 @@ Variable flush-comment flush-comment off
f-comment 2@ nip
IF cr f-comment 2@ 2 /string 1-
dup IF
flush-comment @ 1 =
IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP
ELSE ." has? " type ." [IF]" THEN cr
2dup s" -" compare 0=
IF
flush-comment @ 1 =
IF ." #else"
ELSE ." [ELSE]" THEN
ELSE
flush-comment @ 1 =
IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP
ELSE ." has? " type ." [IF]" THEN
THEN cr
ELSE flush-comment @ 1 = IF ." #endif" ELSE ." [THEN]" THEN
cr THEN
0 0 f-comment 2! THEN ;
......@@ -269,7 +276,7 @@ nowhite ++
(( nl || eof ))
)) <- primitive ( -- )
(( (( primitive {{ printprim }} )) ** eof ))
(( (( primitive {{ printprim }} )) ** eof ))
parser primitives2something
warnings @ [IF]
.( parser generated ok ) cr
......@@ -717,4 +724,3 @@ set-current
: process ( xt -- )
bl word count rot
process-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