Commit baa14309 authored by anton's avatar anton

Initial revision

parents
/*
$Id: 386.h,v 1.1 1994-02-11 16:30:45 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
This is the machine-specific part for Intel 386 compatible processors
*/
/* Cell and UCell must be the same size as a pointer */
typedef long Cell;
typedef unsigned long UCell;
/* DCell and UDCell must be twice as large as Cell */
typedef long long DCell;
typedef unsigned long long UDCell;
/* define this if IEEE singles and doubles are available as C data types */
#define IEEE_FP
/* the IEEE types are used only for loading and storing */
/* the IEEE double precision type */
typedef double DFloat;
/* the IEEE single precision type */
typedef float SFloat;
/* define this if the least-significant byte is at the largets address */
/* #define BIG_ENDIAN */
#ifdef DIRECT_THREADED
/* PFA gives the parameter field address corresponding to a cfa */
#define PFA(cfa) (((Cell *)cfa)+2)
/* PFA1 is a special version for use just after a NEXT1 */
#define PFA1(cfa) PFA(cfa)
/* CODE_ADDRESS is the address of the code jumped to through the code field */
#define CODE_ADDRESS(cfa) ({long _cfa = (char *)(cfa); (Label)(_cfa+*((long *)(_cfa+1))-5);})
/* MAKE_CF creates an appropriate code field at the cfa; ca is the code address */
#define MAKE_CF(cfa,ca) ({long _cfa = (long *)(cfa); \
*(char *)_cfa = 0xe9; /* jmp */ \
*(long *)(_cfa+1) = ((long)(ca))-(_cfa+5);})
/* this is the point where the does code starts if label points to the
* jump dodoes */
#define DOES_CODE(label) ((Xt *)(((char *)label)+8))
/* this is a special version of DOES_CODE for use in dodoes */
#define DOES_CODE1(label) DOES_CODE(label)
/* this stores a jump dodoes at addr */
#define MAKE_DOESJUMP(addr) ({long _addr = (long *)(addr); \
*(char *)_addr = 0xe9; /* jmp */ \
*(long *)(_addr+1) = ((long)(&&dodoes))-(_addr+5);})
#endif
2, is accepted as a double number. anton 5oct93
after a stack underflow the stack contains 4 values. anton 5oct93
The system quits on exceptions like segmentation faults. anton 5oct93
compile does not have its traditional meaning. anton 5oct93
include does not read the last line if it does not end with \n. anton 6oct93
No warning is given when words are redefined. This is a problem when
using software from a case sensitive system. anton 6oct93
create-file creates a file with 000 protection anton 22oct93
Very preliminary version
Create a machine description file for your machine, if necessary.
Make a symbolic link to machine.h, e.g.
ln -s decstation.h machine.h
Now you can type
make
#$Id: Makefile,v 1.1 1994-02-11 16:30:45 anton Exp $
#Copyright 1992 by the ANSI figForth Development Group
RM = echo 'Trying to remove'
GCC = gcc
CC = gcc
SWITCHES = -DUSE_TOS -DUSE_FTOS # -DDIRECT_THREADED
CFLAGS = -O4 -Wall -g $(SWITCHES)
#-Xlinker -n puts text and data into the same 256M region
#John Wavrik should use -Xlinker -N to get a writable text (executable)
LDFLAGS = -g # -Xlinker -N
LDLIBS = -lm -lmalloc
EMACS = emacs
INCLUDES = forth.h io.h
FORTH_SRC = cross.fs debug.fs environ.fs errore.fs extend.fs \
filedump.fs glosgen.fs kernal.fs look.fs machine32b.fs \
machine32l.fs main.fs other.fs search-order.fs see.fs sieve.fs \
struct.fs tools.fs toolsext.fs vars.fs wordinfo.fs
SOURCES = Makefile primitives primitives2c.el engine.c main.c io.c \
apollo68k.h decstation.h 386.h hppa.h sparc.h \
$(INCLUDES) $(FORTH_SRC)
RCS_FILES = $(SOURCES) INSTALL ToDo model high-level
GEN = ansforth
GEN_PRECIOUS = primitives.i prim_labels.i primitives.b
OBJECTS = engine.o io.o main.o
all: ansforth aliases.fs
#from the gcc Makefile:
#"Deletion of files made during compilation.
# There are four levels of this:
# `mostlyclean', `clean', `distclean' and `realclean'.
# `mostlyclean' is useful while working on a particular type of machine.
# It deletes most, but not all, of the files made by compilation.
# It does not delete libgcc.a or its parts, so it won't have to be recompiled.
# `clean' deletes everything made by running `make all'.
# `distclean' also deletes the files made by config.
# `realclean' also deletes everything that could be regenerated automatically."
clean:
-rm $(GEN)
distclean: clean
-rm machine.h
realclean: distclean
-rm $(GEN_PRECIOUS)
current: $(RCS_FILES)
ansforth: $(OBJECTS)
$(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@
engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
$(GCC) $(CFLAGS) -S engine.c
engine.o: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
primitives.b: primitives
m4 primitives >$@
primitives.i : primitives.b primitives2c.el
$(EMACS) -batch -load primitives2c.el -funcall make-c
prim_labels.i : primitives.b primitives2c.el
$(EMACS) -batch -load primitives2c.el -funcall make-list
prim_alias.4th: primitives.b primitives2c.el
$(EMACS) -batch -load primitives2c.el -funcall make-alias
aliases.fs: prim_alias.4th
-$(GCC) -E -P -x c-header prim_alias.4th >$@
primitives.4th: primitives.b primitives2c.el
$(EMACS) -batch -load primitives2c.el -funcall make-forth
#GNU make default rules
% :: RCS/%,v
co $@
%.o : %.c $(INCLUDES)
$(CC) $(CFLAGS) -c $< -o $@
This file describes all the things left to do on ANSI figForth. The
list is not complete, so you should add topics you miss or refine
existing topics. If you are working on a topic, add your name to the
right of the topic. If you have completed the work, remove the topic.
This an emacs outline. Use '*' to create topics.
*The Engine
**measure the effect of some variations on different machines:
direct/indirect, NEXT splitting, keeping the TOSses in variables
**make it easy to put the right variation for each processor into the
configuration.
* ANSI Forth
**Core and Core Ext
*** high-level words
**Other Word Sets
*Run-time System
**Gender-independent image file format and loader
**Memory Management
**Stack Checking
On most systems we could use the MMU (OS dependent).
*Porting/Portability
** Machines/OSs
UNIX (all machines supported by gcc)
VMS (Vax)
DOS Extender, 386sx and up
DOS 8088 (16-bit or 32-bit?)
Windows
OS/2
Mac
Atari
Amiga
Use gcc-generated assembly on machines without gcc
*Locals
**Concept
**Implementation
*Postponing anton
*Foreign Language Interface
**Concept anton
**C
**FORTRAN
**C++
*Windows and Graphics
Ask Brian Dunn and Mike Hore for their OS-independent interface
*Program Development Environment
Issues: Convenience, portability across plattforms, compatibility with
existing tools (Emacs, F-PC)
**prefix file generator
A tool for generating a prefix file for a program that explains in
what way the program conforms to ANSI and contains Forth definitions
for the simple non-ANSI words.
*Object-Oriented Extensions
John Hayes (?) has a portable package
Ask Phil Burke (phil@ntg.com), if he wants to contribute ODE
*Documentation
A texinfo file
**glossaries of all wordsets.
***Tool to generate glossaries benschop
***Inclusion of glossary comments in all source files.
*Distribution and Announcements
** Ask the FSF, if they want to distribute it
** Write articles for (general-purpose) magazines
\ ADD.FS Kernal additional things 20may93jaw
\ linked list primitive
: linked here over @ a, swap ! ;
: discard 0 ?DO drop LOOP ;
/*
$Id: apollo68k.h,v 1.1 1994-02-11 16:30:45 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
This is the machine-specific part for a HP/Apollo with a 680x0
processor running Domain/OS
*/
/* Cell and UCell must be the same size as a pointer */
typedef long Cell;
typedef unsigned long UCell;
/* DCell and UDCell must be twice as large as Cell */
typedef long long DCell;
typedef unsigned long long UDCell;
/* define this if IEEE singles and doubles are available as C data types */
#define IEEE_FP
/* the IEEE types are used only for loading and storing */
/* the IEEE double precision type */
typedef double DFloat;
/* the IEEE single precision type */
typedef float SFloat;
/* define this if the least-significant byte is at the largets address */
#define BIG_ENDIAN
#ifdef DIRECT_THREADED
/* PFA gives the parameter field address corresponding to a cfa */
#define PFA(cfa) (((Cell *)cfa)+2)
/* PFA1 is a special version for use just after a NEXT1 */
#define PFA1(cfa) PFA(cfa)
/* CODE_ADDRESS is the address of the code jumped to through the code field */
#define CODE_ADDRESS(cfa) (*(Label *)(((char *)(cfa))+2))
/* MAKE_CF creates an appropriate code field at the cfa;
ca is the code address */
#define MAKE_CF(cfa,ca) ({short * _cfa = (short *)cfa; \
_cfa[0] = 0x4ef9; /* jmp.l */ \
*(long *)(_cfa+1) = (long)(ca);})
#endif
/* this is the point where the does code starts if label points to the
* jump dodoes */
#define DOES_CODE(label) ((Xt *)(((char *)label)+8))
/* this is a special version of DOES_CODE for use in dodoes */
#define DOES_CODE1(label) DOES_CODE(label)
/* this stores a jump dodoes at ca */
#define MAKE_DOESJUMP(ca) ({short * _ca = (short *)ca; \
_ca[0] = 0x4ef9; /* jmp.l */ \
*(long *)(_ca+1) = (long)&&dodoes;})
\ BUFOUT.STR Buffered output for Debug 13jun93jaw
CREATE O-Buffer 4000 chars allot align
VARIABLE O-PNT
: O-TYPE O-PNT @ over chars O-PNT +!
swap move ;
: O-EMIT O-PNT @ c! 1 chars O-PNT +! ;
VARIABLE EmitXT
VARIABLE TypeXT
: O-INIT What's type TypeXT !
What's emit EmitXT !
O-Buffer O-PNT !
['] o-type IS type
['] o-emit IS emit ;
: O-DEINIT EmitXT @ IS Emit
TypeXT @ IS Type ;
: O-PNT@ O-PNT @ O-Buffer - ;
This diff is collapsed.
\ DEBUG.FS Debugger 12jun93jaw
decimal
VARIABLE IP \ istruction pointer for debugger
\ Formated debugger words 12jun93jaw
false [IF]
Color: Men#
<A red >b yellow >f bold A> Men# CT!
CREATE D-LineIP 80 cells allot
CREATE D-XPos 300 chars allot align
CREATE D-LineA 80 cells allot
VARIABLE ^LineA
VARIABLE D-Lines
VARIABLE D-Line
VARIABLE D-MaxLines 10 D-MaxLines !
VARIABLE D-Bugline
: WatcherInit
D-MaxLines @ 3 + YPos ! 0 D-Line ! ;
: (lines)
1 cells ^LineA +!
O-PNT@ ^LineA @ ! ;
VARIABLE Body
: ScanWord ( body -- )
dup body !
c-init
ScanMode c-pass !
C-Formated on 0 Level !
C-ClearLine on
Colors on
0 XPos ! 0 YPos !
O-INIT
dup MakePass
DisplayMode c-pass !
c-stop off
D-LineIP 80 cells erase
0 D-Lines ! dup D-LineIP !
O-PNT@ D-LineA ! D-LineA ^LineA !
['] (lines) IS nlcount
XPos @ D-XPos c!
BEGIN analyse
D-Lines @ YPos @ <>
IF YPos @ D-Lines !
dup YPos @ cells D-LineIP + !
THEN
XPos @ over Body @ - 0 1 cells um/mod nip chars
D-XPos + c!
C-Stop @
UNTIL drop
O-PNT@ YPos @ 1+ cells D-LineA + !
-1 YPos @ 1+ cells D-LineIP + !
O-DEINIT
C-Formated off
0 D-Line !
['] noop IS nlcount ;
: SearchLine ( addr -- n )
D-LineIP D-Lines @ 0
?DO dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN
cell+
LOOP 2drop 0 ;
: Display ( n -- )
dup cells D-LineA + @ O-Buffer +
swap D-MaxLines @ + D-Lines @ min 1+
cells D-LineA + @ O-Buffer +
over - type ;
\ [IFDEF] Green Colors on [THEN]
\ dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos !
\ D-LineIP + @ C-Stop off
\ BEGIN
\ [IFDEF] Green IP @ over =
\ IF hig# C-Highlight ! ELSE C-Highlight off THEN
\ [THEN]
\ Analyse
\ C-Stop @ YPos @ D-MaxLines @ u>= or
\ UNTIL drop ;
: TopLine
0 0 at-xy
Men# CT@ attr!
." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr
\ one step beyond
0 CT@ attr! ;
: BottomLine
0 D-MaxLines @ 3 + at-xy
Men# CT@ attr!
." U-nnest D-one N-est A-bort" cr
0 CT@ attr! ;
VARIABLE LastIP
: (supress)
YPos @ D-MaxLines @ U>=
IF c-output off THEN ;
: DispIP
['] (supress) IS nlcount
dup SearchLine D-Line @ - dup YPos ! 2 +
over Body @ - 0 1 cells um/mod nip chars D-XPos + c@
swap AT-XY
Analyse drop
['] noop IS nlcount
c-output on ;
: Watcher ( -- )
TopLine
IP @ SearchLine dup D-Line @ dup D-MaxLines @ +
within
IF drop D-Line @ Display
ELSE D-MaxLines @ 2/ - 0 max dup D-Line !
Display
THEN
C-Formated off Colors on
\ LastIP @ ?DUP IF DispIP THEN
Hig# C-Highlight !
IP @ DispIP IP @ LastIP !
C-Formated on C-Highlight off
BottomLine ;
' noop ALIAS \w immediate
\ end formated debugger words
[ELSE]
' \ alias \w immediate
: scanword ( body -- )
c-init C-Output off
ScanMode c-pass !
dup MakePass
0 Level !
0 XPos !
DisplayMode c-pass !
MakePass
C-Output on ;
[THEN]
: .n 0 <# # # # # #S #> ctype bl cemit ;
: d.s ." [ " depth . ." ] "
depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
: NoFine XPos off YPos off
NLFlag off Level off
C-Formated off
[IFDEF] Colors Colors off [THEN]
;
: disp-step
DisplayMode c-pass ! \ change to displaymode
\ Branches Off \ don't display
\ \ BEGIN and THEN
cr
\w YPos @ 1+ D-BugLine !
\w Watcher
c-stop off
\w 0 D-BugLine @ at-xy
Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space
Base !
NoFine 10 XPos !
\w D-Bugline @ YPos !
ip @ DisplayMode c-pass ! Analyse drop
25 XPos @ - 0 max spaces ." -> " ;
: get-next ( -- n | n n )
DebugMode c-pass !
ip @ Analyse ;
: jump ( addr -- )
r> drop \ discard last ip
>r ;
AVARIABLE DebugLoop
: breaker r> 1 cells - IP ! DebugLoop @ jump ;
CREATE BP 0 , 0 ,
CREATE DT 0 , 0 ,
: set-bp ( 0 n | 0 n n -- )
0. BP 2!
?dup IF dup BP ! dup @ DT !
['] Breaker swap !
?dup IF dup BP cell+ ! dup @ DT cell+ !
['] Breaker swap ! drop THEN
THEN ;
: restore-bp ( -- )
BP @ ?dup IF DT @ swap ! THEN
BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
VARIABLE Body
: NestXT ( xt -- true | body false )
DebugMode c-pass ! C-Output off
xtc C-Output on
c-pass @ DebugMode = dup
IF ." Cannot debug" cr
THEN ;
VARIABLE Nesting
: Leave-D
[IFDEF] Colors Colors on [THEN]
C-Formated on
C-Output on ;
VARIABLE Unnest
: D-KEY ( -- flag )
BEGIN
Unnest @ IF 0 ELSE key THEN
CASE [char] n OF IP @ @ NestXT EXIT ENDOF
[char] s OF Leave-D
-128 THROW ENDOF
[char] a OF Leave-D
-128 THROW ENDOF
[char] d OF Leave-D
cr ." Done..." cr
Nesting off
r> drop IP @ >r
EXIT ENDOF
[char] ? OF cr ." Nest Stop Done Unnest" cr
ENDOF
[char] u OF Unnest on true EXIT ENDOF
drop true EXIT
ENDCASE
AGAIN ;
: (debug) ( body -- )
0 Nesting !
BEGIN Unnest off
cr ." Scanning code..." cr C-Formated on
dup scanword IP !
cr ." Nesting debugger ready!" cr
\w WatcherInit 0 CT@ attr! page
BEGIN disp-step D-Key
WHILE C-Stop @ 0=
WHILE 0 get-next set-bp
IP @ jump
[ here DebugLoop ! ]
restore-bp
d.s
REPEAT
Nesting @ 0= ?EXIT
-1 Nesting +! r>
ELSE
IP @ >r 1 Nesting +!
THEN
AGAIN ;
: dbg ' NestXT ?EXIT (debug) ;
: test 1 2 4 swap dup . ;
/*
$Id: decstation.h,v 1.1 1994-02-11 16:30:46 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
This is the machine-specific part for a Decstation running Ultrix
*/
/* Cell and UCell must be the same size as a pointer */
typedef long Cell;
typedef unsigned long UCell;
/* DCell and UDCell must be twice as large as Cell */
typedef long long DCell;
typedef unsigned long long UDCell;
/* define this if IEEE singles and doubles are available as C data types */
#define IEEE_FP
/* the IEEE types are used only for loading and storing */
/* the IEEE double precision type */
typedef double DFloat;
/* the IEEE single precision type */
typedef float SFloat;
/* define this if the least-significant byte is at the largets address */
/* #define BIG_ENDIAN */
/* some definitions for composing opcodes */
#define JUMP_MASK 0x03ffffff
#define J_PATTERN 0x08000000
#define JAL_PATTERN 0x0c000000
/* this provides the first 4 bits of a jump address, i.e. it must be <16 */
#define SEGMENT_NUM 1
#ifdef DIRECT_THREADED
/* PFA gives the parameter field address corresponding to a cfa */
# define PFA(cfa) (((Cell *)cfa)+2)
/* PFA1 is a special version for use just after a NEXT1 */
# define PFA1(cfa) PFA(cfa)
/* CODE_ADDRESS is the address of the code jumped to through the code field */
# define CODE_ADDRESS(cfa) ((Label)(((*(unsigned *)(cfa))^J_PATTERN^(SEGMENT_NUM<<26))<<2))
/* MAKE_CF creates an appropriate code field at the cfa; ca is the code address */
# define MAKE_CF(cfa,ca) ({long * _cfa = (long *)(cfa); \
_cfa[0] = J_PATTERN|((((long)(ca))&JUMP_MASK)>>2); /* J ca */ \
_cfa[1] = 0; /* nop */})
# ifdef undefined
/* the following version uses JAL to make PFA1 faster */
# define PFA1(label) ({register Cell *pfa asm("$31"); \
pfa; })
/* CODE_ADDRESS is the address of the code jumped to through the code field */
# define CODE_ADDRESS(cfa) ((Label)(((*(unsigned *)(cfa))^JAL_PATTERN^(SEGMENT_NUM<<26))<<2))
# define MAKE_CF(cfa,ca) ({long *_cfa = (long *)(cfa); \
long _ca = (long)(ca);
_cfa[0] = JAL_PATTERN|(((((long)_ca)>>2)+4)&JUMP_MASK), /* JAL ca+4 */ \
_cfa[1] = *(long *)_ca; /* delay slot */})
# endif /* undefined */
/* this is the point where the does code starts if label points to the
* jump dodoes */
# define DOES_CODE(cfa) ((Xt *)(((char *)CODE_ADDRESS(cfa))+8))
/* this is a special version of DOES_CODE for use in dodoes */
# define DOES_CODE1(cfa) DOES_CODE(cfa)
# define DOES_HANDLER_SIZE 8
# define MAKE_DOES_CF(cfa, does_code) ({char *does_handlerp=((char *)does_code)-DOES_HANDLER_SIZE; \
MAKE_CF(cfa,does_handlerp); \
MAKE_DOES_HANDLER(does_handlerp);})
/* this stores a jump dodoes at addr */
# define MAKE_DOES_HANDLER(addr) ({long * _addr = (long *)addr; \
_addr[0] = J_PATTERN|((((long)DODOES)>>2)&JUMP_MASK); /* J dodoes */ \
_addr[1] = 0; /* nop */})
#endif
#ifdef undefined
/* and here are some more efficient versions that can be tried later */
/* the first version saves one cycle by doing something useful in the
delay slot. !! check that the instruction in the delay slot is legal
*/
#define MAKE_DOESJUMP(addr) ({long * _addr = (long *)addr; \
_addr[0] = J_PATTERN|(((((long)symbols[3])>>2)+4)&JUMP_MASK), /* J dodoes+4 */ \
_addr[1] = *(long *)symbols[3]; /* delay */})
/* the following version uses JAL to make DOES_CODE1 faster */
/* !! does the declaration clear the register ? */
/* it's ok to use the same reg as in PFA1:
dodoes is the only potential problem and I have taken care of it */
#define DOES_CODE1(cfa) ({register Code *_does_code asm("$31"); \
_does_code; })
#define MAKE_DOESJUMP(addr) ({long * _addr = (long *)addr; \
_addr[0] = JAL_PATTERN|(((((long)symbols[3])>>2)+4)&JUMP_MASK), /* JAL dodoes+4 */ \
_addr[1] = *(long *)symbols[3]; /* delay */})
#endif
/*
$Id: engine.c,v 1.1 1994-02-11 16:30:46 anton Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
#include <ctype.h>
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <assert.h>
#include <stdlib.h>
#include "forth.h"
#include "io.h"
extern unlink(char *);
extern ftruncate(int, int);
typedef union {
struct {
#ifdef BIG_ENDIAN
Cell high;
Cell low;
#else
Cell low;
Cell high;
#endif;
} cells;
DCell dcell;
} Double_Store;
typedef struct F83Name {
struct F83Name *next; /* the link field for old hands */
char countetc;
Char name[0];
} F83Name;
/* are macros for setting necessary? */
#define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
#define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
#define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
/* NEXT and NEXT1 are split into several parts to help scheduling */
#ifdef DIRECT_THREADED
#define NEXT1_P1
#define NEXT1_P2 ({goto *cfa;})
#else
#define NEXT1_P1 ({ca = *cfa;})
#define NEXT1_P2 ({goto *ca;})
#endif
#define NEXT_P1 ({cfa = *ip++; NEXT1_P1;})