vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-05 23:22:25 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding powerpc target

Browse source
This commit is contained in:
Norayr Chilingarian 2014-01-06 20:30:21 +04:00
parent b18729c519
commit 931dae4763
37 changed files with 2846 additions and 4948 deletions
Download patch file Download diff file Expand all files Collapse all files

7
makefile
View file

@ -2,7 +2,7 @@
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = x86_64
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0
@ -250,11 +250,6 @@ clean:
rm *.a
rm *.sym
coco:
$(JET) Sets.Mod Oberon.Mod CRS.Mod CRT.Mod CRA.Mod CRX.Mod CRP.Mod Coco.Mod -m
$(CC) Sets.c Oberon.c CRS.c CRT.c CRA.c CRX.c CRP.c
$(CL) -static -o Coco Coco.c Sets.o Oberon.o CRS.o CRT.o CRA.o CRX.o CRP.o CmdlnTexts.o SYSTEM.o Files.o -L. -lOberon -L/usr/lib -ldl
install:
test -d $(PREFIX)/bin | mkdir -p $(PREFIX)/bin
cp voc $(PREFIX)/bin/

2
makefile.gnuc.armv6j
View file

@ -2,7 +2,7 @@
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = armv6j
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0

2
makefile.gnuc.armv6j_hardfp
View file

@ -2,7 +2,7 @@
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = armv6j_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0

2
makefile.gnuc.armv7a_hardfp
View file

@ -2,7 +2,7 @@
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0

281
makefile.gnuc.powerpc Normal file
View file

@ -0,0 +1,281 @@
#SHELL := /bin/bash
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = powerpc
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0
INCLUDEPATH = -Isrc/lib/system/$(CCOMP)/$(TARCH)
SETPATH = CFLAGS=$(INCLUDEPATH) PATH=.:/bin:/usr/bin MODULES=.:src/lib:src/lib/v4:src/lib/v4/$(TARCH):src/lib/system:src/lib/system/$(CCOMP):src/lib/system/$(CCOMP)/$(TARCH):src/lib/ulm:src/lib/ulm/$(CCOMP):src/lib/ulm/$(TARCH):src/lib/ooc2:src/lib/ooc2/$(CCOMP):src/lib/ooc:src/lib/ooc/$(CCOMP):src/lib/pow:src/lib/misc:src/lib/s3:src/voc:src/voc/$(CCOMP):src/voc/$(CCOMP)/$(TARCH):src/tools/ocat:src/tools/browser:src/tools/vocparam:src/tools/vmake:src/tools/coco:src/test
VOC = voc
VOCSTATIC0 = $(SETPATH) ./vocstatic.$(TOS).$(CCOMP).$(TARCH)
VOCSTATIC = $(SETPATH) ./voc
VOCPARAM = $(shell ./vocparam > voc.par)
VERSION = GNU_Linux_$(TARCH)
LIBNAME = VishapOberon
LIBRARY = lib$(LIBNAME)
ifndef PREFIX
PREFIX = /opt/voc-$(RELEASE)
endif
CCOPT = -fPIC $(INCLUDEPATH) -g
CC = cc $(CCOPT) -c
CL = cc $(CCOPT)
LD = cc -shared -o $(LIBRARY).so
# s is necessary to create index inside a archive
ARCHIVE = ar rcs $(LIBRARY).a
#%.c: %.Mod
#%.o: %.c
# $(CC) $(input)
all: stage2 stage3 stage4 stage5 stage6 stage7
# when porting to new platform:
# * put corresponding .par file into current directory. it can be generated on the target platform by compiling vocparam (stage0) and running (stage1)
# * run make port0 - this will generate C source files for the target architecture
# * move the source tree to the target machine, and compile (or compile here via crosscompiler) (port1)
port0: stage2 stage3 stage4
# now compile C source files for voc, showdef and ocat on target machine (or by using crosscompiler)
port1: stage5
# after you have "voc" compiled for target architecture. replace vocstatic with it and run make on target platform to get everything compiled
# this builds binary which generates voc.par
stage0: src/tools/vocparam/vocparam.c
$(CL) -I src/lib -o vocparam src/tools/vocparam/vocparam.c
# this creates voc.par for a host architecture.
# comment this out if you need to build a compiler for a different architecture.
stage1:
#rm voc.par
#$(shell "./vocparam > voc.par")
#./vocparam > voc.par
$(VOCPARAM)
# this copies necessary voc.par to the current directory.
# skip this if you are building compiler for the host architecture.
stage2:
cp src/par/voc.par.$(CCOMP).$(TARCH) voc.par
# cp src/par/voc.par.gnu.x86_64 voc.par
# cp src/par/voc.par.gnu.x86 voc.par
# cp src/par/voc.par.gnu.armv6 voc.par
# cp src/par/voc.par.gnu.armv7 voc.par
# this prepares modules necessary to build the compiler itself
stage3:
$(VOCSTATIC0) -siapxPS SYSTEM.Mod
$(VOCSTATIC0) -sPS Args.Mod Console.Mod Unix.Mod
$(VOCSTATIC0) -sPS oocOakStrings.Mod architecture.Mod version.Mod Kernel.Mod Modules.Mod
$(VOCSTATIC0) -sxPS Files.Mod
$(VOCSTATIC0) -sxPS OakFiles.Mod
$(VOCSTATIC0) -sPS Reals.Mod CmdlnTexts.Mod errors.Mod
# build the compiler
stage4:
$(VOCSTATIC0) -sPS extTools.Mod
$(VOCSTATIC0) -sPS OPM.cmdln.Mod
$(VOCSTATIC0) -sxPS OPS.Mod
$(VOCSTATIC0) -sPS OPT.Mod OPC.Mod OPV.Mod OPB.Mod OPP.Mod
$(VOCSTATIC0) -smPS voc.Mod
$(VOCSTATIC0) -smPS BrowserCmd.Mod
$(VOCSTATIC0) -smPS OCatCmd.Mod
$(VOCSTATIC0) -sPS compatIn.Mod
$(VOCSTATIC0) -smPS vmake.Mod
#this is to build the compiler from C sources.
#this is a way to create a bootstrap binary.
stage5:
$(CC) SYSTEM.c Args.c Console.c Modules.c Unix.c \
oocOakStrings.c architecture.c version.c Kernel.c Files.c OakFiles.c Reals.c CmdlnTexts.c \
version.c extTools.c \
OPM.c OPS.c OPT.c OPC.c OPV.c OPB.c OPP.c errors.c
$(CL) -static voc.c -o voc \
SYSTEM.o Args.o Console.o Modules.o Unix.o \
oocOakStrings.o architecture.o version.o Kernel.o Files.o Reals.o CmdlnTexts.o \
extTools.o \
OPM.o OPS.o OPT.o OPC.o OPV.o OPB.o OPP.o errors.o
$(CL) BrowserCmd.c -o showdef \
SYSTEM.o Args.o Console.o Modules.o Unix.o oocOakStrings.o architecture.o version.o Kernel.o Files.o Reals.o CmdlnTexts.o \
OPM.o OPS.o OPT.o OPV.o OPC.o errors.o
$(CL) OCatCmd.c -o ocat \
SYSTEM.o Args.o Console.o Modules.o Unix.o oocOakStrings.o architecture.o version.o Kernel.o Files.o Reals.o CmdlnTexts.o
$(CC) compatIn.c
$(CL) vmake.c -o vmake SYSTEM.o Args.o compatIn.o CmdlnTexts.o Console.o Files.o Reals.o Modules.o Kernel.o Unix.o oocOakStrings.o version.o architecture.o
# build all library files
stage6:
#more v4 libs
$(VOCSTATIC) -sP Printer.Mod
$(VOCSTATIC) -sP Strings.Mod
#ooc libs
$(VOCSTATIC) -sP oocAscii.Mod
$(VOCSTATIC) -sP oocStrings.Mod
$(VOCSTATIC) -sP oocStrings2.Mod
$(VOCSTATIC) -sP oocCharClass.Mod
$(VOCSTATIC) -sP oocConvTypes.Mod
$(VOCSTATIC) -sP oocIntConv.Mod
$(VOCSTATIC) -sP oocIntStr.Mod
$(VOCSTATIC) -sP oocSysClock.Mod
$(VOCSTATIC) -sP oocTime.Mod
# $(VOCSTATIC) -s oocLongStrings.Mod
# $(CC) oocLongStrings.c
# $(VOCSTATIC) -s oocMsg.Mod
# $(CC) oocMsg.c
#ooc2 libs
$(VOCSTATIC) -sP ooc2Strings.Mod
$(VOCSTATIC) -sP ooc2Ascii.Mod
$(VOCSTATIC) -sP ooc2CharClass.Mod
$(VOCSTATIC) -sP ooc2ConvTypes.Mod
$(VOCSTATIC) -sP ooc2IntConv.Mod
$(VOCSTATIC) -sP ooc2IntStr.Mod
$(VOCSTATIC) -sP ooc2Real0.Mod
#ooc libs
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocComplexMath.Mod oocLComplexMath.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod
$(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
#Ulm's Oberon system libs
$(VOCSTATIC) -sP ulmSys.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod
$(VOCSTATIC) -sP ulmSets.Mod
$(VOCSTATIC) -sP ulmObjects.Mod
$(VOCSTATIC) -sP ulmDisciplines.Mod
$(VOCSTATIC) -sP ulmPriorities.Mod
$(VOCSTATIC) -sP ulmServices.Mod
$(VOCSTATIC) -sP ulmEvents.Mod
$(VOCSTATIC) -sP ulmResources.Mod
$(VOCSTATIC) -sP ulmForwarders.Mod
$(VOCSTATIC) -sP ulmRelatedEvents.Mod
$(VOCSTATIC) -sP ulmIO.Mod
$(VOCSTATIC) -sP ulmProcess.Mod
$(VOCSTATIC) -sP ulmTypes.Mod
$(VOCSTATIC) -sP ulmStreams.Mod
$(VOCSTATIC) -sP ulmAssertions.Mod
$(VOCSTATIC) -sP ulmIndirectDisciplines.Mod
$(VOCSTATIC) -sP ulmStreamDisciplines.Mod
$(VOCSTATIC) -sP ulmIEEE.Mod
$(VOCSTATIC) -sP ulmMC68881.Mod
$(VOCSTATIC) -sP ulmReals.Mod
$(VOCSTATIC) -sP ulmPrint.Mod
$(VOCSTATIC) -sP ulmWrite.Mod
$(VOCSTATIC) -sP ulmTexts.Mod
$(VOCSTATIC) -sP ulmStrings.Mod
$(VOCSTATIC) -sP ulmConstStrings.Mod
$(VOCSTATIC) -sP ulmPlotters.Mod
$(VOCSTATIC) -sP ulmSysTypes.Mod
$(VOCSTATIC) -sP ulmSysConversions.Mod
$(VOCSTATIC) -sP ulmErrors.Mod
$(VOCSTATIC) -sP ulmSysErrors.Mod
$(VOCSTATIC) -sP ulmSysIO.Mod
$(VOCSTATIC) -sP ulmLoader.Mod
$(VOCSTATIC) -sP ulmNetIO.Mod
$(VOCSTATIC) -sP ulmPersistentObjects.Mod
$(VOCSTATIC) -sP ulmPersistentDisciplines.Mod
$(VOCSTATIC) -sP ulmOperations.Mod
$(VOCSTATIC) -sP ulmScales.Mod
$(VOCSTATIC) -sP ulmTimes.Mod
$(VOCSTATIC) -sP ulmClocks.Mod
$(VOCSTATIC) -sP ulmTimers.Mod
$(VOCSTATIC) -sP ulmConditions.Mod
$(VOCSTATIC) -sP ulmStreamConditions.Mod
$(VOCSTATIC) -sP ulmTimeConditions.Mod
$(VOCSTATIC) -sP ulmSysConversions.Mod
$(VOCSTATIC) -sP ulmSysStat.Mod
#pow32 libs
$(VOCSTATIC) -sP powStrings.Mod
#misc libs
$(VOCSTATIC) -sP MultiArrays.Mod
$(VOCSTATIC) -sP MultiArrayRiders.Mod
$(VOCSTATIC) -sP MersenneTwister.Mod
#s3 libs
$(VOCSTATIC) -sP ethBTrees.Mod
$(VOCSTATIC) -sP ethMD5.Mod
$(VOCSTATIC) -sP ethSets.Mod
$(VOCSTATIC) -sP ethZlib.Mod
$(VOCSTATIC) -sP ethZlibBuffers.Mod
$(VOCSTATIC) -sP ethZlibInflate.Mod
$(VOCSTATIC) -sP ethZlibDeflate.Mod
$(VOCSTATIC) -sP ethZlibReaders.Mod
$(VOCSTATIC) -sP ethZlibWriters.Mod
$(VOCSTATIC) -sP ethZip.Mod
$(VOCSTATIC) -sP ethRandomNumbers.Mod
$(VOCSTATIC) -sP ethGZReaders.Mod
$(VOCSTATIC) -sP ethGZWriters.Mod
stage7:
#objects := $(wildcard *.o)
#$(LD) objects
$(ARCHIVE) *.o
#$(ARCHIVE) objects
$(LD) *.o
echo "$(PREFIX)/lib" > 05vishap.conf
clean:
# rm_objects := rm $(wildcard *.o)
# objects
rm *.o
rm *.so
rm *.h
rm *.c
rm *.a
rm *.sym
coco:
$(JET) Sets.Mod Oberon.Mod CRS.Mod CRT.Mod CRA.Mod CRX.Mod CRP.Mod Coco.Mod -m
$(CC) Sets.c Oberon.c CRS.c CRT.c CRA.c CRX.c CRP.c
$(CL) -static -o Coco Coco.c Sets.o Oberon.o CRS.o CRT.o CRA.o CRX.o CRP.o CmdlnTexts.o SYSTEM.o Files.o -L. -lOberon -L/usr/lib -ldl
install:
test -d $(PREFIX)/bin | mkdir -p $(PREFIX)/bin
cp voc $(PREFIX)/bin/
cp showdef $(PREFIX)/bin/
cp ocat $(PREFIX)/bin/
cp vmake $(PREFIX)/bin/
cp -a src $(PREFIX)/
test -d $(PREFIX)/lib/voc | mkdir -p $(PREFIX)/lib/voc
test -d $(PREFIX)/lib/voc/ | mkdir -p $(PREFIX)/lib/voc
test -d $(PREFIX)/lib/voc/obj | mkdir -p $(PREFIX)/lib/voc/obj
test -d $(PREFIX)/lib/voc/sym | mkdir -p $(PREFIX)/lib/voc/sym
cp $(LIBRARY).so $(PREFIX)/lib
cp $(LIBRARY).a $(PREFIX)/lib
cp *.c $(PREFIX)/lib/voc/obj/
cp *.h $(PREFIX)/lib/voc/obj/
cp *.sym $(PREFIX)/lib/voc/sym/
cp 05vishap.conf /etc/ld.so.conf.d/
ldconfig
# cp *.o $(PREFIX)/lib/voc/$(RELEASE)/obj/
uninstall:
rm -rf $(PREFIX)

2
makefile.gnuc.x86
View file

@ -2,7 +2,7 @@
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = x86
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0

2
makefile.gnuc.x86_64
View file

@ -2,7 +2,7 @@
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = x86_64
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = gnuc
RELEASE = 1.0

BIN
ocat
View file

Binary file not shown.

BIN
showdef
View file

Binary file not shown.

64
src/lib/system/gnuc/powerpc/Args.Mod Normal file
View file

@ -0,0 +1,64 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for ofront *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN
COPY(p^, val);
RETURN TRUE
ELSE
RETURN FALSE
END
END getEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/powerpc/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the Ofront runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

215
src/lib/system/gnuc/powerpc/SYSTEM.h Normal file
View file

@ -0,0 +1,215 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
the Ofront runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
//extern void *memcpy(void *dest, const void *src, long n);
extern void *memcpy(void *dest, const void *src, size_t n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
typedef char BOOLEAN;
typedef unsigned char CHAR;
typedef signed char SHORTINT;
typedef short int INTEGER;
typedef long LONGINT;
typedef float REAL;
typedef double LONGREAL;
typedef unsigned long SET;
typedef void *SYSTEM_PTR;
typedef unsigned char SYSTEM_BYTE;
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
#define __IN(x, s) (((s)>>(x))&1)
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
extern LONGINT SYSTEM_argc;
extern LONGINT SYSTEM_argv;
extern void (*SYSTEM_Halt)();
extern LONGINT SYSTEM_halt;
extern LONGINT SYSTEM_assert;
extern SYSTEM_PTR SYSTEM_modules;
extern LONGINT SYSTEM_heapsize;
extern LONGINT SYSTEM_allocated;
extern LONGINT SYSTEM_lock;
extern SHORTINT SYSTEM_gclock;
extern BOOLEAN SYSTEM_interrupted;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

419
src/lib/system/gnuc/powerpc/Unix.Mod Normal file
View file

@ -0,0 +1,419 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* system procedure added by noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
EPERM* = 1; (* Not owner *)
ENOENT* = 2; (* No such file or directory *)
ESRCH* = 3; (* No such process *)
EINTR* = 4; (* Interrupted system call *)
EIO* = 5; (* I/O error *)
ENXIO* = 6; (* No such device or address *)
E2BIG* = 7; (* Arg list too long *)
ENOEXEC* = 8; (* Exec format error *)
EBADF* = 9; (* Bad file number *)
ECHILD* = 10; (* No children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
EACCES* = 13; (* Permission denied *)
EFAULT* = 14; (* Bad address *)
ENOTBLK* = 15; (* Block device required *)
EBUSY* = 16; (* Mount device busy *)
EEXIST* = 17; (* File exists *)
EXDEV* = 18; (* Cross-device link *)
ENODEV* = 19; (* No such device *)
ENOTDIR* = 20; (* Not a directory*)
EISDIR* = 21; (* Is a directory *)
EINVAL* = 22; (* Invalid argument *)
ENFILE* = 23; (* File table overflow *)
EMFILE* = 24; (* Too many open files *)
ENOTTY* = 25; (* Not a typewriter *)
ETXTBSY* = 26; (* Text file busy *)
EFBIG* = 27; (* File too large *)
ENOSPC* = 28; (* No space left on device *)
ESPIPE* = 29; (* Illegal seek *)
EROFS* = 30; (* Read-only file system *)
EMLINK* = 31; (* Too many links *)
EPIPE* = 32; (* Broken pipe *)
EDOM* = 33; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
TYPE
JmpBuf* = RECORD
bx*, si*, di*, bp*, sp*, pc*: LONGINT;
maskWasSaved*, savedMask*: LONGINT;
END ;
Status* = RECORD (* struct stat *)
dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad1: INTEGER;
ino*, mode*, nlink*, uid*, gid*: LONGINT;
rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad2: INTEGER;
size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*,
unused3*, unused4*, unused5*: LONGINT;
END ;
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
Timezone* = RECORD
minuteswest*, dsttime*: LONGINT
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Pipe*(fds : LONGINT): LONGINT
"pipe(fds)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER;
VAR r : INTEGER;
BEGIN
r := sys(cmd);
RETURN r
END System;
END Unix.

574
src/lib/ulm/powerpc/ulmSysConversions.Mod Normal file
View file

@ -0,0 +1,574 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysConversi.om,v 1.2 1997/07/30 09:38:16 borchert Exp $
----------------------------------------------------------------------------
$Log: SysConversi.om,v $
Revision 1.2 1997/07/30 09:38:16 borchert
bug in ReadConv fixed: cv.flags was used but not set for
counts > 1
Revision 1.1 1994/02/23 07:58:28 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/90
adapted to linux cae 02/01
----------------------------------------------------------------------------
*)
MODULE ulmSysConversions;
(* convert Oberon records to/from C structures *)
IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts;
TYPE
Address* = SysTypes.Address;
Size* = Address;
(* format:
Format = Conversion { "/" Conversion } .
Conversion = [ Factors ] ConvChars [ Comment ] .
Factors = Array | Factor | Array Factor | Factor Array .
Array = Integer ":" .
Factor = Integer "*" .
ConvChars = OberonType CType | Skip CType | OberonType Skip .
OberonType = "a" | "b" | "c" | "s" | "i" | "l" | "S" .
CType = "a" | "c" | "s" | "i" | "l" .
Integer = Digit { Digit } .
Digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" .
Skip = "-" .
Comment = "=" { AnyChar } .
AnyChar = (* all characters except "/" *) .
Oberon data types:
a: Address
b: SYS.BYTE
B: BOOLEAN
c: CHAR
s: SHORTINT
i: INTEGER
l: LONGINT
S: SET
C data types:
a: char *
c: /* signed */ char
C: unsigned char
s: short int
S: unsigned short int
i: int
I: unsigned int
u: unsigned int
l: long int
L: unsigned long int
example:
conversion from
Rec =
RECORD
a, b: INTEGER;
c: CHAR;
s: SET;
f: ARRAY 3 OF INTEGER;
END;
to
struct rec {
short a, b;
char c;
int xx; /* to be skipped on conversion */
int s;
int f[3];
};
or vice versa:
"2*is=a,b/cc=c/-i=xx/Si=s/3:ii=f"
The comments allow to give the field names.
*)
CONST
(* conversion flags *)
unsigned = 0; (* suppress sign extension *)
boolean = 1; (* convert anything # 0 to 1 *)
TYPE
Flags = SET;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
format*: Events.Message;
END;
ConvStream = POINTER TO ConvStreamRec;
ConvStreamRec =
RECORD
fmt: Texts.Text;
char: CHAR;
eof: BOOLEAN;
(* 1: Oberon type
2: C type
*)
type1, type2: CHAR; length: INTEGER; left: INTEGER;
offset1, offset2: Address;
size1, size2: Address; elementsleft: INTEGER; flags: Flags;
END;
Format* = POINTER TO FormatRec;
FormatRec* =
RECORD
(Objects.ObjectRec)
offset1, offset2: Address;
size1, size2: Address;
flags: Flags;
next: Format;
END;
VAR
badformat*: Events.EventType;
PROCEDURE Error(cv: ConvStream; msg: ARRAY OF CHAR);
VAR
event: Event;
BEGIN
NEW(event);
event.type := badformat;
event.message := "SysConversions: ";
Strings.Concatenate(event.message, msg);
Strings.Read(event.format, cv.fmt);
Events.Raise(event);
cv.eof := TRUE;
cv.char := 0X;
cv.left := 0;
cv.elementsleft := 0;
END Error;
PROCEDURE SizeError(msg, format: ARRAY OF CHAR);
VAR
event: Event;
BEGIN
NEW(event);
event.type := badformat;
event.message := "SysConversions: ";
Strings.Concatenate(event.message, msg);
COPY(format, event.format);
Events.Raise(event);
END SizeError;
PROCEDURE NextCh(cv: ConvStream);
BEGIN
cv.eof := cv.eof OR ~Streams.ReadByte(cv.fmt, cv.char) OR (cv.char = 0X);
IF cv.eof THEN
cv.char := 0X;
END;
END NextCh;
PROCEDURE IsDigit(ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch >= "0") & (ch <= "9")
END IsDigit;
PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER);
BEGIN
i := 0;
REPEAT
i := 10 * i + ORD(cv.char) - ORD("0");
NextCh(cv);
UNTIL ~IsDigit(cv.char);
END ReadInt;
PROCEDURE Open(VAR cv: ConvStream; format: ARRAY OF CHAR);
BEGIN
NEW(cv);
Texts.Open(SYS.VAL(Streams.Stream, cv.fmt));
Strings.Write(cv.fmt, format);
cv.left := 0; cv.elementsleft := 0;
cv.offset1 := 0; cv.offset2 := 0;
cv.eof := FALSE;
NextCh(cv);
END Open;
PROCEDURE Close(VAR cv: ConvStream);
BEGIN
IF ~Streams.Close(cv.fmt) THEN END;
END Close;
PROCEDURE ScanConv(cv: ConvStream;
VAR type1, type2: CHAR;
VAR length: INTEGER) : BOOLEAN;
VAR
i: INTEGER;
factor: INTEGER;
BEGIN
IF cv.left > 0 THEN
type1 := cv.type1;
type2 := cv.type2;
length := cv.length;
DEC(cv.left);
RETURN TRUE
END;
IF cv.char = "/" THEN
NextCh(cv);
END;
IF cv.eof THEN
RETURN FALSE
END;
factor := 0; length := 0;
WHILE IsDigit(cv.char) DO
ReadInt(cv, i);
IF i <= 0 THEN
Error(cv, "integer must be positive"); RETURN FALSE
END;
IF cv.char = ":" THEN
IF length # 0 THEN
Error(cv, "multiple length specification"); RETURN FALSE
END;
length := i;
NextCh(cv);
ELSIF cv.char = "*" THEN
IF factor # 0 THEN
Error(cv, "multiple factor specification"); RETURN FALSE
END;
factor := i; cv.left := factor - 1;
NextCh(cv);
ELSE
Error(cv, "factor or length expected"); RETURN FALSE
END;
END;
type1 := cv.char; NextCh(cv);
type2 := cv.char; NextCh(cv);
IF cv.left > 0 THEN
cv.type1 := type1; cv.type2 := type2; cv.length := length;
END;
IF cv.char = "=" THEN (* comment *)
REPEAT
NextCh(cv);
UNTIL cv.eof OR (cv.char = "/");
END;
RETURN TRUE
END ScanConv;
PROCEDURE Align(VAR offset: Address; boundary: Address);
BEGIN
IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN
offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary));
END;
END Align;
PROCEDURE ReadConv(cv: ConvStream;
VAR offset1, offset2: Address;
VAR size1, size2: Address;
VAR flags: Flags) : BOOLEAN;
VAR
type1, type2: CHAR;
length: INTEGER;
align: BOOLEAN;
boundary: INTEGER;
BEGIN
IF cv.elementsleft > 0 THEN
DEC(cv.elementsleft);
(* Oberon type *)
IF size1 > SIZE(SYS.BYTE) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1;
size1 := cv.size1; size2 := cv.size2; flags := cv.flags;
IF (size1 > 0) & (cv.elementsleft = 0) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
(* C type *)
IF size2 > 1 THEN
Align(cv.offset2, 2);
END;
offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2);
RETURN TRUE
END;
IF ScanConv(cv, type1, type2, length) THEN
flags := {};
(* Oberon type *)
CASE type1 OF
| "a": size1 := SIZE(Address); INCL(flags, unsigned);
| "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned);
| "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean);
| "c": size1 := SIZE(CHAR); INCL(flags, unsigned);
| "s": size1 := SIZE(SHORTINT);
| "i": size1 := SIZE(INTEGER);
| "l": size1 := SIZE(LONGINT);
| "S": size1 := SIZE(SET); INCL(flags, unsigned);
| "-": size1 := 0;
ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE
END;
IF size1 > 0 THEN
IF length > 0 THEN
Align(cv.offset1, SIZE(INTEGER));
ELSIF size1 > SIZE(SYS.BYTE) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
END;
offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1;
(* C type *)
CASE type2 OF
| "a": size2 := 4; INCL(flags, unsigned); (* char* *)
| "c": size2 := 1; (* /* signed */ char *)
| "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *)
| "s": size2 := 2; (* short int *)
| "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *)
| "i": size2 := 4; (* int *)
| "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *)
| "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *)
| "l": size2 := 4; (* long int *)
| "L": size2 := 4; INCL(flags, unsigned); (* long int *)
| "-": size2 := 0;
ELSE Error(cv, "bad C type specifier"); RETURN FALSE
END;
IF size2 > 1 THEN
Align(cv.offset2, size2);
END;
offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2);
cv.size1 := size1; cv.size2 := size2;
IF length > 0 THEN
cv.elementsleft := length - 1;
cv.flags := flags;
END;
RETURN TRUE
ELSE
RETURN FALSE
END;
END ReadConv;
PROCEDURE Convert(from, to: Address; ssize, dsize: Address; flags: Flags);
TYPE
Bytes = ARRAY 8 OF CHAR;
Pointer = POINTER TO Bytes;
VAR
dest, source: Pointer;
dindex, sindex: INTEGER;
nonzero: BOOLEAN;
fill : CHAR;
BEGIN
IF ssize > 0 THEN
dest := SYS.VAL(Pointer, to);
source := SYS.VAL(Pointer, from);
dindex := 0; sindex := 0;
IF boolean IN flags THEN
nonzero := FALSE;
WHILE ssize > 0 DO
nonzero := nonzero OR (source[sindex] # 0X);
INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1;
END;
IF dsize > 0 THEN
IF nonzero THEN
dest[dindex] := 1X;
ELSE
dest[dindex] := 0X;
END;
dsize := dsize - 1; INC (dindex);
END;
WHILE dsize > 0 DO
dest[dindex] := 0X;
dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex);
END;
ELSE
WHILE (dsize > 0) & (ssize > 0) DO
dest[dindex] := source[sindex];
ssize := SYS.VAL (INTEGER, ssize) - 1;
dsize := dsize - 1;
INC(dindex); INC(sindex);
END;
IF dsize > 0 THEN
(* sindex has been incremented at least once because
* ssize and dsize were greater than 0, i.e. sindex-1
* is a valid inex. *)
fill := 0X;
IF ~(unsigned IN flags) & (source[sindex-1] >= 080X) THEN
fill := 0FFX;
END;
END;
WHILE dsize > 0 DO
dest[dindex] := fill;
dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex);
END;
END;
END;
END Convert;
PROCEDURE ByAddrToC*(from, to: Address; format: ARRAY OF CHAR);
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
Convert(from + offset1, to + offset2, size1, size2, flags);
END;
Close(cv);
END ByAddrToC;
PROCEDURE ByAddrFromC*(from, to: Address; format: ARRAY OF CHAR);
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
Convert(from + offset2, to + offset1, size2, size1, flags);
END;
Close(cv);
END ByAddrFromC;
PROCEDURE CSize*(format: ARRAY OF CHAR) : Size;
(* returns the size of the C-structure described by `format' *)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
size: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END;
Close(cv);
size := offset2 + size2;
Align(size, 2);
RETURN size
END CSize;
PROCEDURE OberonSize*(format: ARRAY OF CHAR) : Size;
(* returns the size of the Oberon-structure described by `format' *)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
size: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END;
Close(cv);
size := offset1 + size1;
Align(size, SIZE(INTEGER));
RETURN size
END OberonSize;
PROCEDURE ToC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR);
BEGIN
IF OberonSize(format) > LEN(from) THEN
SizeError("Oberon record is too small", format); RETURN
END;
IF CSize(format) > LEN(to) THEN
SizeError("C structure is too small", format); RETURN
END;
ByAddrToC(SYS.ADR(from), SYS.ADR(to), format);
END ToC;
PROCEDURE FromC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR);
BEGIN
IF OberonSize(format) > LEN(to) THEN
SizeError("Oberon record is too small", format); RETURN
END;
IF CSize(format) > LEN(from) THEN
SizeError("C structure is too small", format); RETURN
END;
ByAddrFromC(SYS.ADR(from), SYS.ADR(to), format);
END FromC;
PROCEDURE Compile*(VAR fmt: Format; format: ARRAY OF CHAR);
(* translate format into an internal representation
which is later referenced by fmt;
ByFmtToC and ByFmtFromC are faster than ToC and FromC
*)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
element: Format;
head, tail: Format;
BEGIN
Open(cv, format);
head := NIL; tail := NIL;
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
NEW(element);
element.offset1 := offset1;
element.offset2 := offset2;
element.size1 := size1;
element.size2 := size2;
element.flags := flags;
element.next := NIL;
IF tail # NIL THEN
tail.next := element;
ELSE
head := element;
END;
tail := element;
END;
fmt := head;
Close(cv);
END Compile;
PROCEDURE ByFmtAndAddrToC*(from, to: Address; format: Format);
VAR
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
WHILE format # NIL DO
Convert(from + format.offset1, to + format.offset2,
format.size1, format.size2, format.flags);
format := format.next;
END;
END ByFmtAndAddrToC;
PROCEDURE ByFmtAndAddrFromC*(from, to: Address; format: Format);
VAR
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
WHILE format # NIL DO
Convert(from + format.offset2, to + format.offset1,
format.size2, format.size1, format.flags);
format := format.next;
END;
END ByFmtAndAddrFromC;
PROCEDURE ByFmtToC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format);
BEGIN
ByFmtAndAddrToC(SYS.ADR(from), SYS.ADR(to), format);
END ByFmtToC;
PROCEDURE ByFmtFromC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format);
BEGIN
ByFmtAndAddrFromC(SYS.ADR(from), SYS.ADR(to), format);
END ByFmtFromC;
BEGIN
Events.Define(badformat);
Events.SetPriority(badformat, Priorities.liberrors);
END ulmSysConversions.

