Skip to content

gforth
gforth
Commit 5db7fd0b authored by jwilke's avatar jwilke
Browse files
Options

Fixes to tasker.fs, environ.fs 

Changed has-xy flags to environmental queries!!
parent 6d81e2f4
Show whitespace changes
Inline Side-by-side
Showing with 165 additions and 128 deletions
cross.fs
View file @ 5db7fd0b
......@@ -128,9 +128,12 @@ false DefaultValue create-forward-warn \ warn on forward declaration of create
previous >CROSS
: .dec
base @ decimal swap . base ! ;
: .sourcepos
cr sourcefilename type ." :"
base @ decimal sourceline# . base ! ;
sourceline# .dec ;
: warnhead
\G display error-message head
......@@ -274,21 +277,33 @@ VARIABLE env-current \ save information of current dictionary to restore with en
: e? name T environment? H 0= ABORT" environment variable not defined!" ;
: has? name T environment? H IF ELSE false THEN ;
: has? name T environment? H
IF \ environment variable is present, return its value
ELSE \ environment variable is not present, return false
\ !! JAW abort is just for testing
false true ABORT" arg"
THEN ;
: $has? T environment? H IF ELSE false THEN ;
>ENVIRON
true Value cross
false SetValue ionly
true SetValue cross
>TARGET
mach-file count included hex
>TARGET
>ENVIRON
[IFUNDEF] has-interpreter true Value has-interpreter [THEN]
[IFUNDEF] itc true Value itc [THEN]
[IFUNDEF] has-rom false Value has-rom [THEN]
s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]
s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]
s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN]
>TARGET
s" relocate" T environment? H
[IF] SetValue NIL
[ELSE] >ENVIRON T NIL H SetValue relocate
[THEN]
>CROSS
......@@ -406,7 +421,7 @@ Variable mirrored-link \ linked list for mirrored regions
." End: " r@ 1 cells + @ + .addr space
." DP: " r> 2 cells + @ .addr
REPEAT drop
s" rom" $has? 0= ?EXIT
s" rom" T $has? H 0= ?EXIT
cr ." Mirrored:"
mirrored-link @
BEGIN dup
......@@ -422,7 +437,7 @@ Variable mirrored-link \ linked list for mirrored regions
0 0 region dictionary
\ rom area for the compiler
has? rom
T has? rom H
[IF]
0 0 region ram-dictionary mirrored
\ ram area for the compiler
......@@ -440,7 +455,7 @@ has? rom
: setup-target ( -- ) \G initialize targets memory space
s" rom" $has?
s" rom" T $has? H
IF \ check for ram and rom...
address-space area nip
ram-dictionary area nip
......@@ -493,7 +508,7 @@ variable fixed \ flag: true: no automatic switching
variable constflag constflag off
: (switchram)
fixed @ ?EXIT has-rom 0= ?EXIT
fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
ram-dictionary >rdp to tdp ;
: switchram
......@@ -674,7 +689,37 @@ DEFER comp[ \ ends compilation
: compile, colon, ;
>CROSS
\ file loading
Variable filelist 0 filelist !
0 Value loadfile
0 [IF] \ !! JAW WIP
: add-included-file ( adr len -- )
dup 2 cells + allocate throw >r
r@ 1 cells + dup TO loadfile place
filelist @ r@ !
r> filelist ! ;
: included? ( c-addr u -- f )
filelist
BEGIN @ dup
WHILE >r r@ 1 cells + count compare 0=
IF rdrop 2drop true EXIT THEN
r>
REPEAT
2drop drop false ;
: included
cr ." Including: " 2dup type ." ..."
2dup add-included-file included ;
: include bl word count included ;
: require bl word count included ;
[THEN]
\ resolve structure
......@@ -682,10 +727,15 @@ DEFER comp[ \ ends compilation
: >tag cell+ ; \ indecates type of reference: 0: call, 1: address
: >taddr cell+ cell+ ;
: >ghost 3 cells + ;
: >file 4 cells + ;
: >line 5 cells + ;
: refered ( ghost tag -- )
\G creates a resolve structure
swap >r here r@ >link @ , r@ >link ! ( tag ) ,
T here aligned H , r> drop last-header-ghost @ , ;
T here aligned H , r> drop last-header-ghost @ ,
loadfile , sourceline# ,
;
Defer resolve-warning
......@@ -768,9 +818,24 @@ variable ResolveFlag
: ?touched ( ghost -- flag ) dup forward? swap >link @
0 <> and ;
: .forwarddefs ( ghost -- )
." appeared in:"
>link
BEGIN @ dup
WHILE cr 5 spaces
dup >ghost @ >ghostname type
." file " dup >file @ ?dup IF count type ELSE ." CON" THEN
." line " dup >line @ .dec
REPEAT
drop ;
: ?resolved ( ghostname -- )
dup cell+ @ ?touched
IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
IF dup
cell+ cell+ count cr type ResolveFlag on
cell+ @ .forwarddefs
ELSE drop
THEN ;
>MINIMAL
: .unresolved ( -- )
......@@ -789,8 +854,6 @@ variable ResolveFlag
: .stats
base @ >r decimal
cr ." named Headers: " headers-named @ .
\ cr ." MaxRam*" ramdp @ .
\ cr ." MaxRom*" romdp @ .
r> base ! ;
>CROSS
......@@ -958,16 +1021,16 @@ VARIABLE ;Resolve 1 cells allot
>TARGET
: Alias ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !
dup 0< has-prims 0= and
dup 0< s" prims" T $has? H 0= and
IF
." needs prim: " >in @ bl word count type >in ! cr
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
THEN
(THeader over resolve T A, H 80 flag! ;
: Alias: ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !
dup 0< has-prims 0= and
dup 0< s" prims" T $has? H 0= and
IF
." needs doer: " >in @ bl word count type >in ! cr
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr
THEN
ghost tuck swap resolve <do:> swap >magic ! ;
>CROSS
......@@ -1066,7 +1129,7 @@ Defer (end-code)
: Code
defempty?
(THeader there resolve
[ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]
[ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
doprim,
[THEN]
depth (code) ;
......@@ -1268,7 +1331,7 @@ Cond: DOES> restrict?
: BuildSmart: ( -- [xt] [colon-sys] )
:noname
[ has-rom [IF] ]
[ T has? rom H [IF] ]
postpone RTCreate
[ [ELSE] ]
postpone TCreate
......@@ -1320,7 +1383,7 @@ BuildSmart: ;
by: :dovar ( ghost -- addr ) ;DO
Builder Create
has-rom [IF]
T has? rom H [IF]
Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
by (Constant)
Builder Variable
......@@ -1330,7 +1393,7 @@ by Create
Builder Variable
[THEN]
has-rom [IF]
T has? rom H [IF]
Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
by (Constant)
Builder AVariable
......@@ -1504,6 +1567,7 @@ Cond: NEXT restrict? sys? compile (next) loop] ;Cond
Cond: BUT restrict? sys? swap ;Cond
Cond: YET restrict? sys? dup ;Cond
1 [IF]
>CROSS
Variable tleavings
>TARGET
......@@ -1519,8 +1583,44 @@ Cond: DONE ( addr -- ) restrict? tleavings @
Cond: LEAVE restrict? compile branch (leave ;Cond
Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond
[ELSE]
\ !! This is WIP
\ The problem is (?DO)!
\ perhaps we need a plug-in for (?DO)
>CROSS
Variable tleavings 0 tleavings !
>TARGET
Cond: DONE ( addr -- )
restrict? tleavings @
BEGIN dup
WHILE >r dup r@ cell+ @ \ address of branch
u> 0= \ lower than DO?
WHILE r@ 2 cells + @ \ branch token
branchtoresolve,
r@ @ r> free throw
REPEAT drop r>
THEN
tleavings ! drop ;Cond
>CROSS
: (leave ( branchtoken -- )
3 cells allocate throw >r
T here H r@ cell+ !
r@ 2 cells + !
tleavings @ r@ !
r> tleavings ! ;
>TARGET
Cond: LEAVE restrict? branchmark, (leave ;Cond
Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave ;Cond
[THEN]
\ Structural Conditionals 12dec92py
>TARGET
Cond: AHEAD restrict? branchmark, ;Cond
Cond: IF restrict? ?branchmark, ;Cond
Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond
......@@ -1545,7 +1645,7 @@ Cond: ?DO restrict? compile (?do) T (leave here H ;Cond
Cond: FOR restrict? compile (for) T here H ;Cond
>CROSS
: loop] dup <resolve tcell - compile DONE compile unloop ;
: loop] branchto, dup <resolve tcell - compile DONE compile unloop ;
>TARGET
Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
......
environ.fs
View file @ 5db7fd0b
......@@ -29,7 +29,7 @@ Create environment-wordlist wordlist drop
false
endif ;
: e? name environment? ; immediate
: e? name environment? 0= ABORT" environmental dependency not existing" ;
: has? name environment? IF ELSE false THEN ;
......
hash.fs
View file @ 5db7fd0b
......@@ -18,19 +18,15 @@
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
[IFUNDEF] e? : e? name 2drop false ; [THEN]
e? ec
[IF]
[IFUNDEF] allocate
: reserve-mem here swap allot ;
\ ToDo: check memory space with unused
\ move to a kernel/memory.fs
[ELSE]
: reserve-mem allocate throw ;
[THEN]
[IFUNDEF] hashbits
11 value hashbits
11 Value hashbits
[THEN]
1 hashbits lshift Value Hashlen
......@@ -140,7 +136,7 @@ to hashsearch-map
HashTable Hashlen cells erase THEN
HashIndex @ over ! 1 HashIndex +!
HashIndex @ Hashlen >=
[ e? ec [IF] ]
[ [IFUNDEF] allocate ]
ABORT" no more space in hashtable"
[ [ELSE] ]
IF HashTable >r clearhash
......@@ -151,7 +147,7 @@ to hashsearch-map
[ [THEN] ] ; is hash-alloc
\ Hash-Find 01jan93py
e? cross 0=
has? cross 0=
[IF]
: make-hash
hashsearch-map forth-wordlist cell+ !
......@@ -164,14 +160,14 @@ e? cross 0=
\ for ec version display that vocabulary goes hashed
: hash-cold ( -- )
[ e? ec [IF] ] ." Hashing..." [ [THEN] ]
[ has? ec [IF] ] ." Hashing..." [ [THEN] ]
HashPointer off 0 TO HashTable HashIndex off
addall
\ voclink
\ BEGIN @ dup WHILE
\ dup 0 wordlist-link - initvoc
\ REPEAT drop
[ e? ec [IF] ] ." Done" cr [ [THEN] ] ;
[ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
' hash-cold INIT8 chained
......
look.fs
View file @ 5db7fd0b
......@@ -46,7 +46,7 @@ decimal
[IFUNDEF] look
has? ec [IF]
has-rom
has? rom
[IF]
: look
dup [ unlock rom-dictionary area lock ]
......
mach16b.fs
View file @ 5db7fd0b
......@@ -29,14 +29,4 @@
\ 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
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
include machpc.fs
mach16l.fs
View file @ 5db7fd0b
......@@ -29,14 +29,4 @@ false Constant bigendian
\ 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
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
include machpc.fs
mach32b.fs
View file @ 5db7fd0b
......@@ -29,14 +29,4 @@
\ 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
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
include machpc.fs
mach32l.fs
View file @ 5db7fd0b
......@@ -29,14 +29,4 @@ false Constant bigendian
\ 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
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
include machpc.fs
mach64b.fs
View file @ 5db7fd0b
......@@ -29,14 +29,4 @@
\ 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
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
include machpc.fs
mach64l.fs
View file @ 5db7fd0b
......@@ -29,14 +29,4 @@ false Constant bigendian
\ 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
true Constant has-dcomps
true Constant has-hash
true Constant has-xconds
true Constant has-header
include machpc.fs
prim
View file @ 5db7fd0b
......@@ -128,7 +128,7 @@ EXEC(*(Xt *)a_addr);
:
@ execute ;
\+has-locals [IF]
\+has? glocals [IF]
branch-lp+!# -- gforth branch_lp_plus_store_number
/* this will probably not be used */
......@@ -157,7 +157,7 @@ else
INC_IP(1);
$4
\+has-locals [IF]
\+has? glocals [IF]
$1-lp+!# $2_lp_plus_store_number
$3 goto branch_adjust_lp;
......@@ -181,7 +181,7 @@ if (f==0) {
\ we don't need an lp_plus_store version of the ?dup-stuff, because it
\ is only used in if's (yet)
\+has-xconds [IF]
\+has? xconds [IF]
?dup-?branch f -- f new question_dupe_question_branch
""The run-time procedure compiled by @code{?DUP-IF}.""
......@@ -250,7 +250,7 @@ if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
IF >r + >r dup @ + >r
ELSE >r >r drop cell+ >r THEN ;)
\+has-xconds [IF]
\+has? xconds [IF]
condbranch((-loop),u -- gforth paren_minus_loop,
/* !! check this thoroughly */
......@@ -325,7 +325,7 @@ else {
cell+ >r
THEN ; \ --> CORE-EXT
\+has-xconds [IF]
\+has? xconds [IF]
(+do) nlimit nstart -- gforth paren_plus_do
*--rp = nlimit;
......@@ -905,7 +905,7 @@ f = FLAG($4>=$5);
)
\+has-dcomps [IF]
\+has? dcomps [IF]
dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
......@@ -931,7 +931,7 @@ a_addr = rp;
rp! a_addr -- gforth rpstore
rp = a_addr;
\+has-floats [IF]
\+has? floating [IF]
fp@ -- f_addr gforth fp_fetch
f_addr = fp;
......@@ -1017,7 +1017,7 @@ Variable (rot)
nip w1 w2 -- w2 core-ext
:
>r drop r> ;
swap drop ;
tuck w1 w2 -- w2 w1 w2 core-ext
:
......@@ -1191,7 +1191,7 @@ f83name2=f83name1;
: (find-samelen) ( u f83name1 -- u f83name2/0 )
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
\+has-hash [IF]
\+has? hash [IF]
(hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
F83Name *f83name1;
......@@ -1369,7 +1369,7 @@ n=1;
:
1 ;
\+has-os [IF]
\+has? os [IF]
(key) -- n gforth paren_key
fflush(stdout);
......@@ -1493,7 +1493,7 @@ fp=FP;
IF_TOS(TOS=sp[0]);
IF_FTOS(FTOS=fp[0]);
\+[THEN] ( has-os ) has-files [IF]
\+[THEN] ( has? os ) has? file [IF]
close-file wfileid -- wior file close_file
wior = IOR(fclose((FILE *)wfileid)==EOF);
......@@ -1574,7 +1574,7 @@ else {
u2=0;
}
\+[THEN] has-files [IF] -1 [ELSE] has-os [THEN] [IF]
\+[THEN] has? file [IF] -1 [ELSE] has? os [THEN] [IF]
write-file c_addr u1 wfileid -- wior file write_file
/* !! fwrite does not guarantee enough */
......@@ -1590,7 +1590,7 @@ wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
if (wior)
clearerr((FILE *)wfileid);
\+[THEN] has-files [IF]
\+[THEN] has? file [IF]
flush-file wfileid -- wior file-ext flush_file
wior = IOR(fflush((FILE *) wfileid)==EOF);
......@@ -1619,7 +1619,7 @@ else {
wior=0;
}
\+[THEN] ( has-files ) has-floats [IF]
\+[THEN] ( has? file ) has? floating [IF]
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
......@@ -1914,7 +1914,7 @@ df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
\ local variable implementation primitives
\+[THEN] ( has-floats ) has-locals [IF]
\+[THEN] ( has? floats ) has? glocals [IF]
@local# -- w gforth fetch_local_number
w = *(Cell *)(lp+(Cell)NEXT_INST);
......@@ -1932,7 +1932,7 @@ w = *(Cell *)(lp+2*sizeof(Cell));
@local3 -- w new fetch_local_twelve
w = *(Cell *)(lp+3*sizeof(Cell));
\+has-floats [IF]
\+has? floating [IF]
f@local# -- r gforth f_fetch_local_number
r = *(Float *)(lp+(Cell)NEXT_INST);
......@@ -1974,15 +1974,15 @@ lp = (Address)c_addr;
lp -= sizeof(Cell);
*(Cell *)lp = w;
\+has-floats [IF]
\+has? floating [IF]
f>l r -- gforth f_to_l
lp -= sizeof(Float);
*(Float *)lp = r;
\+[THEN] [THEN] \ has-locals
\+[THEN] [THEN] \ has? glocals
\+has-OS [IF]
\+has? OS [IF]
define(`uploop',
`pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
......@@ -2043,7 +2043,7 @@ icall(20)
uploop(i, 0, 7, `fcall(i)')
fcall(20)
\+[THEN] \ has-OS
\+[THEN] \ has? OS
up! a_addr -- gforth up_store
UP=up=(char *)a_addr;
......
prims2x.fs
View file @ 5db7fd0b
......@@ -615,7 +615,9 @@ set-current
: output-forth ( -- ) flush-comment on
?flush-comment
forth-code @ 0=
IF output-alias
IF \ output-alias
\ this is bad for ec: an alias is compiled if tho word does not exist!
\ JAW
ELSE ." : " forth-name 2@ type ." ( "
effect-in effect-in-end @ .stack-list ." -- "
effect-out effect-out-end @ .stack-list ." )" cr
......
tasker.fs
View file @ 5db7fd0b
......@@ -41,10 +41,9 @@ Create sleepers sleepers A, sleepers A, 0 ,
lp! fp! rp! prev-task @ sleep ;
\ USER' computes the task offset
: user' ( 'user' -- n )
' >body @ postpone literal ; immediate
interpretation:
' >body @ ;
:noname ' >body @ ;
:noname ' >body @ postpone literal ;
interpret/compile: user' ( 'user' -- n )
\ NEWTASK creates a new, sleeping task
: NewTask ( n -- Task ) dup 2* 2* udp @ + dup
......
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