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

freebsd port works.

Browse source 
I have no freebsd, and port was made by request and with help of
tangentstorm from #oberon channel (:
still it's not well tested and is considered experimental.
This commit is contained in:
Norayr Chilingarian 2014-05-20 00:56:33 +04:00
parent 1186133f78
commit 2d6ac451ba
18 changed files with 5532 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

306
makefile.freebsd.clang.x86_64 Normal file
View file

@ -0,0 +1,306 @@
#SHELL := /bin/bash
BUILDID=$(shell date +%Y/%m/%d)
TOS = freebsd
TARCH = x86_64
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp powerpc
CCOMP = clang
RELEASE = 1.0
INCLUDEPATH = -Isrc/lib/system/$(TOS)/$(CCOMP)/$(TARCH)
SETPATH = CFLAGS=$(INCLUDEPATH) PATH=.:/bin:/usr/bin MODULES=.:src/lib:src/lib/v4:src/lib/v4/$(TARCH):src/lib/system/$(TOS)/$(CCOMP):src/lib/system/$(TOS)/$(CCOMP)/$(TARCH):src/lib/ulm:src/lib/ulm/$(TARCH):src/lib/ooc2:src/lib/ooc2/$(TOS)/$(CCOMP):src/lib/ooc:src/lib/ooc/$(TOS)/$(CCOMP)/$(TARCH):src/lib/pow:src/lib/misc:src/lib/s3:src/voc:src/voc/$(TOS)/$(CCOMP):src/voc/$(TOS)/$(CCOMP)/$(TARCH):src/tools/ocat:src/tools/browser:src/tools/vocparam:src/tools/vmake:src/tools/coco:src/test
VOC = voc
VERSION = $(TOS).$(CCOMP).$(TARCH)
VOCSTATIC0 = $(SETPATH) ./vocstatic.$(TOS).$(CCOMP).$(TARCH)
VOCSTATIC = $(SETPATH) ./voc
VOCPARAM = $(shell ./vocparam > voc.par)
LIBNAME = VishapOberon
LIBRARY = lib$(LIBNAME)
ifndef PRF
PRF = "/opt"
endif
PREFIX = $(PRF)/voc-$(RELEASE)
PREFIXLN = $(PRF)/voc
CCOPT = -fPIC $(INCLUDEPATH) -g
SHRLIBEXT = so
CC = $(CCOMP) $(CCOPT) -c
CL = $(CCOMP) $(CCOPT)
LD = $(CCOMP) -shared -o $(LIBRARY).$(SHRLIBEXT)
# 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/system/$(TOS)/$(CCOMP)/$(TARCH) -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
cp src/voc/prf.Mod_default src/voc/prf.Mod
# this prepares modules necessary to build the compiler itself
stage3:
$(VOCSTATIC0) -siapxPS SYSTEM.Mod
$(VOCSTATIC0) -sPS Args.Mod Console.Mod Unix.Mod
sed -i.tmp "s#/opt#$(PRF)#g" src/voc/prf.Mod
$(VOCSTATIC0) -sPS prf.Mod
$(VOCSTATIC0) -sPS Strings.Mod architecture.Mod version.Mod Kernel0.Mod Modules.Mod
$(VOCSTATIC0) -sxPS Files0.Mod
$(VOCSTATIC0) -sPS Reals.Mod Texts0.Mod
$(VOCSTATIC0) -sPS vt100.Mod
# build the compiler
stage4:
$(VOCSTATIC0) -sPS errors.Mod
$(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
#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 \
Strings.c architecture.c prf.c version.c Kernel0.c Files0.c Reals.c Texts0.c vt100.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 \
Strings.o architecture.o prf.o version.o Kernel0.o Files0.o Reals.o Texts0.o vt100.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 Strings.o architecture.o prf.o version.o Kernel0.o Files0.o Reals.o Texts0.o vt100.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 Strings.o architecture.o prf.o version.o Kernel0.o Files0.o Reals.o Texts0.o
# build all library files
stage6:
#v4 libs
$(VOCSTATIC) -sP Kernel.Mod
$(VOCSTATIC) -sP Files.Mod
$(VOCSTATIC) -sP Texts.Mod
$(VOCSTATIC) -sP Printer.Mod
$(VOCSTATIC) -sP Strings.Mod
$(VOCSTATIC) -sP Sets.Mod
$(VOCSTATIC) -sP Sets0.Mod
#ooc libs
$(VOCSTATIC) -sP oocAscii.Mod
$(VOCSTATIC) -sP oocStrings.Mod
$(VOCSTATIC) -sP oocStrings2.Mod
$(VOCSTATIC) -sP oocOakStrings.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 oocFilenames.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP oocC.Mod
# $(VOCSTATIC) -sP oocX11.Mod
# $(VOCSTATIC) -sP oocXutil.Mod
# $(VOCSTATIC) -sP oocXYplane.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
$(VOCSTATIC) -sP ulmCiphers.Mod
$(VOCSTATIC) -sP ulmCipherOps.Mod
$(VOCSTATIC) -sP ulmBlockCiphers.Mod
$(VOCSTATIC) -sP ulmAsymmetricCiphers.Mod
$(VOCSTATIC) -sP ulmConclusions.Mod
$(VOCSTATIC) -sP ulmRandomGenerators.Mod
$(VOCSTATIC) -sP ulmTCrypt.Mod
#pow32 libs
$(VOCSTATIC) -sP powStrings.Mod
#misc libs
$(VOCSTATIC) -sP MultiArrays.Mod
$(VOCSTATIC) -sP MultiArrayRiders.Mod
$(VOCSTATIC) -sP MersenneTwister.Mod
$(VOCSTATIC) -sP Listen.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
# build remaining tools
# $(VOCSTATIC0) -sPS compatIn.Mod
# $(VOCSTATIC0) -smPS vmake.Mod
# $(CC) compatIn.c
# $(CL) vmake.c -o vmake SYSTEM.o Args.o compatIn.o Texts.o Console.o Files.o Reals.o Modules.o Kernel.o Unix.o Strings.o oocIntStr.o oocConvTypes.o oocIntConv.o
stage7:
#remove non library objects
rm -f Kernel0.o Files0.o Texts0.o architecture.o prf.o version.o extTools.o OPM.o OPS.o OPT.o OPC.o OPV.o OPB.o OPP.o errors.o
#objects := $(wildcard *.o)
#$(LD) objects
$(ARCHIVE) *.o
#$(ARCHIVE) objects
$(LD) *.o
echo "$(PREFIX)/lib" > 05vishap.conf
clean:
# rm_objects := rm $(wildcard *.o)
# objects
rm *.h
rm *.c
rm *.sym
rm *.o
rm *.a
rm *.$(SHRLIBEXT)
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).$(SHRLIBEXT) $(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
ln -s $(PREFIX) $(PREFIXLN)
# cp *.o $(PREFIX)/lib/voc/$(RELEASE)/obj/
uninstall:
rm -rf $(PREFIX)
rm -rf $(PREFIXLN)

71
src/lib/ooc/freebsd/clang/x86_64/oocC.Mod Normal file
View file

@ -0,0 +1,71 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
Copyright (C) 1997-1998 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = RECORD a,b : SYSTEM.BYTE END; (* 2 bytes on x64_64 *) (* short int *)
int* = INTEGER;
set* = INTEGER;(*SET;*) (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
longset* = SET; (*SYSTEM.SET64; *) (* unsigned long, used as set *)
address* = LONGINT; (*SYSTEM.ADDRESS;*)
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER (*[CSTRING]*) TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

34
src/lib/ooc2/freebsd/clang/oocwrapperlibc.Mod Normal file
View file

@ -0,0 +1,34 @@
MODULE oocwrapperlibc;
IMPORT SYSTEM;
PROCEDURE -includeStdio()
"#include <stdio.h>";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
(*
PROCEDURE strtod* (string: C.address;
VAR tailptr: C.charPtr1d): C.double;
PROCEDURE strtof* (string: C.address;
VAR tailptr: C.charPtr1d): C.float;
PROCEDURE sscanf* (s: C.address; template: ARRAY OF CHAR; ...) : C.int;
*)
PROCEDURE -sprntf(s, t0, t1, t2: ARRAY OF CHAR): INTEGER
"sprintf(s, t0, t1, t2)";
PROCEDURE sprintf* (VAR s: ARRAY OF CHAR; template0: ARRAY OF CHAR; template1: ARRAY OF CHAR; template2: ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sprntf (s, template0, template1, template2);
END sprintf;
BEGIN
END oocwrapperlibc.

89
src/lib/system/freebsd/clang/Console.Mod Normal file
View file

@ -0,0 +1,89 @@
MODULE Console; (* J. Templ, 29-June-96 *)
(* output to Unix standard output device based Write system call *)
IMPORT SYSTEM;
VAR line: ARRAY 128 OF CHAR;
pos: INTEGER;
PROCEDURE -includeUnistd()
"#include <unistd.h>";
PROCEDURE -Write(adr, n: LONGINT)
"write(1/*stdout*/, adr, n)";
PROCEDURE -read(VAR ch: CHAR): LONGINT
"read(0/*stdin*/, ch, 1)";
PROCEDURE Flush*();
BEGIN
Write(SYSTEM.ADR(line), pos); pos := 0;
END Flush;
PROCEDURE Char*(ch: CHAR);
BEGIN
IF pos = LEN(line) THEN Flush() END ;
line[pos] := ch; INC(pos);
IF ch = 0AX THEN Flush() END
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] # 0X DO Char(s[i]); INC(i) END
END String;
PROCEDURE Int*(i, n: LONGINT);
VAR s: ARRAY 32 OF CHAR; i1, k: LONGINT;
BEGIN
IF i = SYSTEM.LSH(LONG(LONG(1)), SIZE(LONGINT)*8 - 1) THEN
IF SIZE(LONGINT) = 8 THEN s := "8085774586302733229"; k := 19
ELSE s := "8463847412"; k := 10
END
ELSE
i1 := ABS(i);
s[0] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; k := 1;
WHILE i1 > 0 DO s[k] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; INC(k) END
END ;
IF i < 0 THEN s[k] := "-"; INC(k) END ;
WHILE n > k DO Char(" "); DEC(n) END ;
WHILE k > 0 DO DEC(k); Char(s[k]) END
END Int;
PROCEDURE Ln*;
BEGIN Char(0AX); (* Unix end-of-line *)
END Ln;
PROCEDURE Bool*(b: BOOLEAN);
BEGIN IF b THEN String("TRUE") ELSE String("FALSE") END
END Bool;
PROCEDURE Hex*(i: LONGINT);
VAR k, n: LONGINT;
BEGIN
k := -28;
WHILE k <= 0 DO
n := ASH(i, k) MOD 16;
IF n <= 9 THEN Char(CHR(ORD("0") + n)) ELSE Char(CHR(ORD("A") - 10 + n)) END ;
INC(k, 4)
END
END Hex;
PROCEDURE Read*(VAR ch: CHAR);
VAR n: LONGINT;
BEGIN Flush();
n := read(ch);
IF n # 1 THEN ch := 0X END
END Read;
PROCEDURE ReadLine*(VAR line: ARRAY OF CHAR);
VAR i: LONGINT; ch: CHAR;
BEGIN Flush();
i := 0; Read(ch);
WHILE (i < LEN(line) - 1) & (ch # 0AX) & (ch # 0X) DO line[i] := ch; INC(i); Read(ch) END ;
line[i] := 0X
END ReadLine;
BEGIN pos := 0;
END Console.

658
src/lib/system/freebsd/clang/Files.Mod Normal file
View file

@ -0,0 +1,658 @@
MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
(* modified version of Files, which opens only the file provided and does not scan any path in any environment variable, also ReadLine procedure added; -- noch *)
IMPORT SYSTEM, Unix, Kernel, Args, Console;
(* standard data type I/O
little endian,
Sint:1, Int:2, Lint:4
ORD({0}) = 1,
false = 0, true =1
IEEE real format,
null terminated strings,
compact numbers according to M.Odersky *)
CONST
nofbufs = 4;
bufsize = 4096;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-, len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(Files_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.Ln;
HALT(99)
END Err;
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END ;
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END ;
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END ;
dest[i] := 0X
END MakeFileName;
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
VAR n, i, j: LONGINT;
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
DEC(i);
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
IF f.fd = noDesc THEN
IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
BEGIN
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len
END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
BEGIN
NEW(f); f.workName := ""; COPY(name, f.registerName);
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
RETURN f
END New;
(*
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
dir[i] := 0X
END ScanPath;
*)
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0];
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END ;
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd, res, errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE
pos := 0;
COPY(name, path); (* -- noch *)
(*ScanPath(pos, dir);*) (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
END ;
LOOP
fd := Unix.Open(path, Unix.rdwr, {}); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, Unix.rdwr, {});
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, Unix.rdonly, {}); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
RETURN NIL
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
BEGIN RETURN r.org + r.offset
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END ;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END ;
IF i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
ELSE buf := f.bufs[i]
END
ELSE
f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper];
Flush(buf)
END ;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
f.pos := org + n;
buf.size := n
END ;
buf.org := org; buf.chg := FALSE
END
ELSE buf := NIL; org := 0; offset := 0
END ;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set;
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END ;
IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE Base* (VAR r: Rider): File;
BEGIN RETURN r.buf.f
END Base;
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
buf.data[offset] := x;
buf.chg := TRUE;
IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len)
END ;
r.offset := offset + 1; r.res := 0
END Write;
PROCEDURE WriteByte* (VAR r : Rider; x : SYSTEM.BYTE); (* added for compatibility with PO 2013, -- noch *)
BEGIN
Write(r, x);
END WriteByte;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := bufsize - offset;
IF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
INC(xpos, min); DEC(n, min); buf.chg := TRUE
END ;
r.res := 0
END WriteBytes;
(* another solution would be one that is similar to ReadBytes, WriteBytes.
No code duplication, more symmetric, only two ifs for
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
must be made consistent with offset (if offset > buf.size) in a lazy way.
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= bufsize) OR (r.org # buf.org) THEN
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
END ;
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write;
PROCEDURE WriteBytes ...
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= buf.size) OR (r.org # buf.org) THEN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END
END ;
x := buf.data[offset]; r.offset := offset + 1
END Read;
but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex.
*)
PROCEDURE Delete* (name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew, n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, Unix.rdonly, {});
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
END FlipBytes;
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
END ReadBool;
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
(* need to read line; -- noch *)
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
BEGIN i := 0;
b := FALSE;
REPEAT
Read(R, ch);
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
b := TRUE
ELSE
x[i] := ch;
INC(i);
END;
UNTIL b
END ReadLine;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
WriteBytes(R, b, 4);
END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x);
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
WriteBytes(R, b, 4);
END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END ;
WriteBytes(R, x, i+1)
END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END Files.