201
src/lib/ulm/powerpc/ulmSysStat.Mod Normal file
View file

@ -0,0 +1,201 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $
----------------------------------------------------------------------------
$Log: SysStat.om,v $
Revision 1.3 2000/11/12 13:02:09 borchert
door file type added
Revision 1.2 2000/11/12 12:48:07 borchert
- conversion adapted to Solaris 2.x
- Lstat added
Revision 1.1 1994/02/23 08:00:48 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSysStat;
(* examine inode: stat(2) and fstat(2) *)
IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors,
SysTypes := ulmSysTypes;
CONST
(* file mode:
bit 0 = 1<<0 bit 31 = 1<<31
user group other
3 1 1111 11
1 ... 6 5432 109 876 543 210
+--------+------+-----+-----+-----+-----+
| unused | type | sst | rwx | rwx | rwx |
+--------+------+-----+-----+-----+-----+
*)
type* = {12..15};
prot* = {0..8};
(* file types; example: (stat.mode * type = dir) *)
reg* = {15}; (* regular *)
dir* = {14}; (* directory *)
chr* = {13}; (* character special *)
fifo* = {12}; (* fifo *)
blk* = {13..14}; (* block special *)
symlink* = {13, 15}; (* symbolic link *)
socket* = {14, 15}; (* socket *)
(* special *)
setuid* = 11; (* set user id on execution *)
setgid* = 10; (* set group id on execution *)
savetext* = 9; (* save swapped text even after use *)
(* protection *)
uread* = 8; (* read permission owner *)
uwrite* = 7; (* write permission owner *)
uexec* = 6; (* execute/search permission owner *)
gread* = 5; (* read permission group *)
gwrite* = 4; (* write permission group *)
gexec* = 3; (* execute/search permission group *)
oread* = 2; (* read permission other *)
owrite* = 1; (* write permission other *)
oexec* = 0; (* execute/search permission other *)
(* example for "r-xr-x---": (read + exec) * (owner + group) *)
owner* = {uread, uwrite, uexec};
group* = {gread, gwrite, gexec};
other* = {oread, owrite, oexec};
read* = {uread, gread, oread};
write* = {uwrite, gwrite, owrite};
exec* = {uexec, gexec, oexec};
rwx* = prot;
TYPE
StatRec* = (* result of stat(2) and fstat(2) *)
RECORD
device*: SysTypes.Device; (* ID of device containing
a directory entry for this file *)
inode*: SysTypes.Inode; (* inode number *)
mode*: SET; (* file mode; see mknod(2) *)
nlinks*: LONGINT; (* number of links *)
uid*: LONGINT; (* user id of the file's owner *)
gid*: LONGINT; (* group id of the file's group *)
rdev*: SysTypes.Device; (* ID of device
this entry is defined only for
character special or block
special files
*)
size*: SysTypes.Offset; (* file size in bytes *)
blksize*: LONGINT; (* preferred blocksize *)
blocks*: LONGINT; (* # of blocks allocated *)
atime*: SysTypes.Time; (* time of last access *)
mtime*: SysTypes.Time; (* time of last data modification *)
ctime*: SysTypes.Time; (* time of last file status change *)
END;
(* Linux kernel struct stat (2.2.17)
struct stat {
unsigned short st_dev;
unsigned short __pad1;
unsigned long st_ino;
unsigned short st_mode;
unsigned short st_nlink;
unsigned short st_uid;
unsigned short st_gid;
unsigned short st_rdev;
unsigned short __pad2;
unsigned long st_size;
unsigned long st_blksize;
unsigned long st_blocks;
unsigned long st_atime;
unsigned long __unused1;
unsigned long st_mtime;
unsigned long __unused2;
unsigned long st_ctime;
unsigned long __unused3;
unsigned long __unused4;
unsigned long __unused5;
};
*)
CONST
statbufsize = 88(*64*); (* see <sys/stat.h> *) (* sizeof struct stat gives us 144 on x86_64 and 88 on x86 *)
TYPE
UnixStatRec = ARRAY statbufsize OF SYS.BYTE;
CONST
statbufconv =
(*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*)
(*"ls=dev/-s=pad1/lL=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/lL=size/2*lL=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";*)
"ll=dev/-l=devx/-s=pad1/ll=ino/Sl=mode/ll=nlink/ll=uid/ll=gid/ll=rdev/-l=rdevx/-s=pad2/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";
VAR
statbuffmt: SysConversions.Format;
PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1, d2: LONGINT;
origbuf: UnixStatRec;
BEGIN
IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newstat, path);
RETURN FALSE
END;
END Stat;
(*
PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: INTEGER;
origbuf: UnixStatRec;
BEGIN
IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newlstat, path);
RETURN FALSE
END;
END Lstat;
*)
PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1, d2: LONGINT;
origbuf: UnixStatRec;
BEGIN
IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newfstat, "");
RETURN FALSE
END;
END Fstat;
BEGIN
SysConversions.Compile(statbuffmt, statbufconv);
END ulmSysStat.

70
src/lib/ulm/powerpc/ulmSysTypes.Mod Normal file
View file

