Skip to content

gforth
gforth
Commit 14fd3cd8 authored by pazsan's avatar pazsan
Browse files
Options

Started to merge in changes made for gforth-EC project.

parent 9d388260
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 823 additions and 622 deletions
Makefile.in
View file @ 14fd3cd8
......@@ -84,11 +84,12 @@ emacssitelispdir=$(datadir)/emacs/site-lisp
INCLUDES = forth.h threading.h io.h
KERN_SRC = \
add.fs \
aliases0.fs \
aliases.fs \
conditionals.fs \
cross.fs \
errore.fs \
extend.fs \
files.fs \
kernel.fs \
main.fs \
search-order.fs \
......@@ -106,6 +107,8 @@ GFORTH_FI_SRC = \
debugging.fs \
dumpimage.fs \
environ.fs \
errors.fs \
extend.fs \
float.fs \
glocals.fs \
hash.fs \
......@@ -435,8 +438,9 @@ primitives.i : primitives.b prims2x.fs
prim_labels.i : primitives.b prims2x.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-label process-file bye" >$@
aliases.fs: primitives.b prims2x.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-alias process-file bye" >$@
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" >$@
......
aliases0.fs 0 → 100644
View file @ 14fd3cd8
-2 Alias: :docol
-3 Alias: :docon
-4 Alias: :dovar
-5 Alias: :douser
-6 Alias: :dodefer
-7 Alias: :dofield
-8 Alias: :dodoes
-9 Alias: :doesjump
args.fs 0 → 100644
View file @ 14fd3cd8
\ argument expansion
: cstring>sstring ( cstring -- addr n ) \ gforth cstring-to-sstring
-1 0 scan 0 swap 1+ /string ;
: arg ( n -- addr count ) \ gforth
cells argv @ + @ cstring>sstring ;
: #! postpone \ ; immediate
Create pathstring 2 cells allot \ string
Create pathdirs 2 cells allot \ dir string array, pointer and count
Variable argv
Variable argc
0 Value script? ( -- flag )
: process-path ( addr1 u1 -- addr2 u2 )
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings
align here >r
BEGIN
over >r 0 scan
over r> tuck - ( rest-str this-str )
dup
IF
2dup 1- chars + c@ [char] / <>
IF
2dup chars + [char] / swap c!
1+
THEN
2,
ELSE
2drop
THEN
dup
WHILE
1 /string
REPEAT
2drop
here r> tuck - 2 cells / ;
: do-option ( addr1 len1 addr2 len2 -- n )
2swap
2dup s" -e" compare 0= >r
2dup s" --evaluate" compare 0= r> or
IF 2drop dup >r ['] evaluate catch
?dup IF dup >r DoError r> negate (bye) THEN
r> >tib +! 2 EXIT THEN
." Unknown option: " type cr 2drop 1 ;
: process-args ( -- )
true to script?
>tib @ >r
argc @ 1
?DO
I arg over c@ [char] - <>
IF
required 1
ELSE
I 1+ argc @ = IF s" " ELSE I 1+ arg THEN
do-option
THEN
+LOOP
r> >tib !
false to script?
;
cross.fs
View file @ 14fd3cd8
......@@ -104,7 +104,7 @@ Variable tdp
\ Parameter for target systems 06oct92py
included
mach-file count included
\ Create additional parameters 19jan95py
......@@ -131,14 +131,6 @@ H
>TARGET
20 CONSTANT bl
-1 Constant NIL
-2 Constant :docol
-3 Constant :docon
-4 Constant :dovar
-5 Constant :douser
-6 Constant :dodefer
-7 Constant :dofield
-8 Constant :dodoes
-9 Constant :doesjump
>CROSS
......@@ -233,15 +225,10 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
\ threading modell 13dec92py
\ generic threading modell
: docol, ( -- ) :docol T A, 0 , H ;
>TARGET
: >body ( cfa -- pfa ) T cell+ cell+ H ;
>CROSS
: dodoes, ( -- ) T :doesjump A, 0 , H ;
\ Ghost Builder 06oct92py
\ <T T> new version with temp variable 10may93jaw
......@@ -252,7 +239,7 @@ VARIABLE VocTemp
: T> previous VocTemp @ set-current ;
4711 Constant <fwd> 4712 Constant <res>
4713 Constant <imm>
4713 Constant <imm> 4714 Constant <do:>
\ iForth makes only immediate directly after create
\ make atonce trick! ?
......@@ -464,6 +451,8 @@ VARIABLE ;Resolve 1 cells allot
>TARGET
: Alias ( cfa -- ) \ name
(THeader over resolve T A, H 80 flag! ;
: Alias: ( cfa -- ) \ name
ghost tuck swap resolve <do:> swap >magic ! ;
>CROSS
\ Conditionals and Comments 11may93jaw
......@@ -500,6 +489,7 @@ ghost lit ghost (compile) ghost ! 2drop drop
ghost (does>) ghost noop 2drop
ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost ' drop
ghost :docol ghost :doesjump ghost :dodoes 2drop drop
\ compile 10may93jaw
......@@ -511,6 +501,11 @@ ghost ' drop
ELSE postpone literal postpone gexecute THEN ;
immediate
\ generic threading modell
: docol, ( -- ) compile :docol T 0 , H ;
: dodoes, ( -- ) compile :doesjump T 0 , H ;
>TARGET
: ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
......@@ -586,7 +581,8 @@ Cond: ; ( -- ) restrict?
Cond: [ restrict? state off ;Cond
>CROSS
: !does :dodoes tlastcfa @ tuck T ! cell+ ! H ;
: !does
tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
>TARGET
Cond: DOES> restrict?
......@@ -607,8 +603,11 @@ Cond: DOES> restrict?
\ DOES> dup >exec @ execute ;
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
:dodoes T A, H gexecute T here H cell - reloff ;
IF
dup >magic @ <do:> =
IF gexecute T 0 , H EXIT THEN
THEN
compile :dodoes gexecute T here H cell - reloff ;
: TCreate ( -- )
last-ghost @
......@@ -631,6 +630,10 @@ Cond: DOES> restrict?
here ghostheader
:noname postpone gdoes> postpone ?EXIT ;
: by: ( -- addr [xt] [colon-sys] ) \ name
ghost
:noname postpone gdoes> postpone ?EXIT ;
: ;DO ( addr [xt] [colon-sys] -- )
postpone ; ( S addr xt )
over >exec ! ; immediate
......@@ -642,9 +645,8 @@ Cond: DOES> restrict?
\ Variables and Constants 05dec92py
Build: ;
DO: ( ghost -- addr ) ;DO
by: :dovar ( ghost -- addr ) ;DO
Builder Create
by Create :dovar resolve
Build: T 0 , H ;
by Create
......@@ -668,9 +670,8 @@ Variable tudp 0 tudp !
>TARGET
Build: T 0 u, , H ;
DO: ( ghost -- up-addr ) T @ H tup @ + ;DO
by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO
Builder User
by User :douser resolve
Build: T 0 u, , 0 u, drop H ;
by User
......@@ -681,9 +682,8 @@ by User
Builder AUser
Build: ( n -- ) T , H ;
DO: ( ghost -- n ) T @ H ;DO
by: :docon ( ghost -- n ) T @ H ;DO
Builder Constant
by Constant :docon resolve
Build: ( n -- ) T A, H ;
by Constant
......@@ -702,9 +702,8 @@ by Constant
Builder AValue
Build: ( -- ) compile noop ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder Defer
by Defer :dodefer resolve
Build: ( inter comp -- ) swap T immediate A, A, H ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
......@@ -720,9 +719,8 @@ Builder interpret/compile:
Build: >r rot r@ nalign dup T , H ( align1 size offset )
+ swap r> nalign ;
DO: T @ H + ;DO
by: :dofield T @ H + ;DO
Builder Field
by Field :dofield resolve
: struct T 0 1 chars H ;
: end-struct T 2Constant H ;
......@@ -916,7 +914,9 @@ char 1 bigendian + cell + magic 7 + c!
: drop drop ; : = = ;
: lshift lshift ; : 2/ 2/ ;
: . . ;
cell constant cell
\ cell constant cell
mach-file count included
\ include bug5.fs
\ only forth also minimal definitions
......
engine.c
View file @ 14fd3cd8
......@@ -110,7 +110,7 @@ char *tilde_cstr(Char *from, UCell size, int clear)
s2 = from+1;
s2_len = size-1;
} else {
int i;
UCell i;
for (i=1; i<size && from[i]!='/'; i++)
;
{
......
errore.fs
View file @ 14fd3cd8
......@@ -25,72 +25,8 @@
AVARIABLE ErrLink \ Linked list entry point
NIL ErrLink !
: ERR" ( n -- )
ErrLink linked
,
[char] " parse
string, align ;
decimal
-1 ERR" Aborted"
-3 ERR" Stack overflow"
-4 ERR" Stack underflow"
-5 ERR" Return stack overflow"
-6 ERR" Return stack undeflow"
-7 ERR" Do-loops nested too deeply"
-8 ERR" Dictionary overflow"
-9 ERR" Invalid memory address"
-10 ERR" Division by zero"
-11 ERR" Result out of range"
-12 ERR" Argument type mismatch"
-13 ERR" Undefined word"
-14 ERR" Interpreting a compile-only word"
-15 ERR" Invalid FORGET"
-16 ERR" Attempt to use zero-length string as a name"
-17 ERR" Pictured numeric ouput string overflow"
-18 ERR" Parsed string overflow"
-19 ERR" Word name too long"
-20 ERR" Write to a read-only location"
-21 ERR" Unsupported operation"
-22 ERR" Control structure mismatch"
-23 ERR" Address alignment exception"
-24 ERR" Invalid numeric argument"
-25 ERR" Return stack imbalance"
-26 ERR" Loop parameters unavailable"
-27 ERR" Invalid recursion"
-28 ERR" User interrupt"
-29 ERR" Compiler nesting"
-30 ERR" Obsolescent feature"
-31 ERR" >BODY used on non-CREATEd definition"
-32 ERR" Invalid name argument"
-33 ERR" Block read exception"
-34 ERR" Block write exception"
-35 ERR" Invalid block number"
-36 ERR" Invalid file position"
-37 ERR" File I/O exception"
-38 ERR" Non-existent file"
-39 ERR" Unexpected end of file"
-40 ERR" Invalid BASE for floating point conversion"
-41 ERR" Loss of precision"
-42 ERR" Floating-point divide by zero"
-43 ERR" Floating-point result out of range"
-44 ERR" Floating-point stack overflow"
-45 ERR" Floating-point stack underflow"
-46 ERR" Floating-point invalid argument"
-47 ERR" Compilation word list deleted"
-48 ERR" invalid POSTPONE"
-49 ERR" Search-order overflow"
-50 ERR" Search-order underflow"
-51 ERR" Compilation word list changed"
-52 ERR" Control-flow stack overflow"
-53 ERR" Exception stack overflow"
-54 ERR" Floating-point underflow"
-55 ERR" Floating-point unidentified fault"
-56 ERR" QUIT"
-57 ERR" Error in sending or receiving a character"
-58 ERR" [IF], [ELSE], [THEN] error"
\ error numbers between -256 and -511 represent signals
\ signals are handled with strsignal
\ but some signals produce throw-codes > -256, e.g., -28
......
errors.fs 0 → 100644
View file @ 14fd3cd8
\ Load in error strings
: linked here over @ a, swap ! ;
: ERR" ( n -- )
ErrLink linked
,
[char] " parse
string, align ;
decimal
-1 ERR" Aborted"
-3 ERR" Stack overflow"
-4 ERR" Stack underflow"
-5 ERR" Return stack overflow"
-6 ERR" Return stack undeflow"
-7 ERR" Do-loops nested too deeply"
-8 ERR" Dictionary overflow"
-9 ERR" Invalid memory address"
-10 ERR" Division by zero"
-11 ERR" Result out of range"
-12 ERR" Argument type mismatch"
-13 ERR" Undefined word"
-14 ERR" Interpreting a compile-only word"
-15 ERR" Invalid FORGET"
-16 ERR" Attempt to use zero-length string as a name"
-17 ERR" Pictured numeric ouput string overflow"
-18 ERR" Parsed string overflow"
-19 ERR" Word name too long"
-20 ERR" Write to a read-only location"
-21 ERR" Unsupported operation"
-22 ERR" Control structure mismatch"
-23 ERR" Address alignment exception"
-24 ERR" Invalid numeric argument"
-25 ERR" Return stack imbalance"
-26 ERR" Loop parameters unavailable"
-27 ERR" Invalid recursion"
-28 ERR" User interrupt"
-29 ERR" Compiler nesting"
-30 ERR" Obsolescent feature"
-31 ERR" >BODY used on non-CREATEd definition"
-32 ERR" Invalid name argument"
-33 ERR" Block read exception"
-34 ERR" Block write exception"
-35 ERR" Invalid block number"
-36 ERR" Invalid file position"
-37 ERR" File I/O exception"
-38 ERR" Non-existent file"
-39 ERR" Unexpected end of file"
-40 ERR" Invalid BASE for floating point conversion"
-41 ERR" Loss of precision"
-42 ERR" Floating-point divide by zero"
-43 ERR" Floating-point result out of range"
-44 ERR" Floating-point stack overflow"
-45 ERR" Floating-point stack underflow"
-46 ERR" Floating-point invalid argument"
-47 ERR" Compilation word list deleted"
-48 ERR" invalid POSTPONE"
-49 ERR" Search-order overflow"
-50 ERR" Search-order underflow"
-51 ERR" Compilation word list changed"
-52 ERR" Control-flow stack overflow"
-53 ERR" Exception stack overflow"
-54 ERR" Floating-point underflow"
-55 ERR" Floating-point unidentified fault"
-56 ERR" QUIT"
-57 ERR" Error in sending or receiving a character"
-58 ERR" [IF], [ELSE], [THEN] error"
extend.fs
View file @ 14fd3cd8
......@@ -160,26 +160,6 @@ decimal
>in !
false ;
\ : save-input ( -- x1 .. xn n ) \ core-ext
\ >in @
\ loadfile @ ?dup
\ IF dup file-position throw sourceline# >tib @ 6
\ #tib @ >tib +!
\ ELSE sourceline# blk @ linestart @ >tib @ 5 THEN
\ ;
\ : restore-input ( x1 .. xn n -- flag ) \ core-ext
\ swap >tib !
\ 6 = IF loadline ! rot dup loadfile !
\ reposition-file IF drop true EXIT THEN
\ ELSE linestart ! blk !
\ dup sourceline# <> IF 2drop true EXIT THEN
\ loadline !
\ THEN
\ >in ! false ;
\ This things we don't need, but for being complete... jaw
\ EXPECT SPAN 17may93jaw
......
files.fs 0 → 100644
View file @ 14fd3cd8
\ File specifiers 11jun93jaw
4 Constant w/o ( -- fam ) \ file w-o
2 Constant r/w ( -- fam ) \ file r-w
0 Constant r/o ( -- fam ) \ file r-o
: bin ( fam1 -- fam2 ) \ file
1 or ;
\ BIN WRITE-LINE 11jun93jaw
: write-line ( c-addr u fileid -- ior ) \ file
dup >r write-file
?dup IF
r> drop EXIT
THEN
#lf r> emit-file ;
\ include-file 07apr93py
: push-file ( -- ) r>
sourceline# >r loadfile @ >r
blk @ >r tibstack @ >r >tib @ >r #tib @ >r
>tib @ tibstack @ = IF r@ tibstack +! THEN
tibstack @ >tib ! >in @ >r >r ;
: pop-file ( throw-code -- throw-code )
dup IF
source >in @ sourceline# sourcefilename
error-stack dup @ dup 1+
max-errors 1- min error-stack !
6 * cells + cell+
5 cells bounds swap DO
I !
-1 cells +LOOP
THEN
r>
r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> blk !
r> loadfile ! r> loadline ! >r ;
: read-loop ( i*x -- j*x )
BEGIN refill WHILE interpret REPEAT ;
: include-file ( i*x fid -- j*x ) \ file
push-file loadfile !
0 loadline ! blk off ['] read-loop catch
loadfile @ close-file swap 2dup or
pop-file drop throw throw ;
create pathfilenamebuf 256 chars allot \ !! make this grow on demand
: 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 ./* or ../*, extended regexp: ^[/~]|./|../
\G Pathes simply containing a / are not absolute!
over c@ '/ = >r
over c@ '~ = >r
2dup 2 min S" ./" compare 0= >r
3 min S" ../" compare 0=
r> r> r> or or or ;
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
\G opens a file for reading, searching in the path for it (unless
\G the filename contains a slash); c-addr2 u2 is the full filename
\G (valid until the next call); if the file is not found (or in
\G case of other errors for each try), -38 (non-existant file) is
\G thrown. Opening for other access modes makes little sense, as
\G the path will usually contain dirs that are only readable for
\G the user
\ !! use file-status to determine access mode?
2dup absolut-path?
IF \ the filename contains a slash
2dup r/o open-file throw ( c-addr1 u1 file-id )
-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
pathfilenamebuf r> EXIT
THEN
pathdirs 2@ 0
?DO ( c-addr1 u1 dirnamep )
dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
pathfilenamebuf over r> + dup >r r/o open-file 0=
IF ( addr u file-id )
nip nip r> rdrop 0 LEAVE
THEN
rdrop drop r> cell+ cell+
LOOP
0<> -&38 and throw ( file-id u2 )
pathfilenamebuf swap ;
create included-files 0 , 0 , ( pointer to and count of included files )
here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells -
create image-included-files 1 , A, ( pointer to and count of included files )
\ included-files points to ALLOCATEd space, while image-included-files
\ points to ALLOTed objects, so it survives a save-system
: loadfilename ( -- a-addr )
\G a-addr 2@ produces the current file name ( c-addr u )
included-files 2@ drop loadfilename# @ 2* cells + ;
: sourcefilename ( -- c-addr u ) \ gforth
\G the name of the source file which is currently the input
\G source. The result is valid only while the file is being
\G loaded. If the current input source is no (stream) file, the
\G result is undefined.
loadfilename 2@ ;
: sourceline# ( -- u ) \ gforth sourceline-number
\G the line number of the line that is currently being interpreted
\G from a (stream) file. The first line has the number 1. If the
\G current input source is no (stream) file, the result is
\G undefined.
loadline @ ;
: init-included-files ( -- )
image-included-files 2@ 2* cells save-mem drop ( addr )
image-included-files 2@ nip included-files 2! ;
: included? ( c-addr u -- f ) \ gforth
\G true, iff filename c-addr u is in included-files
included-files 2@ 0
?do ( c-addr u addr )
dup >r 2@ 2over compare 0=
if
2drop rdrop unloop
true EXIT
then
r> cell+ cell+
loop
2drop drop false ;
: add-included-file ( c-addr u -- ) \ gforth
\G add name c-addr u to included-files
included-files 2@ 2* cells 2 cells extend-mem
2/ cell / included-files 2!
2! ;
: included1 ( i*x file-id c-addr u -- j*x ) \ gforth
\G include the file file-id with the name given by c-addr u
loadfilename# @ >r
save-mem add-included-file ( file-id )
included-files 2@ nip 1- loadfilename# !
['] include-file catch
r> loadfilename# !
throw ;
: included ( i*x addr u -- j*x ) \ file
open-path-file included1 ;
: required ( i*x addr u -- j*x ) \ gforth
\G include the file with the name given by addr u, if it is not
\G included already. Currently this works by comparing the name of
\G the file (with path) against the names of earlier included
\G files; however, it would probably be better to fstat the file,
\G and compare the device and inode. The advantages would be: no
\G problems with several paths to the same file (e.g., due to
\G links) and we would catch files included with include-file and
\G write a require-file.
open-path-file 2dup included?
if
2drop close-file throw
else
included1
then ;
\ INCLUDE 9may93jaw
: include ( "file" -- ) \ gforth
name included ;
: require ( "file" -- ) \ gforth
name required ;
\ additional words only needed if there is file support
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren
loadfile @ 0= IF postpone ( EXIT THEN
BEGIN
>in @
[char] ) parse nip
>in @ rot - = \ is there no delimter?
WHILE
refill 0=
IF
warnings @
IF
." warning: ')' missing" cr
THEN
EXIT
THEN
REPEAT ; immediate
kernel.fs
View file @ 14fd3cd8
This diff is collapsed.
mach16b.fs
View file @ 14fd3cd8
......@@ -25,3 +25,13 @@
8 Constant float
true Constant bigendian
( true=big, false=little )
\ 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
mach16l.fs
View file @ 14fd3cd8
......@@ -25,3 +25,13 @@
8 Constant float
false Constant bigendian
( true=big, false=little )
\ 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
mach32b.fs
View file @ 14fd3cd8
......@@ -25,3 +25,21 @@
8 Constant float
true Constant bigendian
( true=big, false=little )
\ feature list
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
mach32l.fs
View file @ 14fd3cd8
......@@ -25,3 +25,13 @@
8 Constant float
false Constant bigendian
( true=big, false=little )
\ 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
mach64b.fs
View file @ 14fd3cd8
......@@ -25,3 +25,13 @@
8 Constant float
true Constant bigendian
( true=big, false=little )
\ 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
mach64l.fs
View file @ 14fd3cd8
......@@ -25,3 +25,13 @@
8 Constant float
false Constant bigendian
( true=big, false=little )
\ feature list
true Constant NIL \ relocating
true Constant has-files
true Constant has-OS