630
src/lib/system/freebsd/clang/Files0.Mod Normal file
View file

@ -0,0 +1,630 @@
MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
(* this module is not for use by developers and inteded to bootstrap voc *)
(* for general use import Files module *)
IMPORT SYSTEM, Unix, Kernel := Kernel0, Args, Console;
(* standard data type I/O
little endian,
Sint:1, Int:2, Lint:4
ORD({0}) = 1,
false = 0, true =1
IEEE real format,
null terminated strings,
compact numbers according to M.Odersky *)
CONST
nofbufs = 4;
bufsize = 4096;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-, len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(Files0_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.Ln;
HALT(99)
END Err;
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END ;
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END ;
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END ;
dest[i] := 0X
END MakeFileName;
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
VAR n, i, j: LONGINT;
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
DEC(i);
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
IF f.fd = noDesc THEN
IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
BEGIN
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len
END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
BEGIN
NEW(f); f.workName := ""; COPY(name, f.registerName);
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
RETURN f
END New;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
dir[i] := 0X
END ScanPath;
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0];
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END ;
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd, res, errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
END ;
LOOP
fd := Unix.Open(path, Unix.rdwr, {}); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, Unix.rdwr, {});
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, Unix.rdonly, {}); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files0.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE MakeFileName(dir, name, path); ScanPath(pos, dir)
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
BEGIN RETURN r.org + r.offset
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END ;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END ;
IF i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
ELSE buf := f.bufs[i]
END
ELSE
f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper];
Flush(buf)
END ;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
f.pos := org + n;
buf.size := n
END ;
buf.org := org; buf.chg := FALSE
END
ELSE buf := NIL; org := 0; offset := 0
END ;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set;
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END ;
IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE Base* (VAR r: Rider): File;
BEGIN RETURN r.buf.f
END Base;
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
buf.data[offset] := x;
buf.chg := TRUE;
IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len)
END ;
r.offset := offset + 1; r.res := 0
END Write;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := bufsize - offset;
IF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
INC(xpos, min); DEC(n, min); buf.chg := TRUE
END ;
r.res := 0
END WriteBytes;
(* another solution would be one that is similar to ReadBytes, WriteBytes.
No code duplication, more symmetric, only two ifs for
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
must be made consistent with offset (if offset > buf.size) in a lazy way.
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= bufsize) OR (r.org # buf.org) THEN
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
END ;
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write;
PROCEDURE WriteBytes ...
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= buf.size) OR (r.org # buf.org) THEN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END
END ;
x := buf.data[offset]; r.offset := offset + 1
END Read;
but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex.
*)
PROCEDURE Delete* (name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew, n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, Unix.rdonly, {});
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
END FlipBytes;
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
END ReadBool;
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
WriteBytes(R, b, 4);
END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x);
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
WriteBytes(R, b, 4);
END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END ;
WriteBytes(R, x, i+1)
END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END Files0.

167
src/lib/system/freebsd/clang/Kernel.Mod Normal file
View file

@ -0,0 +1,167 @@
MODULE Kernel;
(*
J. Templ, 16.4.95
communication with C-runtime and storage management
*)
IMPORT SYSTEM, Unix, Args;
TYPE
RealTime = POINTER TO TimeDesc;
TimeDesc = RECORD
sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT
END ;
KeyCmd* = PROCEDURE;
ObjFinalizer* = PROCEDURE(obj: SYSTEM.PTR);
VAR
(* trap handling *)
trapEnv*: Unix.JmpBuf; (* saved stack environment for trap handling *)
(* oberon heap management *)
nofiles*: LONGINT;
(* input event handling *)
readSet*, readySet*: Unix.FdSet;
FKey*: ARRAY 16 OF KeyCmd;
littleEndian*: BOOLEAN;
TimeUnit*: LONGINT; (* 1 sec *)
LIB*, CWD*: ARRAY 256 OF CHAR;
OBERON*: ARRAY 1024 OF CHAR;
timeStart: LONGINT; (* milliseconds *)
PROCEDURE -includesetjmp()
'#include "setjmp.h"';
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -Lock*()
"SYSTEM_lock++";
PROCEDURE -Unlock*()
"SYSTEM_lock--; if (SYSTEM_interrupted && SYSTEM_lock == 0) __HALT(-9)";
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -sigsetjmp*(VAR env: Unix.JmpBuf; savemask: LONGINT): LONGINT
"__sigsetjmp(env, savemask)";
PROCEDURE -siglongjmp*(VAR env:Unix. JmpBuf; val: LONGINT)
"siglongjmp(env, val)";
PROCEDURE -heapsize*(): LONGINT
"SYSTEM_heapsize";
PROCEDURE -allocated*(): LONGINT
"SYSTEM_allocated";
PROCEDURE -localtime(VAR clock: LONGINT): RealTime
"(Kernel_RealTime)localtime(clock)";
PROCEDURE -malloc*(size: LONGINT): LONGINT
"(LONGINT)malloc(size)";
PROCEDURE -free*(adr: LONGINT)
"(void)free(adr)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE GetClock* (VAR t, d: LONGINT);
VAR tv: Unix.Timeval; tz: Unix.Timezone; time: RealTime;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(tv, tz);
time := localtime(tv.sec);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9);
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
VAR err: ARRAY 25 OF CHAR;
BEGIN err := "not yet implemented"; HALT(99)
END SetClock;
PROCEDURE Time*(): LONGINT;
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(timeval, timezone);
RETURN (timeval.usec DIV 1000 + timeval.sec * 1000 - timeStart) MOD 7FFFFFFFH
END Time;
(*
PROCEDURE UserTime*(): LONGINT;
VAR rusage: Unix.Rusage;
BEGIN
Unix.Getrusage(0, S.ADR(rusage));
RETURN rusage.utime.sec*1000 + rusage.utime.usec DIV 1000
(* + rusage.stime.sec*1000 + rusage.stime.usec DIV 1000*)
END UserTime;
*)
PROCEDURE Select*(delay: LONGINT);
VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval;
BEGIN
rs := readSet;
FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END;
IF delay < 0 THEN delay := 0 END ;
tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000;
n := Unix.Select(256, rs, ws, xs, tv);
IF n >= 0 THEN readySet := rs END
END Select;
PROCEDURE -GC*(markStack: BOOLEAN)
"SYSTEM_GC(markStack)";
PROCEDURE -RegisterObject*(obj: SYSTEM.PTR; finalize: ObjFinalizer)
"SYSTEM_REGFIN(obj, finalize)";
PROCEDURE -SetHalt*(p: PROCEDURE(n: LONGINT))
"SYSTEM_Halt = p";
PROCEDURE InstallTermHandler*(p: PROCEDURE);
(* not yet supported; no Modules.Free *)
END InstallTermHandler;
PROCEDURE LargestAvailable*(): LONGINT;
BEGIN
(* dummy proc for System 3 compatibility
no meaningful value except may be the remaining swap space can be returned
in the context of an extensible heap *)
RETURN MAX(LONGINT)
END LargestAvailable;
PROCEDURE Halt(n: LONGINT);
VAR res: LONGINT;
BEGIN res := Unix.Kill(Unix.Getpid(), 4);
END Halt;
PROCEDURE EndianTest;
VAR i: LONGINT; dmy: INTEGER;
BEGIN
dmy := 1; i := SYSTEM.ADR(dmy);
SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)
END EndianTest;
BEGIN
EndianTest();
SetHalt(Halt);
CWD := ""; OBERON := "."; LIB := "";
getcwd(CWD);
Args.GetEnv("OBERON", OBERON);
Args.GetEnv("OBERON_LIB", LIB);
TimeUnit := 1000; timeStart := 0; timeStart := Time()
END Kernel.

179
src/lib/system/freebsd/clang/Kernel0.Mod Normal file
View file

@ -0,0 +1,179 @@
MODULE Kernel0;
(*
J. Templ, 16.4.95
communication with C-runtime and storage management
*)
(* version for bootstrapping voc *)
IMPORT SYSTEM, Unix, Args, Strings, version;
TYPE
RealTime = POINTER TO TimeDesc;
TimeDesc = RECORD
sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT
(* sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: INTEGER*)
END ;
KeyCmd* = PROCEDURE;
ObjFinalizer* = PROCEDURE(obj: SYSTEM.PTR);
VAR
(* trap handling *)
trapEnv*: Unix.JmpBuf; (* saved stack environment for trap handling *)
(* oberon heap management *)
nofiles*: LONGINT;
(* input event handling *)
readSet*, readySet*: Unix.FdSet;
FKey*: ARRAY 16 OF KeyCmd;
littleEndian*: BOOLEAN;
TimeUnit*: LONGINT; (* 1 sec *)
LIB*, CWD*: ARRAY 256 OF CHAR;
OBERON*: ARRAY 1024 OF CHAR;
MODULES-: ARRAY 1024 OF CHAR;
prefix*, fullprefix* : ARRAY 256 OF CHAR;
timeStart: LONGINT; (* milliseconds *)
PROCEDURE -includesetjmp()
'#include "setjmp.h"';
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -Lock*()
"SYSTEM_lock++";
PROCEDURE -Unlock*()
"SYSTEM_lock--; if (SYSTEM_interrupted && SYSTEM_lock == 0) __HALT(-9)";
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -sigsetjmp*(VAR env: Unix.JmpBuf; savemask: LONGINT): LONGINT
"__sigsetjmp(env, savemask)";
PROCEDURE -siglongjmp*(VAR env:Unix.JmpBuf; val: LONGINT)
"siglongjmp(env, val)";
PROCEDURE -heapsize*(): LONGINT
"SYSTEM_heapsize";
PROCEDURE -allocated*(): LONGINT
"SYSTEM_allocated";
PROCEDURE -localtime(VAR clock: LONGINT): RealTime
"(Kernel0_RealTime)localtime(clock)";
PROCEDURE -malloc*(size: LONGINT): LONGINT
"(LONGINT)malloc(size)";
PROCEDURE -free*(adr: LONGINT)
"(void)free(adr)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE GetClock* (VAR t, d: LONGINT);
VAR tv: Unix.Timeval; tz: Unix.Timezone; time: RealTime;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(tv, tz);
time := localtime(tv.sec);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9);
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
VAR err: ARRAY 25 OF CHAR;
BEGIN err := "not yet implemented"; HALT(99)
END SetClock;
PROCEDURE Time*(): LONGINT;
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(timeval, timezone);
RETURN (timeval.usec DIV 1000 + timeval.sec * 1000 - timeStart) MOD 7FFFFFFFH
END Time;
(*
PROCEDURE UserTime*(): LONGINT;
VAR rusage: Unix.Rusage;
BEGIN
Unix.Getrusage(0, S.ADR(rusage));
RETURN rusage.utime.sec*1000 + rusage.utime.usec DIV 1000
(* + rusage.stime.sec*1000 + rusage.stime.usec DIV 1000*)
END UserTime;
*)
PROCEDURE Select*(delay: LONGINT);
VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval;
BEGIN
rs := readSet;
FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END;
IF delay < 0 THEN delay := 0 END ;
tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000;
n := Unix.Select(256, rs, ws, xs, tv);
IF n >= 0 THEN readySet := rs END
END Select;
PROCEDURE -GC*(markStack: BOOLEAN)
"SYSTEM_GC(markStack)";
PROCEDURE -RegisterObject*(obj: SYSTEM.PTR; finalize: ObjFinalizer)
"SYSTEM_REGFIN(obj, finalize)";
PROCEDURE -SetHalt*(p: PROCEDURE(n: LONGINT))
"SYSTEM_Halt = p";
PROCEDURE InstallTermHandler*(p: PROCEDURE);
(* not yet supported; no Modules.Free *)
END InstallTermHandler;
PROCEDURE LargestAvailable*(): LONGINT;
BEGIN
(* dummy proc for System 3 compatibility
no meaningful value except may be the remaining swap space can be returned
in the context of an extensible heap *)
RETURN MAX(LONGINT)
END LargestAvailable;
PROCEDURE Halt(n: LONGINT);
VAR res: LONGINT;
BEGIN res := Unix.Kill(Unix.Getpid(), 4);
END Halt;
PROCEDURE EndianTest;
VAR i: LONGINT; dmy: INTEGER;
BEGIN
dmy := 1; i := SYSTEM.ADR(dmy);
SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)
END EndianTest;
BEGIN
EndianTest();
SetHalt(Halt);
CWD := ""; OBERON := "."; LIB := "";
MODULES := ""; (* additional modules path which can be specified on commandline and will be added to the OBERON variable; noch *)
getcwd(CWD);
Args.GetEnv ("MODULES", MODULES);
Args.GetEnv("OBERON", OBERON);
(* always have current directory in module search path, noch *)
Strings.Append(":.:", OBERON);
Strings.Append(MODULES, OBERON);
Strings.Append(":", OBERON);
Strings.Append(version.prefix, OBERON);
Strings.Append("/lib/voc/sym:", OBERON);
Args.GetEnv("OBERON_LIB", LIB);
TimeUnit := 1000; timeStart := 0; timeStart := Time()
END Kernel0.

520
src/lib/system/freebsd/clang/SYSTEM.Mod Normal file
View file