@ -0,0 +1,70 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysTypes.om,v 1.1 1994/02/23 08:01:38 borchert Exp $
----------------------------------------------------------------------------
$Log: SysTypes.om,v $
Revision 1.1 1994/02/23 08:01:38 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSysTypes;
IMPORT Types := ulmTypes;
TYPE
Address* = Types.Address;
UntracedAddress* = Types.UntracedAddress;
Count* = Types.Count;
Size* = Types.Size;
Byte* = Types.Byte;
File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *)
Offset* = LONGINT;
Device* = LONGINT;
Inode* = LONGINT;
Time* = LONGINT;
Word* = INTEGER; (* must have the size of C's int-type *)
(* Note: linux supports wait4 but not waitid, i.e. these
* constants aren't needed. *)
(*
CONST
(* possible values of the idtype parameter (4 bytes),
see <sys/procset.h>
*)
idPid = 0; (* a process identifier *)
idPpid = 1; (* a parent process identifier *)
idPgid = 2; (* a process group (job control group) identifier *)
idSid = 3; (* a session identifier *)
idCid = 4; (* a scheduling class identifier *)
idUid = 5; (* a user identifier *)
idGid = 6; (* a group identifier *)
idAll = 7; (* all processes *)
idLwpid = 8; (* an LWP identifier *)
TYPE
IdType = INTEGER; (* idPid .. idLwpid *)
*)
END ulmSysTypes.

125
src/lib/ulm/powerpc/ulmTypes.Mod Normal file
View file

@ -0,0 +1,125 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2000 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Types.om,v 1.5 2000/12/13 10:03:00 borchert Exp $
----------------------------------------------------------------------------
$Log: Types.om,v $
Revision 1.5 2000/12/13 10:03:00 borchert
SetInt type used in msb constant
Revision 1.4 2000/12/13 09:51:57 borchert
constants and types for the relationship of INTEGER and SET added
Revision 1.3 1998/09/25 15:23:09 borchert
Real32..Real128 added
Revision 1.2 1994/07/01 11:08:04 borchert
IntAddress, Int8/16/32, ToInt8/16/32 and bit/little endian stuff added
Revision 1.1 1994/02/22 20:12:14 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/93
----------------------------------------------------------------------------
*)
MODULE ulmTypes;
(* compiler-dependent type definitions;
this version works for Ulm's Oberon Compilers on
following architectures: m68k and sparc
*)
IMPORT SYS := SYSTEM;
TYPE
Address* = LONGINT (*SYS.ADDRESS*);
UntracedAddress* = LONGINT; (*SYS.UNTRACEDADDRESS;*)
Count* = LONGINT;
Size* = Count;
Byte* = SYS.BYTE;
IntAddress* = LONGINT;
Int8* = SHORTINT;
Int16* = INTEGER;
Int32* = LONGINT;
Real32* = REAL;
Real64* = LONGREAL;
CONST
bigEndian* = 0; (* SPARC, M68K etc *)
littleEndian* = 1; (* Intel 80x86, VAX etc *)
byteorder* = littleEndian; (* machine-dependent constant *)
TYPE
ByteOrder* = SHORTINT; (* bigEndian or littleEndian *)
(* following constants and type definitions try to make
conversions from INTEGER to SET and vice versa more portable
to allow for bit operations on INTEGER values
*)
TYPE
SetInt* = LONGINT; (* INTEGER type that corresponds to SET *)
VAR msb* : SET;
msbIsMax*, msbIs0*: SHORTINT;
msbindex*, lsbindex*, nofbits*: LONGINT;
PROCEDURE ToInt8*(int: LONGINT) : Int8;
BEGIN
RETURN SHORT(SHORT(int))
END ToInt8;
PROCEDURE ToInt16*(int: LONGINT) : Int16;
BEGIN
RETURN SYS.VAL(Int16, int)
END ToInt16;
PROCEDURE ToInt32*(int: LONGINT) : Int32;
BEGIN
RETURN int
END ToInt32;
PROCEDURE ToReal32*(real: LONGREAL) : Real32;
BEGIN
RETURN SHORT(real)
END ToReal32;
PROCEDURE ToReal64*(real: LONGREAL) : Real64;
BEGIN
RETURN real
END ToReal64;
BEGIN
msb := SYS.VAL(SET, MIN(SetInt));
(* most significant bit, converted to a SET *)
(* we expect msbIsMax XOR msbIs0 to be 1;
this is checked for by an assertion
*)
msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)}));
(* is 1, if msb equals {MAX(SET)} *)
msbIs0 := SYS.VAL(SHORTINT, (msb = {0}));
(* is 0, if msb equals {0} *)
msbindex := msbIsMax * MAX(SET);
(* set element that corresponds to the most-significant-bit *)
lsbindex := MAX(SET) - msbindex;
(* set element that corresponds to the lowest-significant-bit *)
nofbits := MAX(SET) + 1;
(* number of elements in SETs *)
ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1));
END ulmTypes.

109
src/lib/v4/powerpc/Reals.Mod Normal file
View file

@ -0,0 +1,109 @@
MODULE Reals;
(* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*)
IMPORT S := SYSTEM;
PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT
"ecvt (x, ndigit, decpt, sign)";
PROCEDURE Ten*(e: INTEGER): REAL;
VAR r, power: LONGREAL;
BEGIN r := 1.0;
power := 10.0;
WHILE e > 0 DO
IF ODD(e) THEN r := r * power END ;
power := power * power; e := e DIV 2
END ;
RETURN SHORT(r)
END Ten;
PROCEDURE TenL*(e: INTEGER): LONGREAL;
VAR r, power: LONGREAL;
BEGIN r := 1.0;
power := 10.0;
LOOP
IF ODD(e) THEN r := r * power END ;
e := e DIV 2;
IF e <= 0 THEN RETURN r END ;
power := power * power
END
END TenL;
PROCEDURE Expo*(x: REAL): INTEGER;
BEGIN
RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256)
END Expo;
PROCEDURE ExpoL*(x: LONGREAL): INTEGER;
VAR h: LONGINT;
BEGIN
S.GET(S.ADR(x)+4, h);
RETURN SHORT(ASH(h, -20) MOD 2048)
END ExpoL;
PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL);
CONST expo = {1..8};
BEGIN
x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23)))
END SetExpo;
PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL);
CONST expo = {1..11};
VAR h: SET;
BEGIN
S.GET(S.ADR(x)+4, h);
h := h - expo + S.VAL(SET, ASH(LONG(e), 20));
S.PUT(S.ADR(x)+4, h)
END SetExpoL;
PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR);
VAR i, k: LONGINT;
BEGIN
i := ENTIER(x); k := 0;
WHILE k < n DO
d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k)
END
END Convert;
(*
PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR);
VAR i, k: LONGINT;
BEGIN
i := ENTIER(x); k := 0;
WHILE k < n DO
d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k)
END
END ConvertL;
*)
PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR);
VAR decpt, sign, i: LONGINT; buf: LONGINT;
BEGIN
(*x := x - 0.5; already rounded in ecvt*)
buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign));
i := 0;
WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *)
i := n - i - 1;
WHILE i >= 0 DO d[i] := "0"; DEC(i) END ;
END ConvertL;
PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE);
VAR i, k: SHORTINT; len: LONGINT;
BEGIN i := 0; len := LEN(b);
WHILE i < len DO
k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16);
IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ;
k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16);
IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ;
INC(i)
END
END Unpack;
PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR);
BEGIN Unpack(y, d)
END ConvertH;
PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR);
BEGIN Unpack(x, d)
END ConvertHL;
END Reals.

12
src/par/voc.par.gnuc.powerpc Normal file
View file

@ -0,0 +1,12 @@
CHAR 1 1
BOOLEAN 1 1
SHORTINT 1 1
INTEGER 2 2
LONGINT 4 4
SET 4 4
REAL 4 4
LONGREAL 8 8
PTR 4 4
PROC 4 4
RECORD 1 1
ENDIAN 0 0

376
src/tools/coco/CR.ATG
View file

@ -1,376 +0,0 @@
COMPILER CR (*H.Moessenboeck 17.11.93, Coco/R*)
(*---------------------- semantic declarations ----------------------------*)
IMPORT CRT, CRA, CRX, Sets, Texts := CmdlnTexts, Oberon;
CONST
ident = 0; string = 1; (*symbol kind*)
VAR
str: ARRAY 32 OF CHAR;
w: Texts.Writer;
genScanner: BOOLEAN;
PROCEDURE SemErr(nr: INTEGER);
BEGIN
CRS.Error(200+nr, CRS.pos);
END SemErr;
PROCEDURE MatchLiteral(sp: INTEGER); (*store string either as token or as literal*)
VAR sn, sn1: CRT.SymbolNode; matchedSp: INTEGER;
BEGIN
CRT.GetSym(sp, sn);
CRA.MatchDFA(sn.name, sp, matchedSp);
IF matchedSp # CRT.noSym THEN
CRT.GetSym(matchedSp, sn1); sn1.struct := CRT.classLitToken; CRT.PutSym(matchedSp, sn1);
sn.struct := CRT.litToken
ELSE sn.struct := CRT.classToken;
END;
CRT.PutSym(sp, sn)
END MatchLiteral;
PROCEDURE SetCtx(gp: INTEGER); (*set transition code to CRT.contextTrans*)
VAR gn: CRT.GraphNode;
BEGIN
WHILE gp > 0 DO
CRT.GetNode(gp, gn);
IF gn.typ IN {CRT.char, CRT.class} THEN
gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
ELSIF gn.typ IN {CRT.opt, CRT.iter} THEN SetCtx(gn.p1)
ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
END;
gp := gn.next
END
END SetCtx;
PROCEDURE SetDDT(s: ARRAY OF CHAR);
VAR name: ARRAY 64 OF CHAR; i: INTEGER; ch: CHAR;
BEGIN
i := 1;
WHILE s[i] # 0X DO
ch := s[i]; INC(i);
IF (ch >= "0") & (ch <= "9") THEN CRT.ddt[ORD(ch)-ORD("0")] := TRUE END
END
END SetDDT;
PROCEDURE FixString (VAR s: ARRAY OF CHAR; len: INTEGER);
VAR double: BOOLEAN; i: INTEGER;
BEGIN
double := FALSE;
FOR i := 0 TO len-2 DO
IF s[i] = '"' THEN double := TRUE END
END;
IF ~ double THEN s[0] := '"'; s[len-1] := '"' END
END FixString;
(*-------------------------------------------------------------------------*)
CHARACTERS
letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz".
digit = "0123456789".
eol = CHR(13).
tab = CHR(9).
noQuote1 = ANY - '"' - eol.
noQuote2 = ANY - "'" - eol.
IGNORE eol + tab + CHR(28)
TOKENS
ident = letter {letter | digit}.
string = '"' {noQuote1} '"' | "'" {noQuote2} "'".
number = digit {digit}.
PRAGMAS
ddtSym = "$" {digit}. (. CRS.GetName(CRS.nextPos, CRS.nextLen, str); SetDDT(str) .)
COMMENTS FROM "(*" TO "*)" NESTED
(*-------------------------------------------------------------------------*)
PRODUCTIONS
CR (. VAR undef, hasAttrs, ok, ok1: BOOLEAN; eofSy, gR: INTEGER;
gramLine, sp: INTEGER;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
name, gramName: CRT.Name; .)
=
"COMPILER" (. Texts.OpenWriter(w);
CRT.Init; CRX.Init; CRA.Init;
gramLine := CRS.line;
eofSy := CRT.NewSym(CRT.t, "EOF", 0);
genScanner := TRUE;
CRT.ignoreCase := FALSE;
ok := TRUE;
Sets.Clear(CRT.ignored) .)
ident (. CRS.GetName(CRS.pos, CRS.len, gramName);
CRT.semDeclPos.beg := CRS.nextPos; CRT.importPos.beg := -1; .)
{ "IMPORT" (. CRT.importPos.beg := CRS.nextPos .)
{ANY} ";" (. CRT.importPos.len := SHORT(CRS.pos - CRT.importPos.beg);
CRT.importPos.col := 0;
CRT.semDeclPos.beg := CRS.nextPos .)
| ANY
} (. CRT.semDeclPos.len := SHORT(CRS.nextPos - CRT.semDeclPos.beg);
CRT.semDeclPos.col := 0 .)
{ Declaration }
SYNC
"PRODUCTIONS" (. IF genScanner THEN CRA.MakeDeterministic(ok) END;
CRT.nNodes := 0 .)
{ ident (. CRS.GetName(CRS.pos, CRS.len, name);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
sp := CRT.NewSym(CRT.nt, name, CRS.line);
CRT.GetSym(sp, sn);
ELSE
CRT.GetSym(sp, sn);
IF sn.typ = CRT.nt THEN
IF sn.struct > 0 THEN SemErr(7) END
ELSE SemErr(8)
END;
sn.line := CRS.line
END;
hasAttrs := sn.attrPos.beg >= 0 .)
( Attribs <sn.attrPos> (. IF ~undef & ~hasAttrs THEN SemErr(9) END;
CRT.PutSym(sp, sn) .)
| (. IF ~undef & hasAttrs THEN SemErr(10) END .)
)
[ SemText <sn.semPos>]
WEAK "="
Expression <sn.struct, gR> (. CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
IF CRT.ddt[2] THEN CRT.PrintGraph END .)
WEAK "."
} (. sp := CRT.FindSym(gramName);
IF sp = CRT.noSym THEN SemErr(11);
ELSE
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(12) END;
CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
END .)
"END" ident (. CRS.GetName(CRS.pos, CRS.len, name);
IF name # gramName THEN SemErr(17) END;
IF CRS.errors = 0 THEN
Texts.WriteString(w, " checking"); Texts.Append(Oberon.Log, w.buf);
CRT.CompSymbolSets;
IF ok THEN CRT.TestCompleteness(ok) END;
IF ok THEN
CRT.TestIfAllNtReached(ok1); CRT.FindCircularProductions(ok)
END;
IF ok THEN CRT.TestIfNtToTerm(ok) END;
IF ok THEN CRT.LL1Test(ok1) END;
IF CRT.ddt[0] THEN CRA.PrintStates END;
IF CRT.ddt[7] THEN CRT.XRef END;
IF ok THEN
Texts.WriteString(w, " +parser");
Texts.Append(Oberon.Log, w.buf);
CRX.GenCompiler;
IF genScanner THEN
Texts.WriteString(w, " +scanner");
Texts.Append(Oberon.Log, w.buf);
CRA.WriteScanner
END;
IF CRT.ddt[8] THEN CRX.WriteStatistics END
END
ELSE ok := FALSE
END;
IF CRT.ddt[6] THEN CRT.PrintSymbolTable END;
IF ok THEN Texts.WriteString(w, " done") END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf) .)
".".
(*------------------------------------------------------------------------------------*)
Declaration (. VAR gL1, gR1, gL2, gR2: INTEGER; nested: BOOLEAN; .)
=
"CHARACTERS" { SetDecl }
| "TOKENS" { TokenDecl <CRT.t> }
| "PRAGMAS" { TokenDecl <CRT.pr> }
| "COMMENTS"
"FROM" TokenExpr <gL1, gR1>
"TO" TokenExpr <gL2, gR2>
( "NESTED" (. nested := TRUE .)
| (. nested := FALSE .)
) (. CRA.NewComment(gL1, gL2, nested) .)
| "IGNORE"
( "CASE" (. CRT.ignoreCase := TRUE .)
| Set <CRT.ignored>
)
.
(*------------------------------------------------------------------------------------*)
SetDecl (. VAR c: INTEGER; set: CRT.Set; name: CRT.Name; .)
=
ident (. CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name); IF c >= 0 THEN SemErr(7) END .)
"=" Set <set> (. c := CRT.NewClass(name, set) .)
".".
(*------------------------------------------------------------------------------------*)
Set <VAR set: CRT.Set> (. VAR set2: CRT.Set; .)
=
SimSet <set>
{ "+" SimSet <set2> (. Sets.Unite(set, set2) .)
| "-" SimSet <set2> (. Sets.Differ(set, set2) .)
}.
(*------------------------------------------------------------------------------------*)
SimSet <VAR set: CRT.Set> (. VAR c, n, i: INTEGER; name: CRT.Name; s: ARRAY 128 OF CHAR; .)
=
ident (. CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name);
IF c < 0 THEN SemErr(15); Sets.Clear(set)
ELSE CRT.GetClass(c, set)
END .)
| string (. CRS.GetName(CRS.pos, CRS.len, s);
Sets.Clear(set); i := 1;
WHILE s[i] # s[0] DO
Sets.Incl(set, ORD(s[i])); INC(i)
END .)
| "CHR" "(" number (. CRS.GetName(CRS.pos, CRS.len, name);
n := 0; i := 0;
WHILE name[i] # 0X DO
n := 10 * n + (ORD(name[i]) - ORD("0"));
INC(i)
END;
Sets.Clear(set); Sets.Incl(set, n) .)
")"
| "ANY" (. Sets.Fill(set) .)
.
(*------------------------------------------------------------------------------------*)
TokenDecl <typ: INTEGER> (. VAR sp, kind, gL, gR: INTEGER; sn: CRT.SymbolNode;
pos: CRT.Position; name: CRT.Name; .)
=
Symbol <name, kind> (. IF CRT.FindSym(name) # CRT.noSym THEN SemErr(7)
ELSE
sp := CRT.NewSym(typ, name, CRS.line);
CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
CRT.PutSym(sp, sn)
END .)
SYNC
( "=" TokenExpr <gL, gR> "." (. IF kind # ident THEN SemErr(13) END;
CRT.CompleteGraph(gR);
CRA.ConvertToStates(gL, sp) .)
| (. IF kind = ident THEN genScanner := FALSE
ELSE MatchLiteral(sp)
END .)
)
[ SemText <pos> (. IF typ = CRT.t THEN SemErr(14) END;
CRT.GetSym(sp, sn); sn.semPos := pos; CRT.PutSym(sp, sn) .)
].
(*------------------------------------------------------------------------------------*)
Expression <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; first: BOOLEAN; .)
=
Term <gL, gR> (. first := TRUE .)
{ WEAK "|"
Term <gL2, gR2> (. IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) .)
}.
(*------------------------------------------------------------------------------------*)
Term<VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; .)
= (. gL := 0; gR := 0 .)
( Factor <gL, gR>
{ Factor <gL2, gR2> (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
}
| (. gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL .)
).
(*------------------------------------------------------------------------------------*)
Factor <VAR gL, gR: INTEGER> (. VAR sp, kind, c: INTEGER; name: CRT.Name;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
set: CRT.Set;
undef, weak: BOOLEAN;
pos: CRT.Position; .)
=
(. gL :=0; gR := 0; weak := FALSE .)
( [ "WEAK" (. weak := TRUE .)
]
Symbol <name, kind> (. sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
IF kind = ident THEN (*forward nt*)
sp := CRT.NewSym(CRT.nt, name, 0)
ELSE (*undefined string in production*)
sp := CRT.NewSym(CRT.t, name, CRS.line);
MatchLiteral(sp)
END
END;
CRT.GetSym(sp, sn);
IF ~(sn.typ IN {CRT.t,CRT.nt}) THEN SemErr(4) END;
IF weak THEN
IF sn.typ = CRT.t THEN sn.typ := CRT.wt ELSE SemErr(23) END
END;
gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL .)
( Attribs <pos> (. CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn);
CRT.GetSym(sp, sn);
IF undef THEN
sn.attrPos := pos; CRT.PutSym(sp, sn)
ELSIF sn.attrPos.beg < 0 THEN SemErr(5)
END;
IF kind # ident THEN SemErr(3) END .)
| (. CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(6) END .)
)
| "(" Expression <gL, gR> ")"
| "[" Expression <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
| "{" Expression <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
| SemText <pos> (. gL := CRT.NewNode(CRT.sem, 0, 0);
gR := gL;
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn) .)
| "ANY" (. Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL .)
| "SYNC" (. gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL .)
).
(*------------------------------------------------------------------------------------*)
TokenExpr <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; first: BOOLEAN; .)
=
TokenTerm <gL, gR> (. first := TRUE .)
{ WEAK "|"
TokenTerm <gL2, gR2> (. IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) .)
}.
(*------------------------------------------------------------------------------------*)
TokenTerm <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; .)
=
TokenFactor <gL, gR>
{ TokenFactor <gL2, gR2> (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
}
[ "CONTEXT"
"(" TokenExpr <gL2, gR2> (. SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) .)
")"
].
(*------------------------------------------------------------------------------------*)
TokenFactor <VAR gL, gR: INTEGER> (. VAR kind, c: INTEGER; set: CRT.Set; name: CRT.Name; .)
=
(. gL :=0; gR := 0 .)
( Symbol <name, kind> (. IF kind = ident THEN
c := CRT.ClassWithName(name);
IF c < 0 THEN
SemErr(15);
Sets.Clear(set); c := CRT.NewClass(name, set)
END;
gL := CRT.NewNode(CRT.class, c, 0); gR := gL
ELSE (*string*)
CRT.StrToGraph(name, gL, gR)
END .)
| "(" TokenExpr <gL, gR> ")"
| "[" TokenExpr <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
| "{" TokenExpr <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
).
(*------------------------------------------------------------------------------------*)
Symbol <VAR name: CRT.Name; VAR kind: INTEGER> =
( ident (. kind := ident .)
| string (. kind := string .)
) (. CRS.GetName(CRS.pos, CRS.len, name);
IF kind = string THEN FixString(name, CRS.len) END .) .
(*------------------------------------------------------------------------------------*)
Attribs <VAR attrPos: CRT.Position> =
"<" (. attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol .)
{ ANY }
">" (. attrPos.len := SHORT(CRS.pos - attrPos.beg) .).
(*------------------------------------------------------------------------------------*)
SemText <VAR semPos: CRT.Position> =
"(." (. semPos.beg := CRS.nextPos; semPos.col := CRS.nextCol .)
{ ANY }
".)" (. semPos.len := SHORT(CRS.pos - semPos.beg) .).
END CR.

