Commit 8442500c authored by jwilke's avatar jwilke

A lot of small changes.

Added some ANS compatibility header.
Included path and number handling (optional for non gforth systems).
require while cross-compiling works now.
New directive skipdef, skips definitions in undef-words mode.
Some code refinements.
parent 8f3945de
......@@ -31,6 +31,171 @@ Clean up mark> and >resolve stuff jaw
[THEN]
hex
\ debugging for compiling
\ print stack at each colon definition
\ : : save-input cr bl word count type restore-input throw .s : ;
\ print stack at each created word
\ : create save-input cr bl word count type restore-input throw .s create ;
\ \ ------------- Setup Vocabularies
\ Remark: Vocabulary is not ANS, but it should work...
Vocabulary Cross
Vocabulary Target
Vocabulary Ghosts
Vocabulary Minimal
only Forth also Target also also
definitions Forth
: T previous Cross also Target ; immediate
: G Ghosts ; immediate
: H previous Forth also Cross ; immediate
forth definitions
: T previous Cross also Target ; immediate
: G Ghosts ; immediate
: >cross also Cross definitions previous ;
: >target also Target definitions previous ;
: >minimal also Minimal definitions previous ;
H
>CROSS
\ find out whether we are compiling with gforth
: defined? bl word find nip ;
defined? emit-file defined? toupper and \ drop 0
[IF]
\ use this in a gforth system
: \GFORTH ; immediate
: \ANSI postpone \ ; immediate
[ELSE]
: \GFORTH postpone \ ; immediate
: \ANSI ; immediate
[THEN]
\ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate
\ANSI : [IFDEF] defined? postpone [IF] ; immediate
0 \ANSI drop 1
[IF]
: \G postpone \ ; immediate
: rdrop postpone r> postpone drop ; immediate
: name bl word count ;
: bounds over + swap ;
: scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
: linked here over @ , swap ! ;
: alias create , DOES> @ EXECUTE ;
: defer ['] noop alias ;
: is state @
IF ' >body postpone literal postpone !
ELSE ' >body ! THEN ; immediate
: 0>= 0< 0= ;
: d<> rot <> -rot <> or ;
: toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;
Variable ebuf
: emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;
0a Constant #lf
0d Constant #cr
[IFUNDEF] Warnings Variable Warnings [THEN]
\ \ Number parsing 23feb93py
\ number? number 23feb93py
Variable dpl
hex
Create bases 10 , 2 , A , 100 ,
\ 16 2 10 character
\ !! protect BASE saving wrapper against exceptions
: getbase ( addr u -- addr' u' )
over c@ [char] $ - dup 4 u<
IF
cells bases + @ base ! 1 /string
ELSE
drop
THEN ;
: sign? ( addr u -- addr u flag )
over c@ [char] - = dup >r
IF
1 /string
THEN
r> ;
: s>unumber? ( addr u -- ud flag )
base @ >r dpl on getbase
0. 2swap
BEGIN ( d addr len )
dup >r >number dup
WHILE \ there are characters left
dup r> -
WHILE \ the last >number parsed something
dup 1- dpl ! over c@ [char] . =
WHILE \ the current char is '.'
1 /string
REPEAT THEN \ there are unparseable characters left
2drop false
ELSE
rdrop 2drop true
THEN
r> base ! ;
\ ouch, this is complicated; there must be a simpler way - anton
: s>number? ( addr len -- d f )
\ converts string addr len into d, flag indicates success
sign? >r
s>unumber?
0= IF
rdrop false
ELSE \ no characters left, all ok
r>
IF
dnegate
THEN
true
THEN ;
: s>number ( addr len -- d )
\ don't use this, there is no way to tell success
s>number? drop ;
: snumber? ( c-addr u -- 0 / n -1 / d 0> )
s>number? 0=
IF
2drop false EXIT
THEN
dpl @ dup 0< IF
nip
ELSE
1+
THEN ;
: number? ( string -- string 0 / n -1 / d 0> )
dup >r count snumber? dup if
rdrop
else
r> swap
then ;
: number ( string -- d )
number? ?dup 0= abort" ?" 0<
IF
s>d
THEN ;
[THEN]
hex \ the defualt base for the cross-compiler is hex !!
Warnings off
......@@ -48,6 +213,8 @@ Warnings off
\ puts down string as cstring
dup c, here swap chars dup allot move ;
: ," [char] " parse string, ;
: SetValue ( n -- <name> )
\G Same behaviour as "Value" if the <name> is not defined
\G Same behaviour as "to" if <name> is defined
......@@ -70,30 +237,6 @@ Warnings off
hex
Vocabulary Cross
Vocabulary Target
Vocabulary Ghosts
VOCABULARY Minimal
only Forth also Target also also
definitions Forth
: T previous Cross also Target ; immediate
: G Ghosts ; immediate
: H previous Forth also Cross ; immediate
forth definitions
: T previous Cross also Target ; immediate
: G Ghosts ; immediate
: >cross also Cross definitions previous ;
: >target also Target definitions previous ;
: >minimal also Minimal definitions previous ;
H
>CROSS
\ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
\ for cross-compiling
\ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
......@@ -106,40 +249,6 @@ H
\ Begin CROSS COMPILER:
\ \ -------------------- Error Handling 05aug97jaw
\ Flags
also forth definitions \ these values may be predefined before
\ the cross-compiler is loaded
false DefaultValue stack-warn \ check on empty stack at any definition
false DefaultValue create-forward-warn \ warn on forward declaration of created words
previous >CROSS
: .dec
base @ decimal swap . base ! ;
: .sourcepos
cr sourcefilename type ." :"
sourceline# .dec ;
: warnhead
\G display error-message head
\G perhaps with linenumber and filename
.sourcepos ." Warning: " ;
: empty? depth IF .sourcepos ." Stack not empty!" THEN ;
stack-warn [IF]
: defempty? empty? ;
[ELSE]
: defempty? ; immediate
[THEN]
\ debugging
0 [IF]
......@@ -151,6 +260,8 @@ its value is true, the flag is switched on.
[THEN]
>CROSS
Vocabulary debugflags \ debug flags for cross
also debugflags get-order over
Constant debugflags-wl
......@@ -181,6 +292,344 @@ set-order previous
\ POSTPONE false
THEN ; immediate
\ \ -------------------- source file
decimal
Variable cross-file-list
0 cross-file-list !
Variable target-file-list
0 target-file-list !
Variable host-file-list
0 host-file-list !
cross-file-list Value file-list
0 Value source-desc
\ file loading
: >fl-id 1 cells + ;
: >fl-name 2 cells + ;
Variable filelist 0 filelist !
Create NoFile ," #load-file#"
: loadfile ( -- adr )
source-desc ?dup IF >fl-name ELSE NoFile THEN ;
: sourcefilename ( -- adr len )
loadfile count ;
\ANSI : sourceline# 0 ;
\ \ -------------------- path handling from kernel/paths.fs
\ paths.fs path file handling 03may97jaw
\ -Changing the search-path:
\ fpath+ <path> adds a directory to the searchpath
\ fpath= <path>|<path> makes complete now searchpath
\ seperator is |
\ .fpath displays the search path
\ remark I:
\ a ./ in the beginning of filename is expanded to the directory the
\ current file comes from. ./ can also be included in the search-path!
\ ~+/ loads from the current working directory
\ remark II:
\ if there is no sufficient space for the search path increase it!
\ -Creating custom paths:
\ It is possible to use the search mechanism on yourself.
\ Make a buffer for the path:
\ create mypath 100 chars , \ maximum length (is checked)
\ 0 , \ real len
\ 100 chars allot \ space for path
\ use the same functions as above with:
\ mypath path+
\ mypath path=
\ mypath .path
\ do a open with the search path:
\ open-path-file ( adr len path -- fd adr len ior )
\ the file is opened read-only; if the file is not found an error is generated
\ questions to: wilke@jwdt.com
[IFUNDEF] +place
: +place ( adr len adr )
2dup >r >r
dup c@ char+ + swap move
r> r> dup c@ rot + swap c! ;
[THEN]
[IFUNDEF] place
: place ( c-addr1 u c-addr2 )
2dup c! char+ swap move ;
[THEN]
\ if we have path handling, use this and the setup of it
[IFUNDEF] open-fpath-file
create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
sourcepath value fpath
: also-path ( adr len path^ -- )
>r
\ len check
r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!"
\ copy into
tuck r@ cell+ dup @ cell+ + swap cmove
\ make delimiter
0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +!
;
: only-path ( adr len path^ -- )
dup 0 swap cell+ ! also-path ;
: path+ ( path-addr "dir" -- ) \ gforth
\G Add the directory @var{dir} to the search path @var{path-addr}.
name rot also-path ;
: fpath+ ( "dir" ) \ gforth
\G Add directory @var{dir} to the Forth search path.
fpath path+ ;
: path= ( path-addr "dir1|dir2|dir3" ) \ gforth
\G Make a complete new search path; the path separator is |.
name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP
rot only-path ;
: fpath= ( "dir1|dir2|dir3" ) \ gforth
\G Make a complete new Forth search path; the path separator is |.
fpath path= ;
: path>counted cell+ dup cell+ swap @ ;
: next-path ( adr len -- adr2 len2 )
2dup 0 scan
dup 0= IF 2drop 0 -rot 0 -rot EXIT THEN
>r 1+ -rot r@ 1- -rot
r> - ;
: previous-path ( path^ -- )
dup path>counted
BEGIN tuck dup WHILE repeat ;
: .path ( path-addr -- ) \ gforth
\G Display the contents of the search path @var{path-addr}.
path>counted
BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
: .fpath ( -- ) \ gforth
\G Display the contents of the Forth search path.
fpath .path ;
: absolut-path? ( addr u -- flag ) \ gforth
\G A path is absolute if it starts with a / or a ~ (~ expansion),
\G or if it is in the form ./*, extended regexp: ^[/~]|./, or if
\G it has a colon as second character ("C:..."). Paths simply
\G containing a / are not absolute!
2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
over c@ [char] / = >r
over c@ [char] ~ = >r
\ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
2 min S" ./" compare 0=
r> r> r> or or or ;
Create ofile 0 c, 255 chars allot
Create tfile 0 c, 255 chars allot
: pathsep? dup [char] / = swap [char] \ = or ;
: need/ ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ;
: extractpath ( adr len -- adr len2 )
BEGIN dup WHILE 1-
2dup + c@ pathsep? IF EXIT THEN
REPEAT ;
: remove~+ ( -- )
ofile count 3 min s" ~+/" compare 0=
IF
ofile count 3 /string ofile place
THEN ;
: expandtopic ( -- ) \ stack effect correct? - anton
\ expands "./" into an absolute name
ofile count 2 min s" ./" compare 0=
IF
ofile count 1 /string tfile place
0 ofile c! sourcefilename extractpath ofile place
ofile c@ IF need/ THEN
tfile count over c@ pathsep? IF 1 /string THEN
ofile +place
THEN ;
: compact.. ( adr len -- adr2 len2 )
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw
over >r -1 >r
BEGIN dup WHILE
over c@ pathsep?
IF r@ -1 =
IF r> drop dup >r
ELSE 2dup 1 /string
3 min s" ../" compare
0=
IF r@ over - ( diff )
2 pick swap - ( dest-adr )
>r 3 /string r> swap 2dup >r >r
move r> r>
ELSE r> drop dup >r
THEN
THEN
THEN
1 /string
REPEAT
r> drop
drop r> tuck - ;
: reworkdir ( -- )
remove~+
ofile count compact..
nip ofile c! ;
: open-ofile ( -- fid ior )
\G opens the file whose name is in ofile
expandtopic reworkdir
ofile count r/o open-file ;
: check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 )
0 ofile ! >r >r ofile place need/
r> r> ofile +place
open-ofile ;
: open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth
\G Look in path @var{path-addr} for the file specified by @var{addr1 u1}.
\G If found, the resulting path and an open file descriptor
\G are returned. If the file is not found, @var{ior} is non-zero.
>r
2dup absolut-path?
IF rdrop
ofile place open-ofile
dup 0= IF >r ofile count r> THEN EXIT
ELSE r> path>counted
BEGIN next-path dup
WHILE 5 pick 5 pick check-path
0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
REPEAT
2drop 2drop 2drop -38
THEN ;
: open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth
\G Look in the Forth search path for the file specified by @var{addr1 u1}.
\G If found, the resulting path and an open file descriptor
\G are returned. If the file is not found, @var{ior} is non-zero.
fpath open-path-file ;
fpath= ~+
[THEN]
\ \ -------------------- include require 13may99jaw
>CROSS
: add-included-file ( adr len -- adr )
dup >fl-name char+ allocate throw >r
file-list @ r@ ! r@ file-list !
r@ >fl-name place r> ;
: included? ( c-addr u -- f )
file-list
BEGIN @ dup
WHILE >r 2dup r@ >fl-name count compare 0=
IF rdrop 2drop true EXIT THEN
r>
REPEAT
2drop drop false ;
false DebugFlag showincludedfiles
: included1 ( fd adr u -- )
\ include file adr u / fd
\ we don't use fd with include-file, because the forth system
\ doesn't know the name of the file to get a nice error report
[d?] showincludedfiles
IF cr ." Including: " 2dup type ." ..." THEN
rot close-file throw
source-desc >r
add-included-file to source-desc
sourcefilename
['] included catch
r> to source-desc
throw ;
: included ( adr len -- )
cross-file-list to file-list
open-fpath-file throw
included1 ;
: required ( adr len -- )
cross-file-list to file-list
open-fpath-file throw \ 2dup cr ." R:" type
2dup included?
IF 2drop close-file throw
ELSE included1
THEN ;
: include bl word count included ;
: require bl word count required ;
also forth definitions previous
: included ( adr len -- ) included ;
: required ( adr len -- ) required ;
: include include ;
: require require ;
>CROSS
hex
\ \ -------------------- Error Handling 05aug97jaw
\ Flags
also forth definitions \ these values may be predefined before
\ the cross-compiler is loaded
false DefaultValue stack-warn \ check on empty stack at any definition
false DefaultValue create-forward-warn \ warn on forward declaration of created words
previous >CROSS
: .dec
base @ decimal swap . base ! ;
: .sourcepos
cr sourcefilename type ." :"
sourceline# .dec ;
: warnhead
\G display error-message head
\G perhaps with linenumber and filename
.sourcepos ." Warning: " ;
: empty? depth IF .sourcepos ." Stack not empty!" THEN ;
stack-warn [IF]
: defempty? empty? ;
[ELSE]
: defempty? ; immediate
[THEN]
\ \ GhostNames Ghosts 9may93jaw
\ second name source to search trough list
......@@ -242,7 +691,7 @@ Variable last-header-ghost \ last ghost definitions with header
: gfind ( string -- ghost true/1 / string false )
\ searches for string in word-list ghosts
dup count [ ' ghosts >wordlist ] ALiteral search-wordlist
dup count [ ' ghosts >wordlist ] Literal search-wordlist
dup IF >r >body nip r> THEN ;
: gdiscover ( xt -- ghost true | xt false )
......@@ -272,7 +721,7 @@ VARIABLE Already
s" ?!?!?!"
THEN ;
' >ghostname ALIAS @name
\ ' >ghostname ALIAS @name
: forward? ( ghost -- flag )
>magic @ <fwd> = ;
......@@ -332,8 +781,12 @@ true SetValue cross
true SetValue standard-threading
>TARGET previous
mach-file count included hex
0
[IFDEF] mach-file mach-file count 1 [THEN]
[IFDEF] machine-file machine-file 1 [THEN]
[IF] included hex drop
[ELSE] cr ." No machine description!" ABORT
[THEN]
>ENVIRON
......@@ -383,7 +836,7 @@ check-address-unit-bits
8 Constant bits/byte \ we define: byte is address-unit
1 bits/byte lshift Constant maxbyte
\ this sets byte size for the target machine, an (probably right guess) jaw
\ this sets byte size for the target machine, (probably right guess) jaw
T
NIL Constant TNIL
......@@ -474,7 +927,7 @@ Variable mirrored-link \ linked list for mirrored regions
\G prints a 16 or 32 Bit nice hex value
base @ >r hex
tcell 2 u>
IF s>d <# # # # # '. hold # # # # #> type
IF s>d <# # # # # [char] . hold # # # # #> type
ELSE s>d <# # # # # # #> type
THEN r> base ! ;
......@@ -789,12 +1242,11 @@ T has? relocate H
>TARGET
H also Forth definitions
: X also target bl word find
: X bl word count [ ' target >wordlist ] Literal search-wordlist
IF state @ IF compile,
ELSE execute THEN
ELSE previous ABORT" Cross: access method not supported!"
THEN
previous ; immediate
ELSE -1 ABORT" Cross: access method not supported!"
THEN ; immediate
[IFDEF] asm-include asm-include [THEN] hex
......@@ -877,49 +1329,6 @@ DEFER comp[ \ ends compilation
: compile, colon, ;
>CROSS
\ file loading
: >fl-id 1 cells + ;
: >fl-name 2 cells + ;
Variable filelist 0 filelist !
Create NoFile ," #load-file#"
0 Value filemem
: loadfile FileMem ?dup IF >fl-name ELSE NoFile THEN ;
1 [IF] \ !! JAW WIP
: add-included-file ( adr len -- )
dup char+ >fl-name allocate throw >r
r@ >fl-name place
filelist @ r@ !
r> dup filelist ! to FileMem
;
: 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 ;
false DebugFlag showincludedfiles
: included
[d?] showincludedfiles
IF cr ." Including: " 2dup type ." ..." THEN
FileMem >r
2dup add-included-file included
r> to FileMem ;
: include bl word count included ;
: require bl word count included ;
[THEN]
\ resolve structure
: >next ; \ link to next field
......@@ -1140,7 +1549,8 @@ Variable to-doc to-doc on
IF
s" " doc-file-id write-line throw
s" make-doc " doc-file-id write-file throw
tlast @ >image count $1F and doc-file-id write-file throw
tlast @ >image count 1F and doc-file-id write-file throw
>in @
[char] ( parse 2drop
[char] ) parse doc-file-id write-file throw
......@@ -1162,7 +1572,7 @@ Create tag-bof 1 c, 0C c,
2variable last-loadfilename 0 0 last-loadfilename 2!
: put-load-file-name ( -- )
loadfilename 2@ last-loadfilename 2@ d<>
sourcefilename last-loadfilename 2@ d<>
IF
tag-bof count tag-file-id write-line throw
sourcefilename 2dup
......@@ -1177,7 +1587,7 @@ Create tag-bof 1 c, 0C c,
put-load-file-name
source >in @ min tag-file-id write-file throw
tag-beg count tag-file-id write-file throw
tlast @ >image count $1F and tag-file-id write-file throw
tlast @ >image count 1F and tag-file-id write-file throw
tag-end count tag-file-id write-file throw
base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
\ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
......@@ -1195,7 +1605,7 @@ Defer skip? ' false IS skip?
IF >magic <skip> swap !
ELSE drop THEN ;
: defined? ( -- flag ) \ name
: tdefined? ( -- flag ) \ name
ghost undefined? 0= ;
: defined2? ( -- flag ) \ name
......@@ -1235,8 +1645,8 @@ NoHeaderFlag off
: .sym
bounds
DO I c@ dup
CASE '/ OF drop ." \/" ENDOF
'\ OF drop ." \\" ENDOF