@ -0,0 +1,520 @@
(*
* voc (jet backend) runtime system, Version 1.1
*
* Copyright (c) Software Templ, 1994, 1995, 1996
*
* 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.
*)
MODULE SYSTEM; (* J. Templ, 31.5.95 *)
IMPORT SYSTEM; (*must not import other modules*)
CONST
ModNameLen = 20;
CmdNameLen = 24;
SZL = SIZE(LONGINT);
Unit = 4*SZL; (* smallest possible heap block *)
nofLists = 9; (* number of free_lists *)
heapSize0 = 8000*Unit; (* startup heap size *)
(* all blocks look the same:
free blocks describe themselves: size = Unit
tag = &tag++
->blksize
sentinel = -SZL
next
*)
(* heap chunks *)
nextChnkOff = 0; (* next heap chunk, sorted ascendingly! *)
endOff = SZL; (* end of heap chunk *)
blkOff = 3*SZL; (* first block in a chunk *)
(* heap blocks *)
tagOff = 0; (* block starts with tag *)
sizeOff = SZL; (* block size in free block relative to block start *)
sntlOff = 2*SZL; (* pointer offset table sentinel in free block relative to block start *)
nextOff = 3*SZL; (* next pointer in free block relative to block start *)
NoPtrSntl = LONG(LONG(-SZL));
TYPE
ModuleName = ARRAY ModNameLen OF CHAR;
CmdName = ARRAY CmdNameLen OF CHAR;
Module = POINTER TO ModuleDesc;
Cmd = POINTER TO CmdDesc;
EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR));
ModuleDesc = RECORD
next: Module;
name: ModuleName;
refcnt: LONGINT;
cmds: Cmd;
types: LONGINT;
enumPtrs: EnumProc;
reserved1, reserved2: LONGINT
END ;
Command = PROCEDURE;
CmdDesc = RECORD
next: Cmd;
name: CmdName;
cmd: Command
END ;
Finalizer = PROCEDURE(obj: SYSTEM.PTR);
FinNode = POINTER TO FinDesc;
FinDesc = RECORD
next: FinNode;
obj: LONGINT; (* weak pointer *)
marked: BOOLEAN;
finalize: Finalizer;
END ;
VAR
(* the list of loaded (=initialization started) modules *)
modules*: SYSTEM.PTR;
freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *)
bigBlocks, allocated*: LONGINT;
firstTry: BOOLEAN;
(* extensible heap *)
heap, (* the sorted list of heap chunks *)
heapend, (* max possible pointer value (used for stack collection) *)
heapsize*: LONGINT; (* the sum of all heap chunk sizes *)
(* finalization candidates *)
fin: FinNode;
(* garbage collector locking *)
gclock*: SHORTINT;
PROCEDURE -malloc(size: LONGINT): LONGINT "(LONGINT)malloc(size)";
PROCEDURE -Lock() "Lock";
PROCEDURE -Unlock() "Unlock";
PROCEDURE -Mainfrm(): LONGINT "SYSTEM_mainfrm";
(*
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN;
BEGIN
oldflag := flag;
flag := TRUE;
RETURN oldflag;
END TAS;
*)
PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): SYSTEM.PTR;
VAR m: Module;
BEGIN
IF name = "SYSTEM" THEN (* cannot use NEW *)
SYSTEM.NEW(m, SIZE(ModuleDesc)); m.cmds := NIL
ELSE NEW(m)
END ;
COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := SYSTEM.VAL(Module, modules);
modules := m;
RETURN m
END REGMOD;
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
VAR c: Cmd;
BEGIN NEW(c);
COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
END REGCMD;
PROCEDURE REGTYP*(m: Module; typ: LONGINT);
BEGIN SYSTEM.PUT(typ, m.types); m.types := typ
END REGTYP;
PROCEDURE INCREF*(m: Module);
BEGIN INC(m.refcnt)
END INCREF;
PROCEDURE NewChunk(blksz: LONGINT): LONGINT;
VAR chnk: LONGINT;
BEGIN
chnk := malloc(blksz + blkOff);
IF chnk # 0 THEN
SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz));
SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
SYSTEM.PUT(chnk + (blkOff + sizeOff), blksz);
SYSTEM.PUT(chnk + (blkOff + sntlOff), NoPtrSntl);
SYSTEM.PUT(chnk + (blkOff + nextOff), bigBlocks);
bigBlocks := chnk + blkOff;
INC(heapsize, blksz)
END ;
RETURN chnk
END NewChunk;
PROCEDURE ExtendHeap(blksz: LONGINT);
VAR size, chnk, j, next: LONGINT;
BEGIN
IF blksz > 10000*Unit THEN size := blksz
ELSE size := 10000*Unit (* additional heuristics *)
END ;
chnk := NewChunk(size);
IF chnk # 0 THEN
(*sorted insertion*)
IF chnk < heap THEN
SYSTEM.PUT(chnk, heap); heap := chnk
ELSE
j := heap; SYSTEM.GET(j, next);
WHILE (next # 0) & (chnk > next) DO j := next; SYSTEM.GET(j, next) END ;
SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk)
END ;
IF next = 0 THEN SYSTEM.GET(chnk + endOff, heapend) END
END
END ExtendHeap;
PROCEDURE ^GC*(markStack: BOOLEAN);
PROCEDURE NEWREC*(tag: LONGINT): SYSTEM.PTR;
VAR i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT; new: SYSTEM.PTR;
BEGIN
Lock();
SYSTEM.GET(tag, blksz);
ASSERT(blksz MOD Unit = 0);
i0 := blksz DIV Unit; i := i0;
IF i < nofLists THEN adr := freeList[i];
WHILE adr = 0 DO INC(i); adr := freeList[i] END
END ;
IF i < nofLists THEN (* unlink *)
SYSTEM.GET(adr + nextOff, next);
freeList[i] := next;
IF i # i0 THEN (* split *)
di := i - i0; restsize := di * Unit; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff);
SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr;
INC(adr, restsize)
END
ELSE
adr := bigBlocks; prev := 0;
LOOP
IF adr = 0 THEN
IF firstTry THEN
GC(TRUE); INC(blksz, Unit);
IF (heapsize - allocated - blksz) * 4 < heapsize THEN
(* heap is still almost full; expand to avoid thrashing *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize)
END ;
firstTry := FALSE; new := NEWREC(tag); firstTry := TRUE;
IF new = NIL THEN
(* depending on the fragmentation, the heap may not have been extended by
the anti-thrashing heuristics above *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize);
new := NEWREC(tag); (* will find a free block if heap has been expanded properly *)
END ;
Unlock(); RETURN new
ELSE
Unlock(); RETURN NIL
END
END ;
SYSTEM.GET(adr+sizeOff, t);
IF t >= blksz THEN EXIT END ;
prev := adr; SYSTEM.GET(adr + nextOff, adr)
END ;
restsize := t - blksz; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff);
IF restsize > nofLists * Unit THEN (*resize*)
SYSTEM.PUT(adr + sizeOff, restsize)
ELSE (*unlink*)
SYSTEM.GET(adr + nextOff, next);
IF prev = 0 THEN bigBlocks := next
ELSE SYSTEM.PUT(prev + nextOff, next);
END ;
IF restsize > 0 THEN (*move*)
di := restsize DIV Unit;
SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr
END
END ;
INC(adr, restsize)
END ;
i := adr + 4*SZL; end := adr + blksz;
WHILE i < end DO (*deliberately unrolled*)
SYSTEM.PUT(i, LONG(LONG(0)));
SYSTEM.PUT(i + SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 2*SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 3*SZL, LONG(LONG(0)));
INC(i, 4*SZL)
END ;
SYSTEM.PUT(adr + nextOff, LONG(LONG(0)));
SYSTEM.PUT(adr, tag);
SYSTEM.PUT(adr + sizeOff, LONG(LONG(0)));
SYSTEM.PUT(adr + sntlOff, LONG(LONG(0)));
INC(allocated, blksz);
Unlock();
RETURN SYSTEM.VAL(SYSTEM.PTR, adr + SZL)
END NEWREC;
PROCEDURE NEWBLK*(size: LONGINT): SYSTEM.PTR;
VAR blksz, tag: LONGINT; new: SYSTEM.PTR;
BEGIN
Lock();
blksz := (size + (4*SZL + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*)
new := NEWREC(SYSTEM.ADR(blksz));
tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL;
SYSTEM.PUT(tag - SZL, LONG(LONG(0))); (*reserved for meta info*)
SYSTEM.PUT(tag, blksz);
SYSTEM.PUT(tag + SZL, NoPtrSntl);
SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag);
Unlock();
RETURN new
END NEWBLK;
PROCEDURE Mark(q: LONGINT);
VAR p, tag, fld, n, offset, tagbits: LONGINT;
BEGIN
IF q # 0 THEN SYSTEM.GET(q - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(q - SZL, tagbits + 1);
p := 0; tag := tagbits + SZL;
LOOP
SYSTEM.GET(tag, offset);
IF offset < 0 THEN
SYSTEM.PUT(q - SZL, tag + offset + 1);
IF p = 0 THEN EXIT END ;
n := q; q := p;
SYSTEM.GET(q - SZL, tag); DEC(tag, 1);
SYSTEM.GET(tag, offset); fld := q + offset;
SYSTEM.GET(fld, p); SYSTEM.PUT(fld, n)
ELSE
fld := q + offset;
SYSTEM.GET(fld, n);
IF n # 0 THEN
SYSTEM.GET(n - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(n - SZL, tagbits + 1);
SYSTEM.PUT(q - SZL, tag + 1);
SYSTEM.PUT(fld, p); p := q; q := n;
tag := tagbits
END
END
END ;
INC(tag, SZL)
END
END
END
END Mark;
PROCEDURE MarkP(p: SYSTEM.PTR); (* for compatibility with EnumPtrs in ANSI mode *)
BEGIN
Mark(SYSTEM.VAL(LONGINT, p))
END MarkP;
PROCEDURE Scan;
VAR chnk, adr, end, start, tag, i, size, freesize: LONGINT;
BEGIN bigBlocks := 0; i := 1;
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
freesize := 0; allocated := 0; chnk := heap;
WHILE chnk # 0 DO
adr := chnk + blkOff; SYSTEM.GET(chnk + endOff, end);
WHILE adr < end DO
SYSTEM.GET(adr, tag);
IF ODD(tag) THEN (*marked*)
IF freesize > 0 THEN
start := adr - freesize;
SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
DEC(tag, 1);
SYSTEM.PUT(adr, tag);
SYSTEM.GET(tag, size);
INC(allocated, size);
INC(adr, size)
ELSE (*unmarked*)
SYSTEM.GET(tag, size);
INC(freesize, size);
INC(adr, size)
END
END ;
IF freesize > 0 THEN (*collect last block*)
start := adr - freesize;
SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
SYSTEM.GET(chnk, chnk)
END
END Scan;
PROCEDURE Sift (l, r: LONGINT; VAR a: ARRAY OF LONGINT);
VAR i, j, x: LONGINT;
BEGIN j := l; x := a[j];
LOOP i := j; j := 2*j + 1;
IF (j < r) & (a[j] < a[j+1]) THEN INC(j) END;
IF (j > r) OR (a[j] <= x) THEN EXIT END;
a[i] := a[j]
END;
a[i] := x
END Sift;
PROCEDURE HeapSort (n: LONGINT; VAR a: ARRAY OF LONGINT);
VAR l, r, x: LONGINT;
BEGIN l := n DIV 2; r := n - 1;
WHILE l > 0 DO DEC(l); Sift(l, r, a) END;
WHILE r > 0 DO x := a[0]; a[0] := a[r]; a[r] := x; DEC(r); Sift(l, r, a) END
END HeapSort;
PROCEDURE MarkCandidates(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR chnk, adr, tag, next, lim, lim1, i, ptr, size: LONGINT;
BEGIN
chnk := heap; i := 0; lim := cand[n-1];
WHILE (chnk # 0 ) & (chnk < lim) DO
adr := chnk + blkOff;
SYSTEM.GET(chnk + endOff, lim1);
IF lim < lim1 THEN lim1 := lim END ;
WHILE adr < lim1 DO
SYSTEM.GET(adr, tag);
IF ODD(tag) THEN (*already marked*)
SYSTEM.GET(tag-1, size); INC(adr, size)
ELSE
SYSTEM.GET(tag, size);
ptr := adr + SZL;
WHILE cand[i] < ptr DO INC(i) END ;
IF i = n THEN RETURN END ;
next := adr + size;
IF cand[i] < next THEN Mark(ptr) END ;
adr := next
END
END ;
SYSTEM.GET(chnk, chnk)
END
END MarkCandidates;
PROCEDURE CheckFin;
VAR n: FinNode; tag: LONGINT;
BEGIN n := fin;
WHILE n # NIL DO
SYSTEM.GET(n.obj - SZL, tag);
IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
ELSE n.marked := TRUE
END ;
n := n.next
END
END CheckFin;
PROCEDURE Finalize;
VAR n, prev: FinNode;
BEGIN n := fin; prev := NIL;
WHILE n # NIL DO
IF ~n.marked THEN
IF n = fin THEN fin := fin.next ELSE prev.next := n.next END ;
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj));
(* new nodes may have been pushed in n.finalize, therefore: *)
IF prev = NIL THEN n := fin ELSE n := n.next END
ELSE prev := n; n := n.next
END
END
END Finalize;
PROCEDURE FINALL*;
VAR n: FinNode;
BEGIN
WHILE fin # NIL DO
n := fin; fin := fin.next;
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj))
END
END FINALL;
PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR
frame: SYSTEM.PTR;
inc, nofcand: LONGINT;
sp, p, stack0, ptr: LONGINT;
align: RECORD ch: CHAR; p: SYSTEM.PTR END ;
BEGIN
IF n > 0 THEN MarkStack(n-1, cand); (* flush register windows by means of recursive calls *)
IF n > 100 THEN RETURN END (* prevent tail recursion optimization *)
END ;
IF n = 0 THEN
nofcand := 0; sp := SYSTEM.ADR(frame);
stack0 := Mainfrm();
(* check for minimum alignment of pointers *)
inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align);
IF sp > stack0 THEN inc := -inc END ;
WHILE sp # stack0 DO
SYSTEM.GET(sp, p);
IF (p > heap) & (p < heapend) THEN
IF nofcand = LEN(cand) THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand); nofcand := 0 END ;
cand[nofcand] := p; INC(nofcand)
END ;
INC(sp, inc)
END ;
IF nofcand > 0 THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand) END
END
END MarkStack;
PROCEDURE GC*(markStack: BOOLEAN);
VAR
m: Module;
i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23: LONGINT;
cand: ARRAY 10000 OF LONGINT;
BEGIN
IF (gclock = 0) OR (gclock = 1) & ~markStack THEN
Lock();
m := SYSTEM.VAL(Module, modules);
WHILE m # NIL DO
IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ;
m := m^.next
END ;
IF markStack THEN
(* generate register pressure to force callee saved registers to memory;
may be simplified by inlining OS calls or processor specific instructions
*)
i0 := -100; i1 := -101; i2 := -102; i3 := -103; i4 := -104; i5 := -105; i6 := -106; i7 := -107;
i8 := 1; i9 := 2; i10 := 3; i11 := 4; i12 := 5; i13 := 6; i14 := 7; i15 := 8;
i16 := 9; i17 := 10; i18 := 11; i19 := 12; i20 := 13; i21 := 14; i22 := 15; i23 := 16;
LOOP INC(i0, 1); INC(i1, 2); INC(i2, 3); INC(i3, 4); INC(i4, 5); INC(i5, 6); INC(i6, 7); INC(i7, 8);
INC(i8, 9); INC(i9, 10); INC(i10, 11); INC(i11, 12); INC(i12, 13); INC(i13, 14); INC(i14, 15); INC(i15, 16);
INC(i16, 17); INC(i17, 18); INC(i18, 19); INC(i19, 20); INC(i20, 21); INC(i21, 22); INC(i22, 23); INC(i23, 24);
IF (i0 = -99) & (i15 = 24) THEN MarkStack(32, cand); EXIT END
END ;
IF i0 + i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8 + i9 + i10 + i11 + i12 + i13 + i14 + i15
+ i16 + i17 + i18 + i19 + i20 + i21 + i22 + i23 > 10000 THEN RETURN (* use all variables *)
END ;
END;
CheckFin;
Scan;
Finalize;
Unlock()
END
END GC;
PROCEDURE REGFIN*(obj: SYSTEM.PTR; finalize: Finalizer);
VAR f: FinNode;
BEGIN NEW(f);
f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; f.next := fin; fin := f
END REGFIN;
PROCEDURE InitHeap; (* initialized before body to enable NEW, SYSTEM.NEW *)
BEGIN
heap := NewChunk(heapSize0);
SYSTEM.GET(heap + endOff, heapend);
SYSTEM.PUT(heap, LONG(LONG(0)));
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; gclock := 0
END InitHeap;
END SYSTEM.