175
src/tools/coco/CRA.Mod
View file

@ -1,6 +1,14 @@
MODULE CRA; (* handles the DFA *)
(* The following check seems to be unnecessary. It reported an error if a symbol + context
was a prefix of another symbol, e.g.:
s1 = "a" "b" "c".
s2 = "a" CONTEXT("b").
But this is ok
IF t.state.endOf # CRT.noSym THEN
PutS("$Ambiguous CONTEXT clause.$"); correct := FALSE
END*)
MODULE CRA; (* handles the DFA *)
IMPORT Oberon, Texts := CmdlnTexts, Sets, CRS, CRT;
IMPORT Oberon, Texts, Sets, CRS, CRT;
CONST
maxStates = 300;
@ -30,6 +38,9 @@ TYPE
next: Target;
END;
Comment = POINTER TO CommentNode;
CommentNode = RECORD (* info about a comment syntax *)
start,stop: ARRAY 2 OF CHAR;
@ -43,7 +54,6 @@ TYPE
state: State; (* new state *)
next: Melted;
END;
VAR
firstState: State;
@ -53,10 +63,10 @@ VAR
stateNr: INTEGER; (*number of last allocated state*)
firstMelted: Melted; (* list of melted states *)
firstComment: Comment; (* list of comments *)
dirtyDFA: BOOLEAN; (* DFA may be nondeterministic *)
out: Texts.Writer; (* current output *)
fram: Texts.Reader; (* scanner frame input *)
PROCEDURE SemErr(nr: INTEGER);
BEGIN CRS.Error(200+nr, CRS.pos)
END SemErr;
@ -101,8 +111,9 @@ BEGIN
END;
(*----- print ranges *)
IF (top = 1) & (lo[0] = 0X) & (hi[1] = 7FX) & (CHR(ORD(hi[0]) + 2) = lo[1]) THEN
Sets.Fill(s1); Sets.Differ(s1, s); PutS("~ ("); PutRange(s1); Put(")")
Sets.Fill(s1); Sets.Differ(s1, s); PutS("~ "); PutRange(s1)
ELSE
PutS("(");
i := 0;
WHILE i <= top DO
IF hi[i] = lo[i] THEN PutS("(ch="); PutC(lo[i])
@ -113,7 +124,8 @@ BEGIN
Put(")");
IF i < top THEN PutS(" OR ") END;
INC(i)
END
END;
PutS(")");
END
END PutRange;
@ -217,6 +229,7 @@ END NewState;
PROCEDURE NewTransition(from, to: State; typ, sym, tc: INTEGER);
VAR a: Action; t: Target;
BEGIN
IF to = firstState THEN SemErr(21) END;
NEW(t); t^.state := to; t^.next := NIL;
NEW(a); a^.typ := typ; a^.sym := sym; a^.tc := tc; a^.target := t;
AddAction(a, from.firstAction)
@ -359,17 +372,33 @@ BEGIN
DelUnused
END DeleteRedundantStates;
PROCEDURE ConvertToStates*(gp0, sp: INTEGER);
(*note: gn.line is abused as a state number!*)
VAR n: INTEGER; S: ARRAY maxStates OF State; gn: CRT.GraphNode;
VAR n: INTEGER; S: ARRAY maxStates OF State; visited: CRT.MarkList;
PROCEDURE NumberNodes (gp: INTEGER; state: State);
VAR gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN RETURN END; (*end of graph*)
CRT.GetNode(gp, gn);
IF gn.line # 0 THEN RETURN END; (*already visited*)
IF state = NIL THEN state := NewState() END;
INC(n); S[n] := state; gn.line := n; CRT.PutNode(gp, gn);
IF CRT.DelGraph(gp) THEN state.endOf := sp END; (*state is final state*)
CASE gn.typ OF
CRT.class, CRT.char: NumberNodes(ABS(gn.next), NIL)
| CRT.opt: NumberNodes(ABS(gn.next), NIL); NumberNodes(gn.p1, state)
| CRT.iter: NumberNodes(ABS(gn.next), state); NumberNodes(gn.p1, state)
| CRT.alt: NumberNodes(gn.p1, state); NumberNodes(gn.p2, state)
END
END NumberNodes;
PROCEDURE TheState(gp: INTEGER): State;
VAR state: State; gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN state := NewState(); state.endOf := sp; RETURN state
ELSE CRT.GetNode(gp, gn); RETURN S[gn.line]
END
END
END TheState;
PROCEDURE Step(from: State; gp: INTEGER);
@ -384,45 +413,39 @@ PROCEDURE ConvertToStates*(gp0, sp: INTEGER);
END
END Step;
PROCEDURE FindTrans(gp: INTEGER; state: State);
VAR gn: CRT.GraphNode; new: BOOLEAN;
PROCEDURE FindTrans (gp: INTEGER; start: BOOLEAN);
VAR gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN RETURN END; (*end of graph*)
CRT.GetNode(gp, gn);
IF gn.line # 0 THEN RETURN END; (*already visited*)
new := state = NIL;
IF new THEN state := NewState() END;
INC(n); S[n] := state; gn.line := n; CRT.PutNode(gp, gn);
IF CRT.DelGraph(gp) THEN state.endOf := sp END; (*state is end state*)
IF (gp = 0) OR Sets.In(visited, gp) THEN RETURN END;
Sets.Incl(visited, gp); CRT.GetNode(gp, gn);
IF start THEN Step(S[gn.line], gp) END; (*start of group of equally numbered nodes*)
CASE gn.typ OF
CRT.class, CRT.char: FindTrans(ABS(gn.next), NIL);
| CRT.opt: FindTrans(ABS(gn.next), NIL); FindTrans(gn.p1, state)
| CRT.iter: FindTrans(ABS(gn.next), state); FindTrans(gn.p1, state)
| CRT.alt: FindTrans(gn.p1, state); FindTrans(gn.p2, state)
END;
IF new OR (state = firstState) & (gp = gp0) THEN (*start of a group of equally numbered nodes*)
Step(state, gp)
CRT.class, CRT.char: FindTrans(ABS(gn.next), TRUE)
| CRT.opt: FindTrans(ABS(gn.next), TRUE); FindTrans(gn.p1, FALSE)
| CRT.iter: FindTrans(ABS(gn.next), FALSE); FindTrans(gn.p1, FALSE)
| CRT.alt: FindTrans(gn.p1, FALSE); FindTrans(gn.p2, FALSE)
END
END FindTrans;
BEGIN
IF CRT.DelGraph(gp0) THEN SemErr(20) END;
CRT.GetNode(gp0, gn);
IF gn.typ = CRT.iter THEN SemErr(21) END;
n := 0; FindTrans(gp0, firstState)
n := 0; NumberNodes(gp0, firstState);
CRT.ClearMarkList(visited); FindTrans(gp0, TRUE)
END ConvertToStates;
PROCEDURE MatchDFA* (s: ARRAY OF CHAR; sp: INTEGER; VAR matchedSp: INTEGER);
VAR state, to: State; a: Action; i, len: INTEGER;
VAR state, to: State; a: Action; i, len: INTEGER; weakMatch: BOOLEAN;
BEGIN (*s with quotes*)
state := firstState; i := 1; len := Length(s) - 1;
state := firstState; i := 1; len := Length(s) - 1; weakMatch := FALSE;
LOOP (*try to match s against existing DFA*)
IF i = len THEN EXIT END;
a := TheAction(state, s[i]);
IF a = NIL THEN EXIT END;
IF a^.typ = CRT.class THEN weakMatch := TRUE END;
state := a.target.state; INC(i)
END;
IF weakMatch & (i < len) THEN state := firstState; i := 1; dirtyDFA := TRUE END;
WHILE i < len DO (*make new DFA for s[i..len-1]*)
to := NewState();
NewTransition(state, to, CRT.char, ORD(s[i]), CRT.normTrans);
@ -542,11 +565,7 @@ VAR
correct:=FALSE
END
END;
IF t^.state.ctx THEN ctx := TRUE;
IF t.state.endOf # CRT.noSym THEN
PutS("$Ambiguous CONTEXT clause.$"); correct := FALSE
END
END;
IF t^.state.ctx THEN ctx := TRUE; END;
t := t^.next
END
END GetStateSet;
@ -595,7 +614,6 @@ BEGIN
Texts.Append(Oberon.Log, out.buf)
END MeltStates;
PROCEDURE MakeDeterministic*(VAR correct: BOOLEAN);
VAR state: State; changed: BOOLEAN;
@ -677,56 +695,60 @@ BEGIN
END PrintStates;
PROCEDURE GenComment(com:Comment);
PROCEDURE GenComment(com:Comment; i: INTEGER);
PROCEDURE GenBody;
BEGIN
PutS(" LOOP$");
PutS(" IF "); PutChCond(com^.stop[0]); PutS(" THEN$");
PutS(" LOOP$");
PutS(" IF "); PutChCond(com^.stop[0]); PutS(" THEN$");
IF Length(com^.stop) = 1 THEN
PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
PutS(" IF level = 0 THEN RETURN TRUE END;$");
PutS(" DEC(level);$");
PutS(" IF level = 0 THEN oldEols := chLine - startLine; NextCh; RETURN TRUE END;$");
PutS(" NextCh;$");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.stop[1]); PutS(" THEN$");
PutS(" DEC(level);$");
PutS(" IF level=0 THEN oldEols := chLine - startLine; NextCh; RETURN TRUE END;$");
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.stop[1]); PutS(" THEN$");
PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
PutS(" IF level=0 THEN RETURN TRUE END$");
PutS(" END;$");
PutS(" END;$");
END;
IF com^.nested THEN
PutS(" ELSIF "); PutChCond(com^.start[0]); PutS(" THEN$");
PutS(" ELSIF "); PutChCond(com^.start[0]); PutS(" THEN$");
IF Length(com^.start) = 1 THEN
PutS(" INC(level); NextCh;$");
PutS(" INC(level); NextCh;$");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" INC(level); NextCh;$");
PutS(" END;$");
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" INC(level); NextCh;$");
PutS(" END;$");
END;
END;
PutS(" ELSIF ch = EOF THEN RETURN FALSE$");
PutS(" ELSE NextCh END;$");
PutS(" END;$");
PutS(" ELSIF ch = EOF THEN RETURN FALSE$");
PutS(" ELSE NextCh END;$");
PutS(" END;$");
END GenBody;
BEGIN
PutS(" IF "); PutChCond(com^.start[0]); PutS(" THEN$");
PutS("PROCEDURE Comment"); PutI(i); PutS("(): BOOLEAN;$");
PutS(" VAR level, startLine: INTEGER; oldLineStart: LONGINT;$");
PutS("BEGIN$");
PutS(" level := 1; startLine := chLine; oldLineStart := lineStart;$");
IF Length(com^.start) = 1 THEN
PutS(" NextCh;$");
PutS(" NextCh;$");
GenBody;
PutS(" END;");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" NextCh;$");
GenBody;
PutS(" ELSE$");
PutS(" IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;$");
PutS(" DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE$");
PutS(" END$");
PutS(" END;");
PutS(" ELSE$");
PutS(" IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;$");
PutS(" DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE$");
PutS(" END$");
END;
END GenComment;
PutS("END Comment"); PutI(i); PutS(";$$$")
END GenComment;
PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR); (*Copy from file <fram> to file <out> until <stopStr>*)
@ -829,7 +851,7 @@ PROCEDURE *Show (t: Texts.Text; op: INTEGER; beg, end: LONGINT);
END Show;
PROCEDURE WriteScanner*;
PROCEDURE WriteScanner* (VAR ok: BOOLEAN);
VAR
scanner: ARRAY 32 OF CHAR;
name: ARRAY 64 OF CHAR;
@ -863,6 +885,7 @@ VAR
END FillStartTab;
BEGIN
IF dirtyDFA THEN MakeDeterministic(ok) END;
FillStartTab;
CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
COPY(sn.name, scanner); l := Length(scanner); scanner[l] := "S"; scanner[l+1] := 0X;
@ -877,22 +900,22 @@ BEGIN
CopyFramePart("-->modulename"); PutS(scanner);
CopyFramePart("-->declarations"); PutS(" noSym = "); PutI(CRT.maxT); Put(";");
CopyFramePart("-->comment");
com := firstComment;
WHILE com # NIL DO GenComment(com); com := com^.next END;
com := firstComment; i := 0;
WHILE com # NIL DO GenComment(com, i); com := com^.next; INC(i) END;
CopyFramePart("-->literals"); GenLiterals;
CopyFramePart("-->GetSy1");
IF ~ Sets.In(CRT.ignored, ORD(EOL)) THEN PutS(" IF oldEols > 0 THEN DEC(oldEols); ch := EOL END;$") END;
PutS(" WHILE (ch=20X)"); IF ~ Sets.Empty(CRT.ignored) THEN PutS(" OR ") END;
PutRange(CRT.ignored); PutS(" DO NextCh END;");
IF firstComment # NIL THEN
PutS("$ IF ("); com := firstComment;
PutS("$ IF "); com := firstComment; i := 0;
WHILE com # NIL DO
PutChCond(com^.start[0]);
PutS(" & Comment"); PutI(i); PutS("() ");
IF com^.next # NIL THEN PutS(" OR ") END;
com := com^.next
com := com^.next; INC(i)
END;
PutS(") & Comment() THEN Get(sym); RETURN END;")
PutS(" THEN Get(sym); RETURN END;")
END;
CopyFramePart("-->GetSy2");
state := firstState.next;
@ -912,7 +935,7 @@ BEGIN
END;
CopyFramePart("-->modulename"); PutS(scanner); Put(".");
NEW(t); (*t.notify := Show;*) Texts.Open(t, ""); Texts.Append(t, out.buf);
NEW(t); t.notify := Show; Texts.Open(t, ""); Texts.Append(t, out.buf);
l := Length(scanner); scanner[l] := "."; scanner[l+1] := "M"; scanner[l+2] := "o"; scanner[l+3] := "d"; scanner[l+4] := 0X;
Texts.Close(t, scanner)
END WriteScanner;
@ -922,9 +945,11 @@ PROCEDURE Init*;
BEGIN
firstState := NIL; lastState := NIL; stateNr := -1;
rootState := NewState();
firstMelted := NIL; firstComment := NIL
firstMelted := NIL; firstComment := NIL;
dirtyDFA := FALSE
END Init;
BEGIN
Texts.OpenWriter(out)
END CRA.

442
src/tools/coco/CRP.Mod
View file

