Commit 0c1b61d3 authored by pazsan's avatar pazsan

Merged in gforth-EC patches

parent 14fd3cd8
......@@ -167,7 +167,7 @@ GEN = gforth version.fs
OBJECTS = engine.o io.o main.o memcasecmp.o @LIBOBJS@ @getopt_long@
# things that need a working forth system to be generated
FORTH_GEN0 = primitives.b primitives.i prim_labels.i aliases.fs
FORTH_GEN0 = primitives.b primitives.i prim_labels.i aliases.fs primitives.fs
FORTH_GEN = $(FORTH_GEN0) @KERNEL@ gforth.fi
# this is used for antidependences,
FORTH_GEN1 = $(FORTH_GEN0) @kernel_fi@
......@@ -203,7 +203,7 @@ version.fs: version-stamp
$(MAKE) gforth
echo ": version-string s\" $(VERSION)\" ;" >$@
more: $(FORTH_GEN) gforth
more: $(OBJECTS) $(FORTH_GEN) gforth
#from the gcc Makefile:
#"Deletion of files made during compilation.
......@@ -309,13 +309,14 @@ install: gforth $(FORTH_SRC) kernel.fi gforth.fi gforth.1 primitives gforth.TAGS
-$(RM) $(bindir)/gforth $(bindir)/gforth-$(VERSION)
$(INSTALL_PROGRAM) -s gforth $(bindir)
ln $(bindir)/gforth $(bindir)/gforth-$(VERSION)
$(INSTALL_DATA) $(srcdir)/gforth.1 $(man1dir)
for i in $(srcdir)/gforth.info*; do $(INSTALL_DATA) $$i $(infodir); done
-$(INSTALL_DATA) $(srcdir)/gforth.1 $(man1dir)
-for i in $(srcdir)/gforth.info*; do $(INSTALL_DATA) $$i $(infodir); done
for i in $(FORTH_SRC) primitives; do \
$(INSTALL_DATA) $(srcdir)/$$i $(datadir)/gforth/$(VERSION); \
done
$(INSTALL_DATA) kernel.fi $(libdir)/gforth/$(VERSION)
$(RM) gforth.fi; $(MAKE) gforth.fi #gforth.fi contains some path names
$(INSTALL_DATA) gforth.fi $(libdir)/gforth/$(VERSION)
sed s:^$(srcdir)/:$(datadir)/gforth/$(VERSION)/: gforth.TAGS >TAGS; $(INSTALL_DATA) TAGS $(datadir)/gforth/$(VERSION)
if test -d $(emacssitelispdir); then \
$(INSTALL_DATA) $(srcdir)/gforth.el $(emacssitelispdir); \
......@@ -356,53 +357,13 @@ gforth: $(OBJECTS)
$(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@
@MAKE_EXE@
kernl16l.fi-: $(KERN_SRC) version.fs mach16l.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach16l.fs"' main.fs -e "save-cross kernl16l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl%.fi-: mach%.fs $(KERN_SRC) version.fs $(FORTH_GEN0)
$(FORTHK) -e 's" $<"' main.fs -e "save-cross $@ $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi-: $(KERN_SRC) version.fs mach16b.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach16b.fs"' main.fs -e "save-cross kernl16b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32l.fi-: $(KERN_SRC) version.fs mach32l.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach32l.fs"' main.fs -e "save-cross kernl32l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32b.fi-: $(KERN_SRC) version.fs mach32b.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach32b.fs"' main.fs -e "save-cross kernl32b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64l.fi-: $(KERN_SRC) version.fs mach64l.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach64l.fs"' main.fs -e "save-cross kernl64l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64b.fi-: $(KERN_SRC) version.fs mach64b.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach64b.fs"' main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi: $(KERNLS)
-$(CP) kernl16b.fi kernl16b.fi~
-$(CP) kernl16b.fi- kernl16b.fi
@LINK_KERNL16B@
kernl16l.fi: $(KERNLS)
-$(CP) kernl16l.fi kernl16l.fi~
-$(CP) kernl16l.fi- kernl16l.fi
@LINK_KERNL16L@
kernl32b.fi: $(KERNLS)
-$(CP) kernl32b.fi kernl32b.fi~
-$(CP) kernl32b.fi- kernl32b.fi
@LINK_KERNL32B@
kernl32l.fi: $(KERNLS)
-$(CP) kernl32l.fi kernl32l.fi~
-$(CP) kernl32l.fi- kernl32l.fi
@LINK_KERNL32L@
kernl64b.fi: $(KERNLS)
-$(CP) kernl64b.fi kernl64b.fi~
-$(CP) kernl64b.fi- kernl64b.fi
@LINK_KERNL64B@
kernl64l.fi: $(KERNLS)
-$(CP) kernl64l.fi kernl64l.fi~
-$(CP) kernl64l.fi- kernl64l.fi
@LINK_KERNL64L@
kernl%.fi: kernl%.fi- $(KERNLS)
-$(CP) $@ $@~
-$(CP) $< $@
@LINK_KERNL@
gforth.fi: @kernel_fi@ gforth $(GFORTH_FI_SRC)
$(FORTHK) --clear-dictionary $(FORTHSIZES) startup.fs -e "savesystem gforth.fi1 bye"
......@@ -442,8 +403,9 @@ aliases.fs: primitives.b prims2x.fs aliases0.fs
$(CP) aliases0.fs aliases.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-alias process-file bye" >>$@
primitives.fs: primitives.b prims2x.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-forth process-file bye" >$@
primitives.fs: primitives.b prims2x.fs aliases0.fs
$(CP) aliases0.fs primitives.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-forth process-file bye" >>$@
primitives.TAGS: primitives.b prims2x.fs
$(FORTHK) prims2x.fs -e "s\" $(srcdir)/primitives.b\" ' output-tag process-file bye" >$@
......
......@@ -187,24 +187,14 @@ AC_DEFINE_UNQUOTED(PATHSEP,'$PATHSEP')
AC_SUBST(FORTHSIZES)
dnl copy commands for systems that don't have links
AC_SUBST(LINK_KERNL16L)
LINK_KERNL16L=""
AC_SUBST(LINK_KERNL16B)
LINK_KERNL16B=""
AC_SUBST(LINK_KERNL32L)
LINK_KERNL32L=""
AC_SUBST(LINK_KERNL32B)
LINK_KERNL32B=""
AC_SUBST(LINK_KERNL64L)
LINK_KERNL64L=""
AC_SUBST(LINK_KERNL64B)
LINK_KERNL64B=""
AC_SUBST(LINK_KERNL)
LINK_KERNL=""
#if test $host_os=dos
#then
# echo Configuring for DOS!!!
# MAKE_EXE="coff2exe gforth"
# LINK_KERNL32L='$(CP) kernl32l.fi kernel.fi'
# LINK_KERNL='$(CP) kernl32l.fi kernel.fi'
#fi
dnl the following macro produces a warning with autoconf-2.1
......
......@@ -91,9 +91,20 @@ H
>CROSS
\ Parameter for target systems 06oct92py
mach-file count included
also Forth definitions
[IFDEF] asm-include asm-include [THEN]
previous
>CROSS
\ Variables 06oct92py
-1 Constant NIL
Variable image
Variable tlast NIL tlast ! \ Last name field
Variable tlastcfa \ Last code field
......@@ -102,10 +113,6 @@ Variable bit$
Variable tdp
: there tdp @ ;
\ Parameter for target systems 06oct92py
mach-file count included
\ Create additional parameters 19jan95py
T
......@@ -187,7 +194,7 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
cell tuck 1- and - [ cell 1- ] Literal and ;
: cfalign+ ( taddr -- rest )
\ see kernel.fs:cfaligned
float tuck 1- and - [ float 1- ] Literal and ;
/maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
>TARGET
: aligned ( taddr -- ta-addr ) dup align+ + ;
......@@ -250,7 +257,9 @@ Variable atonce atonce off
: GhostHeader <fwd> , 0 , ['] NoExec , ;
: >magic ; : >link cell+ ; : >exec cell+ cell+ ;
: >magic ;
: >link cell+ ;
: >exec cell+ cell+ ;
: >end 3 cells + ;
Variable last-ghost
......@@ -424,11 +433,27 @@ Create tag-bof 1 c, 0C c,
base !
THEN ;
\ Check for words
Defer skip? ' false IS skip?
: defined? ( -- flag ) \ name
ghost >magic @ <fwd> <> ;
: needed? ( -- flag ) \ name
ghost dup >magic @ <fwd> =
IF >link @ 0<> ELSE drop false THEN ;
: skip-defs ( -- )
BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ;
\ Target header creation
VARIABLE CreateFlag CreateFlag off
: (Theader ( "name" -- ghost ) T align H view,
: (Theader ( "name" -- ghost )
\ >in @ bl word count type 2 spaces >in !
T align H view,
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
>in @ name, >in ! T here H tlastcfa !
CreateFlag @ IF
......@@ -450,9 +475,19 @@ VARIABLE ;Resolve 1 cells allot
>TARGET
: Alias ( cfa -- ) \ name
(THeader over resolve T A, H 80 flag! ;
>in @ skip? IF 2drop EXIT THEN >in !
dup 0< has-prims 0= and
IF
." needs prim: " >in @ bl word count type >in ! cr
THEN
(THeader over resolve T A, H 80 flag! ;
: Alias: ( cfa -- ) \ name
ghost tuck swap resolve <do:> swap >magic ! ;
>in @ skip? IF 2drop EXIT THEN >in !
dup 0< has-prims 0= and
IF
." needs doer: " >in @ bl word count type >in ! cr
THEN
ghost tuck swap resolve <do:> swap >magic ! ;
>CROSS
\ Conditionals and Comments 11may93jaw
......@@ -506,7 +541,26 @@ ghost :docol ghost :doesjump ghost :dodoes 2drop drop
: dodoes, ( -- ) compile :doesjump T 0 , H ;
[IFUNDEF] (code)
Defer (code)
Defer (end-code)
[THEN]
>TARGET
: Code
(THeader there resolve
there 2 T cells H + T a, 0 , H
depth (code) ;
: Code:
ghost dup there resolve <do:> swap >magic !
depth (code) ;
: end-code
depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
ELSE true ABORT" CROSS: Stack empty" THEN
(end-code) ;
: ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
......@@ -529,6 +583,30 @@ Cond: ALiteral ( n -- ) restrict? alit, ;Cond
: Char ( "<char>" -- ) bl word char+ c@ ;
Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
\ some special literals 27jan97jaw
Cond: MAXU
restrict? compile lit
tcell 0 ?DO FF T c, H LOOP ;Cond
Cond: MINI
restrict? compile lit
bigendian IF
80 T c, H tcell 1 ?DO 0 T c, H LOOP
ELSE
tcell 1 ?DO 0 T c, H LOOP 80 T c, H
THEN
;Cond
Cond: MAXI
restrict? compile lit
bigendian IF
7F T c, H tcell 1 ?DO FF T c, H LOOP
ELSE
tcell 1 ?DO FF T c, H LOOP 7F T c, H
THEN
;Cond
>CROSS
\ Target compiling loop 12dec92py
\ ">tib trick thrown out 10may93jaw
......@@ -561,6 +639,7 @@ Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
\ is not allowed if a system should be ans conform
: : ( -- colon-sys ) \ Name
>in @ skip? IF drop skip-defs EXIT THEN >in !
(THeader ;Resolve ! there ;Resolve cell+ !
docol, depth T ] H ;
......@@ -840,14 +919,14 @@ also minimal
\ define new [IFDEF] and [IFUNDEF] 20may93jaw
: there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
: defined? defined? ;
: [IFDEF] there? postpone [IF] ;
: [IFUNDEF] there? 0= postpone [IF] ;
: [IFDEF] defined? postpone [IF] ;
: [IFUNDEF] defined? 0= postpone [IF] ;
\ C: \- \+ Conditional Compiling 09jun93jaw
: C: >in @ there? 0=
: C: >in @ defined? 0=
IF >in ! T : H
ELSE drop
BEGIN bl word dup c@
......@@ -859,8 +938,8 @@ also minimal
also minimal
: \- there? IF postpone \ THEN ;
: \+ there? 0= IF postpone \ THEN ;
: \- defined? IF postpone \ THEN ;
: \+ defined? 0= IF postpone \ THEN ;
: [IF] postpone [IF] ;
: [THEN] postpone [THEN] ;
......@@ -889,37 +968,54 @@ char 1 bigendian + cell + magic 7 + c!
: save-cross ( "image-name" "binary-name" -- )
bl parse ." Saving to " 2dup type cr
w/o bin create-file throw >r
s" #! " r@ write-file throw
bl parse r@ write-file throw
s" -i" r@ write-file throw
#lf r@ emit-file throw
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
?do
bl over emit-file throw
loop
drop
magic 8 r@ write-file throw \ write magic
NIL IF
s" #! " r@ write-file throw
bl parse r@ write-file throw
s" -i" r@ write-file throw
#lf r@ emit-file throw
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
?do
bl over emit-file throw
loop
drop
magic 8 r@ write-file throw \ write magic
ELSE
bl parse 2drop
THEN
image @ there r@ write-file throw \ write image
bit$ @ there 1- cell>bit rshift 1+
NIL IF
bit$ @ there 1- cell>bit rshift 1+
r@ write-file throw \ write tags
THEN
r> close-file throw ;
\ words that should be in minimal
: + + ; : 1- 1- ;
: - - ; : 2* 2* ;
: * * ; : / / ;
: dup dup ; : over over ;
: swap swap ; : rot rot ;
: drop drop ; : = = ;
: lshift lshift ; : 2/ 2/ ;
: here there ;
also forth [IFDEF] Label : Label Label ; [THEN] previous
: + + ;
: or or ;
: 1- 1- ;
: - - ;
: 2* 2* ;
: * * ;
: / / ;
: dup dup ;
: over over ;
: swap swap ;
: rot rot ;
: drop drop ;
: = = ;
: 0= 0= ;
: lshift lshift ;
: 2/ 2/ ;
: . . ;
\ cell constant cell
mach-file count included
\ include bug5.fs
\ only forth also minimal definitions
: all-words ['] false IS skip? ;
: needed-words ['] needed? IS skip? ;
: undef-words ['] defined? IS skip? ;
: \ postpone \ ; immediate
: ( postpone ( ; immediate
......
......@@ -43,6 +43,7 @@ decimal
IF 2 cells + count type drop exit THEN
REPEAT
drop
[ has-os [IF] ]
dup -511 -255 within
IF
256 + negate strsignal type exit
......@@ -51,5 +52,6 @@ decimal
IF
512 + negate strerror type exit
THEN
[ [THEN] ]
. ;
......@@ -37,6 +37,8 @@
\ header, NAME>STRING must convert that pointer to a string, and
\ HEADER must be a deferred word that is called to create the name.
include extend.fs
: tags-file-name ( -- c-addr u )
\ for now I use just TAGS; this may become more flexible in the
\ future
......
......@@ -96,8 +96,14 @@ NIL AConstant NIL \ gforth
LOOP ;
\ !! this is machine-dependent, but works on all but the strangest machines
' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth
' falign Alias maxalign ( -- ) \ gforth
: maxaligned ( addr -- f-addr ) \ float
[ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
: maxalign ( -- ) \ float
here dup maxaligned swap
?DO
bl c,
LOOP ;
\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
......@@ -407,7 +413,7 @@ hex
: #s ( +d -- 0 0 ) \ core number-sign-s
BEGIN
# 2dup d0=
# 2dup or 0=
UNTIL ;
\ print numbers 07jun92py
......@@ -440,12 +446,13 @@ hex
\ !! allow the user to add rollback actions anton
\ !! use a separate exception stack? anton
has-locals [IF]
: lp@ ( -- addr ) \ gforth l-p-fetch
laddr# [ 0 , ] ;
[THEN]
Defer 'catch
Defer 'throw
Defer 'bounce
' noop IS 'catch
' noop IS 'throw
......@@ -453,8 +460,12 @@ Defer 'bounce
: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
'catch
sp@ >r
[ has-floats [IF] ]
fp@ >r
[ [THEN] ]
[ has-locals [IF] ]
lp@ >r
[ [THEN] ]
handler @ >r
rp@ handler !
execute
......@@ -464,12 +475,20 @@ Defer 'bounce
?DUP IF
[ here 9 cells ! ] \ entry point for signal handler
handler @ dup 0= IF
[ has-os [IF] ]
2 (bye)
[ [ELSE] ]
quit
[ [THEN] ]
THEN
rp!
r> handler !
r> lp!
[ has-locals [IF] ]
r> lp!
[ [THEN] ]
[ has-floats [IF] ]
r> fp!
[ [THEN] ]
r> swap >r sp! drop r>
'throw
THEN ;
......@@ -481,8 +500,12 @@ Defer 'bounce
?DUP IF
handler @ rp!
r> handler !
[ has-locals [IF] ]
r> lp!
[ [THEN] ]
[ has-floats [IF] ]
rdrop
[ [THEN] ]
rdrop
'throw
THEN ;
......@@ -491,7 +514,10 @@ Defer 'bounce
: ?stack ( ?? -- ?? ) \ gforth
sp@ s0 @ u> IF -4 throw THEN
fp@ f0 @ u> IF -&45 throw THEN ;
[ has-floats [IF] ]
fp@ f0 @ u> IF -&45 throw THEN
[ [THEN] ]
;
\ ?stack should be code -- it touches an empty stack!
\ interpret 10mar92py
......@@ -983,7 +1009,7 @@ G -1 warnings T !
dup IF
#bs emit bl emit #bs emit 1- rot 1- -rot
THEN false ;
: (ret) true space ;
: (ret) true bl emit ;
Create ctrlkeys
] false false false false false false false false
......@@ -1006,25 +1032,26 @@ defer everychar
: accept ( addr len -- len ) \ core
dup 0< IF abs over dup 1 chars - c@ tuck type
\ this allows to edit given strings
ELSE 0 THEN rot over
ELSE 0 THEN rot over
BEGIN key decode UNTIL
2drop nip ;
\ Output 13feb93py
has-os [IF]
0 Value outfile-id ( -- file-id ) \ gforth
: (type) ( c-addr u -- ) \ gforth
outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
;
Defer type ( c-addr u -- ) \ core
\ defer type for a output buffer or fast
\ screen write
' (type) IS Type
: (emit) ( c -- ) \ gforth
outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
;
[THEN]
Defer type ( c-addr u -- ) \ core
' (type) IS Type
Defer emit ( c -- ) \ core
' (Emit) IS Emit
......@@ -1034,14 +1061,23 @@ Defer key ( -- c ) \ core
\ Query 07apr93py
has-files 0= [IF]
: sourceline# ( -- n ) loadline @ ;
[THEN]
: refill ( -- flag ) \ core-ext,block-ext,file-ext
blk @ IF 1 blk +! true 0 >in ! EXIT THEN
tib /line
[ has-files [IF] ]
loadfile @ ?dup
IF read-line throw
ELSE sourceline# 0< IF 2drop false EXIT THEN
accept true
ELSE
[ [THEN] ]
sourceline# 0< IF 2drop false EXIT THEN
accept true
[ has-files [IF] ]
THEN
[ [THEN] ]
1 loadline +!
swap #tib ! 0 >in ! ;
......@@ -1052,6 +1088,7 @@ Defer key ( -- c ) \ core
\ save-mem extend-mem
has-os [IF]
: save-mem ( addr1 u -- addr2 u ) \ gforth
\g copy a memory block into a newly allocated region in the heap
swap >r
......@@ -1063,6 +1100,7 @@ Defer key ( -- c ) \ core
\ the (possibly reallocated piece is addr2 u2, the extension is at addr
over >r + dup >r resize throw
r> over r> + -rot ;
[THEN]
\ HEX DECIMAL 2may93jaw
......@@ -1096,6 +1134,17 @@ Defer key ( -- c ) \ core
\ EVALUATE 17may93jaw
has-files 0= [IF]
: push-file ( -- ) r>
sourceline# >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 ;
[THEN]
: evaluate ( c-addr len -- ) \ core,block
push-file #tib ! >tib !
>in off blk off loadfile off -1 loadline !
......@@ -1115,7 +1164,7 @@ Defer .status
: prompt state @ IF ." compiled" EXIT THEN ." ok" ;
: (Query) ( -- )
loadfile off blk off refill drop ;
: (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
: (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
' (quit) IS 'quit
\ DOERROR (DOERROR) 13jun93jaw
......@@ -1214,10 +1263,15 @@ DEFER DOERROR
Defer 'cold ' noop IS 'cold
: cold ( -- ) \ gforth
[ has-os [IF] ]
stdout TO outfile-id
[ [THEN] ]
[ has-files [IF] ]
pathstring 2@ process-path pathdirs 2!
init-included-files
[ [THEN] ]
'cold
[ has-files [IF] ]
argc @ 1 >
IF
['] process-args catch ?dup
......@@ -1226,9 +1280,12 @@ Defer 'cold ' noop IS 'cold
THEN
cr
THEN
[ [THEN] ]
." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
." Type `bye' to exit"
." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
[ has-os [IF] ]
cr ." Type `bye' to exit"
[ [THEN] ]
loadline off quit ;
: license ( -- ) \ gforth
......@@ -1248,16 +1305,40 @@ Defer 'cold ' noop IS 'cold
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
: boot ( path **argv argc -- )
argc ! argv ! pathstring 2! main-task up!
sp@ s0 !
lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off
rp@ r0 !
fp@ f0 !
['] cold catch DoError
bye ;
[ has-files [IF] ]
argc ! argv ! pathstring 2!
[ [THEN] ]
main-task up!
sp@ s0 !
[ has-locals [IF] ]
lp@ forthstart 7 cells + @ -
[ [ELSE] ]
[ has-os [IF] ]
sp@ $1040 +
[ [ELSE] ]
sp@ $40 +
[ [THEN] ]
[ [THEN] ]
dup >tib ! tibstack ! #tib off >in off
rp@ r0 !
[ has-floats [IF] ]
fp@ f0 !
[ [THEN] ]
['] cold catch DoError
[ has-os [IF] ]
bye
[ [THEN] ]
;
has-os [IF]
: bye ( -- ) \ tools-ext
script? 0= IF cr THEN 0 (bye) ;
[ has-files [IF] ]
script? 0= IF cr THEN
[ [ELSE] ]
cr
[ [THEN] ]
0 (bye) ;
[THEN]
\ **argv may be scanned by the C starter to get some important
\ information, as -display and -geometry for an X client FORTH
......
......@@ -23,6 +23,7 @@
4 Constant cell>bit
8 Constant bits/byte
8 Constant float
8 Constant /maxalign
true Constant bigendian
( true=big, false=little )
......@@ -35,3 +36,7 @@ true Constant has-OS
true Constant has-prims
true Constant has-floats
true Constant has-locals
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
......@@ -23,6 +23,7 @@
4 Constant cell>bit
8 Constant bits/byte
8 Constant float
8 Constant /maxalign
false Constant bigendian
( true=big, false=little )
......@@ -35,3 +36,7 @@ true Constant has-OS
true Constant has-prims
true Constant has-floats
true Constant has-locals
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
......@@ -23,6 +23,7 @@
5 Constant cell>bit
8 Constant bits/byte
8 Constant float
8 Constant /maxalign
true Constant bigendian
( true=big, false=little )
......@@ -30,16 +31,12 @@
true Constant NIL \ relocating
true Constant has-files
true Constant has-OS
true Constant has-prims
\ feature list
true Constant NIL \ relocating
true Constant has-files
true Constant has-OS
true Constant has-prims
true Constant has-floats
true Constant has-locals