859
src/lib/system/freebsd/clang/Texts.Mod Normal file
View file

@ -0,0 +1,859 @@
MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *)
IMPORT
Files, Modules, Reals;
(*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *)
CONST
Displaywhite = 15;
ElemChar* = 1CX;
TAB = 9X; CR = 0DX; maxD = 9;
(**FileMsg.id**)
load* = 0; store* = 1;
(**Notifier op**)
replace* = 0; insert* = 1; delete* = 2;
(**Scanner.class**)
Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6;
textTag = 0F0X; DocBlockId = 0F7X; version = 01X;
TYPE
FontsFont = POINTER TO FontDesc;
FontDesc = RECORD
name: ARRAY 32 OF CHAR;
END ;
Run = POINTER TO RunDesc;
RunDesc = RECORD
prev, next: Run;
len: LONGINT;
fnt: FontsFont;
col, voff: SHORTINT;
ascii: BOOLEAN (* << *)
END;
Piece = POINTER TO PieceDesc;
PieceDesc = RECORD (RunDesc)
file: Files.File;
org: LONGINT
END;
Elem* = POINTER TO ElemDesc;
Buffer* = POINTER TO BufDesc;
Text* = POINTER TO TextDesc;
ElemMsg* = RECORD END;
Handler* = PROCEDURE (e: Elem; VAR msg: ElemMsg);
ElemDesc* = RECORD (RunDesc)
W*, H*: LONGINT;
handle*: Handler;
base: Text
END;
FileMsg* = RECORD (ElemMsg)
id*: INTEGER;
pos*: LONGINT;
r*: Files.Rider
END;
CopyMsg* = RECORD (ElemMsg)
e*: Elem
END;
IdentifyMsg* = RECORD (ElemMsg)
mod*, proc*: ARRAY 32 OF CHAR
END;
BufDesc* = RECORD
len*: LONGINT;
head: Run
END;
TextDesc* = RECORD
len*: LONGINT;
head, cache: Run;
corg: LONGINT
END;
Reader* = RECORD
eot*: BOOLEAN;
fnt*: FontsFont;
col*, voff*: SHORTINT;
elem*: Elem;
rider: Files.Rider;
run: Run;
org, off: LONGINT
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*, class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: SHORTINT;
s*: ARRAY 64 OF CHAR (* << *)
END;
Writer* = RECORD
buf*: Buffer;
fnt*: FontsFont;
col*, voff*: SHORTINT;
rider: Files.Rider;
file: Files.File
END;
Alien = POINTER TO RECORD (ElemDesc)
file: Files.File;
org, span: LONGINT;
mod, proc: ARRAY 32 OF CHAR
END;
VAR
new*: Elem;
del: Buffer;
FontsDefault: FontsFont;
PROCEDURE FontsThis(VAR name: ARRAY OF CHAR): FontsFont;
VAR F: FontsFont;
BEGIN
NEW(F); COPY(name, F.name); RETURN F
END FontsThis;
(* run primitives *)
PROCEDURE Find (T: Text; VAR pos: LONGINT; VAR u: Run; VAR org, off: LONGINT);
VAR v: Run; m: LONGINT;
BEGIN
IF pos >= T.len THEN pos := T.len; u := T.head; org := T.len; off := 0; T.cache := T.head; T.corg := 0
ELSE v := T.cache.next; m := pos - T.corg;
IF pos >= T.corg THEN
WHILE m >= v.len DO DEC(m, v.len); v := v.next END
ELSE
WHILE m < 0 DO v := v.prev; INC(m, v.len) END;
END;
u := v; org := pos - m; off := m; T.cache := v.prev; T.corg := org
END
END Find;
PROCEDURE Split (off: LONGINT; VAR u, un: Run);
VAR p, U: Piece;
BEGIN
IF off = 0 THEN un := u; u := un.prev
ELSIF off >= u.len THEN un := u.next
ELSE NEW(p); un := p; U := u(Piece);
p^ := U^; INC(p.org, off); DEC(p.len, off); DEC(U.len, p.len);
p.ascii := u.ascii; p.prev := U; p.next := U.next; p.next.prev := p; U.next := p (* << *)
END
END Split;
PROCEDURE Merge (T: Text; u: Run; VAR v: Run);
VAR p, q: Piece;
BEGIN
IF (u IS Piece) & (v IS Piece) & (u.fnt.name = v.fnt.name) & (u.col = v.col) & (u.voff = v.voff)
& (u(Piece).ascii = v(Piece).ascii) THEN (* << *)
p := u(Piece); q := v(Piece);
IF (p.file = q.file) & (p.org + p.len = q.org) THEN
IF T.cache = u THEN INC(T.corg, q.len)
ELSIF T.cache = v THEN T.cache := T.head; T.corg := 0
END;
INC(p.len, q.len); v := v.next
END
END
END Merge;
PROCEDURE Splice (un, v, w: Run; base: Text); (* (u, un) -> (u, v, w, un) *)
VAR u: Run;
BEGIN
IF v # w.next THEN u := un.prev;
u.next := v; v.prev := u; un.prev := w; w.next := un;
REPEAT
IF v IS Elem THEN v(Elem).base := base END;
v := v.next
UNTIL v = un
END
END Splice;
PROCEDURE ClonePiece (p: Piece): Piece;
VAR q: Piece;
BEGIN NEW(q); q^ := p^; RETURN q
END ClonePiece;
PROCEDURE CloneElem (e: Elem): Elem;
VAR msg: CopyMsg;
BEGIN msg.e := NIL; e.handle(e, msg); RETURN msg.e
END CloneElem;
(** Elements **)
PROCEDURE CopyElem* (SE, DE: Elem);
BEGIN DE.len := SE.len; DE.fnt := SE.fnt; DE.col := SE.col; DE.voff := SE.voff;
DE.W := SE.W; DE.H := SE.H; DE.handle := SE.handle
END CopyElem;
PROCEDURE ElemBase* (E: Elem): Text;
BEGIN RETURN E.base
END ElemBase;
PROCEDURE ElemPos* (E: Elem): LONGINT;
VAR u: Run; pos: LONGINT;
BEGIN u := E.base.head.next; pos := 0;
WHILE u # E DO pos := pos + u.len; u := u.next END;
RETURN pos
END ElemPos;
PROCEDURE HandleAlien (E: Elem; VAR msg: ElemMsg);
VAR e: Alien; r: Files.Rider; i: LONGINT; ch: CHAR;
BEGIN
WITH E: Alien DO
IF msg IS CopyMsg THEN
WITH msg: CopyMsg DO NEW(e); CopyElem(E, e);
e.file := E.file; e.org := E.org; e.span := E.span; e.mod := E.mod; e.proc := E.proc;
msg.e := e
END
ELSIF msg IS IdentifyMsg THEN
WITH msg: IdentifyMsg DO
COPY(E.mod, msg.mod); COPY(E.proc, msg.proc); msg.mod[31] := 1X (*alien*)
END
ELSIF msg IS FileMsg THEN
WITH msg: FileMsg DO
IF msg.id = store THEN Files.Set(r, E.file, E.org); i := E.span;
WHILE i > 0 DO Files.Read(r, ch); Files.Write(msg.r, ch); DEC(i) END
END
END
END
END
END HandleAlien;
(** Buffers **)
PROCEDURE OpenBuf* (B: Buffer);
VAR u: Run;
BEGIN NEW(u); u.next := u; u.prev := u; B.head := u; B.len := 0
END OpenBuf;
PROCEDURE Copy* (SB, DB: Buffer);
VAR u, v, vn: Run;
BEGIN u := SB.head.next; v := DB.head.prev;
WHILE u # SB.head DO
IF u IS Piece THEN vn := ClonePiece(u(Piece)) ELSE vn := CloneElem(u(Elem)) END;
v.next := vn; vn.prev := v; v := vn; u := u.next
END;
v.next := DB.head; DB.head.prev := v;
INC(DB.len, SB.len)
END Copy;
PROCEDURE Recall* (VAR B: Buffer);
BEGIN B := del; del := NIL
END Recall;
(** Texts **)
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR u, v, w, wn: Run; uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Find(T, end, v, vo, vd);
w := B.head.prev;
WHILE u # v DO
IF u IS Piece THEN wn := ClonePiece(u(Piece)); DEC(wn.len, ud); INC(wn(Piece).org, ud)
ELSE wn := CloneElem(u(Elem))
END;
w.next := wn; wn.prev := w; w := wn; u := u.next; ud := 0
END;
IF vd > 0 THEN (*v IS Piece*) wn := ClonePiece(v(Piece)); wn.len := vd - ud; INC(wn(Piece).org, ud);
w.next := wn; wn.prev := w; w := wn
END;
w.next := B.head; B.head.prev := w;
INC(B.len, end - beg)
END Save;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR u, un, v: Run; p, q: Piece; uo, ud, len: LONGINT;
BEGIN Find(T, pos, u, uo, ud); Split(ud, u, un);
len := B.len; v := B.head.next;
Merge(T, u, v); Splice(un, v, B.head.prev, T);
INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0;
END Insert;
PROCEDURE Append* (T: Text; B: Buffer);
VAR v: Run; pos, len: LONGINT;
BEGIN pos := T.len; len := B.len; v := B.head.next;
Merge(T, T.head.prev, v); Splice(T.head, v, B.head.prev, T);
INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0;
END Append;
PROCEDURE Delete* (T: Text; beg, end: LONGINT);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN
Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
NEW(del); OpenBuf(del); del.len := end - beg;
Splice(del.head, un, v, NIL);
Merge(T, u, vn); u.next := vn; vn.prev := u;
DEC(T.len, end - beg);
END Delete;
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: FontsFont; col, voff: SHORTINT);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
WHILE un # vn DO
IF (0 IN sel) & (fnt # NIL) THEN un.fnt := fnt END;
IF 1 IN sel THEN un.col := col END;
IF 2 IN sel THEN un.voff := voff END;
Merge(T, u, un);
IF u.next = un THEN u := un; un := un.next ELSE u.next := un; un.prev := u END
END;
Merge(T, u, un); u.next := un; un.prev := u;
END ChangeLooks;
(** Readers **)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR u: Run;
BEGIN
IF pos >= T.len THEN pos := T.len END;
Find(T, pos, u, R.org, R.off); R.run := u; R.eot := FALSE;
IF u IS Piece THEN
Files.Set(R.rider, u(Piece).file, u(Piece).org + R.off)
END
END OpenReader;
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
VAR u: Run;
BEGIN u := R.run; R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; INC(R.off);
IF u IS Piece THEN Files.Read(R.rider, ch); R.elem := NIL;
IF (ch = 0AX) & u(Piece).ascii THEN ch := CR END (* << LF to CR *)
ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem)
ELSE ch := 0X; R.elem := NIL; R.eot := TRUE
END;
IF R.off = u.len THEN INC(R.org, u.len); u := u.next;
IF u IS Piece THEN
WITH u: Piece DO Files.Set(R.rider, u.file, u.org) END
END;
R.run := u; R.off := 0
END
END Read;
PROCEDURE ReadElem* (VAR R: Reader);
VAR u, un: Run;
BEGIN u := R.run;
WHILE u IS Piece DO INC(R.org, u.len); u := u.next END;
IF u IS Elem THEN un := u.next; R.run := un; INC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem);
IF un IS Piece THEN
WITH un: Piece DO Files.Set(R.rider, un.file, un.org) END
END
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadElem;
PROCEDURE ReadPrevElem* (VAR R: Reader);
VAR u: Run;
BEGIN u := R.run.prev;
WHILE u IS Piece DO DEC(R.org, u.len); u := u.prev END;
IF u IS Elem THEN R.run := u; DEC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem)
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadPrevElem;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(** Scanners --------------- NW --------------- **)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
END OpenScanner;
(*IEEE floating point formats:
x = 2^(e-127) * 1.m bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 2^(e-1023) * 1.m bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Scan* (VAR S: Scanner);
CONST maxD = 32;
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h: SHORTINT;
e: INTEGER; k: LONGINT;
x, f: REAL; y, g: LONGREAL;
d: ARRAY maxD OF CHAR;
PROCEDURE ReadScaleFactor;
BEGIN Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END;
WHILE ("0" <= ch) & (ch <= "9") DO
e := e*10 + ORD(ch) - 30H; Read(S, ch)
END
END ReadScaleFactor;
BEGIN ch := S.nextCh; i := 0;
LOOP
IF ch = CR THEN INC(S.line)
ELSIF (ch # " ") & (ch # TAB) THEN EXIT
END ;
Read(S, ch)
END;
IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch = "/") OR (ch = ".") THEN (*name*) (* << *)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL (CAP(ch) > "Z") & (ch # "_") (* << *)
OR ("A" > CAP(ch)) & (ch > "9")
OR ("0" > ch) & (ch # ".") & (ch # "/") (* << *)
OR (i = 63); (* << *)
S.s[i] := 0X; S.len := i; S.class := 1
ELSIF ch = 22X THEN (*literal string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 63) DO (* << *)
S.s[i] := ch; INC(i); Read(S, ch)
END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2
ELSE
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
hex := FALSE; j := 0;
LOOP d[i] := ch; INC(i); Read(S, ch);
IF ch < "0" THEN EXIT END;
IF "9" < ch THEN
IF ("A" <= ch) & (ch <= "F") THEN hex := TRUE; ch := CHR(ORD(ch)-7)
ELSIF ("a" <= ch) & (ch <= "f") THEN hex := TRUE; ch := CHR(ORD(ch)-27H)
ELSE EXIT
END
END
END;
IF ch = "H" THEN (*hex number*)
Read(S, ch); S.class := 3;
IF i-j > 8 THEN j := i-8 END ;
k := ORD(d[j]) - 30H; INC(j);
IF (i-j = 7) & (k >= 8) THEN DEC(k, 16) END ;
WHILE j < i DO k := k*10H + (ORD(d[j]) - 30H); INC(j) END ;
IF neg THEN S.i := -k ELSE S.i := k END
ELSIF ch = "." THEN (*read real*)
Read(S, ch); h := i;
WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ;
IF ch = "D" THEN
e := 0; y := 0; g := 1;
REPEAT y := y*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO g := g/10; y := (ORD(d[j]) - 30H)*g + y; INC(j) END ;
ReadScaleFactor;
IF negE THEN
IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END
ELSIF e > 0 THEN
IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END
END ;
IF neg THEN y := -y END ;
S.class := 5; S.y := y
ELSE e := 0; x := 0; f := 1;
REPEAT x := x*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO f := f/10; x := (ORD(d[j])-30H)*f + x; INC(j) END;
IF ch = "E" THEN ReadScaleFactor END ;
IF negE THEN
IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END
ELSIF e > 0 THEN
IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END
END ;
IF neg THEN x := -x END ;
S.class := 4; S.x := x
END ;
IF hex THEN S.class := 0 END
ELSE (*decimal integer*)
S.class := 3; k := 0;
REPEAT k := k*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = i;
IF neg THEN S.i := -k ELSE S.i := k END;
IF hex THEN S.class := 0 ELSE S.class := 3 END
END
ELSE S.class := 6;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END;
S.nextCh := ch
END Scan;
(** Writers **)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN NEW(W.buf); OpenBuf(W.buf);
W.fnt := FontsDefault; W.col := Displaywhite; W.voff := 0;
W.file := Files.New(""); Files.Set(W.rider, W.file, 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: FontsFont);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: SHORTINT);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: SHORTINT);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR u, un: Run; p: Piece;
BEGIN Files.Write(W.rider, ch); INC(W.buf.len); un := W.buf.head; u := un.prev;
IF (u IS Piece) & (u(Piece).file = W.file) & (u.fnt.name = W.fnt.name) & (u.col = W.col) & (u.voff = W.voff)
& ~u(Piece).ascii THEN (* << *)
INC(u.len)
ELSE NEW(p); u.next := p; p.prev := u; p.next := un; un.prev := p;
p.len := 1; p.fnt := W.fnt; p.col := W.col; p.voff := W.voff;
p.file := W.file; p.org := Files.Length(W.file) - 1; p.ascii := FALSE (* << *)
END
END Write;
PROCEDURE WriteElem* (VAR W: Writer; e: Elem);
VAR u, un: Run;
BEGIN
IF e.base # NIL THEN HALT(99) END;
INC(W.buf.len); e.len := 1; e.fnt := W.fnt; e.col := W.col; e.voff := W.voff;
un := W.buf.head; u := un.prev; u.next := e; e.prev := u; e.next := un; un.prev := e
END WriteElem;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i: INTEGER; x0: LONGINT;
a: ARRAY 11 OF CHAR;
BEGIN i := 0;
IF x < 0 THEN
IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN
ELSE DEC(n); x0 := -x
END
ELSE x0 := x
END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN i := 0; Write(W, " ");
REPEAT y := x MOD 10H;
IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e: INTEGER; x0: REAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.Expo(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 255 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 9 THEN n := 3 ELSE DEC(n, 6) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 8;
(*there are 2 < n <= 8 digits to be written*)
IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := (e - 127) * 77 DIV 256;
IF e >= 0 THEN x := x / Reals.Ten(e) ELSE x := Reals.Ten(-e) * x END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
x0 := Reals.Ten(n-1); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN x := x*0.1; INC(e) END;
Reals.Convert(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "E");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END WriteReal;
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR e, i: INTEGER; sign: CHAR; x0: REAL;
d: ARRAY maxD OF CHAR;
PROCEDURE seq(ch: CHAR; n: INTEGER);
BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END
END seq;
PROCEDURE dig(n: INTEGER);
BEGIN
WHILE n > 0 DO
DEC(i); Write(W, d[i]); DEC(n)
END
END dig;
BEGIN e := Reals.Expo(x);
IF k < 0 THEN k := 0 END;
IF e = 0 THEN seq(" ", n-k-2); Write(W, "0"); seq(" ", k+1)
ELSIF e = 255 THEN WriteString(W, " NaN"); seq(" ", n-4)
ELSE e := (e - 127) * 77 DIV 256;
IF x < 0 THEN sign := "-"; x := -x ELSE sign := " " END;
IF e >= 0 THEN (*x >= 1.0, 77/256 = log 2*) x := x/Reals.Ten(e)
ELSE (*x < 1.0*) x := Reals.Ten(-e) * x
END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
(* 1 <= x < 10 *)
IF k+e >= maxD-1 THEN k := maxD-1-e
ELSIF k+e < 0 THEN k := -e; x := 0.0
END;
x0 := Reals.Ten(k+e); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN INC(e) END;
(*e = no. of digits before decimal point*)
INC(e); i := k+e; Reals.Convert(x, i, d);
IF e > 0 THEN
seq(" ", n-e-k-2); Write(W, sign); dig(e);
Write(W, "."); dig(k)
ELSE seq(" ", n-k-3);
Write(W, sign); Write(W, "0"); Write(W, ".");
seq("0", -e); dig(k+e)
END
END
END WriteRealFix;
PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
VAR i: INTEGER;
d: ARRAY 8 OF CHAR;
BEGIN Reals.ConvertH(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 8
END WriteRealHex;
PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER);
CONST maxD = 16;
VAR e: INTEGER; x0: LONGREAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.ExpoL(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 2047 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 10 THEN n := 3 ELSE DEC(n, 7) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= maxD;
(*there are 2 <= n <= maxD digits to be written*)
IF x < 0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := SHORT(LONG(e - 1023) * 77 DIV 256);
IF e >= 0 THEN x := x / Reals.TenL(e) ELSE x := Reals.TenL(-e) * x END ;
IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END ;
x0 := Reals.TenL(n-1); x := x0*x + 0.5D0;
IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ;
Reals.ConvertL(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "D");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 100 + 30H)); e := e MOD 100;
Write(W, CHR(e DIV 10 + 30H));
Write(W, CHR(e MOD 10 + 30H))
END
END WriteLongReal;
PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
VAR i: INTEGER;
d: ARRAY 16 OF CHAR;
BEGIN Reals.ConvertHL(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 16
END WriteLongRealHex;
PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT);
PROCEDURE WritePair(ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
BEGIN
WritePair(" ", d MOD 32); WritePair(".", d DIV 32 MOD 16); WritePair(".", d DIV 512 MOD 128);
WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
END WriteDate;
(** Text Filing **)
PROCEDURE Load0 (VAR r: Files.Rider; T: Text);
VAR u, un: Run; p: Piece; e: Elem;
org, pos, hlen, plen: LONGINT; ecnt, fno, fcnt, col, voff: SHORTINT;
f: Files.File;
msg: FileMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
name: ARRAY 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
PROCEDURE LoadElem (VAR r: Files.Rider; pos, span: LONGINT; VAR e: Elem);
VAR M: Modules.Module; Cmd: Modules.Command; a: Alien;
org, ew, eh: LONGINT; eno: SHORTINT;
BEGIN new := NIL;
Files.ReadLInt(r, ew); Files.ReadLInt(r, eh); Files.Read(r, eno);
IF eno > ecnt THEN ecnt := eno; Files.ReadString(r, mods[eno]); Files.ReadString(r, procs[eno]) END;
org := Files.Pos(r); M := Modules.ThisMod(mods[eno]);
IF M # NIL THEN Cmd := Modules.ThisCommand(M, procs[eno]);
IF Cmd # NIL THEN Cmd END
END;
e := new;
IF e # NIL THEN e.W := ew; e.H := eh; e.base := T;
msg.pos := pos; e.handle(e, msg);
IF Files.Pos(r) # org + span THEN e := NIL END
END;
IF e = NIL THEN Files.Set(r, f, org + span);
NEW(a); a.W := ew; a.H := eh; a.handle := HandleAlien; a.base := T;
a.file := f; a.org := org; a.span := span;
COPY(mods[eno], a.mod); COPY(procs[eno], a.proc);
e := a
END
END LoadElem;
BEGIN pos := Files.Pos(r); f := Files.Base(r);
NEW(u); u.len := MAX(LONGINT); (*u.fnt := FontsDefault;*)u.fnt := NIL; u.col := Displaywhite;
T.head := u; ecnt := 0; fcnt := 0;
msg.id := load; msg.r := r;
Files.ReadLInt(msg.r, hlen); (*!!!org := pos + hlen;*) org := pos -2 + hlen; pos := org; Files.Read(msg.r, fno);
WHILE fno # 0 DO
IF fno > fcnt THEN fcnt := fno; Files.ReadString(msg.r, name); fnts[fno] := FontsThis(name) END;
Files.Read(msg.r, col); Files.Read(msg.r, voff); Files.ReadLInt(msg.r, plen);
IF plen > 0 THEN NEW(p); p.file := f; p.org := pos; p.ascii := FALSE; un := p; un.len := plen
ELSE LoadElem(msg.r, pos - org, -plen, e); un := e; un.len := 1
END;
un.fnt := fnts[fno]; un.col := col; un.voff := voff;
INC(pos, un.len); u.next := un; un.prev := u; u := un; Files.Read(msg.r, fno)
END;
u.next := T.head; T.head.prev := u; T.cache := T.head; T.corg := 0;
Files.ReadLInt(msg.r, T.len); Files.Set(r, f, Files.Pos(msg.r) + T.len)
END Load0;
PROCEDURE Load* (VAR r: Files.Rider; T: Text);
CONST oldTag = -4095;
VAR tag: INTEGER;
BEGIN
(* for compatibility inner text tags are checked and skipped; remove this in a later version *)
Files.ReadInt(r, tag); IF tag # oldTag THEN Files.Set(r, Files.Base(r), Files.Pos(r)-2) END;
Load0(r, T)
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; u: Run; p: Piece; tag, version: CHAR; hlen: LONGINT;
BEGIN f := Files.Old(name);
IF f = NIL THEN f := Files.New("") END;
Files.Set(r, f, 0); Files.Read(r, tag); Files.Read(r, version);
IF (tag = textTag) OR (tag = 01X) & (version = textTag) THEN Load0(r, T)
ELSE (*ascii*)
NEW(u); u.len := MAX(LONGINT); u.fnt := NIL; u.col := Displaywhite;
NEW(p);
IF (tag = DocBlockId) & (version = 07X) THEN (* extract ascii text from System 3 text document *)
Files.Set(r, f, 28); Files.ReadLInt(r, hlen);
Files.Set(r, f, 22 + hlen); Files.ReadLInt(r, T.len); p.org := 26 + hlen
ELSE
T.len := Files.Length(f); p.org := 0
END ;
IF T.len > 0 THEN p.len := T.len; p.fnt := FontsDefault;
p.col := Displaywhite; p.voff := 0; p.file := f; p.ascii := TRUE;
u.next := p; u.prev := p; p.next := u; p.prev := u
ELSE u.next := u; u.prev := u
END;
T.head := u; T.cache := T.head; T.corg := 0
END
END Open;
PROCEDURE Store* (VAR r: Files.Rider; T: Text);
VAR r1: Files.Rider; u, un: Run; e: Elem; org, pos, delta, hlen, rlen: LONGINT; ecnt, fno, fcnt: SHORTINT; ch: CHAR; (* << *)
msg: FileMsg; iden: IdentifyMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
block: ARRAY 1024 OF CHAR;
PROCEDURE StoreElem (VAR r: Files.Rider; pos: LONGINT; e: Elem);
VAR r1: Files.Rider; org, span: LONGINT; eno: SHORTINT;
BEGIN COPY(iden.mod, mods[ecnt]); COPY(iden.proc, procs[ecnt]); eno := 1;
WHILE (mods[eno] # iden.mod) OR (procs[eno] # iden.proc) DO INC(eno) END;
Files.Set(r1, Files.Base(r), Files.Pos(r));
Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); (*fixup slot*)
Files.Write(r, eno);
IF eno = ecnt THEN INC(ecnt); Files.WriteString(r, iden.mod); Files.WriteString(r, iden.proc) END;
msg.pos := pos; org := Files.Pos(r); e.handle(e, msg); span := Files.Pos(r) - org;
Files.WriteLInt(r1, -span); Files.WriteLInt(r1, e.W); Files.WriteLInt(r1, e.H) (*fixup*)
END StoreElem;
BEGIN
org := Files.Pos(r); msg.id := store; msg.r := r; Files.WriteLInt(msg.r, 0); (*fixup slot*)
u := T.head.next; pos := 0; delta := 0; fcnt := 1; ecnt := 1;
WHILE u # T.head DO
IF u IS Elem THEN iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden) ELSE iden.mod[0] := 1X END;
IF iden.mod[0] # 0X THEN
fnts[fcnt] := u.fnt; fno := 1;
WHILE fnts[fno].name # u.fnt.name DO INC(fno) END;
Files.Write(msg.r, fno);
IF fno = fcnt THEN INC(fcnt); Files.WriteString(msg.r, u.fnt.name) END;
Files.Write(msg.r, u.col); Files.Write(msg.r, u.voff)
END;
IF u IS Piece THEN rlen := u.len; un := u.next;
WHILE (un IS Piece) & (un.fnt = u.fnt) & (un.col = u.col) & (un.voff = u.voff) DO
INC(rlen, un.len); un := un.next
END;
Files.WriteLInt(msg.r, rlen); INC(pos, rlen); u := un
ELSIF iden.mod[0] # 0X THEN StoreElem(msg.r, pos, u(Elem)); INC(pos); u := u.next
ELSE INC(delta); u := u.next
END
END;
Files.Write(msg.r, 0); Files.WriteLInt(msg.r, T.len - delta);
(*!!!hlen := Files.Pos(msg.r) - org;*) hlen := Files.Pos(msg.r) - org + 2;
Files.Set(r1, Files.Base(msg.r), org); Files.WriteLInt(r1, hlen); (*fixup*)
u := T.head.next;
WHILE u # T.head DO
IF u IS Piece THEN
WITH u: Piece DO
IF u.ascii THEN Files.Set(r1, u.file, u.org); delta := u.len; (* << LF to CR *)
WHILE delta > 0 DO Files.Read(r1, ch); DEC(delta);
IF ch = 0AX THEN Files.Write(msg.r, CR) ELSE Files.Write(msg.r, ch) END
END
ELSE Files.Set(r1, u.file, u.org); delta := u.len;
WHILE delta > LEN(block) DO Files.ReadBytes(r1, block, LEN(block));
Files.WriteBytes(msg.r, block, LEN(block)); DEC(delta, LEN(block))
END;
Files.ReadBytes(r1, block, delta); Files.WriteBytes(msg.r, block, delta)
END
END
ELSE iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden);
IF iden.mod[0] # 0X THEN Files.Write(msg.r, ElemChar) END
END;
u := u.next
END;
r := msg.r;
END Store;
PROCEDURE Close* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; i, res: INTEGER; bak: ARRAY 64 OF CHAR;
BEGIN
f := Files.New(name); Files.Set(r, f, 0); Files.Write(r, textTag); Files.Write(r, version); Store(r, T);
i := 0; WHILE name[i] # 0X DO INC(i) END;
COPY(name, bak); bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
Files.Rename(name, bak, res); Files.Register(f)
END Close;
BEGIN del := NIL; NEW(FontsDefault); FontsDefault.name := "Syntax10.Scn.Fnt"
END Texts.