@ -1,12 +1,12 @@
(* parser module generated by Coco-R *)
MODULE CRP;
IMPORT CRS, CRT, CRA, CRX, Sets, Texts := CmdlnTexts, Oberon;
IMPORT CRS, CRT, CRA, CRX, Sets, Texts, Oberon;
CONST
maxP = 39;
maxT = 38;
nrSets = 18;
maxP = 42;
maxT = 41;
nrSets = 20;
setSize = 32; nSets = (maxT DIV setSize) + 1;
@ -73,7 +73,7 @@ PROCEDURE FixString (VAR s: ARRAY OF CHAR; len: INTEGER);
BEGIN
double := FALSE;
FOR i := 0 TO len-2 DO
IF s[i] = '"' THEN double := TRUE END
IF s[i] = '"' THEN double := TRUE ELSIF s[i] = " " THEN SemErr(24) END
END;
IF ~ double THEN s[0] := '"'; s[len-1] := '"' END
END FixString;
@ -89,9 +89,9 @@ PROCEDURE Get;
BEGIN
LOOP CRS.Get(sym);
IF sym > maxT THEN
IF sym = 39 THEN
IF sym = 42 THEN
CRS.GetName(CRS.nextPos, CRS.nextLen, str); SetDDT(str)
END;
END ;
CRS.nextPos := CRS.pos;
CRS.nextCol := CRS.col;
CRS.nextLine := CRS.line;
@ -161,22 +161,22 @@ BEGIN
ELSE (*string*)
CRT.StrToGraph(name, gL, gR)
END ;
ELSIF (sym = 23) THEN
ELSIF (sym = 24) THEN
Get;
TokenExpr(gL, gR);
Expect(24);
ELSIF (sym = 28) THEN
Expect(25);
ELSIF (sym = 29) THEN
Get;
TokenExpr(gL, gR);
Expect(29);
Expect(30);
CRT.MakeOption(gL, gR) ;
ELSIF (sym = 30) THEN
ELSIF (sym = 31) THEN
Get;
TokenExpr(gL, gR);
Expect(31);
Expect(32);
CRT.MakeIteration(gL, gR) ;
ELSE Error(39)
END;
ELSE Error(42)
END ;
END TokenFactor;
PROCEDURE TokenTerm(VAR gL, gR: INTEGER);
@ -186,14 +186,14 @@ BEGIN
WHILE StartOf(1) DO
TokenFactor(gL2, gR2);
CRT.ConcatSeq(gL, gR, gL2, gR2) ;
END;
IF (sym = 33) THEN
END ;
IF (sym = 34) THEN
Get;
Expect(23);
Expect(24);
TokenExpr(gL2, gR2);
SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) ;
Expect(24);
END;
Expect(25);
END ;
END TokenTerm;
PROCEDURE Factor(VAR gL, gR: INTEGER);
@ -205,10 +205,10 @@ PROCEDURE Factor(VAR gL, gR: INTEGER);
BEGIN
gL :=0; gR := 0; weak := FALSE ;
CASE sym OF
| 1,2,27: IF (sym = 27) THEN
| 1,2,28: IF (sym = 28) THEN
Get;
weak := TRUE ;
END;
END ;
Symbol(name, kind);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
@ -225,7 +225,7 @@ BEGIN
IF sn.typ = CRT.t THEN sn.typ := CRT.wt ELSE SemErr(23) END
END;
gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL ;
IF (sym = 34) THEN
IF (sym = 35) OR (sym = 37) THEN
Attribs(pos);
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn);
CRT.GetSym(sp, sn);
@ -237,30 +237,30 @@ BEGIN
ELSIF StartOf(2) THEN
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(6) END ;
ELSE Error(40)
END;
| 23: Get;
ELSE Error(43)
END ;
| 24: Get;
Expression(gL, gR);
Expect(24);
| 28: Get;
Expect(25);
| 29: Get;
Expression(gL, gR);
Expect(29);
Expect(30);
CRT.MakeOption(gL, gR) ;
| 30: Get;
| 31: Get;
Expression(gL, gR);
Expect(31);
Expect(32);
CRT.MakeIteration(gL, gR) ;
| 36: SemText(pos);
| 39: SemText(pos);
gL := CRT.NewNode(CRT.sem, 0, 0);
gR := gL;
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn) ;
| 25: Get;
| 26: Get;
Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL ;
| 32: Get;
| 33: Get;
gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL ;
ELSE Error(41)
END;
ELSE Error(44)
END ;
END Factor;
PROCEDURE Term(VAR gL, gR: INTEGER);
@ -272,11 +272,11 @@ BEGIN
WHILE StartOf(3) DO
Factor(gL2, gR2);
CRT.ConcatSeq(gL, gR, gL2, gR2) ;
END;
END ;
ELSIF StartOf(4) THEN
gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL ;
ELSE Error(42)
END;
ELSE Error(45)
END ;
END Term;
PROCEDURE Symbol(VAR name: CRT.Name; VAR kind: INTEGER);
@ -287,8 +287,8 @@ BEGIN
ELSIF (sym = 2) THEN
Get;
kind := string ;
ELSE Error(43)
END;
ELSE Error(46)
END ;
CRS.GetName(CRS.pos, CRS.len, name);
IF kind = string THEN FixString(name, CRS.len) END ;
END Symbol;
@ -310,10 +310,10 @@ BEGIN
WHILE s[i] # s[0] DO
Sets.Incl(set, ORD(s[i])); INC(i)
END ;
ELSIF (sym = 22) THEN
ELSIF (sym = 23) THEN
Get;
Expect(23);
Expect(3);
Expect(24);
Expect(4);
CRS.GetName(CRS.pos, CRS.len, name);
n := 0; i := 0;
WHILE name[i] # 0X DO
@ -321,20 +321,20 @@ BEGIN
INC(i)
END;
Sets.Clear(set); Sets.Incl(set, n) ;
Expect(24);
ELSIF (sym = 25) THEN
Expect(25);
ELSIF (sym = 26) THEN
Get;
Sets.Fill(set) ;
ELSE Error(44)
END;
ELSE Error(47)
END ;
END SimSet;
PROCEDURE Set(VAR set: CRT.Set);
VAR set2: CRT.Set;
BEGIN
SimSet(set);
WHILE (sym = 20) OR (sym = 21) DO
IF (sym = 20) THEN
WHILE (sym = 21) OR (sym = 22) DO
IF (sym = 21) THEN
Get;
SimSet(set2);
Sets.Unite(set, set2) ;
@ -342,8 +342,8 @@ BEGIN
Get;
SimSet(set2);
Sets.Differ(set, set2) ;
END;
END;
END ;
END ;
END Set;
PROCEDURE TokenExpr(VAR gL, gR: INTEGER);
@ -351,13 +351,13 @@ PROCEDURE TokenExpr(VAR gL, gR: INTEGER);
BEGIN
TokenTerm(gL, gR);
first := TRUE ;
WHILE WeakSeparator(26, 1, 5) DO
WHILE WeakSeparator(27, 1, 5) DO
TokenTerm(gL2, gR2);
IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) ;
END;
END ;
END TokenExpr;
PROCEDURE TokenDecl(typ: INTEGER);
@ -371,11 +371,11 @@ BEGIN
CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
CRT.PutSym(sp, sn)
END ;
WHILE ~( StartOf(6) ) DO Error(45); Get END;
IF (sym = 8) THEN
WHILE ~( StartOf(6) ) DO Error(48); Get END ;
IF (sym = 9) THEN
Get;
TokenExpr(gL, gR);
Expect(9);
Expect(10);
IF kind # ident THEN SemErr(13) END;
CRT.CompleteGraph(gR);
CRA.ConvertToStates(gL, sp) ;
@ -383,13 +383,13 @@ BEGIN
IF kind = ident THEN genScanner := FALSE
ELSE MatchLiteral(sp)
END ;
ELSE Error(46)
END;
IF (sym = 36) THEN
ELSE Error(49)
END ;
IF (sym = 39) THEN
SemText(pos);
IF typ = CRT.t THEN SemErr(14) END;
CRT.GetSym(sp, sn); sn.semPos := pos; CRT.PutSym(sp, sn) ;
END;
END ;
END TokenDecl;
PROCEDURE SetDecl;
@ -398,10 +398,10 @@ BEGIN
Expect(1);
CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name); IF c >= 0 THEN SemErr(7) END ;
Expect(8);
Expect(9);
Set(set);
c := CRT.NewClass(name, set) ;
Expect(9);
Expect(10);
END SetDecl;
PROCEDURE Expression(VAR gL, gR: INTEGER);
@ -409,80 +409,99 @@ PROCEDURE Expression(VAR gL, gR: INTEGER);
BEGIN
Term(gL, gR);
first := TRUE ;
WHILE WeakSeparator(26, 2, 8) DO
WHILE WeakSeparator(27, 2, 8) DO
Term(gL2, gR2);
IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) ;
END;
END ;
END Expression;
PROCEDURE SemText(VAR semPos: CRT.Position);
BEGIN
Expect(36);
Expect(39);
semPos.beg := CRS.nextPos; semPos.col := CRS.nextCol ;
WHILE StartOf(9) DO
Get;
END;
Expect(37);
semPos.len := SHORT(CRS.pos - semPos.beg) ;
IF StartOf(10) THEN
Get;
ELSIF (sym = 3) THEN
Get;
SemErr(18) ;
ELSE
Get;
SemErr(19) ;
END ;
END ;
Expect(40);
semPos.len := CRS.pos - semPos.beg ;
END SemText;
PROCEDURE Attribs(VAR attrPos: CRT.Position);
BEGIN
Expect(34);
attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol ;
WHILE StartOf(10) DO
IF (sym = 35) THEN
Get;
END;
Expect(35);
attrPos.len := SHORT(CRS.pos - attrPos.beg) ;
attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol ;
WHILE StartOf(11) DO
Get;
END ;
Expect(36);
attrPos.len := CRS.pos - attrPos.beg ;
ELSIF (sym = 37) THEN
Get;
attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol ;
WHILE StartOf(12) DO
Get;
END ;
Expect(38);
attrPos.len := CRS.pos - attrPos.beg ;
ELSE Error(50)
END ;
END Attribs;
PROCEDURE Declaration;
VAR gL1, gR1, gL2, gR2: INTEGER; nested: BOOLEAN;
BEGIN
IF (sym = 11) THEN
IF (sym = 12) THEN
Get;
WHILE (sym = 1) DO
SetDecl;
END;
ELSIF (sym = 12) THEN
Get;
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.t);
END;
END ;
ELSIF (sym = 13) THEN
Get;
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.pr);
END;
TokenDecl(CRT.t);
END ;
ELSIF (sym = 14) THEN
Get;
Expect(15);
TokenExpr(gL1, gR1);
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.pr);
END ;
ELSIF (sym = 15) THEN
Get;
Expect(16);
TokenExpr(gL1, gR1);
Expect(17);
TokenExpr(gL2, gR2);
IF (sym = 17) THEN
IF (sym = 18) THEN
Get;
nested := TRUE ;
ELSIF StartOf(11) THEN
ELSIF StartOf(13) THEN
nested := FALSE ;
ELSE Error(47)
END;
ELSE Error(51)
END ;
CRA.NewComment(gL1, gL2, nested) ;
ELSIF (sym = 18) THEN
ELSIF (sym = 19) THEN
Get;
IF (sym = 19) THEN
IF (sym = 20) THEN
Get;
CRT.ignoreCase := TRUE ;
ELSIF StartOf(12) THEN
ELSIF StartOf(14) THEN
Set(CRT.ignored);
ELSE Error(48)
END;
ELSE Error(49)
END;
ELSE Error(52)
END ;
ELSE Error(53)
END ;
END Declaration;
PROCEDURE CR;
@ -491,7 +510,7 @@ PROCEDURE CR;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
name, gramName: CRT.Name;
BEGIN
Expect(4);
Expect(5);
Texts.OpenWriter(w);
CRT.Init; CRX.Init; CRA.Init;
gramLine := CRS.line;
@ -503,28 +522,28 @@ BEGIN
Expect(1);
CRS.GetName(CRS.pos, CRS.len, gramName);
CRT.semDeclPos.beg := CRS.nextPos; CRT.importPos.beg := -1; ;
WHILE StartOf(13) DO
IF (sym = 5) THEN
WHILE StartOf(15) DO
IF (sym = 6) THEN
Get;
CRT.importPos.beg := CRS.nextPos ;
WHILE StartOf(14) DO
WHILE StartOf(16) DO
Get;
END;
Expect(6);
CRT.importPos.len := SHORT(CRS.pos - CRT.importPos.beg);
END ;
Expect(7);
CRT.importPos.len := CRS.pos - CRT.importPos.beg;
CRT.importPos.col := 0;
CRT.semDeclPos.beg := CRS.nextPos ;
ELSE
Get;
END;
END;
CRT.semDeclPos.len := SHORT(CRS.nextPos - CRT.semDeclPos.beg);
END ;
END ;
CRT.semDeclPos.len := CRS.nextPos - CRT.semDeclPos.beg;
CRT.semDeclPos.col := 0 ;
WHILE StartOf(15) DO
WHILE StartOf(17) DO
Declaration;
END;
WHILE ~( (sym = 0) OR (sym = 7)) DO Error(50); Get END;
Expect(7);
END ;
WHILE ~( (sym = 0) OR (sym = 8)) DO Error(54); Get END ;
Expect(8);
IF genScanner THEN CRA.MakeDeterministic(ok) END;
CRT.nNodes := 0 ;
WHILE (sym = 1) DO
@ -543,23 +562,23 @@ BEGIN
sn.line := CRS.line
END;
hasAttrs := sn.attrPos.beg >= 0 ;
IF (sym = 34) THEN
IF (sym = 35) OR (sym = 37) THEN
Attribs(sn.attrPos);
IF ~undef & ~hasAttrs THEN SemErr(9) END;
CRT.PutSym(sp, sn) ;
ELSIF (sym = 8) OR (sym = 36) THEN
ELSIF (sym = 9) OR (sym = 39) THEN
IF ~undef & hasAttrs THEN SemErr(10) END ;
ELSE Error(51)
END;
IF (sym = 36) THEN
ELSE Error(55)
END ;
IF (sym = 39) THEN
SemText(sn.semPos);
END;
ExpectWeak(8, 16);
END ;
ExpectWeak(9, 18);
Expression(sn.struct, gR);
CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
IF CRT.ddt[2] THEN CRT.PrintGraph END ;
ExpectWeak(9, 17);
END;
ExpectWeak(10, 19);
END ;
sp := CRT.FindSym(gramName);
IF sp = CRT.noSym THEN SemErr(11);
ELSE
@ -567,7 +586,7 @@ BEGIN
IF sn.attrPos.beg >= 0 THEN SemErr(12) END;
CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
END ;
Expect(10);
Expect(11);
Expect(1);
CRS.GetName(CRS.pos, CRS.len, name);
IF name # gramName THEN SemErr(17) END;
@ -589,7 +608,7 @@ BEGIN
IF genScanner THEN
Texts.WriteString(w, " +scanner");
Texts.Append(Oberon.Log, w.buf);
CRA.WriteScanner
CRA.WriteScanner(ok)
END;
IF CRT.ddt[8] THEN CRX.WriteStatistics END
END
@ -598,7 +617,7 @@ BEGIN
IF CRT.ddt[6] THEN CRT.PrintSymbolTable END;
IF ok THEN Texts.WriteString(w, " done") END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf) ;
Expect(9);
Expect(10);
END CR;
@ -611,93 +630,102 @@ BEGIN
END Parse;
BEGIN
symSet[0, 0] := {0,1,2,7,8,11,12,13,14,18};
symSet[0, 1] := {4};
symSet[1, 0] := {1,2,23,28,30};
symSet[0, 0] := {0,1,2,8,9,12,13,14,15,19};
symSet[0, 1] := {7};
symSet[1, 0] := {1,2,24,29,31};
symSet[1, 1] := {};
symSet[2, 0] := {1,2,9,23,24,25,26,27,28,29,30,31};
symSet[2, 1] := {0,4};
symSet[3, 0] := {1,2,23,25,27,28,30};
symSet[3, 1] := {0,4};
symSet[4, 0] := {9,24,26,29,31};
symSet[4, 1] := {};
symSet[5, 0] := {7,9,11,12,13,14,16,17,18,24,29,31};
symSet[5, 1] := {};
symSet[6, 0] := {0,1,2,7,8,11,12,13,14,18};
symSet[6, 1] := {4};
symSet[7, 0] := {1,2,7,11,12,13,14,18};
symSet[7, 1] := {4};
symSet[8, 0] := {9,24,29,31};
symSet[8, 1] := {};
symSet[2, 0] := {1,2,10,24,25,26,27,28,29,30,31};
symSet[2, 1] := {0,1,7};
symSet[3, 0] := {1,2,24,26,28,29,31};
symSet[3, 1] := {1,7};
symSet[4, 0] := {10,25,27,30};
symSet[4, 1] := {0};
symSet[5, 0] := {8,10,12,13,14,15,17,18,19,25,30};
symSet[5, 1] := {0};
symSet[6, 0] := {0,1,2,8,9,12,13,14,15,19};
symSet[6, 1] := {7};
symSet[7, 0] := {1,2,8,12,13,14,15,19};
symSet[7, 1] := {7};
symSet[8, 0] := {10,25,30};
symSet[8, 1] := {0};
symSet[9, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[9, 1] := {0,1,2,3,4,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 1] := {0,1,2,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[11, 0] := {7,11,12,13,14,18};
symSet[11, 1] := {};
symSet[12, 0] := {1,2,22,25};
symSet[12, 1] := {};
symSet[13, 0] := {1,2,3,4,5,6,8,9,10,15,16,17,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[13, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[14, 0] := {1,2,3,4,5,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[14, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[15, 0] := {11,12,13,14,18};
symSet[15, 1] := {};
symSet[16, 0] := {0,1,2,7,8,9,11,12,13,14,18,23,25,26,27,28,30};
symSet[16, 1] := {0,4};
symSet[17, 0] := {0,1,2,7,8,10,11,12,13,14,18};
symSet[17, 1] := {4};
symSet[9, 1] := {0,1,2,3,4,5,6,7,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 0] := {1,2,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 1] := {0,1,2,3,4,5,6,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[11, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[11, 1] := {0,1,2,3,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[12, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[12, 1] := {0,1,2,3,4,5,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[13, 0] := {8,12,13,14,15,19};
symSet[13, 1] := {};
symSet[14, 0] := {1,2,23,26};
symSet[14, 1] := {};
symSet[15, 0] := {1,2,3,4,5,6,7,9,10,11,16,17,18,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[15, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[16, 0] := {1,2,3,4,5,6,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[16, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[17, 0] := {12,13,14,15,19};
symSet[17, 1] := {};
symSet[18, 0] := {0,1,2,8,9,10,12,13,14,15,19,24,26,27,28,29,31};
symSet[18, 1] := {1,7};
symSet[19, 0] := {0,1,2,8,9,11,12,13,14,15,19};
symSet[19, 1] := {7};
END CRP.
| 0: Msg("EOF expected")
| 1: Msg("ident expected")
| 2: Msg("string expected")
| 3: Msg("number expected")
| 4: Msg("'COMPILER' expected")
| 5: Msg("'IMPORT' expected")
| 6: Msg("';' expected")
| 7: Msg("'PRODUCTIONS' expected")
| 8: Msg("'=' expected")
| 9: Msg("'.' expected")
| 10: Msg("'END' expected")
| 11: Msg("'CHARACTERS' expected")
| 12: Msg("'TOKENS' expected")
| 13: Msg("'PRAGMAS' expected")
| 14: Msg("'COMMENTS' expected")
| 15: Msg("'FROM' expected")
| 16: Msg("'TO' expected")
| 17: Msg("'NESTED' expected")
| 18: Msg("'IGNORE' expected")
| 19: Msg("'CASE' expected")
| 20: Msg("'+' expected")
| 21: Msg("'-' expected")
| 22: Msg("'CHR' expected")
| 23: Msg("'(' expected")
| 24: Msg("')' expected")
| 25: Msg("'ANY' expected")
| 26: Msg("'|' expected")
| 27: Msg("'WEAK' expected")
| 28: Msg("'[' expected")
| 29: Msg("']' expected")
| 30: Msg("'{' expected")
| 31: Msg("'}' expected")
| 32: Msg("'SYNC' expected")
| 33: Msg("'CONTEXT' expected")
| 34: Msg("'<' expected")
| 35: Msg("'>' expected")
| 36: Msg("'(.' expected")
| 37: Msg("'.)' expected")
| 38: Msg("??? expected")
| 39: Msg("invalid TokenFactor")
| 40: Msg("invalid Factor")
| 41: Msg("invalid Factor")
| 42: Msg("invalid Term")
| 43: Msg("invalid Symbol")
| 44: Msg("invalid SimSet")
| 45: Msg("this symbol not expected in TokenDecl")
| 46: Msg("invalid TokenDecl")
| 47: Msg("invalid Declaration")
| 48: Msg("invalid Declaration")
| 49: Msg("invalid Declaration")
| 50: Msg("this symbol not expected in CR")
| 51: Msg("invalid CR")
| 3: Msg("badString expected")
| 4: Msg("number expected")
| 5: Msg("'COMPILER' expected")
| 6: Msg("'IMPORT' expected")
| 7: Msg("';' expected")
| 8: Msg("'PRODUCTIONS' expected")
| 9: Msg("'=' expected")
| 10: Msg("'.' expected")
| 11: Msg("'END' expected")
| 12: Msg("'CHARACTERS' expected")
| 13: Msg("'TOKENS' expected")
| 14: Msg("'PRAGMAS' expected")
| 15: Msg("'COMMENTS' expected")
| 16: Msg("'FROM' expected")
| 17: Msg("'TO' expected")
| 18: Msg("'NESTED' expected")
| 19: Msg("'IGNORE' expected")
| 20: Msg("'CASE' expected")
| 21: Msg("'+' expected")
| 22: Msg("'-' expected")
| 23: Msg("'CHR' expected")
| 24: Msg("'(' expected")
| 25: Msg("')' expected")
| 26: Msg("'ANY' expected")
| 27: Msg("'|' expected")
| 28: Msg("'WEAK' expected")
| 29: Msg("'[' expected")
| 30: Msg("']' expected")
| 31: Msg("'{' expected")
| 32: Msg("'}' expected")
| 33: Msg("'SYNC' expected")
| 34: Msg("'CONTEXT' expected")
| 35: Msg("'<' expected")
| 36: Msg("'>' expected")
| 37: Msg("'<.' expected")
| 38: Msg("'.>' expected")
| 39: Msg("'(.' expected")
| 40: Msg("'.)' expected")
| 41: Msg("??? expected")
| 42: Msg("invalid TokenFactor")
| 43: Msg("invalid Factor")
| 44: Msg("invalid Factor")
| 45: Msg("invalid Term")
| 46: Msg("invalid Symbol")
| 47: Msg("invalid SimSet")
| 48: Msg("this symbol not expected in TokenDecl")
| 49: Msg("invalid TokenDecl")
| 50: Msg("invalid Attribs")
| 51: Msg("invalid Declaration")
| 52: Msg("invalid Declaration")
| 53: Msg("invalid Declaration")
| 54: Msg("this symbol not expected in CR")
| 55: Msg("invalid CR")

133
src/tools/coco/CRS.Mod
View file

@ -7,7 +7,7 @@ CONST
EOL = 0DX;
EOF = 0X;
maxLexLen = 127;
noSym = 38;
noSym = 41;
TYPE
ErrorProc* = PROCEDURE (n: INTEGER; pos: LONGINT);
@ -35,8 +35,11 @@ VAR
PROCEDURE NextCh; (*return global variable ch*)
BEGIN
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
IF oldEols > 0 THEN DEC(oldEols); ch := EOL
ELSE
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
END
END NextCh;
@ -52,8 +55,9 @@ BEGIN (*Comment*)
IF (ch ="*") THEN
NextCh;
IF (ch =")") THEN
DEC(level); oldEols := chLine - startLine; NextCh;
IF level=0 THEN RETURN TRUE END
DEC(level);
IF level=0 THEN oldEols := chLine - startLine; NextCh; RETURN TRUE END;
NextCh;
END;
ELSIF (ch ="(") THEN
NextCh;
@ -79,33 +83,33 @@ VAR state: INTEGER; lexeme: ARRAY maxLexLen+1 OF CHAR;
IF nextLen < maxLexLen THEN lexeme[nextLen] := 0X END;
IF (lexeme[0] >= "A") & (lexeme[0] <= "W") THEN
CASE lexeme[0] OF
| "A": IF lexeme = "ANY" THEN sym := 25
| "A": IF lexeme = "ANY" THEN sym := 26
END
| "C": IF lexeme = "CASE" THEN sym := 19
ELSIF lexeme = "CHARACTERS" THEN sym := 11
ELSIF lexeme = "CHR" THEN sym := 22
ELSIF lexeme = "COMMENTS" THEN sym := 14
ELSIF lexeme = "COMPILER" THEN sym := 4
ELSIF lexeme = "CONTEXT" THEN sym := 33
| "C": IF lexeme = "CASE" THEN sym := 20
ELSIF lexeme = "CHARACTERS" THEN sym := 12
ELSIF lexeme = "CHR" THEN sym := 23
ELSIF lexeme = "COMMENTS" THEN sym := 15
ELSIF lexeme = "COMPILER" THEN sym := 5
ELSIF lexeme = "CONTEXT" THEN sym := 34
END
| "E": IF lexeme = "END" THEN sym := 10
| "E": IF lexeme = "END" THEN sym := 11
END
| "F": IF lexeme = "FROM" THEN sym := 15
| "F": IF lexeme = "FROM" THEN sym := 16
END
| "I": IF lexeme = "IGNORE" THEN sym := 18
ELSIF lexeme = "IMPORT" THEN sym := 5
| "I": IF lexeme = "IGNORE" THEN sym := 19
ELSIF lexeme = "IMPORT" THEN sym := 6
END
| "N": IF lexeme = "NESTED" THEN sym := 17
| "N": IF lexeme = "NESTED" THEN sym := 18
END
| "P": IF lexeme = "PRAGMAS" THEN sym := 13
ELSIF lexeme = "PRODUCTIONS" THEN sym := 7
| "P": IF lexeme = "PRAGMAS" THEN sym := 14
ELSIF lexeme = "PRODUCTIONS" THEN sym := 8
END
| "S": IF lexeme = "SYNC" THEN sym := 32
| "S": IF lexeme = "SYNC" THEN sym := 33
END
| "T": IF lexeme = "TO" THEN sym := 16
ELSIF lexeme = "TOKENS" THEN sym := 12
| "T": IF lexeme = "TO" THEN sym := 17
ELSIF lexeme = "TOKENS" THEN sym := 13
END
| "W": IF lexeme = "WEAK" THEN sym := 27
| "W": IF lexeme = "WEAK" THEN sym := 28
END
ELSE
END
@ -129,42 +133,50 @@ BEGIN
| 1: IF (ch>="0") & (ch<="9") OR (ch>="A") & (ch<="Z") OR (ch>="a") & (ch<="z") THEN
ELSE sym := 1; CheckLiteral; RETURN
END;
| 2: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="!") OR (ch>="#") THEN
ELSIF (ch =CHR(34)) THEN state := 3;
ELSE sym := noSym; RETURN
END;
| 3: sym := 2; RETURN
| 4: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="&") OR (ch>="(") THEN
ELSIF (ch ="'") THEN state := 3;
ELSE sym := noSym; RETURN
| 2: sym := 2; RETURN
| 3: sym := 3; RETURN
| 4: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 4; RETURN
END;
| 5: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 3; RETURN
ELSE sym := 42; RETURN
END;
| 6: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 39; RETURN
| 6: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="!") OR (ch>="#") THEN
ELSIF (ch=CHR(13)) THEN state := 3;
ELSIF (ch =CHR(34)) THEN state := 2;
ELSE sym := noSym; RETURN
END;
| 7: sym := 6; RETURN
| 8: sym := 8; RETURN
| 9: IF (ch =")") THEN state := 22;
ELSE sym := 9; RETURN
| 7: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="&") OR (ch>="(") THEN
ELSIF (ch=CHR(13)) THEN state := 3;
ELSIF (ch ="'") THEN state := 2;
ELSE sym := noSym; RETURN
END;
| 8: sym := 7; RETURN
| 9: sym := 9; RETURN
| 10: IF (ch =">") THEN state := 23;
ELSIF (ch =")") THEN state := 25;
ELSE sym := 10; RETURN
END;
| 10: sym := 20; RETURN
| 11: sym := 21; RETURN
| 12: IF (ch =".") THEN state := 21;
ELSE sym := 23; RETURN
| 12: sym := 22; RETURN
| 13: IF (ch =".") THEN state := 24;
ELSE sym := 24; RETURN
END;
| 13: sym := 24; RETURN
| 14: sym := 26; RETURN
| 15: sym := 28; RETURN
| 14: sym := 25; RETURN
| 15: sym := 27; RETURN
| 16: sym := 29; RETURN
| 17: sym := 30; RETURN
| 18: sym := 31; RETURN
| 19: sym := 34; RETURN
| 20: sym := 35; RETURN
| 19: sym := 32; RETURN
| 20: IF (ch =".") THEN state := 22;
ELSE sym := 35; RETURN
END;
| 21: sym := 36; RETURN
| 22: sym := 37; RETURN
| 23: sym := 0; ch := 0X; RETURN
| 23: sym := 38; RETURN
| 24: sym := 39; RETURN
| 25: sym := 40; RETURN
| 26: sym := 0; ch := 0X; RETURN
END (*CASE*)
ELSE sym := noSym; RETURN (*NextCh already done*)
@ -195,7 +207,7 @@ BEGIN
END Reset;
BEGIN
start[0]:=23; start[1]:=0; start[2]:=0; start[3]:=0;
start[0]:=26; start[1]:=0; start[2]:=0; start[3]:=0;
start[4]:=0; start[5]:=0; start[6]:=0; start[7]:=0;
start[8]:=0; start[9]:=0; start[10]:=0; start[11]:=0;
start[12]:=0; start[13]:=0; start[14]:=0; start[15]:=0;
@ -203,28 +215,29 @@ BEGIN
start[20]:=0; start[21]:=0; start[22]:=0; start[23]:=0;
start[24]:=0; start[25]:=0; start[26]:=0; start[27]:=0;
start[28]:=0; start[29]:=0; start[30]:=0; start[31]:=0;
start[32]:=0; start[33]:=0; start[34]:=2; start[35]:=0;
start[36]:=6; start[37]:=0; start[38]:=0; start[39]:=4;
start[40]:=12; start[41]:=13; start[42]:=0; start[43]:=10;
start[44]:=0; start[45]:=11; start[46]:=9; start[47]:=0;
start[48]:=5; start[49]:=5; start[50]:=5; start[51]:=5;
start[52]:=5; start[53]:=5; start[54]:=5; start[55]:=5;
start[56]:=5; start[57]:=5; start[58]:=0; start[59]:=7;
start[60]:=19; start[61]:=8; start[62]:=20; start[63]:=0;
start[32]:=0; start[33]:=0; start[34]:=6; start[35]:=0;
start[36]:=5; start[37]:=0; start[38]:=0; start[39]:=7;
start[40]:=13; start[41]:=14; start[42]:=0; start[43]:=11;
start[44]:=0; start[45]:=12; start[46]:=10; start[47]:=0;
start[48]:=4; start[49]:=4; start[50]:=4; start[51]:=4;
start[52]:=4; start[53]:=4; start[54]:=4; start[55]:=4;
start[56]:=4; start[57]:=4; start[58]:=0; start[59]:=8;
start[60]:=20; start[61]:=9; start[62]:=21; start[63]:=0;
start[64]:=0; start[65]:=1; start[66]:=1; start[67]:=1;
start[68]:=1; start[69]:=1; start[70]:=1; start[71]:=1;
start[72]:=1; start[73]:=1; start[74]:=1; start[75]:=1;
start[76]:=1; start[77]:=1; start[78]:=1; start[79]:=1;
start[80]:=1; start[81]:=1; start[82]:=1; start[83]:=1;
start[84]:=1; start[85]:=1; start[86]:=1; start[87]:=1;
start[88]:=1; start[89]:=1; start[90]:=1; start[91]:=15;
start[92]:=0; start[93]:=16; start[94]:=0; start[95]:=0;
start[88]:=1; start[89]:=1; start[90]:=1; start[91]:=16;
start[92]:=0; start[93]:=17; start[94]:=0; start[95]:=0;
start[96]:=0; start[97]:=1; start[98]:=1; start[99]:=1;
start[100]:=1; start[101]:=1; start[102]:=1; start[103]:=1;
start[104]:=1; start[105]:=1; start[106]:=1; start[107]:=1;
start[108]:=1; start[109]:=1; start[110]:=1; start[111]:=1;
start[112]:=1; start[113]:=1; start[114]:=1; start[115]:=1;
start[116]:=1; start[117]:=1; start[118]:=1; start[119]:=1;
start[120]:=1; start[121]:=1; start[122]:=1; start[123]:=17;
start[124]:=14; start[125]:=18; start[126]:=0; start[127]:=0;
start[120]:=1; start[121]:=1; start[122]:=1; start[123]:=18;
start[124]:=15; start[125]:=19; start[126]:=0; start[127]:=0;
END CRS.

20
src/tools/coco/CRT.Mod
View file

@ -1,6 +1,6 @@
MODULE CRT; (* H.Moessenboeck 17.11.93, Cocol-R Tables *)
MODULE CRT; (* Cocol-R Tables *)
IMPORT Texts := CmdlnTexts, Oberon, Sets;
IMPORT Texts := CmdlnTexts,(* Oberon, Sets;
CONST
maxSymbols* = 300; (*max nr of t, nt, and pragmas*)
@ -27,7 +27,7 @@ TYPE
Name* = ARRAY 16 OF CHAR; (*symbol name*)
Position* = RECORD (*position of stretch of source text*)
beg*: LONGINT; (*start relative to beginning of file*)
len*: INTEGER; (*length*)
len*: LONGINT; (*length*)
col*: INTEGER; (*column number of start position*)
END;
@ -129,7 +129,7 @@ BEGIN
HALT(99)
END Restriction;
PROCEDURE ClearMarkList(VAR m: MarkList);
PROCEDURE ClearMarkList*(VAR m: MarkList);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < maxNodes DIV Sets.size DO m[i] := {}; INC(i) END;
@ -303,10 +303,10 @@ PROCEDURE CompFollowSets;
WHILE j <= lastNt - firstNt DO (* for all nonterminals *)
IF Sets.In(follow[i].nts, j) THEN
Complete(j); Sets.Unite(follow[i].ts, follow[j].ts);
Sets.Excl(follow[i].nts, j)
IF i = curSy THEN Sets.Excl(follow[i].nts, j) END
END;
INC(j)
END;
END
END Complete;
BEGIN (* CompFollowSets *)
@ -323,7 +323,7 @@ BEGIN (* CompFollowSets *)
INC(curSy)
END;
CompFol(root); (*curSy=lastNt+1*)
curSy := 0; (*add indirect successors to follow.ts*)
WHILE curSy <= lastNt - firstNt DO
ClearMarkList(visited); Complete(curSy);
@ -945,9 +945,8 @@ PROCEDURE TestIfNtToTerm* (VAR ok: BOOLEAN);
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF (gn.typ = nt) & ~ Sets.In(termList, gn.p1)
OR (gn.typ = alt) & ~ IsTerm(gn.p1) & ~ IsTerm(gn.p2) THEN RETURN FALSE
END;
IF (gn.typ = nt) & ~ Sets.In(termList, gn.p1) THEN RETURN FALSE END;
IF (gn.typ = alt) & ~ IsTerm(gn.p1) & ((gn.p2 = 0) OR ~IsTerm(gn.p2)) THEN RETURN FALSE END;
gp := gn.next
END;
RETURN TRUE
@ -992,3 +991,4 @@ BEGIN (* CRT *)
gn[0].typ := -1; gn[0].p1 := 0; gn[0].p2 := 0; gn[0].next := 0; gn[0].line := 0;
Texts.OpenWriter(w)
END CRT.

163
src/tools/coco/CRX.Mod
View file

@ -1,11 +1,11 @@
MODULE CRX; (* H.Moessenboeck 17.11.93 *)
MODULE CRX;
IMPORT Oberon, Texts := CmdlnTexts, Sets, CRS, CRT, SYSTEM;
IMPORT Oberon, Texts, Sets, CRS, CRT, SYSTEM;
CONST
CONST
symSetSize = 100;
maxTerm = 3; (* sets of size < maxTerm are enumerated *)
tErr = 0; altErr = 1; syncErr = 2;
EOL = 0DX;
@ -23,7 +23,7 @@ VAR
PROCEDURE Restriction(n: INTEGER);
BEGIN
Texts.WriteLn(w); Texts.WriteString(w, "Restriction ");
Texts.WriteLn(w); Texts.WriteString(w, "Restriction ");
Texts.WriteInt(w, n, 0); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf);
HALT(99)
END Restriction;
@ -32,7 +32,7 @@ PROCEDURE PutS(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF s[i] = "$" THEN Texts.WriteLn(syn) ELSE Texts.Write(syn, s[i]) END;
IF s[i] = "$" THEN Texts.WriteLn(syn) ELSE Texts.Write(syn, s[i]) END ;
INC(i)
END
END PutS;
@ -52,9 +52,9 @@ BEGIN
i := 0; first := TRUE;
WHILE i < Sets.size DO
IF i IN s THEN
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END;
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END ;
PutI(i)
END;
END ;
INC(i)
END
END PutSet;
@ -65,9 +65,9 @@ BEGIN
i := 0; first := TRUE;
WHILE i <= CRT.maxT DO
IF Sets.In(s, i) THEN
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END;
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END ;
PutI(i)
END;
END ;
INC(i)
END
END PutSet1;
@ -75,7 +75,7 @@ END PutSet1;
PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END ;
RETURN i
END Length;
@ -85,7 +85,7 @@ BEGIN
n := 0;
WHILE gp > 0 DO
CRT.GetNode(gp, gn); gp := gn.p2; INC(n)
END;
END ;
RETURN n
END Alternatives;
@ -97,7 +97,7 @@ BEGIN
IF ch = startCh THEN (* check if stopString occurs *)
i := 0;
REPEAT
IF i = high THEN RETURN END; (*stopStr[0..i] found; no unrecognized character*)
IF i = high THEN RETURN END ; (*stopStr[0..i] found; no unrecognized character*)
Texts.Read (fram, ch); INC(i);
UNTIL ch # stopStr[i];
(*stopStr[0..i-1] found; 1 unrecognized character*)
@ -107,7 +107,7 @@ BEGIN
END
END CopyFramePart;
PROCEDURE CopySourcePart (pos: CRT.Position; indent: INTEGER);
PROCEDURE CopySourcePart (pos: CRT.Position; indent: INTEGER);
(*Copy sequence <position> from <src> to <syn>*)
VAR ch: CHAR; i: INTEGER; nChars: LONGINT; r: Texts.Reader;
BEGIN
@ -118,13 +118,13 @@ BEGIN
LOOP
WHILE ch = EOL DO
Texts.WriteLn(syn); Indent(indent);
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END;
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END ;
i := pos.col;
WHILE (ch = " ") & (i > 0) DO (* skip blanks at beginning of line *)
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END;
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END ;
DEC(i)
END
END;
END ;
Texts.Write (syn, ch);
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END
END
@ -135,18 +135,18 @@ BEGIN
nChars := pos.len; col := pos.col - 1; ch := " ";
WHILE (nChars > 0) & (ch = " ") DO (*skip leading blanks*)
Texts.Read(r, ch); DEC(nChars); INC(col)
END;
END ;
Indent(indent);
LOOP
WHILE ch = EOL DO
Texts.WriteLn(syn); Indent(indent);
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END;
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END ;
i := col - 1;
WHILE (ch = " ") & (i > 0) DO (* skip blanks at beginning of line *)
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END;
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END ;
DEC(i)
END
END;
END ;
Texts.Write (syn, ch);
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END
END (* LOOP *)
@ -154,18 +154,18 @@ BEGIN
END CopySourcePart;
PROCEDURE GenErrorMsg (errTyp, errSym: INTEGER; VAR errNr: INTEGER);
VAR i: INTEGER; name: ARRAY 32 OF CHAR; sn: CRT.SymbolNode;
VAR i: INTEGER; name: ARRAY 32 OF CHAR; sn: CRT.SymbolNode;
BEGIN
INC (errorNr); errNr := errorNr;
CRT.GetSym (errSym, sn); COPY(sn.name, name);
i := 0; WHILE name[i] # 0X DO IF name[i] = CHR(34) THEN name[i] := "'" END; INC(i) END;
i := 0; WHILE name[i] # 0X DO IF name[i] = CHR(34) THEN name[i] := "'" END ; INC(i) END ;
Texts.WriteString(err, " |");
Texts.WriteInt (err, errNr, 3); Texts.WriteString (err, ": Msg("); Texts.Write(err, CHR(34));
CASE errTyp OF
| tErr : Texts.WriteString (err, name); Texts.WriteString (err, " expected")
| altErr : Texts.WriteString (err, "invalid "); Texts.WriteString (err, name)
| syncErr: Texts.WriteString (err, "this symbol not expected in "); Texts.WriteString (err, name)
END;
END ;
Texts.Write(err, CHR(34)); Texts.Write(err, ")"); Texts.WriteLn(err)
END GenErrorMsg;
@ -174,27 +174,27 @@ PROCEDURE NewCondSet (set: CRT.Set): INTEGER;
BEGIN
i := 1; (*skip symSet[0]*)
WHILE i <= maxSS DO
IF Sets.Equal(set, symSet[i]) THEN RETURN i END;
INC(i)
END;
INC(maxSS); IF maxSS > symSetSize THEN Restriction (9) END;
IF Sets.Equal(set, symSet[i]) THEN RETURN i END ;
INC(i)
END ;
INC(maxSS); IF maxSS > symSetSize THEN Restriction (9) END ;
symSet[maxSS] := set;
RETURN maxSS
END NewCondSet;
PROCEDURE GenCond (set: CRT.Set);
VAR sx, i, n: INTEGER;
PROCEDURE Small(s: CRT.Set): BOOLEAN;
BEGIN
i := Sets.size;
WHILE i <= CRT.maxT DO
IF Sets.In(set, i) THEN RETURN FALSE END;
IF Sets.In(set, i) THEN RETURN FALSE END ;
INC(i)
END;
END ;
RETURN TRUE
END Small;
BEGIN
n := Sets.Elements(set, i);
(*IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
@ -206,11 +206,11 @@ BEGIN
IF Sets.In (set, i) THEN
PutS(" (sym = "); PutI(i); Texts.Write(syn, ")");
DEC(n); IF n > 0 THEN PutS(" OR") END
END;
END ;
INC(i)
END
ELSE PutS(" sym IN symSet["); PutI(NewCondSet(set)); PutS(",0]")
END;*)
END ;*)
IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
ELSIF n <= maxTerm THEN
i := 0;
@ -218,12 +218,12 @@ BEGIN
IF Sets.In (set, i) THEN
PutS(" (sym = "); PutI(i); Texts.Write(syn, ")");
DEC(n); IF n > 0 THEN PutS(" OR") END
END;
END ;
INC(i)
END
ELSE PutS(" StartOf("); PutI(NewCondSet(set)); PutS(") ")
END;
END ;
END GenCond;
PROCEDURE GenCode (gp, indent: INTEGER; checked: CRT.Set);
@ -233,15 +233,15 @@ BEGIN
WHILE gp > 0 DO
CRT.GetNode (gp, gn);
CASE gn.typ OF
| CRT.nt:
Indent(indent);
CRT.GetSym(gn.p1, sn); PutS(sn.name);
IF gn.pos.beg >= 0 THEN
Texts.Write(syn, "("); CopySourcePart(gn.pos, 0); Texts.Write(syn, ")")
END;
END ;
PutS(";$")
| CRT.t:
CRT.GetSym(gn.p1, sn); Indent(indent);
IF Sets.In(checked, gn.p1) THEN
@ -249,32 +249,32 @@ BEGIN
ELSE
PutS("Expect("); PutI(gn.p1); PutS(");$")
END
| CRT.wt:
CRT.CompExpected(ABS(gn.next), curSy, s1);
CRT.GetSet(0, s2); Sets.Unite(s1, s2);
CRT.GetSym(gn.p1, sn); Indent(indent);
PutS("ExpectWeak("); PutI(gn.p1); PutS(", "); PutI(NewCondSet(s1)); PutS(");$")
| CRT.any:
Indent(indent); PutS("Get;$")
| CRT.eps: (* nothing *)
| CRT.sem:
| CRT.sem:
CopySourcePart(gn.pos, indent); PutS(";$");
| CRT.sync:
CRT.GetSet(gn.p1, s1);
GenErrorMsg (syncErr, curSy, errNr);
Indent(indent);
Indent(indent);
PutS("WHILE ~("); GenCond(s1); PutS(") DO Error(");
PutI(errNr); PutS("); Get END;$")
PutI(errNr); PutS("); Get END ;$")
| CRT.alt:
CRT.CompFirstSet(gp, s1); equal := Sets.Equal(s1, checked);
alts := Alternatives(gp);
IF alts > 5 THEN Indent(indent); PutS("CASE sym OF$") END;
IF alts > 5 THEN Indent(indent); PutS("CASE sym OF$") END ;
gp2 := gp;
WHILE gp2 # 0 DO
CRT.GetNode(gp2, gn2);
@ -284,16 +284,16 @@ BEGIN
ELSIF gp2 = gp THEN PutS("IF"); GenCond(s1); PutS(" THEN$")
ELSIF (gn2.p2 = 0) & equal THEN PutS("ELSE$")
ELSE PutS("ELSIF"); GenCond(s1); PutS(" THEN$")
END;
END ;
Sets.Unite(s1, checked);
GenCode(gn2.p1, indent + 2, s1);
gp2 := gn2.p2
END;
END ;
IF ~ equal THEN
GenErrorMsg(altErr, curSy, errNr);
Indent(indent); PutS("ELSE Error("); PutI(errNr); PutS(")$")
END;
Indent(indent); PutS("END;$")
END ;
Indent(indent); PutS("END ;$")
| CRT.iter:
CRT.GetNode(gn.p1, gn2);
@ -302,58 +302,58 @@ BEGIN
CRT.CompExpected(ABS(gn2.next), curSy, s1);
CRT.CompExpected(ABS(gn.next), curSy, s2);
CRT.GetSym(gn2.p1, sn);
PutS(" WeakSeparator("); PutI(gn2.p1); PutS(", "); PutI(NewCondSet(s1));
PutS(" WeakSeparator("); PutI(gn2.p1); PutS(", "); PutI(NewCondSet(s1));
PutS(", "); PutI(NewCondSet(s2)); PutS(") ");
Sets.Clear(s1); (*for inner structure*)
IF gn2.next > 0 THEN gp2 := gn2.next ELSE gp2 := 0 END
ELSE
gp2 := gn.p1; CRT.CompFirstSet(gp2, s1); GenCond(s1)
END;
END ;
PutS(" DO$");
GenCode(gp2, indent + 2, s1);
Indent(indent); PutS("END;$")
Indent(indent); PutS("END ;$")
| CRT.opt:
CRT.CompFirstSet(gn.p1, s1);
IF ~ Sets.Equal(checked, s1) THEN
Indent(indent); PutS("IF"); GenCond(s1); PutS(" THEN$");
GenCode(gn.p1, indent + 2, s1);
Indent(indent); PutS("END;$")
Indent(indent); PutS("END ;$")
ELSE GenCode(gn.p1, indent, checked)
END
END; (*CASE*)
IF ~ (gn.typ IN {CRT.eps, CRT.sem, CRT.sync}) THEN Sets.Clear(checked) END;
END ; (*CASE*)
IF ~ (gn.typ IN {CRT.eps, CRT.sem, CRT.sync}) THEN Sets.Clear(checked) END ;
gp := gn.next
END
END GenCode;
PROCEDURE GenCodePragmas;
VAR i, p: INTEGER; sn: CRT.SymbolNode;
PROCEDURE P(s1, s2: ARRAY OF CHAR);
BEGIN
PutS(" "); PutS(scanner); PutS(s1); PutS(" := "); PutS(scanner); PutS(s2); PutS(";$")
END P;
BEGIN
i := CRT.maxT + 1;
WHILE i <= CRT.maxP DO
WHILE i <= CRT.maxP DO
CRT.GetSym(i, sn);
PutS(" IF sym = "); PutI(i); PutS(" THEN$"); CopySourcePart(sn.semPos, 9); PutS("$ END;$");
PutS(" IF sym = "); PutI(i); PutS(" THEN$"); CopySourcePart(sn.semPos, 9); PutS("$ END ;$");
INC(i)
END;
END ;
P(".nextPos", ".pos"); P(".nextCol", ".col"); P(".nextLine", ".line"); P(".nextLen", ".len")
END GenCodePragmas;
PROCEDURE GenProcedureHeading (sn: CRT.SymbolNode; forward: BOOLEAN);
BEGIN
PutS("PROCEDURE ");
IF forward THEN Texts.Write(syn, "^") END;
IF forward THEN Texts.Write(syn, "^") END ;
PutS(sn.name);
IF sn.attrPos.beg >= 0 THEN
IF sn.attrPos.beg >= 0 THEN
Texts.Write(syn, "("); CopySourcePart(sn.attrPos, 0); Texts.Write(syn, ")")
END;
END ;
PutS(";$")
END GenProcedureHeading;
@ -365,7 +365,7 @@ BEGIN
WHILE sp <= CRT.lastNt DO (* for all nonterminals *)
CRT.GetSym (sp, sn); GenProcedureHeading(sn, TRUE);
INC(sp)
END;
END ;
Texts.WriteLn(syn)
END
END GenForwardRefs;
@ -376,26 +376,26 @@ BEGIN
curSy := CRT.firstNt;
WHILE curSy <= CRT.lastNt DO (* for all nonterminals *)
CRT.GetSym (curSy, sn); GenProcedureHeading (sn, FALSE);
IF sn.semPos.beg >= 0 THEN CopySourcePart(sn.semPos, 2); PutS(" $") END;
IF sn.semPos.beg >= 0 THEN CopySourcePart(sn.semPos, 2); PutS(" $") END ;
PutS("BEGIN$"); Sets.Clear(checked);
GenCode (sn.struct, 2, checked);
GenCode (sn.struct, 2, checked);
PutS("END "); PutS(sn.name); PutS(";$$");
INC (curSy);
END;
END ;
END GenProductions;
PROCEDURE InitSets;
VAR i, j: INTEGER;
BEGIN
i := 0; CRT.GetSet(0, symSet[0]);
WHILE i <= maxSS DO
WHILE i <= maxSS DO
j := 0;
WHILE j <= CRT.maxT DIV Sets.size DO
PutS(" symSet["); PutI(i); PutS(", ");PutI(j);
PutS(" symSet["); PutI(i); PutS(", ");PutI(j);
PutS("] := {"); PutSet(symSet[i, j]); PutS("};$");
INC(j)
END;
INC(i)
END ;
INC(i)
END
END InitSets;
@ -406,29 +406,29 @@ PROCEDURE GenCompiler*;
VAR errNr, i: INTEGER; checked: CRT.Set;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
parser: ARRAY 32 OF CHAR;
t: Texts.Text; pos: LONGINT;
t: Texts.Text; pos: LONGINT;
ch1, ch2: CHAR;
BEGIN
CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
COPY(sn.name, parser); i := Length(parser); parser[i] := "P"; parser[i+1] := 0X;
COPY(parser, scanner); scanner[i] := "S";
NEW(t); Texts.Open(t, "Parser.FRM"); Texts.OpenReader(fram, t, 0);
IF t.len = 0 THEN
Texts.WriteString(w, "Parser.FRM not found"); Texts.WriteLn(w);
Texts.Append(Oberon.Log, w.buf); HALT(99)
END;
END ;
Texts.OpenWriter(err); Texts.WriteLn(err);
i := 0;
WHILE i <= CRT.maxT DO GenErrorMsg(tErr, i, errNr); INC(i) END;
WHILE i <= CRT.maxT DO GenErrorMsg(tErr, i, errNr); INC(i) END ;
(*----- write *P.Mod -----*)
Texts.OpenWriter(syn);
NEW(t); (*t.notify := Show;*) Texts.Open(t, "");
NEW(t); t.notify := Show; Texts.Open(t, "");
CopyFramePart("-->modulename"); PutS(parser);
CopyFramePart("-->scanner"); PutS(scanner);
IF CRT.importPos.beg >= 0 THEN PutS(", "); CopySourcePart(CRT.importPos, 0) END;
IF CRT.importPos.beg >= 0 THEN PutS(", "); CopySourcePart(CRT.importPos, 0) END ;
CopyFramePart("-->constants");
PutS("maxP = "); PutI(CRT.maxP); PutS(";$");
PutS(" maxT = "); PutI(CRT.maxT); PutS(";$");
@ -444,7 +444,7 @@ BEGIN
PutS(" ELSE EXIT$");
PutS(" END$");
PutS("END$")
END;
END ;
CopyFramePart("-->productions"); GenForwardRefs; GenProductions;
CopyFramePart("-->parseRoot"); Sets.Clear(checked); GenCode (CRT.root, 2, checked);
CopyFramePart("-->initialization"); InitSets;
@ -472,3 +472,4 @@ END Init;
BEGIN
Texts.OpenWriter(w)
END CRX.

124
src/tools/coco/Coco.Mod
View file

@ -19,7 +19,7 @@
==========================================================================*)
MODULE Coco;
IMPORT Oberon, (*TextFrames,*) Texts := CmdlnTexts,(* Viewers,*) CRS, CRP, CRT;
IMPORT Oberon, TextFrames, Texts, Viewers, CRS, CRP, CRT;
CONST minErrDist = 8;
@ -42,55 +42,59 @@ BEGIN
| 0: Msg("EOF expected")
| 1: Msg("ident expected")
| 2: Msg("string expected")
| 3: Msg("number expected")
| 4: Msg("'COMPILER' expected")
| 5: Msg("'IMPORT' expected")
| 6: Msg("';' expected")
| 7: Msg("'PRODUCTIONS' expected")
| 8: Msg("'=' expected")
| 9: Msg("'.' expected")
| 10: Msg("'END' expected")
| 11: Msg("'CHARACTERS' expected")
| 12: Msg("'TOKENS' expected")
| 13: Msg("'PRAGMAS' expected")
| 14: Msg("'COMMENTS' expected")
| 15: Msg("'FROM' expected")
| 16: Msg("'TO' expected")
| 17: Msg("'NESTED' expected")
| 18: Msg("'IGNORE' expected")
| 19: Msg("'CASE' expected")
| 20: Msg("'+' expected")
| 21: Msg("'-' expected")
| 22: Msg("'CHR' expected")
| 23: Msg("'(' expected")
| 24: Msg("')' expected")
| 25: Msg("'ANY' expected")
| 26: Msg("'|' expected")
| 27: Msg("'WEAK' expected")
| 28: Msg("'[' expected")
| 29: Msg("']' expected")
| 30: Msg("'{' expected")
| 31: Msg("'}' expected")
| 32: Msg("'SYNC' expected")
| 33: Msg("'CONTEXT' expected")
| 34: Msg("'<' expected")
| 35: Msg("'>' expected")
| 36: Msg("'(.' expected")
| 37: Msg("'.)' expected")
| 38: Msg("??? expected")
| 39: Msg("invalid TokenFactor")
| 40: Msg("invalid Factor")
| 41: Msg("invalid Factor")
| 42: Msg("invalid Term")
| 43: Msg("invalid Symbol")
| 44: Msg("invalid SimSet")
| 45: Msg("this symbol not expected in TokenDecl")
| 46: Msg("invalid TokenDecl")
| 47: Msg("invalid Declaration")
| 48: Msg("invalid Declaration")
| 49: Msg("invalid Declaration")
| 50: Msg("this symbol not expected in Coco")
| 51: Msg("invalid start of the program")
| 3: Msg("badString expected")
| 4: Msg("number expected")
| 5: Msg("'COMPILER' expected")
| 6: Msg("'IMPORT' expected")
| 7: Msg("';' expected")
| 8: Msg("'PRODUCTIONS' expected")
| 9: Msg("'=' expected")
| 10: Msg("'.' expected")
| 11: Msg("'END' expected")
| 12: Msg("'CHARACTERS' expected")
| 13: Msg("'TOKENS' expected")
| 14: Msg("'PRAGMAS' expected")
| 15: Msg("'COMMENTS' expected")
| 16: Msg("'FROM' expected")
| 17: Msg("'TO' expected")
| 18: Msg("'NESTED' expected")
| 19: Msg("'IGNORE' expected")
| 20: Msg("'CASE' expected")
| 21: Msg("'+' expected")
| 22: Msg("'-' expected")
| 23: Msg("'CHR' expected")
| 24: Msg("'(' expected")
| 25: Msg("')' expected")
| 26: Msg("'ANY' expected")
| 27: Msg("'|' expected")
| 28: Msg("'WEAK' expected")
| 29: Msg("'[' expected")
| 30: Msg("']' expected")
| 31: Msg("'{' expected")
| 32: Msg("'}' expected")
| 33: Msg("'SYNC' expected")
| 34: Msg("'CONTEXT' expected")
| 35: Msg("'<' expected")
| 36: Msg("'>' expected")
| 37: Msg("'<.' expected")
| 38: Msg("'.>' expected")
| 39: Msg("'(.' expected")
| 40: Msg("'.)' expected")
| 41: Msg("??? expected")
| 42: Msg("invalid TokenFactor")
| 43: Msg("invalid Factor")
| 44: Msg("invalid Factor")
| 45: Msg("invalid Term")
| 46: Msg("invalid Symbol")
| 47: Msg("invalid SimSet")
| 48: Msg("this symbol not expected in TokenDecl")
| 49: Msg("invalid TokenDecl")
| 50: Msg("invalid Attribs")
| 51: Msg("invalid Declaration")
| 52: Msg("invalid Declaration")
| 53: Msg("invalid Declaration")
| 54: Msg("this symbol not expected in CR")
| 55: Msg("invalid CR")
ELSE Texts.WriteString(w, "error "); Texts.WriteInt(w, n, 0)
END
ELSE
@ -112,11 +116,13 @@ BEGIN
| 215: Msg("undefined name")
| 216: Msg("attributes not allowed in token declaration")
| 217: Msg("name does not match name in heading")
| 218: Msg("bad string in semantic action")
| 219: Msg("Missing end of previous semantic action")
| 220: Msg("token may be empty")
| 221: Msg("token must not start with an iteration")
| 222: Msg("only characters allowed in comment declaration")
| 223: Msg("only terminals may be weak")
| 224:
| 224: Msg("tokens must not contain blanks")
| 225: Msg("comment delimiter must not exceed 2 characters")
| 226: Msg("character set contains more than one character")
ELSE Texts.WriteString(w, "error "); Texts.WriteInt(w, n, 0)
@ -128,7 +134,7 @@ END Error;
PROCEDURE Options(VAR s: Texts.Scanner);
VAR i: INTEGER;
BEGIN
IF s.nextCh = "/" THEN Texts.Scan(s); Texts.Scan(s);
IF s.nextCh = "\" THEN Texts.Scan(s); Texts.Scan(s);
IF s.class = Texts.Name THEN i := 0;
WHILE s.s[i] # 0X DO
IF CAP(s.s[i]) = "X" THEN CRT.ddt[7] := TRUE
@ -142,19 +148,19 @@ END Options;
PROCEDURE Compile*;
VAR (*v: Viewers.Viewer;*)(* f: TextFrames.Frame; *) s: Texts.Scanner; src, t: Texts.Text;
VAR v: Viewers.Viewer; f: TextFrames.Frame; s: Texts.Scanner; src, t: Texts.Text;
pos, beg, end, time: LONGINT; i: INTEGER;
BEGIN
(* Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
f := Oberon.Par.frame(TextFrames.Frame);
src := NIL; pos := 0;
IF (s.class = Texts.Char) & (s.c = "^") THEN
Oberon.GetSelection(t, beg, end, time);
IF time >= 0 THEN Texts.OpenScanner(s, t, beg); Texts.Scan(s) END
END;*)
END;
IF s.class = Texts.Name THEN
NEW(src); Texts.Open(src, s.s);
(*ELSIF (s.class = Texts.Char) & (s.c = "*") THEN
ELSIF (s.class = Texts.Char) & (s.c = "*") THEN
v := Oberon.MarkedViewer();
IF (v # NIL) & (v.dsc.next IS TextFrames.Frame) THEN
src := v.dsc.next(TextFrames.Frame).text;
@ -162,7 +168,7 @@ BEGIN
END
ELSIF (s.class = Texts.Char) & (s.c = "@") THEN
Oberon.GetSelection(t, beg, end, time);
IF time >= 0 THEN src := t; pos := beg; s.s := " " END*)
IF time >= 0 THEN src := t; pos := beg; s.s := " " END
END;
IF src # NIL THEN
Texts.WriteString (w, "Coco/R - Compiler-Compiler V2.2"); Texts.Append(Oberon.Log, w.buf);
@ -175,6 +181,6 @@ BEGIN
END Compile;
BEGIN
Texts.OpenWriter(w);
Compile;
Texts.OpenWriter(w)
END Coco.

5
src/tools/coco/Coco.Report.ps.1
View file

File diff suppressed because one or more lines are too long

83
src/tools/coco/Coco.Tool
View file

@ -1,83 +0,0 @@
Coco/R - the Oberon scanner and parser generator
For a complete documentation see the postscript file Coco.Report.ps.
Compiler.Compile
Sets.Mod CRS.Mod CRT.Mod CRA.Mod CRX.Mod CRP.Mod Coco.Mod ~
NOTE: the option character should be changed to "\" in Coco.Mod for Unix implementations.
Coco.Compile *
Coco.Compile ~
Coco.Compile ^
Coco.Compile @
(*________________________ usage ________________________*)
Coco.Compile <filename> [options]
The file CR.ATG is an example of an input file to Coco. If the grammar in the input file has the name X
the generated scanner has the name XS.Mod and the generated parser has the name XP.Mod.
Options:
/X generates a cross reference list of all syntax symbols
/S generates a list of all terminal start symbols and successors of nonterminal symbols.
Interface of the generated scanner:
DEFINITION XS;
IMPORT Texts;
TYPE
ErrorProc = PROCEDURE (n: INTEGER; pos: LONGINT);
VAR
Error: ErrorProc;
col, errors, len, line, nextCol, nextLen, nextLine: INTEGER;
nextPos, pos: LONGINT;
src: Texts.Text;
PROCEDURE Reset (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
PROCEDURE Get(VAR sym: INTEGER);
PROCEDURE GetName(pos: LONGINT; len: INTEGER; VAR name: ARRAY OF CHAR);
PROCEDURE StdErrorProc (n: INTEGER; pos: LONGINT);
END XS.
Interface of the generated parser:
DEFINITION XP;
PROCEDURE Parse;
END XP.
Example how to use the generated parts;
Texts.OpenScanner(s, Oberon.Par.Text, Oberon.Par.Pos); Texts.Scan(s);
IF s.class = Texts.Name THEN
NEW(text); Texts.Open(text, s.s);
XS.Reset(text, 0, MyErrorHandler);
XP.Parse;
END
Error handling in the generated parser:
The grammar has to contain hints, from which Coco can generate appropriate error handling.
The hints can be placed arbitrarily on the right-hand side of a production:
SYNC Denotes a synchronisation point. At such points symbols are skipped until a symbol
is found which is a legal continuation symbol at that point (or eof). SYNC is usually
placed at points where particularly "safe" symbols are expected, i.e., symbols that
are rarely missing or misspelled.
WEAK s s is an arbitrary terminal symbol (e.g., ";") which is considered "weak", because it is
frequently missing or misspelled (e.g., a semicolon between statements).
Example:
Statement =
SYNC
( ident WEAK ":=" Expression
| "IF" Expression "THEN" StatSeq ["ELSE" StatSeq] "END"
| "WHILE" Expression "DO" StatSeq "END"
).
StatSeq =
Statement { WEAK ";" Statement}.þ

8
src/tools/coco/Oberon.Mod
View file

@ -1,8 +0,0 @@
MODULE Oberon;
IMPORT Texts := CmdlnTexts;
VAR Log* : Texts.Text;
END Oberon.

65
src/tools/coco/Parser.FRM
View file

@ -1,65 +0,0 @@
(* parser module generated by Coco-R *)
MODULE -->modulename;
IMPORT -->scanner;
CONST
-->constants
setSize = 32; nSets = (maxT DIV setSize) + 1;
TYPE
SymbolSet = ARRAY nSets OF SET;
VAR
sym: INTEGER; (* current input symbol *)
symSet: ARRAY nrSets OF SymbolSet;
-->declarations
PROCEDURE Error (n: INTEGER);
BEGIN -->errors
END Error;
PROCEDURE Get;
BEGIN
-->scanProc
END Get;
PROCEDURE Expect(n: INTEGER);
BEGIN IF sym = n THEN Get ELSE Error(n) END
END Expect;
PROCEDURE StartOf(s: INTEGER): BOOLEAN;
BEGIN RETURN (sym MOD setSize) IN symSet[s, sym DIV setSize]
END StartOf;
PROCEDURE ExpectWeak(n, follow: INTEGER);
BEGIN
IF sym = n THEN Get
ELSE Error(n); WHILE ~ StartOf(follow) DO Get END
END
END ExpectWeak;
PROCEDURE WeakSeparator(n, syFol, repFol: INTEGER): BOOLEAN;
VAR s: SymbolSet; i: INTEGER;
BEGIN
IF sym = n THEN Get; RETURN TRUE
ELSIF StartOf(repFol) THEN RETURN FALSE
ELSE
i := 0; WHILE i < nSets DO s[i] := symSet[syFol, i] + symSet[repFol, i] + symSet[0, i]; INC(i) END;
Error(n); WHILE ~ ((sym MOD setSize) IN s[sym DIV setSize]) DO Get END;
RETURN StartOf(syFol)
END
END WeakSeparator;
-->productions
PROCEDURE Parse*;
BEGIN
Get;
-->parseRoot
END Parse;
BEGIN
-->initialization
END -->modulename.

103
src/tools/coco/Scanner.FRM
View file

@ -1,103 +0,0 @@
(* scanner module generated by Coco-R *)
MODULE -->modulename;
IMPORT Texts := CmdlnTexts, SYSTEM;
CONST
EOL = 0DX;
EOF = 0X;
maxLexLen = 127;
-->declarations
TYPE
ErrorProc* = PROCEDURE (n: INTEGER; pos: LONGINT);
StartTable = ARRAY 128 OF INTEGER;
VAR
src*: Texts.Text; (*source text. To be set by the main pgm*)
pos*: LONGINT; (*position of current symbol*)
line*, col*, len*: INTEGER; (*line, column, length of current symbol*)
nextPos*: LONGINT; (*position of lookahead symbol*)
nextLine*, nextCol*, nextLen*: INTEGER; (*line, column, length of lookahead symbol*)
errors*: INTEGER; (*number of errors detected*)
Error*: ErrorProc;
ch: CHAR; (*current input character*)
r: Texts.Reader; (*global reader*)
chPos: LONGINT; (*position of current character*)
chLine: INTEGER; (*current line number*)
lineStart: LONGINT; (*start position of current line*)
apx: INTEGER; (*length of appendix*)
oldEols: INTEGER; (*nr. of EOLs in a comment*)
start: StartTable; (*start state for every character*)
PROCEDURE NextCh; (*return global variable ch*)
BEGIN
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
END NextCh;
PROCEDURE Comment(): BOOLEAN;
VAR level, startLine: INTEGER; oldLineStart: LONGINT;
BEGIN (*Comment*)
level := 1; startLine := chLine; oldLineStart := lineStart;
-->comment
END Comment;
PROCEDURE Get*(VAR sym: INTEGER);
VAR state: INTEGER; lexeme: ARRAY maxLexLen+1 OF CHAR;
PROCEDURE CheckLiteral;
BEGIN
IF nextLen < maxLexLen THEN lexeme[nextLen] := 0X END;
-->literals
END CheckLiteral;
BEGIN
-->GetSy1
IF ch > 7FX THEN ch := " " END;
pos := nextPos; col := nextCol; line := nextLine; len := nextLen;
nextPos := chPos; nextCol := SHORT(chPos - lineStart); nextLine := chLine; nextLen := 0;
state := start[ORD(ch)]; apx := 0;
LOOP
IF nextLen < maxLexLen THEN lexeme[nextLen] := ch END;
INC(nextLen);
NextCh;
IF state > 0 THEN
CASE state OF
-->GetSy2
END (*CASE*)
ELSE sym := noSym; RETURN (*NextCh already done*)
END (*IF*)
END (*LOOP*)
END Get;
PROCEDURE GetName*(pos: LONGINT; len: INTEGER; VAR s: ARRAY OF CHAR);
VAR i: INTEGER; r: Texts.Reader;
BEGIN
Texts.OpenReader(r, src, pos);
IF len >= LEN(s) THEN len := SHORT(LEN(s)) - 1 END;
i := 0; WHILE i < len DO Texts.Read(r, s[i]); INC(i) END;
s[i] := 0X
END GetName;
PROCEDURE StdErrorProc* (n: INTEGER; pos: LONGINT);
BEGIN INC(errors) END StdErrorProc;
PROCEDURE Reset* (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
BEGIN
src := t; Error := errProc;
Texts.OpenReader(r, src, pos);
chPos := pos - 1; chLine := 1; lineStart := 0;
oldEols := 0; apx := 0; errors := 0;
NextCh
END Reset;
BEGIN
-->initialization
END -->modulename.

138
src/tools/coco/Sets.Mod
View file

@ -1,138 +0,0 @@
MODULE Sets;
IMPORT Texts := CmdlnTexts;
CONST size* = 32;
PROCEDURE Clear*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {}; INC(i) END
END Clear;
PROCEDURE Fill*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {0 .. size-1}; INC(i) END
END Fill;
PROCEDURE Incl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN INCL(s[x DIV size], x MOD size)
END Incl;
PROCEDURE Excl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN EXCL(s[x DIV size], x MOD size)
END Excl;
PROCEDURE In*(VAR s: ARRAY OF SET; x: INTEGER): BOOLEAN;
BEGIN RETURN x MOD size IN s[x DIV size]
END In;
PROCEDURE Includes*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] + s2[i] # s1[i] THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE;
END Includes;
PROCEDURE Elements*(VAR s: ARRAY OF SET; VAR lastElem: INTEGER): INTEGER;
VAR i, n, max: INTEGER;
BEGIN
i := 0; n := 0; max := SHORT(LEN(s)) * size;
WHILE i < max DO
IF (i MOD size) IN s[i DIV size] THEN INC(n); lastElem := i END;
INC(i)
END;
RETURN n
END Elements;
PROCEDURE Empty*(VAR s: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s) DO
IF s[i] # {} THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Empty;
PROCEDURE Equal*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] # s2[i] THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Equal;
PROCEDURE Different*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] * s2[i] # {} THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Different;
PROCEDURE Unite*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s1[i] := s1[i] + s2[i]; INC(i) END
END Unite;
PROCEDURE Differ*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s1[i] := s1[i] - s2[i]; INC(i) END
END Differ;
PROCEDURE Intersect*(VAR s1, s2, s3: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s3[i] := s1[i] * s2[i]; INC(i) END
END Intersect;
PROCEDURE Print*(VAR f: Texts.Writer; s: ARRAY OF SET; w, indent: INTEGER);
VAR col, i, max: INTEGER;
BEGIN
i := 0; col := indent; max := SHORT(LEN(s)) * size;
Texts.Write(f, "{");
WHILE i < max DO
IF In(s, i) THEN
IF col + 4 > w THEN
Texts.WriteLn(f);
col := 0; WHILE col < indent DO Texts.Write(f, " "); INC(col) END
END;
Texts.WriteInt(f, i, 3); Texts.Write(f, ",");
INC(col, 4)
END;
INC(i)
END;
Texts.Write(f, "}")
END Print;
END Sets.

471
src/tools/coco/v4_compat/Oberon.Mod
View file

@ -1,471 +0,0 @@
MODULE Oberon; (*JG 6.9.90 / 23.9.93*)
IMPORT SYSTEM, Unix, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, X11; (* << *)
CONST
(*message ids*)
consume* = 0; track* = 1;
defocus* = 0; neutralize* = 1; mark* = 2;
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
VAR
User*: ARRAY 12 OF CHAR; (* << *)
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
Password*: LONGINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
ArrowFade: Painter; (* << *)
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER); (* << *)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER); (* << RC *)
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF c.marker.Fade = ArrowFade THEN
IF m.Fade # ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.noCursor) END
ELSE
IF m.Fade = ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.arrow) END
END ;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END;
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE res := -1
END
ELSE res := Modules.res
END
ELSE res := -1
END
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN IF ActCnt <= 0 THEN Kernel.GC(FALSE); ActCnt := BasicCycle END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF (t.next # T) & (CurTask # T) THEN
IF CurTask # NIL THEN (* called from a task *)
T.next := CurTask.next; CurTask.next := T
ELSE (* no task is currently running *)
T.next := PrevTask.next; PrevTask.next := T
END
END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE MinTime(): LONGINT; (* << *)
VAR minTime: LONGINT; t: Task;
BEGIN
minTime := MAX(LONGINT); t := PrevTask;
REPEAT
IF (t.time # -1) & (t.time < minTime) THEN minTime := t.time END ;
t := t.next;
UNTIL t = PrevTask ;
RETURN minTime
END MinTime;
PROCEDURE NotifyTasks; (* << *)
VAR t0, p: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
p := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # p THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE Loop*;
VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; i: INTEGER; res: LONGINT; (* << *)
BEGIN
res := Kernel.sigsetjmp(Kernel.trapEnv, 1); (* << *)
LOOP
CurTask := NIL;
Input.Mouse(keys, X, Y);
IF Input.Available() > 0 THEN Input.Read(ch);
IF ch < 0F0X THEN
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << *)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
ELSIF ch = 0F1X THEN Display.SetMode(0, {})
ELSIF ch = 0F2X THEN Display.SetMode(0, {0})
ELSIF ch = 0F3X THEN Display.SetMode(0, {2})
ELSIF ch = 0F4X THEN X11.InitColors
ELSIF Kernel.FKey[ORD(ch) - 0F0H] # NIL THEN Kernel.FKey[ORD(ch) - 0F0H]
END
ELSIF keys # {} THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSE
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M);
prevX := X; prevY := Y
END;
X11.DoSync; (* << *)
IF X11.EventsQueued(X11.display, X11.QueuedAfterReading) = 0 THEN (* << *)
Kernel.Select(MinTime() - Input.Time()); NotifyTasks;
FOR i := 0 TO 7 DO Kernel.readySet[i] := {} END
END ;
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END Loop;
BEGIN User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
ArrowFade := FlipArrow; (* << *)
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
(* moved into Configuration.Mod
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
*)
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << *)
PrevTask.next := PrevTask;
CurTask := NIL;
Display.SetMode(0, {});
END Oberon.

471
src/tools/coco/v4_compat/Oberon.Mod_orig
View file

@ -1,471 +0,0 @@
MODULE Oberon; (*JG 6.9.90 / 23.9.93*)
IMPORT SYSTEM, Unix, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, X11; (* << *)
CONST
(*message ids*)
consume* = 0; track* = 1;
defocus* = 0; neutralize* = 1; mark* = 2;
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
VAR
User*: ARRAY 12 OF CHAR; (* << *)
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
Password*: LONGINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
ArrowFade: Painter; (* << *)
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER); (* << *)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER); (* << RC *)
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF c.marker.Fade = ArrowFade THEN
IF m.Fade # ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.noCursor) END
ELSE
IF m.Fade = ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.arrow) END
END ;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END;
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE res := -1
END
ELSE res := Modules.res
END
ELSE res := -1
END
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN IF ActCnt <= 0 THEN Kernel.GC(FALSE); ActCnt := BasicCycle END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF (t.next # T) & (CurTask # T) THEN
IF CurTask # NIL THEN (* called from a task *)
T.next := CurTask.next; CurTask.next := T
ELSE (* no task is currently running *)
T.next := PrevTask.next; PrevTask.next := T
END
END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE MinTime(): LONGINT; (* << *)
VAR minTime: LONGINT; t: Task;
BEGIN
minTime := MAX(LONGINT); t := PrevTask;
REPEAT
IF (t.time # -1) & (t.time < minTime) THEN minTime := t.time END ;
t := t.next;
UNTIL t = PrevTask ;
RETURN minTime
END MinTime;
PROCEDURE NotifyTasks; (* << *)
VAR t0, p: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
p := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # p THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE Loop*;
VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; i: INTEGER; res: LONGINT; (* << *)
BEGIN
res := Kernel.sigsetjmp(Kernel.trapEnv, 1); (* << *)
LOOP
CurTask := NIL;
Input.Mouse(keys, X, Y);
IF Input.Available() > 0 THEN Input.Read(ch);
IF ch < 0F0X THEN
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << *)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
ELSIF ch = 0F1X THEN Display.SetMode(0, {})
ELSIF ch = 0F2X THEN Display.SetMode(0, {0})
ELSIF ch = 0F3X THEN Display.SetMode(0, {2})
ELSIF ch = 0F4X THEN X11.InitColors
ELSIF Kernel.FKey[ORD(ch) - 0F0H] # NIL THEN Kernel.FKey[ORD(ch) - 0F0H]
END
ELSIF keys # {} THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSE
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M);
prevX := X; prevY := Y
END;
X11.DoSync; (* << *)
IF X11.EventsQueued(X11.display, X11.QueuedAfterReading) = 0 THEN (* << *)
Kernel.Select(MinTime() - Input.Time()); NotifyTasks;
FOR i := 0 TO 7 DO Kernel.readySet[i] := {} END
END ;
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END Loop;
BEGIN User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
ArrowFade := FlipArrow; (* << *)
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
(* moved into Configuration.Mod
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
*)
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << *)
PrevTask.next := PrevTask;
CurTask := NIL;
Display.SetMode(0, {});
END Oberon.

1363
src/tools/coco/v4_compat/TextFrames.Mod
View file

File diff suppressed because it is too large Load diff

1362
src/tools/coco/v4_compat/TextFrames.Mod_orig
View file

File diff suppressed because it is too large Load diff

BIN
voc
View file

Binary file not shown.