859
src/lib/system/freebsd/clang/Texts0.Mod Normal file
View file

@ -0,0 +1,859 @@
MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *)
IMPORT
Files := Files0, Modules, Reals;
(*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *)
(* this module is for bootstrapping voc, use Texts instead *)
CONST
Displaywhite = 15;
ElemChar* = 1CX;
TAB = 9X; CR = 0DX; maxD = 9;
(**FileMsg.id**)
load* = 0; store* = 1;
(**Notifier op**)
replace* = 0; insert* = 1; delete* = 2;
(**Scanner.class**)
Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6;
textTag = 0F0X; DocBlockId = 0F7X; version = 01X;
TYPE
FontsFont = POINTER TO FontDesc;
FontDesc = RECORD
name: ARRAY 32 OF CHAR;
END ;
Run = POINTER TO RunDesc;
RunDesc = RECORD
prev, next: Run;
len: LONGINT;
fnt: FontsFont;
col, voff: SHORTINT;
ascii: BOOLEAN (* << *)
END;
Piece = POINTER TO PieceDesc;
PieceDesc = RECORD (RunDesc)
file: Files.File;
org: LONGINT
END;
Elem* = POINTER TO ElemDesc;
Buffer* = POINTER TO BufDesc;
Text* = POINTER TO TextDesc;
ElemMsg* = RECORD END;
Handler* = PROCEDURE (e: Elem; VAR msg: ElemMsg);
ElemDesc* = RECORD (RunDesc)
W*, H*: LONGINT;
handle*: Handler;
base: Text
END;
FileMsg* = RECORD (ElemMsg)
id*: INTEGER;
pos*: LONGINT;
r*: Files.Rider
END;
CopyMsg* = RECORD (ElemMsg)
e*: Elem
END;
IdentifyMsg* = RECORD (ElemMsg)
mod*, proc*: ARRAY 32 OF CHAR
END;
BufDesc* = RECORD
len*: LONGINT;
head: Run
END;
TextDesc* = RECORD
len*: LONGINT;
head, cache: Run;
corg: LONGINT
END;
Reader* = RECORD
eot*: BOOLEAN;
fnt*: FontsFont;
col*, voff*: SHORTINT;
elem*: Elem;
rider: Files.Rider;
run: Run;
org, off: LONGINT
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*, class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: SHORTINT;
s*: ARRAY 64 OF CHAR (* << *)
END;
Writer* = RECORD
buf*: Buffer;
fnt*: FontsFont;
col*, voff*: SHORTINT;
rider: Files.Rider;
file: Files.File
END;
Alien = POINTER TO RECORD (ElemDesc)
file: Files.File;
org, span: LONGINT;
mod, proc: ARRAY 32 OF CHAR
END;
VAR
new*: Elem;
del: Buffer;
FontsDefault: FontsFont;
PROCEDURE FontsThis(VAR name: ARRAY OF CHAR): FontsFont;
VAR F: FontsFont;
BEGIN
NEW(F); COPY(name, F.name); RETURN F
END FontsThis;
(* run primitives *)
PROCEDURE Find (T: Text; VAR pos: LONGINT; VAR u: Run; VAR org, off: LONGINT);
VAR v: Run; m: LONGINT;
BEGIN
IF pos >= T.len THEN pos := T.len; u := T.head; org := T.len; off := 0; T.cache := T.head; T.corg := 0
ELSE v := T.cache.next; m := pos - T.corg;
IF pos >= T.corg THEN
WHILE m >= v.len DO DEC(m, v.len); v := v.next END
ELSE
WHILE m < 0 DO v := v.prev; INC(m, v.len) END;
END;
u := v; org := pos - m; off := m; T.cache := v.prev; T.corg := org
END
END Find;
PROCEDURE Split (off: LONGINT; VAR u, un: Run);
VAR p, U: Piece;
BEGIN
IF off = 0 THEN un := u; u := un.prev
ELSIF off >= u.len THEN un := u.next
ELSE NEW(p); un := p; U := u(Piece);
p^ := U^; INC(p.org, off); DEC(p.len, off); DEC(U.len, p.len);
p.ascii := u.ascii; p.prev := U; p.next := U.next; p.next.prev := p; U.next := p (* << *)
END
END Split;
PROCEDURE Merge (T: Text; u: Run; VAR v: Run);
VAR p, q: Piece;
BEGIN
IF (u IS Piece) & (v IS Piece) & (u.fnt.name = v.fnt.name) & (u.col = v.col) & (u.voff = v.voff)
& (u(Piece).ascii = v(Piece).ascii) THEN (* << *)
p := u(Piece); q := v(Piece);
IF (p.file = q.file) & (p.org + p.len = q.org) THEN
IF T.cache = u THEN INC(T.corg, q.len)
ELSIF T.cache = v THEN T.cache := T.head; T.corg := 0
END;
INC(p.len, q.len); v := v.next
END
END
END Merge;
PROCEDURE Splice (un, v, w: Run; base: Text); (* (u, un) -> (u, v, w, un) *)
VAR u: Run;
BEGIN
IF v # w.next THEN u := un.prev;
u.next := v; v.prev := u; un.prev := w; w.next := un;
REPEAT
IF v IS Elem THEN v(Elem).base := base END;
v := v.next
UNTIL v = un
END
END Splice;
PROCEDURE ClonePiece (p: Piece): Piece;
VAR q: Piece;
BEGIN NEW(q); q^ := p^; RETURN q
END ClonePiece;
PROCEDURE CloneElem (e: Elem): Elem;
VAR msg: CopyMsg;
BEGIN msg.e := NIL; e.handle(e, msg); RETURN msg.e
END CloneElem;
(** Elements **)
PROCEDURE CopyElem* (SE, DE: Elem);
BEGIN DE.len := SE.len; DE.fnt := SE.fnt; DE.col := SE.col; DE.voff := SE.voff;
DE.W := SE.W; DE.H := SE.H; DE.handle := SE.handle
END CopyElem;
PROCEDURE ElemBase* (E: Elem): Text;
BEGIN RETURN E.base
END ElemBase;
PROCEDURE ElemPos* (E: Elem): LONGINT;
VAR u: Run; pos: LONGINT;
BEGIN u := E.base.head.next; pos := 0;
WHILE u # E DO pos := pos + u.len; u := u.next END;
RETURN pos
END ElemPos;
PROCEDURE HandleAlien (E: Elem; VAR msg: ElemMsg);
VAR e: Alien; r: Files.Rider; i: LONGINT; ch: CHAR;
BEGIN
WITH E: Alien DO
IF msg IS CopyMsg THEN
WITH msg: CopyMsg DO NEW(e); CopyElem(E, e);
e.file := E.file; e.org := E.org; e.span := E.span; e.mod := E.mod; e.proc := E.proc;
msg.e := e
END
ELSIF msg IS IdentifyMsg THEN
WITH msg: IdentifyMsg DO
COPY(E.mod, msg.mod); COPY(E.proc, msg.proc); msg.mod[31] := 1X (*alien*)
END
ELSIF msg IS FileMsg THEN
WITH msg: FileMsg DO
IF msg.id = store THEN Files.Set(r, E.file, E.org); i := E.span;
WHILE i > 0 DO Files.Read(r, ch); Files.Write(msg.r, ch); DEC(i) END
END
END
END
END
END HandleAlien;
(** Buffers **)
PROCEDURE OpenBuf* (B: Buffer);
VAR u: Run;
BEGIN NEW(u); u.next := u; u.prev := u; B.head := u; B.len := 0
END OpenBuf;
PROCEDURE Copy* (SB, DB: Buffer);
VAR u, v, vn: Run;
BEGIN u := SB.head.next; v := DB.head.prev;
WHILE u # SB.head DO
IF u IS Piece THEN vn := ClonePiece(u(Piece)) ELSE vn := CloneElem(u(Elem)) END;
v.next := vn; vn.prev := v; v := vn; u := u.next
END;
v.next := DB.head; DB.head.prev := v;
INC(DB.len, SB.len)
END Copy;
PROCEDURE Recall* (VAR B: Buffer);
BEGIN B := del; del := NIL
END Recall;
(** Texts **)
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR u, v, w, wn: Run; uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Find(T, end, v, vo, vd);
w := B.head.prev;
WHILE u # v DO
IF u IS Piece THEN wn := ClonePiece(u(Piece)); DEC(wn.len, ud); INC(wn(Piece).org, ud)
ELSE wn := CloneElem(u(Elem))
END;
w.next := wn; wn.prev := w; w := wn; u := u.next; ud := 0
END;
IF vd > 0 THEN (*v IS Piece*) wn := ClonePiece(v(Piece)); wn.len := vd - ud; INC(wn(Piece).org, ud);
w.next := wn; wn.prev := w; w := wn
END;
w.next := B.head; B.head.prev := w;
INC(B.len, end - beg)
END Save;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR u, un, v: Run; p, q: Piece; uo, ud, len: LONGINT;
BEGIN Find(T, pos, u, uo, ud); Split(ud, u, un);
len := B.len; v := B.head.next;
Merge(T, u, v); Splice(un, v, B.head.prev, T);
INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0;
END Insert;
PROCEDURE Append* (T: Text; B: Buffer);
VAR v: Run; pos, len: LONGINT;
BEGIN pos := T.len; len := B.len; v := B.head.next;
Merge(T, T.head.prev, v); Splice(T.head, v, B.head.prev, T);
INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0;
END Append;
PROCEDURE Delete* (T: Text; beg, end: LONGINT);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN
Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
NEW(del); OpenBuf(del); del.len := end - beg;
Splice(del.head, un, v, NIL);
Merge(T, u, vn); u.next := vn; vn.prev := u;
DEC(T.len, end - beg);
END Delete;
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: FontsFont; col, voff: SHORTINT);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
WHILE un # vn DO
IF (0 IN sel) & (fnt # NIL) THEN un.fnt := fnt END;
IF 1 IN sel THEN un.col := col END;
IF 2 IN sel THEN un.voff := voff END;
Merge(T, u, un);
IF u.next = un THEN u := un; un := un.next ELSE u.next := un; un.prev := u END
END;
Merge(T, u, un); u.next := un; un.prev := u;
END ChangeLooks;
(** Readers **)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR u: Run;
BEGIN
IF pos >= T.len THEN pos := T.len END;
Find(T, pos, u, R.org, R.off); R.run := u; R.eot := FALSE;
IF u IS Piece THEN
Files.Set(R.rider, u(Piece).file, u(Piece).org + R.off)
END
END OpenReader;
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
VAR u: Run;
BEGIN u := R.run; R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; INC(R.off);
IF u IS Piece THEN Files.Read(R.rider, ch); R.elem := NIL;
IF (ch = 0AX) & u(Piece).ascii THEN ch := CR END (* << LF to CR *)
ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem)
ELSE ch := 0X; R.elem := NIL; R.eot := TRUE
END;
IF R.off = u.len THEN INC(R.org, u.len); u := u.next;
IF u IS Piece THEN
WITH u: Piece DO Files.Set(R.rider, u.file, u.org) END
END;
R.run := u; R.off := 0
END
END Read;
PROCEDURE ReadElem* (VAR R: Reader);
VAR u, un: Run;
BEGIN u := R.run;
WHILE u IS Piece DO INC(R.org, u.len); u := u.next END;
IF u IS Elem THEN un := u.next; R.run := un; INC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem);
IF un IS Piece THEN
WITH un: Piece DO Files.Set(R.rider, un.file, un.org) END
END
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadElem;
PROCEDURE ReadPrevElem* (VAR R: Reader);
VAR u: Run;
BEGIN u := R.run.prev;
WHILE u IS Piece DO DEC(R.org, u.len); u := u.prev END;
IF u IS Elem THEN R.run := u; DEC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem)
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadPrevElem;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(** Scanners --------------- NW --------------- **)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
END OpenScanner;
(*IEEE floating point formats:
x = 2^(e-127) * 1.m bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 2^(e-1023) * 1.m bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Scan* (VAR S: Scanner);
CONST maxD = 32;
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h: SHORTINT;
e: INTEGER; k: LONGINT;
x, f: REAL; y, g: LONGREAL;
d: ARRAY maxD OF CHAR;
PROCEDURE ReadScaleFactor;
BEGIN Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END;
WHILE ("0" <= ch) & (ch <= "9") DO
e := e*10 + ORD(ch) - 30H; Read(S, ch)
END
END ReadScaleFactor;
BEGIN ch := S.nextCh; i := 0;
LOOP
IF ch = CR THEN INC(S.line)
ELSIF (ch # " ") & (ch # TAB) THEN EXIT
END ;
Read(S, ch)
END;
IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch = "/") OR (ch = ".") THEN (*name*) (* << *)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL (CAP(ch) > "Z") & (ch # "_") (* << *)
OR ("A" > CAP(ch)) & (ch > "9")
OR ("0" > ch) & (ch # ".") & (ch # "/") (* << *)
OR (i = 63); (* << *)
S.s[i] := 0X; S.len := i; S.class := 1
ELSIF ch = 22X THEN (*literal string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 63) DO (* << *)
S.s[i] := ch; INC(i); Read(S, ch)
END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2
ELSE
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
hex := FALSE; j := 0;
LOOP d[i] := ch; INC(i); Read(S, ch);
IF ch < "0" THEN EXIT END;
IF "9" < ch THEN
IF ("A" <= ch) & (ch <= "F") THEN hex := TRUE; ch := CHR(ORD(ch)-7)
ELSIF ("a" <= ch) & (ch <= "f") THEN hex := TRUE; ch := CHR(ORD(ch)-27H)
ELSE EXIT
END
END
END;
IF ch = "H" THEN (*hex number*)
Read(S, ch); S.class := 3;
IF i-j > 8 THEN j := i-8 END ;
k := ORD(d[j]) - 30H; INC(j);
IF (i-j = 7) & (k >= 8) THEN DEC(k, 16) END ;
WHILE j < i DO k := k*10H + (ORD(d[j]) - 30H); INC(j) END ;
IF neg THEN S.i := -k ELSE S.i := k END
ELSIF ch = "." THEN (*read real*)
Read(S, ch); h := i;
WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ;
IF ch = "D" THEN
e := 0; y := 0; g := 1;
REPEAT y := y*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO g := g/10; y := (ORD(d[j]) - 30H)*g + y; INC(j) END ;
ReadScaleFactor;
IF negE THEN
IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END
ELSIF e > 0 THEN
IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END
END ;
IF neg THEN y := -y END ;
S.class := 5; S.y := y
ELSE e := 0; x := 0; f := 1;
REPEAT x := x*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO f := f/10; x := (ORD(d[j])-30H)*f + x; INC(j) END;
IF ch = "E" THEN ReadScaleFactor END ;
IF negE THEN
IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END
ELSIF e > 0 THEN
IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END
END ;
IF neg THEN x := -x END ;
S.class := 4; S.x := x
END ;
IF hex THEN S.class := 0 END
ELSE (*decimal integer*)
S.class := 3; k := 0;
REPEAT k := k*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = i;
IF neg THEN S.i := -k ELSE S.i := k END;
IF hex THEN S.class := 0 ELSE S.class := 3 END
END
ELSE S.class := 6;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END;
S.nextCh := ch
END Scan;
(** Writers **)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN NEW(W.buf); OpenBuf(W.buf);
W.fnt := FontsDefault; W.col := Displaywhite; W.voff := 0;
W.file := Files.New(""); Files.Set(W.rider, W.file, 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: FontsFont);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: SHORTINT);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: SHORTINT);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR u, un: Run; p: Piece;
BEGIN Files.Write(W.rider, ch); INC(W.buf.len); un := W.buf.head; u := un.prev;
IF (u IS Piece) & (u(Piece).file = W.file) & (u.fnt.name = W.fnt.name) & (u.col = W.col) & (u.voff = W.voff)
& ~u(Piece).ascii THEN (* << *)
INC(u.len)
ELSE NEW(p); u.next := p; p.prev := u; p.next := un; un.prev := p;
p.len := 1; p.fnt := W.fnt; p.col := W.col; p.voff := W.voff;
p.file := W.file; p.org := Files.Length(W.file) - 1; p.ascii := FALSE (* << *)
END
END Write;
PROCEDURE WriteElem* (VAR W: Writer; e: Elem);
VAR u, un: Run;
BEGIN
IF e.base # NIL THEN HALT(99) END;
INC(W.buf.len); e.len := 1; e.fnt := W.fnt; e.col := W.col; e.voff := W.voff;
un := W.buf.head; u := un.prev; u.next := e; e.prev := u; e.next := un; un.prev := e
END WriteElem;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i: INTEGER; x0: LONGINT;
a: ARRAY 11 OF CHAR;
BEGIN i := 0;
IF x < 0 THEN
IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN
ELSE DEC(n); x0 := -x
END
ELSE x0 := x
END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN i := 0; Write(W, " ");
REPEAT y := x MOD 10H;
IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e: INTEGER; x0: REAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.Expo(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 255 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 9 THEN n := 3 ELSE DEC(n, 6) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 8;
(*there are 2 < n <= 8 digits to be written*)
IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := (e - 127) * 77 DIV 256;
IF e >= 0 THEN x := x / Reals.Ten(e) ELSE x := Reals.Ten(-e) * x END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
x0 := Reals.Ten(n-1); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN x := x*0.1; INC(e) END;
Reals.Convert(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "E");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END WriteReal;
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR e, i: INTEGER; sign: CHAR; x0: REAL;
d: ARRAY maxD OF CHAR;
PROCEDURE seq(ch: CHAR; n: INTEGER);
BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END
END seq;
PROCEDURE dig(n: INTEGER);
BEGIN
WHILE n > 0 DO
DEC(i); Write(W, d[i]); DEC(n)
END
END dig;
BEGIN e := Reals.Expo(x);
IF k < 0 THEN k := 0 END;
IF e = 0 THEN seq(" ", n-k-2); Write(W, "0"); seq(" ", k+1)
ELSIF e = 255 THEN WriteString(W, " NaN"); seq(" ", n-4)
ELSE e := (e - 127) * 77 DIV 256;
IF x < 0 THEN sign := "-"; x := -x ELSE sign := " " END;
IF e >= 0 THEN (*x >= 1.0, 77/256 = log 2*) x := x/Reals.Ten(e)
ELSE (*x < 1.0*) x := Reals.Ten(-e) * x
END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
(* 1 <= x < 10 *)
IF k+e >= maxD-1 THEN k := maxD-1-e
ELSIF k+e < 0 THEN k := -e; x := 0.0
END;
x0 := Reals.Ten(k+e); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN INC(e) END;
(*e = no. of digits before decimal point*)
INC(e); i := k+e; Reals.Convert(x, i, d);
IF e > 0 THEN
seq(" ", n-e-k-2); Write(W, sign); dig(e);
Write(W, "."); dig(k)
ELSE seq(" ", n-k-3);
Write(W, sign); Write(W, "0"); Write(W, ".");
seq("0", -e); dig(k+e)
END
END
END WriteRealFix;
PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
VAR i: INTEGER;
d: ARRAY 8 OF CHAR;
BEGIN Reals.ConvertH(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 8
END WriteRealHex;
PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER);
CONST maxD = 16;
VAR e: INTEGER; x0: LONGREAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.ExpoL(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 2047 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 10 THEN n := 3 ELSE DEC(n, 7) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= maxD;
(*there are 2 <= n <= maxD digits to be written*)
IF x < 0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := SHORT(LONG(e - 1023) * 77 DIV 256);
IF e >= 0 THEN x := x / Reals.TenL(e) ELSE x := Reals.TenL(-e) * x END ;
IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END ;
x0 := Reals.TenL(n-1); x := x0*x + 0.5D0;
IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ;
Reals.ConvertL(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "D");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 100 + 30H)); e := e MOD 100;
Write(W, CHR(e DIV 10 + 30H));
Write(W, CHR(e MOD 10 + 30H))
END
END WriteLongReal;
PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
VAR i: INTEGER;
d: ARRAY 16 OF CHAR;
BEGIN Reals.ConvertHL(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 16
END WriteLongRealHex;
PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT);
PROCEDURE WritePair(ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
BEGIN
WritePair(" ", d MOD 32); WritePair(".", d DIV 32 MOD 16); WritePair(".", d DIV 512 MOD 128);
WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
END WriteDate;
(** Text Filing **)
PROCEDURE Load0 (VAR r: Files.Rider; T: Text);
VAR u, un: Run; p: Piece; e: Elem;
org, pos, hlen, plen: LONGINT; ecnt, fno, fcnt, col, voff: SHORTINT;
f: Files.File;
msg: FileMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
name: ARRAY 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
PROCEDURE LoadElem (VAR r: Files.Rider; pos, span: LONGINT; VAR e: Elem);
VAR M: Modules.Module; Cmd: Modules.Command; a: Alien;
org, ew, eh: LONGINT; eno: SHORTINT;
BEGIN new := NIL;
Files.ReadLInt(r, ew); Files.ReadLInt(r, eh); Files.Read(r, eno);
IF eno > ecnt THEN ecnt := eno; Files.ReadString(r, mods[eno]); Files.ReadString(r, procs[eno]) END;
org := Files.Pos(r); M := Modules.ThisMod(mods[eno]);
IF M # NIL THEN Cmd := Modules.ThisCommand(M, procs[eno]);
IF Cmd # NIL THEN Cmd END
END;
e := new;
IF e # NIL THEN e.W := ew; e.H := eh; e.base := T;
msg.pos := pos; e.handle(e, msg);
IF Files.Pos(r) # org + span THEN e := NIL END
END;
IF e = NIL THEN Files.Set(r, f, org + span);
NEW(a); a.W := ew; a.H := eh; a.handle := HandleAlien; a.base := T;
a.file := f; a.org := org; a.span := span;
COPY(mods[eno], a.mod); COPY(procs[eno], a.proc);
e := a
END
END LoadElem;
BEGIN pos := Files.Pos(r); f := Files.Base(r);
NEW(u); u.len := MAX(LONGINT); (*u.fnt := FontsDefault;*)u.fnt := NIL; u.col := Displaywhite;
T.head := u; ecnt := 0; fcnt := 0;
msg.id := load; msg.r := r;
Files.ReadLInt(msg.r, hlen); (*!!!org := pos + hlen;*) org := pos -2 + hlen; pos := org; Files.Read(msg.r, fno);
WHILE fno # 0 DO
IF fno > fcnt THEN fcnt := fno; Files.ReadString(msg.r, name); fnts[fno] := FontsThis(name) END;
Files.Read(msg.r, col); Files.Read(msg.r, voff); Files.ReadLInt(msg.r, plen);
IF plen > 0 THEN NEW(p); p.file := f; p.org := pos; p.ascii := FALSE; un := p; un.len := plen
ELSE LoadElem(msg.r, pos - org, -plen, e); un := e; un.len := 1
END;
un.fnt := fnts[fno]; un.col := col; un.voff := voff;
INC(pos, un.len); u.next := un; un.prev := u; u := un; Files.Read(msg.r, fno)
END;
u.next := T.head; T.head.prev := u; T.cache := T.head; T.corg := 0;
Files.ReadLInt(msg.r, T.len); Files.Set(r, f, Files.Pos(msg.r) + T.len)
END Load0;
PROCEDURE Load* (VAR r: Files.Rider; T: Text);
CONST oldTag = -4095;
VAR tag: INTEGER;
BEGIN
(* for compatibility inner text tags are checked and skipped; remove this in a later version *)
Files.ReadInt(r, tag); IF tag # oldTag THEN Files.Set(r, Files.Base(r), Files.Pos(r)-2) END;
Load0(r, T)
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; u: Run; p: Piece; tag, version: CHAR; hlen: LONGINT;
BEGIN f := Files.Old(name);
IF f = NIL THEN f := Files.New("") END;
Files.Set(r, f, 0); Files.Read(r, tag); Files.Read(r, version);
IF (tag = textTag) OR (tag = 01X) & (version = textTag) THEN Load0(r, T)
ELSE (*ascii*)
NEW(u); u.len := MAX(LONGINT); u.fnt := NIL; u.col := Displaywhite;
NEW(p);
IF (tag = DocBlockId) & (version = 07X) THEN (* extract ascii text from System 3 text document *)
Files.Set(r, f, 28); Files.ReadLInt(r, hlen);
Files.Set(r, f, 22 + hlen); Files.ReadLInt(r, T.len); p.org := 26 + hlen
ELSE
T.len := Files.Length(f); p.org := 0
END ;
IF T.len > 0 THEN p.len := T.len; p.fnt := FontsDefault;
p.col := Displaywhite; p.voff := 0; p.file := f; p.ascii := TRUE;
u.next := p; u.prev := p; p.next := u; p.prev := u
ELSE u.next := u; u.prev := u
END;
T.head := u; T.cache := T.head; T.corg := 0
END
END Open;
PROCEDURE Store* (VAR r: Files.Rider; T: Text);
VAR r1: Files.Rider; u, un: Run; e: Elem; org, pos, delta, hlen, rlen: LONGINT; ecnt, fno, fcnt: SHORTINT; ch: CHAR; (* << *)
msg: FileMsg; iden: IdentifyMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
block: ARRAY 1024 OF CHAR;
PROCEDURE StoreElem (VAR r: Files.Rider; pos: LONGINT; e: Elem);
VAR r1: Files.Rider; org, span: LONGINT; eno: SHORTINT;
BEGIN COPY(iden.mod, mods[ecnt]); COPY(iden.proc, procs[ecnt]); eno := 1;
WHILE (mods[eno] # iden.mod) OR (procs[eno] # iden.proc) DO INC(eno) END;
Files.Set(r1, Files.Base(r), Files.Pos(r));
Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); (*fixup slot*)
Files.Write(r, eno);
IF eno = ecnt THEN INC(ecnt); Files.WriteString(r, iden.mod); Files.WriteString(r, iden.proc) END;
msg.pos := pos; org := Files.Pos(r); e.handle(e, msg); span := Files.Pos(r) - org;
Files.WriteLInt(r1, -span); Files.WriteLInt(r1, e.W); Files.WriteLInt(r1, e.H) (*fixup*)
END StoreElem;
BEGIN
org := Files.Pos(r); msg.id := store; msg.r := r; Files.WriteLInt(msg.r, 0); (*fixup slot*)
u := T.head.next; pos := 0; delta := 0; fcnt := 1; ecnt := 1;
WHILE u # T.head DO
IF u IS Elem THEN iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden) ELSE iden.mod[0] := 1X END;
IF iden.mod[0] # 0X THEN
fnts[fcnt] := u.fnt; fno := 1;
WHILE fnts[fno].name # u.fnt.name DO INC(fno) END;
Files.Write(msg.r, fno);
IF fno = fcnt THEN INC(fcnt); Files.WriteString(msg.r, u.fnt.name) END;
Files.Write(msg.r, u.col); Files.Write(msg.r, u.voff)
END;
IF u IS Piece THEN rlen := u.len; un := u.next;
WHILE (un IS Piece) & (un.fnt = u.fnt) & (un.col = u.col) & (un.voff = u.voff) DO
INC(rlen, un.len); un := un.next
END;
Files.WriteLInt(msg.r, rlen); INC(pos, rlen); u := un
ELSIF iden.mod[0] # 0X THEN StoreElem(msg.r, pos, u(Elem)); INC(pos); u := u.next
ELSE INC(delta); u := u.next
END
END;
Files.Write(msg.r, 0); Files.WriteLInt(msg.r, T.len - delta);
(*!!!hlen := Files.Pos(msg.r) - org;*) hlen := Files.Pos(msg.r) - org + 2;
Files.Set(r1, Files.Base(msg.r), org); Files.WriteLInt(r1, hlen); (*fixup*)
u := T.head.next;
WHILE u # T.head DO
IF u IS Piece THEN
WITH u: Piece DO
IF u.ascii THEN Files.Set(r1, u.file, u.org); delta := u.len; (* << LF to CR *)
WHILE delta > 0 DO Files.Read(r1, ch); DEC(delta);
IF ch = 0AX THEN Files.Write(msg.r, CR) ELSE Files.Write(msg.r, ch) END
END
ELSE Files.Set(r1, u.file, u.org); delta := u.len;
WHILE delta > LEN(block) DO Files.ReadBytes(r1, block, LEN(block));
Files.WriteBytes(msg.r, block, LEN(block)); DEC(delta, LEN(block))
END;
Files.ReadBytes(r1, block, delta); Files.WriteBytes(msg.r, block, delta)
END
END
ELSE iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden);
IF iden.mod[0] # 0X THEN Files.Write(msg.r, ElemChar) END
END;
u := u.next
END;
r := msg.r;
END Store;
PROCEDURE Close* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; i, res: INTEGER; bak: ARRAY 64 OF CHAR;
BEGIN
f := Files.New(name); Files.Set(r, f, 0); Files.Write(r, textTag); Files.Write(r, version); Store(r, T);
i := 0; WHILE name[i] # 0X DO INC(i) END;
COPY(name, bak); bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
Files.Rename(name, bak, res); Files.Register(f)
END Close;
BEGIN del := NIL; NEW(FontsDefault); FontsDefault.name := "Syntax10.Scn.Fnt"
END Texts0.

65
src/lib/system/freebsd/clang/x86_64/Args.Mod Normal file
View file

@ -0,0 +1,65 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for voc (jet backend) *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
(*PROCEDURE -includestdlib() "#include <stdlib.h>";*)
PROCEDURE -externgetenv() "extern char *getenv(const char *name);"; (* took this from stdlib.h*)
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/freebsd/clang/x86_64/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the voc(jet backend) 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(size_t 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 ------------- */

236
src/lib/system/freebsd/clang/x86_64/SYSTEM.h Normal file
View file

@ -0,0 +1,236 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
voc (jet backend) runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
clang for Darwin version
uses double # as concatenation operator
*/
#include <stdlib.h>
//#include <alloca.h>
//#include <string.h>
extern void *memcpy(void *dest, const void *src, unsigned long n);
extern void *malloc(size_t 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;
#define BOOLEAN char
//typedef unsigned char CHAR;
#define CHAR unsigned char
//exactly two bytes
#define LONGCHAR unsigned short int
//typedef signed char SHORTINT;
#define SHORTINT signed char
//for x86 GNU/Linux
//typedef short int INTEGER;
//for x86_64 GNU/Linux
//typedef int INTEGER;
#define INTEGER int
//typedef long LONGINT;
#define LONGINT long
//typedef float REAL;
#define REAL float
//typedef double LONGREAL;
#define LONGREAL double
//typedef unsigned long SET;
#define SET unsigned long
typedef void *SYSTEM_PTR;
//#define *SYSTEM_PTR void
//typedef unsigned char SYSTEM_BYTE;
#define SYSTEM_BYTE unsigned char
/* 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 t)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(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))
// commented out to use malloc -- noch
//#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUP(x, l, t) x=(void*)memcpy(malloc(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

562
src/lib/system/freebsd/clang/x86_64/Unix.Mod Normal file
View file

@ -0,0 +1,562 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* ported to gnu x86_64 and added system function, 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 *)
CONST sigsetarrlength = 1024 / 8 * SIZE(LONGINT);
TYPE
(* bits/sigset.h
_SIGSET_NWORDS (1024 / (8 * sizeof (unsigned long int)))
1024 / 8*8 = 16
1024 / 8*4 = 32
*)
sigsett* = RECORD
val : ARRAY 16 OF LONGINT (* 32 for 32 bit *)
(*val : ARRAY sigsetarrlength OF LONGINT *)
END;
JmpBuf* = RECORD
(* macosx darwin 64bit, cpp /usr/include/setjmp.h
typedef int jmp_buf[((9 * 2) + 3 + 16)];
*)
(*bx*, si*, di*, bp*, sp*, pc*: LONGINT;*)
(* bits/setjmp.h sets up longer array in GNU libc *)
(*
# if __WORDSIZE == 64
typedef long int __jmp_buf[8];
# else
typedef int __jmp_buf[6];
# endif
*)
(*bx*, si*, di*, bp*, sp*, pc*, ki*, ku*: LONGINT;*)
f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15,
f16, f17, f18, f19, f20, f21, f22, f23, f24, f25, f26, f27, f28, f29,
f30, f31, f32, f33, f34, f35, f36: INTEGER;
(* setjmp.h
/* Calling environment, plus possibly a saved signal mask. */
struct __jmp_buf_tag
{
/* NOTE: The machine-dependent definitions of `__sigsetjmp'
assume that a `jmp_buf' begins with a `__jmp_buf' and that
`__mask_was_saved' follows it. Do not move these members
or add others before it. */
__jmp_buf __jmpbuf; /* Calling environment. */
int __mask_was_saved; /* Saved the signal mask? */
__sigset_t __saved_mask; /* Saved signal mask. */
};
*)
(*maskWasSaved*, savedMask*: LONGINT;*)
(*maskWasSaved*: INTEGER; *)
(*
# define _SIGSET_NWORDS (1024 / (8 * sizeof (unsigned long int)))
typedef struct
{
unsigned long int __val[_SIGSET_NWORDS];
} __sigset_t;
*)
(*savedMask*: sigsett;*)
END ;
(*
Status* = RECORD (* struct stat *)
dev* : INTEGER; (* dev_t 4 *)
mode*: SHORTINT; mode1*: SHORTINT; (* mode_t 2 *)
nlink* : SHORTINT; nlink1*: SHORTINT; (* nlink_t 2 *)
ino* : LONGINT; (* __darwin_ino64_t 8 *)
uid*, gid*: INTEGER; (* uid_t, gid_t 4 *)
rdev*: INTEGER; (* dev_t 4 *)
atime* : LONGINT; atimences* : LONGINT; (* struct timespec 16 *)
mtime* : LONGINT; mtimences* : LONGINT; (* struct timespec 16 *)
ctime* : LONGINT; ctimences* : LONGINT; (* struct timespec 16 *)
birthtime* : LONGINT; birthtimences* : LONGINT; (* struct timespec 16 *)
size*: LONGINT; (* off_t 8 *)
blocks* : LONGINT;
blksize* : INTEGER;
flags* : INTEGER;
gen* : INTEGER;
lspare* : INTEGER;
qspare*, qspare1*: LONGINT;
END ;
*)
Status* = RECORD (* struct stat *)
dev* : INTEGER; (* dev_t 4 *)
ino* : INTEGER; (* ino_t 4 *)
mode*: SHORTINT; mode1*: SHORTINT; (* mode_t 2 *)
nlink* : SHORTINT; nlink1*: SHORTINT; (* nlink_t 2 *)
uid*, gid*: INTEGER; (* uid_t, gid_t 4 *)
rdev*: INTEGER; (* dev_t 4 *)
atime* : LONGINT; atimences* : LONGINT; (* struct timespec 16 *)
mtime* : LONGINT; mtimences* : LONGINT; (* struct timespec 16 *)
ctime* : LONGINT; ctimences* : LONGINT; (* struct timespec 16 *)
size*: LONGINT; (* off_t 8 *)
blocks* : LONGINT;
blksize* : INTEGER;
flags* : INTEGER;
gen* : INTEGER;
lspare* : INTEGER;
birthtime* : LONGINT; birthtimences* : LONGINT; (* struct timespec 16 *)
qspare*, qspare1*: INTEGER;
END ;
(* from /usr/include/bits/time.h
struct timeval
{
__time_t tv_sec; /* Seconds. */ //__time_t 8
__suseconds_t tv_usec; /* Microseconds. */ __suseconds_t 8
};
*)
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
(*
from man gettimeofday
struct timezone {
int tz_minuteswest; /* minutes west of Greenwich */ int 4
int tz_dsttime; /* type of DST correction */ int 4
};
*)
Timezone* = RECORD
(*minuteswest*, dsttime*: LONGINT*)
minuteswest*, dsttime*: INTEGER
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>";
(* for select() *)
PROCEDURE -includeSelect()
"#include <sys/select.h>";
(* for kill() *)
PROCEDURE -includeSignal()
"#include <signal.h>";
(* for read() also *)
PROCEDURE -includeTypes()
"#include <sys/types.h>";
PROCEDURE -includeUio()
"#include <sys/uio.h>";
(* for getpid(), lseek(), close(), fsync(), ftruncate(), read(), sleep() *)
PROCEDURE -includeUnistd()
"#include <unistd.h>";
(* for rename() *)
PROCEDURE -includeStdio()
"#include <stdio.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
(* for open() *)
PROCEDURE -includeFcntl()
"#include <fcntl.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!) *)
(* don't understand this
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)";
PROCEDURE -Sleep*(ms : INTEGER): INTEGER
"sleep(ms)";
PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): INTEGER
"nanosleep(req, rem)";
(* 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.

88
src/voc/freebsd/clang/extTools.Mod Normal file
View file

@ -0,0 +1,88 @@
MODULE extTools;
IMPORT Args, Unix, Strings, Console, version;
(*
INCLUDEPATH = -Isrc/lib/system/gnuc/x86_64
CCOPT = -fPIC $(INCLUDEPATH) -g
CLOBERONOPTS = -fPIC $(INCLUDEPATH) -L. -L/usr/lib -lOberon -static -g
CC = cc $(CCOPT) -c
*)
CONST compiler="clang";
VAR incPath0, incPath1, ccOpt, ccString, CFLAGS, tmp0, tmp1 : ARRAY 1023 OF CHAR;
PROCEDURE Assemble*(m : ARRAY OF CHAR);
VAR cmd : ARRAY 1023 OF CHAR;
cc : ARRAY 1023 OF CHAR;
ext : ARRAY 5 OF CHAR;
BEGIN
COPY (ccString, cc);
Strings.Append (" -c ", cc);
COPY(cc, cmd);
Strings.Append (" ", cmd);
Strings.Append (ccOpt, cmd);
ext := ".c";
Strings.Append (ext, m);
Strings.Append(m, cmd);
(*Console.Ln; Console.String (cmd); Console.Ln;*)
Unix.system(cmd);
END Assemble;
PROCEDURE LinkMain*(VAR m : ARRAY OF CHAR; statically : BOOLEAN; additionalopts : ARRAY OF CHAR);
VAR lpath : ARRAY 1023 OF CHAR;
cc : ARRAY 1023 OF CHAR;
ccopt : ARRAY 1023 OF CHAR;
cmd : ARRAY 1023 OF CHAR;
ext : ARRAY 5 OF CHAR;
BEGIN
(*
gcc -g -o hello hello.c -I $RPATH/src/lib/system/gnuc/x86_64 -I. -I$RPATH -lOberon -L. -L$RPATH -static
*)
cmd := "";
cc := "";
ext := ".c";
COPY(ccString, cc);
COPY (cc, cmd);
Strings.Append(" ", cmd);
Strings.Append(m, cmd);
Strings.Append(ext, cmd);
Strings.Append(additionalopts, cmd);
IF statically THEN Strings.Append(" -static ", cmd) END;
Strings.Append(" -o ", cmd);
Strings.Append(m, cmd);
Strings.Append(" ", cmd);
Strings.Append (" -lVishapOberon -L. -L", ccOpt);
Strings.Append (version.prefix, ccOpt);
Strings.Append ("/lib ", ccOpt);
Strings.Append(ccOpt, cmd);
Console.Ln; Console.String(cmd); Console.Ln; (* may be it's feasible to add debug mode later *)
Unix.system(cmd);
END LinkMain;
BEGIN
incPath0 := "src/lib/system/freebsd/";
Strings.Append (compiler, incPath0);
incPath1 := "lib/voc/obj ";
ccOpt := " -fPIC -g ";
COPY ("-I ", tmp1);
Strings.Append (version.prefix, tmp1);
Strings.Append("/", tmp1);
Strings.Append(incPath0, tmp1);
Strings.Append("/", tmp1);
Strings.Append(version.arch, tmp1);
Strings.Append(" -I ", tmp1);
Strings.Append(version.prefix, tmp1);
Strings.Append("/", tmp1);
Strings.Append(incPath1, tmp1);
Strings.Append(tmp1, ccOpt);
Args.GetEnv("CFLAGS", CFLAGS);
Strings.Append (CFLAGS, ccOpt);
Strings.Append (" ", ccOpt);
ccString := compiler;
Strings.Append (" ", ccString);
END extTools.

4
src/voc/freebsd/clang/x86_64/architecture.Mod Normal file
View file

@ -0,0 +1,4 @@
MODULE architecture;
CONST arch* = "x86_64";
END architecture.

BIN
vocstatic.freebsd.clang.x86_64 Executable file
View file

Binary file not shown.